79 lines
3.2 KiB
Scheme
79 lines
3.2 KiB
Scheme
(module force mzscheme
|
|
(provide (all-defined-except do-!!))
|
|
|
|
(define-syntax (~ stx)
|
|
(syntax-case stx ()
|
|
[(~ E) (syntax/loc stx (delay E))]))
|
|
|
|
(define (! x) (if (promise? x) (! (force x)) x))
|
|
|
|
(define (!! x) (do-!! x #f))
|
|
;; Similar to the above, but wrap procedure values too
|
|
(define (!!! x) (do-!! x #t))
|
|
;; Force just a top-level list structure, similar to the above.
|
|
;; (todo: this and the next assumes no cycles.)
|
|
(define (!list x)
|
|
(let loop ([x x])
|
|
(let ([x (! x)]) (when (pair? x) (set-cdr! x (loop (cdr x)))) x)))
|
|
;; Force a top-level list structure and the first level of values, again,
|
|
;; similar to the above.
|
|
(define (!!list x)
|
|
(let loop ([x x])
|
|
(let ([x (! x)])
|
|
(when (pair? x)
|
|
(set-car! x (! (car x)))
|
|
(set-cdr! x (loop (cdr x)))) x)))
|
|
;; Force and split resulting values.
|
|
(define (!values x)
|
|
(split-values (! x)))
|
|
;; Similar, but forces the actual values too.
|
|
(define (!!values x)
|
|
(let ([x (! x)])
|
|
(if (multiple-values? x)
|
|
(apply values (map ! (multiple-values-values x)))
|
|
x)))
|
|
|
|
;; Multiple values are problematic: MzScheme promises can use multiple
|
|
;; values, but to carry that out `call-with-values' should be used in all
|
|
;; places that deal with multiple values, which will make the whole thing
|
|
;; much slower -- but multiple values are rarely used (spceifically, students
|
|
;; never use them). Instead, `values' is redefined to produce a first-class
|
|
;; tuple-holding struct, and `split-values' turns that into multiple values.
|
|
(define-struct multiple-values (values))
|
|
(define (split-values x)
|
|
(let ([x (! x)])
|
|
(if (multiple-values? x) (apply values (multiple-values-values x)) x)))
|
|
|
|
;; Force a nested structure -- we don't distinguish values from promises so
|
|
;; it's fine to destructively modify the structure.
|
|
(define (do-!! x translate-procedures?)
|
|
(define table (make-hash-table)) ; avoid loops due to sharing
|
|
(split-values ; see below
|
|
(let loop ([x x])
|
|
(let ([x (! x)])
|
|
(unless (hash-table-get table x (lambda () #f))
|
|
(hash-table-put! table x #t)
|
|
(cond [(pair? x)
|
|
(set-car! x (loop (car x)))
|
|
(set-cdr! x (loop (cdr x)))]
|
|
[(vector? x)
|
|
(let vloop ([i 0])
|
|
(when (< i (vector-length x))
|
|
(vector-set! x i (loop (vector-ref x i)))
|
|
(vloop (add1 i))))]
|
|
[(box? x) (set-box! x (loop (unbox x)))]
|
|
[(struct? x)
|
|
(let-values ([(type skipped?) (struct-info x)])
|
|
(if type
|
|
(let*-values ([(name initk autok ref set imms spr skp?)
|
|
(struct-type-info type)]
|
|
[(k) (+ initk autok)])
|
|
(let sloop ([i 0])
|
|
(unless (= i k)
|
|
(set x i (loop (ref x i)))
|
|
(sloop (add1 i)))))
|
|
x))]))
|
|
(if (and (procedure? x) translate-procedures?)
|
|
(lambda args (do-!! (apply x args) #t))
|
|
x))))))
|