From e40f89fed21dd7c47b1b7657e52843cbaab7babf Mon Sep 17 00:00:00 2001
From: Jay McCarthy <jay@racket-lang.org>
Date: Fri, 30 Apr 2010 13:06:55 -0600
Subject: [PATCH] Adding mark params

---
 collects/tests/unstable/markparam.rkt         | 129 ++++++++++++++++++
 collects/unstable/markparam.rkt               |  41 ++++++
 collects/unstable/scribblings/markparam.scrbl |  37 +++++
 collects/unstable/scribblings/unstable.scrbl  |   1 +
 4 files changed, 208 insertions(+)
 create mode 100644 collects/tests/unstable/markparam.rkt
 create mode 100644 collects/unstable/markparam.rkt
 create mode 100644 collects/unstable/scribblings/markparam.scrbl

diff --git a/collects/tests/unstable/markparam.rkt b/collects/tests/unstable/markparam.rkt
new file mode 100644
index 0000000000..4f6b22d78e
--- /dev/null
+++ b/collects/tests/unstable/markparam.rkt
@@ -0,0 +1,129 @@
+#lang racket
+(require unstable/markparam
+         racket/serialize
+         tests/eli-tester)
+
+(define x (mark-parameter))
+(define y (mark-parameter))
+(test
+ (mark-parameter? x)
+ (mark-parameter? (deserialize (serialize x)))
+ (deserialize (serialize x)) => x
+ 
+ (apply eq? (deserialize (serialize (list x x))))
+ 
+ #:failure-prefix "empty"
+ (mark-parameterize 
+  ()
+  (test 
+   (x) => #f
+   (mark-parameter-first x) => #f
+   (mark-parameter-first y) => #f
+   (mark-parameter-all x) => empty
+   (mark-parameter-all y) => empty
+   (mark-parameters-all (list x)) => empty
+   (mark-parameters-all (list y)) => empty
+   (mark-parameters-all (list x y)) => empty))
+ 
+ #:failure-prefix "x 1"
+ (mark-parameterize 
+  ([x 1])
+  (test
+   (x) => 1
+   (mark-parameter-first x) => 1
+   (mark-parameter-first y) => #f
+   (mark-parameter-all x) => (list 1)
+   (mark-parameter-all y) => empty
+   (mark-parameters-all (list x)) => (list (vector 1))
+   (mark-parameters-all (list y)) => empty
+   (mark-parameters-all (list x y)) => (list (vector 1 #f))
+   (mark-parameters-all (list x y) 20) => (list (vector 1 20))))
+ 
+ #:failure-prefix "x 2 > x 1"
+ (mark-parameterize 
+  ([x 2])
+  (mark-parameterize 
+   ([x 1])
+   (test
+    (mark-parameter-first x) => 1
+    (mark-parameter-first y) => #f
+    (mark-parameter-all x) => (list 1)
+    (mark-parameter-all y) => empty
+    (mark-parameters-all (list x)) => (list (vector 1))
+    (mark-parameters-all (list y)) => empty
+    (mark-parameters-all (list x y)) => (list (vector 1 #f))
+    (mark-parameters-all (list x y) 20) => (list (vector 1 20)))))
+ 
+ #:failure-prefix "x 2 > list > x 1"
+ (mark-parameterize 
+  ([x 2])
+  (list
+   (mark-parameterize 
+    ([x 1])
+    (test
+     (mark-parameter-first x) => 1
+     (mark-parameter-first y) => #f
+     (mark-parameter-all x) => (list 1 2)
+     (mark-parameter-all y) => empty
+     (mark-parameters-all (list x)) => (list (vector 1) (vector 2))
+     (mark-parameters-all (list y)) => empty
+     (mark-parameters-all (list x y)) => (list (vector 1 #f) (vector 2 #f))
+     (mark-parameters-all (list x y) 20) => (list (vector 1 20) (vector 2 20))))))
+ 
+ #:failure-prefix "x 2 > list > x 1"
+ (mark-parameterize 
+  ([x 2])
+  (list
+   (mark-parameterize 
+    ([x 1])
+    (test
+     (mark-parameter-first x) => 1
+     (mark-parameter-first y) => #f
+     (mark-parameter-all x) => (list 1 2)
+     (mark-parameter-all y) => empty
+     (mark-parameters-all (list x)) => (list (vector 1) (vector 2))
+     (mark-parameters-all (list y)) => empty
+     (mark-parameters-all (list x y)) => (list (vector 1 #f) (vector 2 #f))
+     (mark-parameters-all (list x y) 20) => (list (vector 1 20) (vector 2 20))))))
+ 
+  #:failure-prefix "x 2 > list > y 1"
+ (mark-parameterize 
+  ([x 2])
+  (list
+   (mark-parameterize 
+    ([y 1])
+    (test
+     (mark-parameter-first x) => 2
+     (mark-parameter-first y) => 1
+     (mark-parameter-all x) => (list 2)
+     (mark-parameter-all y) => (list 1)
+     (mark-parameters-all (list x)) => (list (vector 2))
+     (mark-parameters-all (list y)) => (list (vector 1))
+     (mark-parameters-all (list x y)) => (list (vector #f 1) (vector 2 #f))
+     (mark-parameters-all (list x y) 20) => (list (vector 20 1) (vector 2 20))))))
+ 
+ #:failure-prefix "x 1 y 2"
+ (mark-parameterize 
+  ([x 1] [y 2])
+  (test
+   (mark-parameter-first x) => 1
+   (mark-parameter-first y) => 2
+   (mark-parameter-all x) => (list 1)
+   (mark-parameter-all y) => (list 2)
+   (mark-parameters-all (list x)) => (list (vector 1))
+   (mark-parameters-all (list y)) => (list (vector 2))
+   (mark-parameters-all (list x y)) => (list (vector 1 2))
+   (mark-parameters-all (list x y) 20) => (list (vector 1 2))))
+ 
+ #:failure-prefix "x 1 y x"
+ (mark-parameterize 
+  ([x 1] [y (mark-parameter-first x)])
+  (test
+   (mark-parameter-first x) => 1
+   (mark-parameter-first y) => #f
+   (mark-parameter-all x) => (list 1)
+   (mark-parameter-all y) => (list #f)
+   (mark-parameters-all (list x)) => (list (vector 1))
+   (mark-parameters-all (list y)) => (list (vector #f))
+   (mark-parameters-all (list x y)) => (list (vector 1 #f))
+   (mark-parameters-all (list x y) 20) => (list (vector 1 #f)))))
\ No newline at end of file
diff --git a/collects/unstable/markparam.rkt b/collects/unstable/markparam.rkt
new file mode 100644
index 0000000000..90d3027c5f
--- /dev/null
+++ b/collects/unstable/markparam.rkt
@@ -0,0 +1,41 @@
+#lang racket
+(require racket/serialize)
+
+(define mark-parameter-first
+  (curry continuation-mark-set-first #f))
+(define (mark-parameter-all mp [prompt-tag (default-continuation-prompt-tag)])
+  (continuation-mark-set->list (current-continuation-marks) mp prompt-tag))
+(define (mark-parameters-all mps [none-v #f] [prompt-tag (default-continuation-prompt-tag)])
+  (continuation-mark-set->list* (current-continuation-marks) mps none-v prompt-tag))
+
+(serializable-struct
+ mark-parameter ()
+ #:transparent
+ #:property prop:procedure mark-parameter-first)
+
+(define-syntax with-continuation-mark*
+  (syntax-rules ()
+    [(_ () body-expr ...)
+     (begin body-expr ...)]
+    [(_ ([k v]) body-expr ...)
+     (with-continuation-mark k v body-expr ...)]
+    [(_ ([k0 v0] [k1 v1] ...) body-expr ...)
+     (with-continuation-mark k0 v0
+       (with-continuation-mark* ([k1 v1] ...)
+         body-expr ...))]))
+
+(define-syntax (mark-parameterize stx)
+  (syntax-case stx ()
+    [(_ ([mp expr] ...) body-expr ...)
+     (with-syntax ([(expr-val ...) (generate-temporaries #'(expr ...))])
+       (syntax/loc stx
+         (let ([expr-val expr] ...)
+           (with-continuation-mark* ([mp expr-val] ...)
+             body-expr ...))))]))
+
+(provide mark-parameterize
+         (struct-out mark-parameter))
+(provide/contract
+ [mark-parameter-first ((mark-parameter?) (continuation-prompt-tag?) . ->* . any/c)]
+ [mark-parameter-all ((mark-parameter?) (continuation-prompt-tag?) . ->* . list?)]
+ [mark-parameters-all (((listof mark-parameter?)) (any/c continuation-prompt-tag?) . ->* . (listof vector?))])
\ No newline at end of file
diff --git a/collects/unstable/scribblings/markparam.scrbl b/collects/unstable/scribblings/markparam.scrbl
new file mode 100644
index 0000000000..ba2d42c0e7
--- /dev/null
+++ b/collects/unstable/scribblings/markparam.scrbl
@@ -0,0 +1,37 @@
+#lang scribble/manual
+@(require "utils.rkt" (for-label racket unstable/markparam))
+
+@title{Mark Parameters}
+
+@defmodule[unstable/markparam]
+
+@unstable[@author+email["Jay McCarthy" "jay@racket-lang.org"]]
+
+This library provides a simplified version of parameters that are backed by continuation marks, rather than parameterizations. This means they are slightly slower, are not inherited by child threads, do not have initial values, and cannot be imperatively mutated.
+
+@defstruct*[mark-parameter ()]{
+ The struct for mark parameters. It is guaranteed to be serializable and transparent. If used as a procedure, it calls @racket[mark-parameter-first] on itself.
+ }
+
+@defproc[(mark-parameter-first [mp mark-parameter?]
+                               [tag continuation-prompt-tag? default-continuation-prompt-tag])
+         any/c]{
+ Returns the first value of @racket[mp] up to @racket[tag].
+ }
+               
+@defproc[(mark-parameter-all [mp mark-parameter?]
+                             [tag continuation-prompt-tag? default-continuation-prompt-tag])
+         list?]{
+ Returns the values of @racket[mp] up to @racket[tag].
+ }   
+  
+@defproc[(mark-parameters-all [mps (listof mark-parameter?)]
+                              [none-v [any/c #f]]
+                              [tag continuation-prompt-tag? default-continuation-prompt-tag])
+         (listof vector?)]{
+ Returns the values of the @racket[mps] up to @racket[tag]. The length of each vector in the result list is the same as the length of @racket[mps], and a value in a particular vector position is the value for the corresponding mark parameter in @racket[mps]. Values for multiple mark parameter appear in a single vector only when the mark parameters are for the same continuation frame in the current continuation. The @racket[none-v] argument is used for vector elements to indicate the lack of a value.
+ }
+                          
+@defform[(mark-parameterize ([mp expr] ...) body-expr ...)]{
+ Parameterizes @racket[(begin body-expr ...)] by associating each @racket[mp] with the evaluation of @racket[expr] in the parameterization of the entire expression.
+ }
\ No newline at end of file
diff --git a/collects/unstable/scribblings/unstable.scrbl b/collects/unstable/scribblings/unstable.scrbl
index 093c06a43a..6a6289c86a 100644
--- a/collects/unstable/scribblings/unstable.scrbl
+++ b/collects/unstable/scribblings/unstable.scrbl
@@ -93,6 +93,7 @@ Keep documentation and tests up to date.
 @include-section["skip-list.scrbl"]
 @include-section["interval-map.scrbl"]
 @include-section["generics.scrbl"]
+@include-section["markparam.scrbl"]
 
 @;{--------}