[r6rs-discuss] [Formal] SRFI-39 should be made an R6RS library

[John Cowan]

R. Kent Dybvig scripsit:

> Here is an implementation of make-parameter and parameterize in about 20
> lines of r5.92rs code.  Adding thread parameters requires an additional
> few lines of nonstandard code.  

Here's Chicken's code for make-parameter (I have globally changed "%"
to "%" and "%%" to "%%" in symbols).  Apparently, Chicken requires
parameter procedures to return only one value.

(define make-parameter
  (let ([count 0])
    (lambda (init . guard)
      (let* ([guard (if (pair? guard) (car guard) (lambda (x) x))]
             [val (guard init)] 
             [i count])
        (set! count (fx+ count 1))
        (when (fx>= i (%size %default-parameter-vector))
          (set! %default-parameter-vector 
            (%grow-vector %default-parameter-vector (fx+ i 1) (%%undefined))))
        (%setslot %default-parameter-vector i val)
        (lambda arg
          (let ([n (%size %current-parameter-vector)])
            (cond [(pair? arg)
                   (when (fx>= i n)
                     (set! %current-parameter-vector
                       (%grow-vector %current-parameter-vector (fx+ i 1) %snafu)))
                   (%setslot %current-parameter-vector i (guard (%slot arg 0)))
                   (%%undefined)]
                  [(fx>= i n)
                   (%slot %default-parameter-vector i)]
                  [else
                   (let ([val (%slot %current-parameter-vector i)])
                     (if (eq? val %snafu)
                         (%slot %default-parameter-vector i) 
                         val))])))))))

It requires considerable behind-the-scenes machinery, as you can see,
including a pair of growable vectors named %default-parameter-vector
and %current-parameter-vector (which latter is apparently thread-local).

And here's parameterize as a low-level macro:

(%register-macro
 'parameterize 
 (let ([car car]
       [cadr cadr] 
       [map map] )
   (lambda (bindings . body)
     (%check-syntax 'parameterize bindings '#((_ _) 0))
     (let* ([swap (gensym)]
            [params (%map car bindings)]
            [vals (%map cadr bindings)]
            [aliases (%map (lambda (z) (gensym)) params)]
            [aliases2 (%map (lambda (z) (gensym)) params)] )
       `(let ,(%append (map %list aliases params) (map %list aliases2 vals))

          (let ((,swap (lambda ()
                         ,@(map (lambda (a a2) `(let ((t (,a))) (,a ,a2) (%%set! ,a2 t)))
                                aliases aliases2))))
            (%dynamic-wind 
                ,swap
                (lambda () , at body)
                ,swap)))))))

-- 
Schlingt dreifach einen Kreis vom dies!    John Cowan <cowan at ccil.org>
Schliesst euer Aug vor heiliger Schau,     http://www.ccil.org/~cowan
Denn er genoss vom Honig-Tau,
Und trank die Milch vom Paradies.            -- Coleridge (tr. Politzer)