+
+
+;;; Playing with procedures arguments
+
+(define undefined)
+(define (bound? var) (not (eq? var undefined)))
+
+(define (required-arguments args values)
+ "Return an alist with required arguments and their values"
+ (define (f vars values)
+ (cond ((null? vars) '())
+ ((null? values) (assoc-set! (f (cdr vars) '())
+ (car vars)
+ undefined))
+ (else (assoc-set! (f (cdr vars) (cdr values))
+ (car vars)
+ (car values)))))
+ (f (assoc-ref args 'required) values))
+
+(define (optional-arguments args values)
+ "Return an alist with optional arguments and their values"
+ (define (f vars values)
+ (cond ((null? vars) '())
+ ((null? values) (assoc-set! (f (cdr vars) '())
+ (car vars)
+ undefined))
+ (else (assoc-set! (f (cdr vars) (cdr values))
+ (car vars)
+ (car values)))))
+ (f (assoc-ref args 'optional)
+ (list-tail values
+ (min (length (assoc-ref args 'required))
+ (length values)))))
+
+(define (keyword-arguments args values)
+ "Return an alist with keyword arguments and their values"
+ (define (f vars values)
+ (cond ((null? vars) '())
+ (else
+ (let ((val (member (car vars) values)))
+ (assoc-set! (f (cdr vars) values)
+ (keyword->symbol (car vars))
+ (if val (cadr val) undefined))))))
+ (f (map (lambda (x) (car x)) (assoc-ref args 'keyword)) values))
+
+(define (rest-arguments args values)
+ "Return an alist with rest arguments"
+ (let ((rest (assoc-ref args 'rest)))
+ (cond (rest (assoc-set! '()
+ rest
+ (list-tail values
+ (min (+ (length (assoc-ref args 'required))
+ (length (assoc-ref args 'optional)))
+ (length values)))))
+ (else '()))))
+
+(define (arguments-calling proc values)
+ "Return an alist with procedure arguments and their values"
+ (let ((args ((@ (ice-9 session) procedure-arguments) proc)))
+ (append (required-arguments args values)
+ (optional-arguments args values)
+ (keyword-arguments args values)
+ (rest-arguments args values))))
+
+(define (required-arguments-apply args values)
+ "Return a list with required arguments for use with apply"
+ (define (f vars values)
+ (cond ((null? vars) '())
+ (else
+ (cons (assoc-ref values (car vars))
+ (f (cdr vars) values)))))
+ (f (assoc-ref args 'required) values))
+
+(define (optional-arguments-apply args values)
+ "Return a list with optional arguments for use with apply"
+ (define (f vars values)
+ (cond ((null? vars) '())
+ (else (let ((a (f (cdr vars) values))
+ (val (assoc (car vars) values)))
+ (cond ((and val (bound? (cdr val)))
+ (cons (cdr val) a))
+ (else a))))))
+ (f (assoc-ref args 'optional) values))
+
+(define (keyword-arguments-apply args values)
+ "Return a list with keyword arguments for use with apply"
+ (define (f vars values)
+ (cond ((null? vars) '())
+ (else (let ((a (f (cdr vars) values))
+ (val (assoc (keyword->symbol (car vars)) values)))
+ (cond ((and val (bound? (cdr val)))
+ (cons (car vars) (cons (cdr val) a)))
+ (else a))))))
+ (f (map (lambda (x) (car x)) (assoc-ref args 'keyword)) values))
+
+(define (rest-arguments-apply args values)
+ "Return a list with rest arguments for use with apply"
+ (let ((rest (assoc-ref args 'rest)))
+ (cond (rest (assoc-ref values rest))
+ (else '()))))
+
+(define (arguments-apply proc values)
+ "Return a list for use with apply"
+ (let ((args ((@ (ice-9 session) procedure-arguments) proc)))
+ (append (required-arguments-apply args values)
+ (optional-arguments-apply args values)
+ (keyword-arguments-apply args values)
+ (rest-arguments-apply args values))))
+
+(define (names-arguments args)
+ (map (lambda (x) (if (list? x) (car x) x))
+ (filter (lambda (x) (not (keyword? x)))
+ (pair-to-list args))))
+
+
+;;; Continuations and coroutines
+
+(define (make-producer body)
+ (define resume #f)
+ (lambda (real-send)
+ (define send-to real-send)
+ (define (send value-to-send)
+ (set! send-to
+ (call/cc
+ (lambda (k)
+ (set! resume k)
+ (send-to value-to-send)))))
+ (if resume
+ (resume real-send)
+ (body send))))
+
+
+;;; Miscellaneous
+
+(define (pair-to-list pair)
+ (cond ((null? pair) '())
+ ((not (pair? pair)) (list pair))
+ (else (cons (car pair) (pair-to-list (cdr pair))))))