Adding mark params

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)))))

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?))])

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.
+ }

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"]
 
 @;{--------}