removed spidey.ss
svn: r3132
This commit is contained in:
Eli Barzilay
parent
f662133a9a
commit
185da3d90d
|
|
@ -9,4 +9,4 @@
|
|||
(define mred-launcher-names (list "gmzc"))
|
||||
|
||||
(define compile-omit-files
|
||||
'("mrspidey.ss" "mrspideyf.ss" "mrspideyi.ss" "embedr.ss")))
|
||||
'("embedr.ss")))
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
|
||||
(module etc (lib "frtime.ss" "frtime")
|
||||
(require (lib "spidey.ss")
|
||||
(lib "main-collects.ss" "setup"))
|
||||
(require (lib "main-collects.ss" "setup"))
|
||||
(require-for-syntax (lib "kerncase.ss" "syntax")
|
||||
(lib "stx.ss" "syntax")
|
||||
(lib "name.ss" "syntax")
|
||||
|
|
@ -39,10 +38,9 @@
|
|||
(define true #t)
|
||||
(define false #f)
|
||||
|
||||
(define identity (polymorphic (lambda (x) x)))
|
||||
(define identity (lambda (x) x))
|
||||
|
||||
(define compose
|
||||
(polymorphic
|
||||
(case-lambda
|
||||
[(f) (if (procedure? f) f (raise-type-error 'compose "procedure" f))]
|
||||
[(f g)
|
||||
|
|
@ -63,7 +61,7 @@
|
|||
f)))))]
|
||||
[(f . more)
|
||||
(let ([m (apply compose more)])
|
||||
(compose f m))])))
|
||||
(compose f m))]))
|
||||
|
||||
|
||||
#|
|
||||
|
|
@ -88,7 +86,6 @@
|
|||
|
||||
#|
|
||||
(define build-vector
|
||||
(polymorphic
|
||||
(lambda (n fcn)
|
||||
(unless (and (integer? n) (exact? n) (>= n 0))
|
||||
(error 'build-vector "~s must be an exact integer >= 0" n))
|
||||
|
|
@ -99,10 +96,9 @@
|
|||
(if (= i n) vec
|
||||
(begin
|
||||
(vector-set! vec i (fcn i))
|
||||
(loop (add1 i)))))))))
|
||||
(loop (add1 i))))))))
|
||||
|#
|
||||
(define build-list
|
||||
(polymorphic
|
||||
(lambda (n fcn)
|
||||
(unless (and (integer? n) (exact? n) (>= n 0))
|
||||
(error 'build-list "~s must be an exact integer >= 0" n))
|
||||
|
|
@ -111,15 +107,14 @@
|
|||
(let loop ([i (sub1 n)] [p '()])
|
||||
(if (>= i 0)
|
||||
(loop (sub1 i) (cons (fcn i) p))
|
||||
p)))))
|
||||
p))))
|
||||
|
||||
(define loop-until
|
||||
(polymorphic
|
||||
(lambda (start done? next body)
|
||||
(let loop ([i start])
|
||||
(unless (done? i)
|
||||
(body i)
|
||||
(loop (next i)))))))
|
||||
(loop (next i))))))
|
||||
|
||||
(define boolean=?
|
||||
(lambda (x y)
|
||||
|
|
|
|||
|
|
@ -1,15 +1,13 @@
|
|||
|
||||
(module etc mzscheme
|
||||
|
||||
(require "spidey.ss"
|
||||
(lib "main-collects.ss" "setup"))
|
||||
(require (lib "main-collects.ss" "setup"))
|
||||
|
||||
(require-for-syntax (lib "kerncase.ss" "syntax")
|
||||
(lib "stx.ss" "syntax")
|
||||
(lib "name.ss" "syntax")
|
||||
(lib "context.ss" "syntax")
|
||||
(lib "main-collects.ss" "setup")
|
||||
"list.ss"
|
||||
"private/stxset.ss")
|
||||
|
||||
|
||||
|
|
@ -48,10 +46,9 @@
|
|||
(define true #t)
|
||||
(define false #f)
|
||||
|
||||
(define identity (polymorphic (lambda (x) x)))
|
||||
(define identity (lambda (x) x))
|
||||
|
||||
(define compose
|
||||
(polymorphic
|
||||
(case-lambda
|
||||
[(f) (if (procedure? f) f (raise-type-error 'compose "procedure" f))]
|
||||
[(f g)
|
||||
|
|
@ -72,82 +69,66 @@
|
|||
f)))))]
|
||||
[(f . more)
|
||||
(let ([m (apply compose more)])
|
||||
(compose f m))])))
|
||||
(compose f m))]))
|
||||
|
||||
|
||||
(define build-string
|
||||
(lambda (n fcn)
|
||||
(define (build-string n fcn)
|
||||
(unless (and (integer? n) (exact? n) (>= n 0))
|
||||
(error 'build-string "~s must be an exact integer >= 0" n))
|
||||
(unless (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))
|
||||
(if (= i n)
|
||||
str
|
||||
(begin
|
||||
(string-set! str i (fcn i))
|
||||
(loop (add1 i))))))))
|
||||
(begin (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).
|
||||
;; The eval order is guaranteed to be: 0, 1, 2, ..., n-1.
|
||||
;; eg: (build-vector 4 (lambda (i) i)) ==> #4(0 1 2 3)
|
||||
|
||||
(define build-vector
|
||||
(polymorphic
|
||||
(lambda (n fcn)
|
||||
(define (build-vector n fcn)
|
||||
(unless (and (integer? n) (exact? n) (>= n 0))
|
||||
(error 'build-vector "~s must be an exact integer >= 0" n))
|
||||
(unless (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))
|
||||
(if (= i n) vec
|
||||
(begin
|
||||
(vector-set! vec i (fcn i))
|
||||
(loop (add1 i)))))))))
|
||||
(if (= i n)
|
||||
vec
|
||||
(begin (vector-set! vec i (fcn i)) (loop (add1 i)))))))
|
||||
|
||||
(define build-list
|
||||
(polymorphic
|
||||
(lambda (n fcn)
|
||||
(define (build-list n fcn)
|
||||
(unless (and (integer? n) (exact? n) (>= n 0))
|
||||
(error 'build-list "~s must be an exact integer >= 0" n))
|
||||
(unless (procedure? fcn)
|
||||
(error 'build-list "~s must be a procedure" fcn))
|
||||
(if (zero? n) '()
|
||||
(if (zero? n)
|
||||
'()
|
||||
(let ([head (list (fcn 0))])
|
||||
(let loop ([i 1] [p head])
|
||||
(if (= i n) head
|
||||
(begin
|
||||
(set-cdr! p (list (fcn i)))
|
||||
(loop (add1 i) (cdr p))))))))))
|
||||
(if (= i n)
|
||||
head
|
||||
(begin (set-cdr! p (list (fcn i)))
|
||||
(loop (add1 i) (cdr p))))))))
|
||||
|
||||
(define loop-until
|
||||
(polymorphic
|
||||
(lambda (start done? next body)
|
||||
(define (loop-until start done? next body)
|
||||
(let loop ([i start])
|
||||
(unless (done? i)
|
||||
(body i)
|
||||
(loop (next i)))))))
|
||||
(loop (next i)))))
|
||||
|
||||
(define boolean=?
|
||||
(lambda (x y)
|
||||
(unless (and (boolean? 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)))
|
||||
(define (boolean=? x y)
|
||||
(unless (and (boolean? x) (boolean? y))
|
||||
(raise-type-error 'boolean=? "boolean" (if (boolean? x) y x)))
|
||||
(eq? x y))
|
||||
|
||||
(define-syntax opt-lambda
|
||||
(lambda (stx)
|
||||
(define (symbol=? x y)
|
||||
(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)
|
||||
(quote-syntax opt-lambda-proc))])
|
||||
(syntax-case stx ()
|
||||
|
|
@ -170,10 +151,7 @@
|
|||
(begin
|
||||
(when needs-default?
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"default value missing"
|
||||
stx
|
||||
(syntax id)))
|
||||
#f "default value missing" stx (syntax id)))
|
||||
(loop (append pre-args (list (syntax id)))
|
||||
(syntax rest)
|
||||
#f))]
|
||||
|
|
@ -193,19 +171,12 @@
|
|||
(syntax bad))]
|
||||
[else
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad identifier sequence"
|
||||
stx
|
||||
(syntax args))]))])
|
||||
#f "bad identifier sequence" stx (syntax args))]))])
|
||||
(with-syntax ([clauses clauses])
|
||||
(syntax/loc stx
|
||||
(letrec ([name
|
||||
(case-lambda
|
||||
. clauses)])
|
||||
name))))]))))
|
||||
(letrec ([name (case-lambda . clauses)]) name))))])))
|
||||
|
||||
(define-syntax local
|
||||
(lambda (stx)
|
||||
(define-syntax (local stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (defn ...) body1 body ...)
|
||||
(let ([defs (let ([expand-context (generate-expand-context)])
|
||||
|
|
@ -238,87 +209,52 @@
|
|||
(list d))]
|
||||
[(define-values . rest)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"ill-formed definition"
|
||||
stx
|
||||
d)]
|
||||
#f "ill-formed definition" stx d)]
|
||||
[(define-syntaxes (id ...) body)
|
||||
(begin
|
||||
(check-ids (syntax->list (syntax (id ...))))
|
||||
(list d))]
|
||||
[(define-syntaxes . rest)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"ill-formed definition"
|
||||
stx
|
||||
d)]
|
||||
#f "ill-formed definition" stx d)]
|
||||
[_else
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"not a definition"
|
||||
stx
|
||||
defn)])))
|
||||
#f "not a definition" stx defn)])))
|
||||
defns))))])
|
||||
(let ([ids (apply append
|
||||
(map
|
||||
(lambda (d)
|
||||
(syntax-case d ()
|
||||
[(_ ids . __)
|
||||
(syntax->list (syntax ids))]))
|
||||
[(_ ids . __) (syntax->list (syntax ids))]))
|
||||
defs))])
|
||||
(let ([dup (check-duplicate-identifier ids)])
|
||||
(when dup
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"duplicate identifier"
|
||||
stx
|
||||
dup)))
|
||||
(raise-syntax-error #f "duplicate identifier" stx dup)))
|
||||
(with-syntax ([(def ...) defs])
|
||||
(syntax/loc
|
||||
stx
|
||||
(let ()
|
||||
def ...
|
||||
(let ()
|
||||
body1
|
||||
body ...))))))]
|
||||
(syntax/loc stx
|
||||
(let () def ... (let () body1 body ...))))))]
|
||||
[(_ x body1 body ...)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"not a definition sequence"
|
||||
stx
|
||||
(syntax x))])))
|
||||
(raise-syntax-error #f "not a definition sequence" stx (syntax x))]))
|
||||
|
||||
;; recur is another name for 'let' in a named let
|
||||
(define-syntax recur
|
||||
(lambda (stx)
|
||||
(define-syntax (recur stx)
|
||||
(syntax-case stx ()
|
||||
[(_ . rest)
|
||||
(syntax/loc stx (let . rest))])))
|
||||
[(_ . rest) (syntax/loc stx (let . rest))]))
|
||||
|
||||
;; define a recursive value
|
||||
(define-syntax rec
|
||||
(lambda (stx)
|
||||
(define-syntax (rec stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name expr)
|
||||
(begin
|
||||
(unless (identifier? (syntax name))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"not an identifier"
|
||||
stx
|
||||
(syntax name)))
|
||||
(syntax/loc stx
|
||||
(letrec ([name expr])
|
||||
name)))])))
|
||||
(begin (unless (identifier? (syntax name))
|
||||
(raise-syntax-error #f "not an identifier" stx (syntax name)))
|
||||
(syntax/loc stx (letrec ([name expr]) name)))]))
|
||||
|
||||
(define-syntax evcase
|
||||
(lambda (stx)
|
||||
(define-syntax (evcase stx)
|
||||
(syntax-case stx ()
|
||||
[(_ val [test body ...] ...)
|
||||
(let ([tests (syntax->list (syntax (test ...)))])
|
||||
(with-syntax ([(a-test ...)
|
||||
(map
|
||||
(lambda (t)
|
||||
(map (lambda (t)
|
||||
(syntax-case t (else)
|
||||
[else (syntax #t)]
|
||||
[_else (with-syntax ([t t])
|
||||
|
|
@ -331,53 +267,35 @@
|
|||
(when (and (identifier? (car tests))
|
||||
(module-identifier=? (quote-syntax else) (car tests)))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"else is not in last clause"
|
||||
stx
|
||||
(car tests)))
|
||||
#f "else is not in last clause" stx (car tests)))
|
||||
(loop (cdr tests)))))
|
||||
(syntax/loc stx
|
||||
(let ([evcase-v val])
|
||||
(cond
|
||||
[a-test
|
||||
(begin body ...)]
|
||||
(cond [a-test (begin body ...)]
|
||||
...)))))]
|
||||
[(_ 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 ...))))])))
|
||||
[(t a ...) (raise-syntax-error #f "invalid clause" stx s)]))
|
||||
(syntax->list (syntax (something ...))))]))
|
||||
|
||||
(define-syntax nor
|
||||
(lambda (stx)
|
||||
(define-syntax (nor stx)
|
||||
(syntax-case stx ()
|
||||
[(_ expr ...)
|
||||
(syntax/loc stx (not (or expr ...)))])))
|
||||
[(_ expr ...) (syntax/loc stx (not (or expr ...)))]))
|
||||
|
||||
(define-syntax nand
|
||||
(lambda (stx)
|
||||
(define-syntax (nand stx)
|
||||
(syntax-case stx ()
|
||||
[(_ expr ...)
|
||||
(syntax/loc stx (not (and expr ...)))])))
|
||||
[(_ expr ...) (syntax/loc stx (not (and expr ...)))]))
|
||||
|
||||
(define-syntax let+
|
||||
(lambda (stx)
|
||||
(define-syntax (let+ stx)
|
||||
(syntax-case stx ()
|
||||
[(_ [clause ...] body1 body ...)
|
||||
(let ([clauses (syntax->list (syntax (clause ...)))]
|
||||
[bad (lambda (c n)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
(format "illegal use of ~a for a clause" n)
|
||||
stx
|
||||
c))]
|
||||
#f (format "illegal use of ~a for a clause" n) stx c))]
|
||||
[var? (lambda (x)
|
||||
(or (identifier? x)
|
||||
(let ([l (syntax->list x)])
|
||||
|
|
@ -392,9 +310,8 @@
|
|||
;; syntax checks
|
||||
(for-each
|
||||
(lambda (clause)
|
||||
(syntax-case* clause (val rec vals recs _) (lambda (a b)
|
||||
(eq? (syntax-e b)
|
||||
(syntax-e a)))
|
||||
(syntax-case* clause (val rec vals recs _)
|
||||
(lambda (a b) (eq? (syntax-e b) (syntax-e a)))
|
||||
[(val var expr)
|
||||
(var? (syntax var))
|
||||
'ok]
|
||||
|
|
@ -421,9 +338,8 @@
|
|||
(if (null? clauses)
|
||||
(syntax (let () body1 body ...))
|
||||
(with-syntax ([rest (loop (cdr clauses))])
|
||||
(syntax-case* (car clauses) (val rec vals recs _) (lambda (a b)
|
||||
(eq? (syntax-e b)
|
||||
(syntax-e a)))
|
||||
(syntax-case* (car clauses) (val rec vals recs _)
|
||||
(lambda (a b) (eq? (syntax-e b) (syntax-e a)))
|
||||
[(val var expr)
|
||||
(with-syntax ([vars (normal-var (syntax var))])
|
||||
(syntax (let-values ([vars expr]) rest)))]
|
||||
|
|
@ -437,14 +353,15 @@
|
|||
(with-syntax ([(vars ...) (map normal-var (syntax->list (syntax (var ...))))])
|
||||
(syntax (letrec-values ([vars expr] ...) rest)))]
|
||||
[(_ expr0 expr ...)
|
||||
(syntax (begin expr0 expr ... rest))])))))])))
|
||||
(syntax (begin expr0 expr ... rest))])))))]))
|
||||
|
||||
(define ns-undefined (gensym))
|
||||
|
||||
(define (namespace-defined? n)
|
||||
(unless (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)
|
||||
(syntax-case stx ()
|
||||
|
|
|
|||
|
|
@ -1,6 +1,5 @@
|
|||
|
||||
(module list mzscheme
|
||||
(require "spidey.ss")
|
||||
|
||||
(provide set-first!
|
||||
first
|
||||
|
|
@ -148,9 +147,7 @@
|
|||
(sort-internal lst less? #t 'sort))
|
||||
|
||||
;; deprecated!
|
||||
(define quicksort
|
||||
(polymorphic
|
||||
(lambda (l less-than)
|
||||
(define (quicksort l less-than)
|
||||
(unless (list? l)
|
||||
(raise-type-error 'quicksort "proper list" l))
|
||||
(unless (procedure-arity-includes? less-than 2)
|
||||
|
|
@ -160,51 +157,40 @@
|
|||
(let loop ([min 0][max count])
|
||||
(if (< min (sub1 max))
|
||||
(let ([pval (vector-ref v min)])
|
||||
(let pivot-loop ([pivot min]
|
||||
[pos (add1 min)])
|
||||
(let pivot-loop ([pivot min] [pos (add1 min)])
|
||||
(if (< pos max)
|
||||
(let ([cval (vector-ref v pos)])
|
||||
(if (less-than cval pval)
|
||||
(begin
|
||||
(vector-set! v pos (vector-ref v pivot))
|
||||
(begin (vector-set! v pos (vector-ref v pivot))
|
||||
(vector-set! v pivot cval)
|
||||
(pivot-loop (add1 pivot) (add1 pos)))
|
||||
(pivot-loop pivot (add1 pos))))
|
||||
(if (= min pivot)
|
||||
(loop (add1 pivot) max)
|
||||
(begin
|
||||
(loop min pivot)
|
||||
(begin (loop min pivot)
|
||||
(loop pivot max))))))))
|
||||
(vector->list v)))))
|
||||
(vector->list v)))
|
||||
|
||||
;; deprecated!
|
||||
(define mergesort sort)
|
||||
|
||||
(define remove
|
||||
(polymorphic
|
||||
(letrec ([rm (case-lambda
|
||||
[(item list) (rm item list equal?)]
|
||||
[(item list equal?)
|
||||
(let loop ([list list])
|
||||
(cond
|
||||
[(null? list) ()]
|
||||
(cond [(null? list) ()]
|
||||
[(equal? item (car list)) (cdr list)]
|
||||
[else (cons (car list)
|
||||
(loop (cdr list)))]))])])
|
||||
rm)))
|
||||
[else (cons (car list) (loop (cdr list)))]))])])
|
||||
rm))
|
||||
|
||||
(define remq
|
||||
(polymorphic
|
||||
(lambda (item list)
|
||||
(remove item list eq?))))
|
||||
(define (remq item list)
|
||||
(remove item list eq?))
|
||||
|
||||
(define remv
|
||||
(polymorphic
|
||||
(lambda (item list)
|
||||
(remove item list eqv?))))
|
||||
(define (remv item list)
|
||||
(remove item list eqv?))
|
||||
|
||||
(define remove*
|
||||
(polymorphic
|
||||
(case-lambda
|
||||
[(l r equal?)
|
||||
(cond
|
||||
|
|
@ -215,17 +201,13 @@
|
|||
[(null? l-rest) (cons first-r (remove* l (cdr r) equal?))]
|
||||
[(equal? (car l-rest) first-r) (remove* l (cdr r) equal?)]
|
||||
[else (loop (cdr l-rest))])))])]
|
||||
[(l r) (remove* l r equal?)])))
|
||||
[(l r) (remove* l r equal?)]))
|
||||
|
||||
(define remq*
|
||||
(polymorphic
|
||||
(lambda (l r)
|
||||
(remove* l r eq?))))
|
||||
(define (remq* l r)
|
||||
(remove* l r eq?))
|
||||
|
||||
(define remv*
|
||||
(polymorphic
|
||||
(lambda (l r)
|
||||
(remove* l r eqv?))))
|
||||
(define (remv* l r)
|
||||
(remove* l r eqv?))
|
||||
|
||||
;; fold : ((A B -> B) B (listof A) -> 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
|
||||
;; beginning of the list.
|
||||
|
||||
(define mapadd
|
||||
(polymorphic
|
||||
(lambda (f l last)
|
||||
(define (mapadd f l last)
|
||||
(letrec ((helper
|
||||
(lambda (l)
|
||||
(cond
|
||||
[(null? l) (list last)]
|
||||
(cond [(null? l) (list last)]
|
||||
[else (cons (f (car l)) (helper (cdr l)))]))))
|
||||
(helper l)))))
|
||||
(helper l)))
|
||||
|
||||
(define foldl
|
||||
(polymorphic
|
||||
(letrec ((fold-one
|
||||
(letrec ([fold-one
|
||||
(lambda (f init l)
|
||||
(letrec ((helper
|
||||
(lambda (init l)
|
||||
(cond
|
||||
[(null? l) init]
|
||||
(cond [(null? l) init]
|
||||
[else (helper (f (car l) init) (cdr l))]))))
|
||||
(helper init l))))
|
||||
(fold-n
|
||||
(helper init l)))]
|
||||
[fold-n
|
||||
(lambda (f init l)
|
||||
(cond
|
||||
[(ormap null? l)
|
||||
(if (andmap null? l)
|
||||
init
|
||||
(error 'foldl "received non-equal length input lists"))]
|
||||
[else (fold-n
|
||||
f
|
||||
(apply f (mapadd car l init))
|
||||
(map cdr l))]))))
|
||||
[else (fold-n f (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))]))))
|
||||
[(f init l . ls) (fold-n f init (cons l ls))])))
|
||||
|
||||
(define foldr
|
||||
(polymorphic
|
||||
(letrec ((fold-one
|
||||
(letrec ([fold-one
|
||||
(lambda (f init l)
|
||||
(letrec ((helper
|
||||
(lambda (init l)
|
||||
(cond
|
||||
[(null? l) init]
|
||||
(cond [(null? l) init]
|
||||
[else (f (car l) (helper init (cdr l)))]))))
|
||||
(helper init l))))
|
||||
(fold-n
|
||||
(helper init l)))]
|
||||
[fold-n
|
||||
(lambda (f init l)
|
||||
(cond
|
||||
[(ormap null? l)
|
||||
(if (andmap null? l)
|
||||
init
|
||||
(error 'foldr "received non-equal length input lists"))]
|
||||
[else (apply f
|
||||
(mapadd car l
|
||||
(fold-n f init (map cdr l))))]))))
|
||||
[else (apply f (mapadd car l (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))]))))
|
||||
[(f init l . ls) (fold-n f init (cons l ls))])))
|
||||
|
||||
(define make-find
|
||||
(lambda (name whole-list?)
|
||||
(polymorphic
|
||||
(define (make-find name whole-list?)
|
||||
(lambda (f list)
|
||||
(unless (and (procedure? f)
|
||||
(procedure-arity-includes? f 1))
|
||||
(unless (and (procedure? f) (procedure-arity-includes? f 1))
|
||||
(raise-type-error name "procedure (arity 1)" f))
|
||||
(let loop ([l list])
|
||||
(cond
|
||||
[(null? l) #f]
|
||||
(cond [(null? l) #f]
|
||||
[(not (pair? l))
|
||||
(raise (make-exn:fail:contract
|
||||
(format "~a: second argument must be a (proper) list; given ~e" name list)
|
||||
(current-continuation-marks)))]
|
||||
[else (let ([a (car l)])
|
||||
(if whole-list?
|
||||
(if (f a)
|
||||
l
|
||||
(loop (cdr l)))
|
||||
(if (f a) l (loop (cdr l)))
|
||||
(if (pair? a)
|
||||
(if (f (car a))
|
||||
a
|
||||
(loop (cdr l)))
|
||||
(if (f (car a)) a (loop (cdr l)))
|
||||
(raise-mismatch-error
|
||||
name
|
||||
"found a non-pair in the list: "
|
||||
a))))]))))))
|
||||
name "found a non-pair in the list: " a))))]))))
|
||||
|
||||
(define assf
|
||||
(let ([a (make-find 'assf #f)])
|
||||
(polymorphic
|
||||
(lambda (f l)
|
||||
(a f l)))))
|
||||
(lambda (f l) (a f l))))
|
||||
|
||||
(define memf
|
||||
(let ([a (make-find 'memf #t)])
|
||||
(polymorphic
|
||||
(lambda (f l)
|
||||
(a f l)))))
|
||||
(lambda (f l) (a f l))))
|
||||
|
||||
(define filter
|
||||
(polymorphic
|
||||
(lambda (f list)
|
||||
(define (filter f list)
|
||||
(unless (and (procedure? f)
|
||||
(procedure-arity-includes? f 1))
|
||||
(raise-type-error 'filter "procedure (arity 1)" f))
|
||||
|
|
@ -343,46 +297,33 @@
|
|||
;; overflow the internal stack using natural recursion.
|
||||
;; It's too bad that our Scheme system is so bad, but
|
||||
;; until someone fixes it...
|
||||
(let loop ([l list][result null])
|
||||
(let loop ([l list] [result null])
|
||||
(cond
|
||||
[(null? l) (reverse! result)]
|
||||
[(pair? l)
|
||||
(loop (cdr l) (if (f (car l))
|
||||
(cons (car l) result)
|
||||
result))]
|
||||
[(pair? l) (loop (cdr l) (if (f (car l)) (cons (car l) result) result))]
|
||||
[else (raise-mismatch-error
|
||||
'filter
|
||||
"expects a proper list: "
|
||||
list)])))))
|
||||
'filter "expects a proper list: " list)])))
|
||||
|
||||
(define first (polymorphic (lambda (x)
|
||||
(unless (pair? x)
|
||||
(raise-type-error 'first "non-empty list" x))
|
||||
(car x))))
|
||||
(define set-first!
|
||||
(polymorphic (lambda (x v)
|
||||
(unless (pair? x)
|
||||
(raise-type-error 'set-first! "non-empty list" x))
|
||||
(set-car! x v))))
|
||||
(define (first x)
|
||||
(unless (pair? x) (raise-type-error 'first "non-empty list" x))
|
||||
(car x))
|
||||
(define (set-first! x v)
|
||||
(unless (pair? x) (raise-type-error 'set-first! "non-empty list" x))
|
||||
(set-car! x v))
|
||||
(define (lget name npos)
|
||||
(lambda (x)
|
||||
(let loop ([l x][pos npos])
|
||||
(cond
|
||||
[(and (= pos 1) (pair? l))
|
||||
(car l)]
|
||||
[(pair? l)
|
||||
(loop (cdr l) (sub1 pos))]
|
||||
[else
|
||||
(raise-type-error name
|
||||
(format "list with ~a or more items" npos)
|
||||
x)]))))
|
||||
[(and (= pos 1) (pair? l)) (car l)]
|
||||
[(pair? l) (loop (cdr l) (sub1 pos))]
|
||||
[else (raise-type-error
|
||||
name (format "list with ~a or more items" npos) x)]))))
|
||||
|
||||
;; Gives the function a name:
|
||||
(define-syntax (mk-lget stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name pos)
|
||||
(syntax (polymorphic (let ([g (lget 'name pos)])
|
||||
(lambda (x) (g x)))))]))
|
||||
(syntax (let ([g (lget 'name pos)]) (lambda (x) (g x))))]))
|
||||
|
||||
(define second (mk-lget second 2))
|
||||
(define third (mk-lget third 3))
|
||||
|
|
@ -392,27 +333,25 @@
|
|||
(define seventh (mk-lget seventh 7))
|
||||
(define eighth (mk-lget eighth 8))
|
||||
|
||||
(define rest (polymorphic (lambda (x)
|
||||
(define (rest x)
|
||||
(unless (pair? 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)
|
||||
(raise-type-error 'set-rest! "non-empty list" x))
|
||||
(unless (or (null? v) (pair? v))
|
||||
(raise-type-error 'set-rest! "second argument must be a list" v))
|
||||
(set-cdr! x v))))
|
||||
(set-cdr! x v))
|
||||
|
||||
(define last-pair
|
||||
(polymorphic
|
||||
(lambda (l)
|
||||
(define (last-pair l)
|
||||
(if (pair? l)
|
||||
(let loop ((l l) (x (cdr l)))
|
||||
(let loop ([l l] [x (cdr l)])
|
||||
(if (pair? x)
|
||||
(loop x (cdr x))
|
||||
l))
|
||||
(raise-type-error 'last-pair "pair" l)))))
|
||||
(raise-type-error 'last-pair "pair" l)))
|
||||
|
||||
(define cons? (lambda (x) (pair? x)))
|
||||
(define empty? (lambda (x) (null? x)))
|
||||
|
|
|
|||
|
|
@ -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)))))
|
||||
|
|
@ -1,8 +1,6 @@
|
|||
|
||||
(module thread mzscheme
|
||||
(require "spidey.ss"
|
||||
"etc.ss"
|
||||
"contract.ss")
|
||||
(require "etc.ss" "contract.ss")
|
||||
|
||||
(provide run-server
|
||||
consumer-thread)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user