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

Move mutable list functions to the compatibility collect.

Browse Source 
Mutable pair functions from racket/base are not moved.

original commit: 52439d528b78db6394798d9bdd39b2017de03a5e
This commit is contained in:
Vincent St-Amour 2012-07-27 16:22:40 -04:00
parent a4f6e69328
commit 5d9dacd19b
2 changed files with 213 additions and 207 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

210
collects/compatibility/mpair.rkt Normal file
View File

@ -0,0 +1,210 @@
#lang racket/base
(require (for-syntax racket/base)
racket/performance-hint)
(provide mmap
mfor-each
mlist
mlist?
mlength
mappend
mappend!
mreverse
mreverse!
mlist-tail
mlist-ref
mmemq
mmemv
mmember
massq
massv
massoc
mlist->list
list->mlist
mlistof)
(begin-encourage-inline
(define mmap
(case-lambda
[(f l) (let loop ([l l])
(cond
[(null? l) null]
[else (mcons (f (mcar l)) (loop (mcdr l)))]))]
[(f l1 l2) (let loop ([l1 l1][l2 l2])
(cond
[(null? l1) null]
[else (mcons (f (mcar l1) (mcar l2))
(loop (mcdr l1) (mcdr l2)))]))]
[(f l . ls) (let loop ([l l][ls ls])
(cond
[(null? l) null]
[else (mcons (apply f (mcar l) (map mcar ls))
(loop (mcdr l) (map mcdr ls)))]))]))
(define mfor-each
(case-lambda
[(f l) (let loop ([l l])
(cond
[(null? l) (void)]
[else (f (mcar l))
(loop (mcdr l))]))]
[(f l1 l2) (let loop ([l1 l1][l2 l2])
(cond
[(null? l1) (void)]
[else (f (mcar l1) (mcar l2))
(loop (mcdr l1) (mcdr l2))]))]
[(f l . ls) (let loop ([l l][ls ls])
(cond
[(null? l) (void)]
[else (apply f (mcar l) (map mcar ls))
(loop (mcdr l) (map mcdr ls))]))])))
(define (list->mlist l)
(cond
[(null? l) null]
[else (mcons (car l) (list->mlist (cdr l)))]))
(define (mlist->list l)
(cond
[(null? l) null]
[else (cons (mcar l) (mlist->list (mcdr l)))]))
(define-syntax mlist
(make-set!-transformer
(lambda (stx)
(syntax-case stx (set!)
[(set! id . _) (raise-syntax-error #f
"cannot mutate imported variable"
stx
#'id)]
[(_ a) #'(mcons a null)]
[(_ a b) #'(mcons a (mcons b null))]
[(_ a b c) #'(mcons a (mcons b (mcons c null)))]
[(_ arg ...) #'(-mlist arg ...)]
[_ #'-mlist]))))
(define -mlist
(let ([mlist
(case-lambda
[() null]
[(a) (mcons a null)]
[(a b) (mcons a (mcons b null))]
[(a b c) (mcons a (mcons b (mcons c null)))]
[(a b c d) (mcons a (mcons b (mcons c (mcons d null))))]
[l (list->mlist l)])])
mlist))
(define (mlist? l)
(cond
[(null? l) #t]
[(mpair? l)
(let loop ([turtle l][hare (mcdr l)])
(cond
[(null? hare) #t]
[(eq? hare turtle) #f]
[(mpair? hare)
(let ([hare (mcdr hare)])
(cond
[(null? hare) #t]
[(eq? hare turtle) #f]
[(mpair? hare)
(loop (mcdr turtle) (mcdr hare))]
[else #f]))]
[else #f]))]
[else #f]))
(define (mlength l)
(let loop ([l l][len 0])
(cond
[(null? l) len]
[else (loop (mcdr l) (add1 len))])))
(define mappend
(case-lambda
[() null]
[(a) a]
[(a b) (let loop ([a a])
(if (null? a)
b
(mcons (mcar a) (loop (mcdr a)))))]
[(a . l) (mappend a (apply mappend l))]))
;; mappend! : like append, but mutate each list to refer to the next.
;; modeled loosely on the v372 behavior
(define mappend!
(case-lambda
[() null]
[(a) a]
[(a b) (if (null? a)
b
(let loop ([atail a])
(cond [(null? (mcdr atail)) (set-mcdr! atail b) a]
[else (loop (mcdr atail))])))]
[(a . l) (mappend! a (apply mappend! l))]))
(define (mreverse l)
(let loop ([l l][a null])
(cond
[(null? l) a]
[else (loop (mcdr l) (mcons (mcar l) a))])))
(define (mreverse! l)
(let loop ([l l][prev null])
(cond
[(null? l) prev]
[else (let ([next (mcdr l)])
(set-mcdr! l prev)
(loop next l))])))
(define (mlist-tail l n)
(cond
[(zero? n) l]
[else (mlist-tail (mcdr l) (sub1 n))]))
(define (mlist-ref l n)
(cond
[(zero? n) (mcar l)]
[else (mlist-ref (mcdr l) (sub1 n))]))
(define (do-member =? v l)
(let loop ([l l])
(cond
[(null? l) #f]
[(=? v (mcar l)) l]
[else (loop (mcdr l))])))
(define (mmemq v l)
(do-member eq? v l))
(define (mmemv v l)
(do-member eqv? v l))
(define (mmember v l)
(do-member equal? v l))
(define (do-assoc =? v l)
(let loop ([l l])
(cond
[(null? l) #f]
[(=? v (mcar (mcar l))) (mcar l)]
[else (loop (mcdr l))])))
(define (massq v l)
(do-assoc eq? v l))
(define (massv v l)
(do-assoc eqv? v l))
(define (massoc v l)
(do-assoc equal? v l))
(define ((mlistof p?) l)
(let loop ([l l])
(cond
[(null? l) #t]
[(not (mpair? l)) #f]
[(p? (mcar l)) (loop (mcdr l))]
[else #f])))

210
collects/racket/mpair.rkt
View File

@ -1,210 +1,6 @@
#lang racket/base
(require (for-syntax racket/base)
"performance-hint.rkt")
;; compatibility library, see compatibility/mpair
(provide mmap
mfor-each
mlist
mlist?
mlength
mappend
mappend!
mreverse
mreverse!
mlist-tail
mlist-ref
mmemq
mmemv
mmember
massq
massv
massoc
mlist->list
list->mlist
mlistof)
(begin-encourage-inline
(define mmap
(case-lambda
[(f l) (let loop ([l l])
(cond
[(null? l) null]
[else (mcons (f (mcar l)) (loop (mcdr l)))]))]
[(f l1 l2) (let loop ([l1 l1][l2 l2])
(cond
[(null? l1) null]
[else (mcons (f (mcar l1) (mcar l2))
(loop (mcdr l1) (mcdr l2)))]))]
[(f l . ls) (let loop ([l l][ls ls])
(cond
[(null? l) null]
[else (mcons (apply f (mcar l) (map mcar ls))
(loop (mcdr l) (map mcdr ls)))]))]))
(define mfor-each
(case-lambda
[(f l) (let loop ([l l])
(cond
[(null? l) (void)]
[else (f (mcar l))
(loop (mcdr l))]))]
[(f l1 l2) (let loop ([l1 l1][l2 l2])
(cond
[(null? l1) (void)]
[else (f (mcar l1) (mcar l2))
(loop (mcdr l1) (mcdr l2))]))]
[(f l . ls) (let loop ([l l][ls ls])
(cond
[(null? l) (void)]
[else (apply f (mcar l) (map mcar ls))
(loop (mcdr l) (map mcdr ls))]))])))
(define (list->mlist l)
(cond
[(null? l) null]
[else (mcons (car l) (list->mlist (cdr l)))]))
(define (mlist->list l)
(cond
[(null? l) null]
[else (cons (mcar l) (mlist->list (mcdr l)))]))
(define-syntax mlist
(make-set!-transformer
(lambda (stx)
(syntax-case stx (set!)
[(set! id . _) (raise-syntax-error #f
"cannot mutate imported variable"
stx
#'id)]
[(_ a) #'(mcons a null)]
[(_ a b) #'(mcons a (mcons b null))]
[(_ a b c) #'(mcons a (mcons b (mcons c null)))]
[(_ arg ...) #'(-mlist arg ...)]
[_ #'-mlist]))))
(define -mlist
(let ([mlist
(case-lambda
[() null]
[(a) (mcons a null)]
[(a b) (mcons a (mcons b null))]
[(a b c) (mcons a (mcons b (mcons c null)))]
[(a b c d) (mcons a (mcons b (mcons c (mcons d null))))]
[l (list->mlist l)])])
mlist))
(define (mlist? l)
(cond
[(null? l) #t]
[(mpair? l)
(let loop ([turtle l][hare (mcdr l)])
(cond
[(null? hare) #t]
[(eq? hare turtle) #f]
[(mpair? hare)
(let ([hare (mcdr hare)])
(cond
[(null? hare) #t]
[(eq? hare turtle) #f]
[(mpair? hare)
(loop (mcdr turtle) (mcdr hare))]
[else #f]))]
[else #f]))]
[else #f]))
(define (mlength l)
(let loop ([l l][len 0])
(cond
[(null? l) len]
[else (loop (mcdr l) (add1 len))])))
(define mappend
(case-lambda
[() null]
[(a) a]
[(a b) (let loop ([a a])
(if (null? a)
b
(mcons (mcar a) (loop (mcdr a)))))]
[(a . l) (mappend a (apply mappend l))]))
;; mappend! : like append, but mutate each list to refer to the next.
;; modeled loosely on the v372 behavior
(define mappend!
(case-lambda
[() null]
[(a) a]
[(a b) (if (null? a)
b
(let loop ([atail a])
(cond [(null? (mcdr atail)) (set-mcdr! atail b) a]
[else (loop (mcdr atail))])))]
[(a . l) (mappend! a (apply mappend! l))]))
(define (mreverse l)
(let loop ([l l][a null])
(cond
[(null? l) a]
[else (loop (mcdr l) (mcons (mcar l) a))])))
(define (mreverse! l)
(let loop ([l l][prev null])
(cond
[(null? l) prev]
[else (let ([next (mcdr l)])
(set-mcdr! l prev)
(loop next l))])))
(define (mlist-tail l n)
(cond
[(zero? n) l]
[else (mlist-tail (mcdr l) (sub1 n))]))
(define (mlist-ref l n)
(cond
[(zero? n) (mcar l)]
[else (mlist-ref (mcdr l) (sub1 n))]))
(define (do-member =? v l)
(let loop ([l l])
(cond
[(null? l) #f]
[(=? v (mcar l)) l]
[else (loop (mcdr l))])))
(define (mmemq v l)
(do-member eq? v l))
(define (mmemv v l)
(do-member eqv? v l))
(define (mmember v l)
(do-member equal? v l))
(define (do-assoc =? v l)
(let loop ([l l])
(cond
[(null? l) #f]
[(=? v (mcar (mcar l))) (mcar l)]
[else (loop (mcdr l))])))
(define (massq v l)
(do-assoc eq? v l))
(define (massv v l)
(do-assoc eqv? v l))
(define (massoc v l)
(do-assoc equal? v l))
(define ((mlistof p?) l)
(let loop ([l l])
(cond
[(null? l) #t]
[(not (mpair? l)) #f]
[(p? (mcar l)) (loop (mcdr l))]
[else #f])))
(require compatibility/mpair)
(provide (all-from-out compatibility/mpair))