From 5d9dacd19bec06d28d062c1485ce404aa8afe9fa Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Fri, 27 Jul 2012 16:22:40 -0400 Subject: [PATCH] Move mutable list functions to the compatibility collect. Mutable pair functions from racket/base are not moved. original commit: 52439d528b78db6394798d9bdd39b2017de03a5e --- collects/compatibility/mpair.rkt | 210 +++++++++++++++++++++++++++++++ collects/racket/mpair.rkt | 210 +------------------------------ 2 files changed, 213 insertions(+), 207 deletions(-) create mode 100644 collects/compatibility/mpair.rkt diff --git a/collects/compatibility/mpair.rkt b/collects/compatibility/mpair.rkt new file mode 100644 index 0000000..9f5169b --- /dev/null +++ b/collects/compatibility/mpair.rkt @@ -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]))) diff --git a/collects/racket/mpair.rkt b/collects/racket/mpair.rkt index ca65b45..535e527 100644 --- a/collects/racket/mpair.rkt +++ b/collects/racket/mpair.rkt @@ -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))