From 92ac61e806c4d2b99a9da695a2409d6b61cd3ac4 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Sat, 29 Dec 2007 12:30:25 +0000
Subject: [PATCH] scheme/mpair

svn: r8151
---
 collects/r5rs/main.ss                       | 127 +---------------
 collects/scheme/mpair.ss                    | 153 +++++++++++++++++++
 collects/scribblings/reference/data.scrbl   |   5 +-
 collects/scribblings/reference/mpairs.scrbl | 156 ++++++++++++++++++++
 collects/scribblings/reference/pairs.scrbl  |  46 ++----
 collects/scribblings/reference/syntax.scrbl |   2 +-
 6 files changed, 331 insertions(+), 158 deletions(-)
 create mode 100644 collects/scheme/mpair.ss
 create mode 100644 collects/scribblings/reference/mpairs.scrbl

diff --git a/collects/r5rs/main.ss b/collects/r5rs/main.ss
index 79c954ceff..fe82598c12 100644
--- a/collects/r5rs/main.ss
+++ b/collects/r5rs/main.ss
@@ -1,6 +1,7 @@
 
 (module main scheme/base
-  (require (for-syntax scheme/base)
+  (require scheme/mpair
+           (for-syntax scheme/base)
            (only-in mzscheme transcript-on transcript-off))
 
   (provide (for-syntax syntax-rules ...)
@@ -108,50 +109,6 @@
                        caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
                        cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr)
 
-  (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 (string->mlist s) (list->mlist (string->list s)))
   (define (mlist->string s) (list->string (mlist->list s)))
@@ -168,86 +125,6 @@
                      (mlist->list (car l))
                      (cons (car l) (loop (cdr l))))))]))
 
-  (define 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)]))
-
-  (define (mlist? l)
-    (cond
-     [(null? l) #t]
-     [(mpair? l) (mlist? (mcdr l))]
-     [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))]))
-
-  (define (mreverse l)
-    (let loop ([l l][a null])
-      (cond
-       [(null? l) a]
-       [else (loop (mcdr l) (mcons (mcar l) a))])))
-  
-  (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 mread
diff --git a/collects/scheme/mpair.ss b/collects/scheme/mpair.ss
new file mode 100644
index 0000000000..f6b6e3caba
--- /dev/null
+++ b/collects/scheme/mpair.ss
@@ -0,0 +1,153 @@
+#lang scheme/base
+
+(provide mmap
+         mfor-each
+         mlist
+         mlist?
+         mlength
+         mappend
+         mreverse
+         mlist-tail
+         mlist-ref
+         mmemq
+         mmemv
+         mmember
+         massq
+         massv
+         massoc
+         mlist->list
+         list->mlist
+         mlistof)
+
+(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 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)]))
+
+(define (mlist? l)
+  (cond
+   [(null? l) #t]
+   [(mpair? l) (mlist? (mcdr l))]
+   [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))]))
+
+(define (mreverse l)
+  (let loop ([l l][a null])
+    (cond
+     [(null? l) a]
+     [else (loop (mcdr l) (mcons (mcar l) a))])))
+
+(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/scribblings/reference/data.scrbl b/collects/scribblings/reference/data.scrbl
index 5c22b91718..8b916794b4 100644
--- a/collects/scribblings/reference/data.scrbl
+++ b/collects/scribblings/reference/data.scrbl
@@ -1,7 +1,7 @@
 #lang scribble/doc
 @require["mz.ss"]
 
-@title[#:style 'toc]{Primitive Datatypes}
+@title[#:style 'toc #:tag "data"]{Primitive Datatypes}
 
 Each of the built-in datatypes comes with a set of procedures for
 manipulating members of the datatype.
@@ -240,6 +240,9 @@ for each pair of keywords is the same as using
 @; ----------------------------------------------------------------------
 @include-section["pairs.scrbl"]
 
+@; ----------------------------------------------------------------------
+@include-section["mpairs.scrbl"]
+
 @; ------------------------------------------------------------
 @section[#:tag "vectors"]{Vectors}
 
diff --git a/collects/scribblings/reference/mpairs.scrbl b/collects/scribblings/reference/mpairs.scrbl
new file mode 100644
index 0000000000..e3200b65d8
--- /dev/null
+++ b/collects/scribblings/reference/mpairs.scrbl
@@ -0,0 +1,156 @@
+#lang scribble/doc
+@(require "mz.ss"
+          scribble/scheme
+          (for-label scheme/mpair))
+
+@title[#:tag "mpairs"]{Mutable Pairs and Lists}
+
+A @deftech{mutable pair} is like a pair created by @scheme[cons], but
+it supports @scheme[set-mcar!] and @scheme[set-mcdr!] mutation
+operations to change the parts of the pair (like traditional Lisp and
+Scheme pairs).
+
+A @deftech{mutable list} is analogous to a list created with pairs, but
+instead created with immutable pairs.
+
+@; ----------------------------------------
+@section{Mutable Pair Constructors and Selectors}
+
+@defproc[(mpair? [v any/c]) boolean?]{Returns @scheme[#t] if @scheme[v] is
+a mutable pair, @scheme[#f] otherwise.}
+
+@defproc[(mcons [a any/c] [d any/c]) pair?]{Returns a mutable pair whose first
+element is @scheme[a] and second element is @scheme[d].}
+
+@defproc[(mcar [p mpair?]) any/c]{Returns the first element of the
+mutable pair @scheme[p].}
+
+@defproc[(mcdr [p mpair?]) any/c]{Returns the second element of the
+mutable pair @scheme[p].}
+
+
+@defproc[(set-mcar! [p mpair?] [v any/v]) 
+         void?]{
+
+Changes the mutable pair @scheme[p] so that its first element is
+@scheme[v].}
+
+@defproc[(set-mcdr! [p mpair?] [v any/v]) 
+         void?]{
+
+Changes the mutable pair @scheme[p] so that its second element is
+@scheme[v].}
+
+@; ----------------------------------------
+@section{Mutable List Functions}
+
+@note-lib-only[scheme/mpair]
+
+For functions described in this section, contracts are not directly
+enforced. In particular, when a mutable list is expected, supplying
+any other kind of value (or mutating a value that starts as a list)
+tends to produce an exception from @scheme[mcar] or @scheme[mcdr].
+
+@defproc[(mlist? [v any/c]) boolean?]{Returns @scheme[#t] if
+ @scheme[v] is a mutable list: either the empty list, or a mutable
+ pair whose second element is a mutable list.}
+
+
+@defproc[(mlist [v any/c] ...) mlist?]{Returns a newly allocated
+mutable list containing the @scheme[v]s as its elements.}
+
+
+@defproc[(list->mlist [lst list?]) mlist?]{
+
+Returns a newly allocated mutable list with the same elements as
+@scheme[lst].}
+
+
+@defproc[(mlist->list [mlst mlist?]) list?]{
+
+Returns a newly allocated list with the same elements as
+@scheme[nlst].}
+
+
+@defproc[(mlength [mlst mlist?])
+         nonnegative-exact-integer?]{
+
+Returns the number of elements in @scheme[mlst].}
+
+
+@defproc[(mlist-ref [mlst mlist?][pos nonnegative-exact-integer?])
+         any/c]{
+
+Like @scheme[list-ref], but for @tech{mutable lists}.}
+
+
+@defproc[(mlist-tail [mlst mlist?][pos nonnegative-exact-integer?])
+         any/c]{
+
+Like @scheme[list-tail], but for @tech{mutable lists}.}
+
+
+@defproc*[([(mappend [mlst mlist?] ...) mlist?]
+           [(mappend [mlst mlist?] ... [v any/c]) any/c])]{
+
+Like @scheme[append], but for @tech{mutable lists}.}
+
+
+@defproc[(mreverse [mlst mlist?]) mlist?]{
+
+Like @scheme[reverse], but for @tech{mutable lists}.}
+
+
+@defproc[(mmap [proc procedure?] [mlst mlist?] ...+) 
+         mlist?]{
+
+Like @scheme[map], but for @tech{mutable lists}.}
+
+
+@defproc[(mfor-each [proc procedure?] [mlst mlist?] ...+)
+         void?]{
+
+Like @scheme[for-each], but for @tech{mutable lists}.}
+
+
+@defproc[(mmember [v any/c] [mlst mlist?])
+         (or/c mlist? false/c)]{
+
+Like @scheme[member], but for @tech{mutable lists}.}
+
+
+@defproc[(mmemv [v any/c] [mlst mlist?])
+         (or/c mlist? false/c)]{
+
+Like @scheme[memv], but for @tech{mutable lists}.}
+
+
+@defproc[(mmemq [v any/c] [mlst mlist?])
+         (or/c list? false/c)]{
+
+Like @scheme[memq], but for @tech{mutable lists}.}
+
+
+@defproc[(massoc [v any/c] [mlst (mlistof mpair?)])
+         (or/c mpair? false/c)]{
+
+Like @scheme[assoc], but for mutable lists of mutable pairs.}
+
+
+@defproc[(massv [v any/c] [mlst (mlistof mpair?)])
+         (or/c mpair? false/c)]{
+
+Like @scheme[assv], but for mutable lists of mutable pairs.}
+
+
+@defproc[(massq [v any/c] [mlst (mlistof mpair?)])
+         (or/c mpair? false/c)]{
+
+Like @scheme[assq], but for mutable lists of mutable pairs.}
+
+
+@defproc[(mlistof [pred (any/c . -> . any/c)])
+         (any/c . -> . boolean?)]{
+
+Returns a procedure that returns @scheme[#t] when given a mutable list
+for which @scheme[pred] returns a true value for all elements.}
diff --git a/collects/scribblings/reference/pairs.scrbl b/collects/scribblings/reference/pairs.scrbl
index 097dc931f9..92a80369c9 100644
--- a/collects/scribblings/reference/pairs.scrbl
+++ b/collects/scribblings/reference/pairs.scrbl
@@ -43,10 +43,23 @@
 
 @title[#:tag "pairs"]{Pairs and Lists}
 
+A @deftech{pair} combines exactly two values. The first value is
+accessed with the @scheme[car] procedure, and the second value is
+accessed with the @scheme[cdr] procedure. Pairs are not mutable (but
+see @secref["mpairs"]).
+
+A @deftech{list} is recursively defined: it is either the constant
+@scheme[null], or it is a pair whose second value is a list.
+
 A list can be used as a single-valued sequence (see
 @secref["sequences"]). The elements of the list serve as elements
 of the sequence. See also @scheme[in-list].
 
+Cyclic data structures can be created using only immutable pairs via
+@scheme[read] or @scheme[make-reader-graph]. If starting with a pair
+and using some number of @scheme[cdr]s returns to the starting pair,
+then the pair is not a list.
+
 @; ----------------------------------------
 @section{Pair Constructors and Selectors}
 
@@ -70,7 +83,7 @@ pair @scheme[p].}
 
 @defproc[(list? [v any/c]) boolean?]{Returns @scheme[#t] if @scheme[v]
  is a list: either the empty list, or a pair whose second element is a
- list.}
+ list. This procedure takes amortized constant time.}
 
 @defproc[(list [v any/c] ...) list?]{Returns a newly allocated list
 containing the @scheme[v]s as its elements.}
@@ -95,35 +108,6 @@ is the value produced by @scheme[(proc _i)].
 (build-list 5 (lambda (x) (* x x)))
 ]}
 
-@; ----------------------------------------
-@section{Mutable Pair Operations}
-
-@defproc[(mpair? [v any/c]) boolean?]{Returns @scheme[#t] if @scheme[v] is
-a mutable pair, @scheme[#f] otherwise.}
-
-@defproc[(mcons [a any/c] [d any/c]) pair?]{Returns a mutable pair whose first
-element is @scheme[a] and second element is @scheme[d].}
-
-@defproc[(mcar [p mpair?]) any/c]{Returns the first element of the
-mutable pair @scheme[p].}
-
-@defproc[(mcdr [p mpair?]) any/c]{Returns the second element of the
-mutable pair @scheme[p].}
-
-
-@defproc[(set-mcar! [p mpair?] [v any/v]) 
-         void?]{
-
-Changes the mutable pair @scheme[p] so that its first element is
-@scheme[v].}
-
-@defproc[(set-mcdr! [p mpair?] [v any/v]) 
-         void?]{
-
-Changes the mutable pair @scheme[p] so that its second element is
-@scheme[v].}
-
-
 @; ----------------------------------------
 @section{List Operations}
 
@@ -136,7 +120,7 @@ Returns the number of elements in @scheme[lst].}
 @defproc[(list-ref [lst list?][pos nonnegative-exact-integer?])
          any/c]{
 
-Returns the element of @scheme[vec] at position @scheme[pos], where
+Returns the element of @scheme[lst] at position @scheme[pos], where
 the list's first element is position @scheme[0]. If the list has
 @scheme[pos] or fewer elements, then the
 @exnraise[exn:fail:contract].}
diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl
index 35d54b6993..200960a1d8 100644
--- a/collects/scribblings/reference/syntax.scrbl
+++ b/collects/scribblings/reference/syntax.scrbl
@@ -1589,7 +1589,7 @@ its variants export only definitions accessible from the lexical
 context of the @scheme[phaseless-spec] form.}
 
 @;------------------------------------------------------------------------
-@section{Interaction Wrapper: @scheme[#%top-interaction]}
+@section[#:tag "#%top-interaction"]{Interaction Wrapper: @scheme[#%top-interaction]}
 
 @defform[(#%top-interaction . form)]{