(write-string "object satisfying " port)
(write predicate port)))))
\f
+;;;; Promises
+
+(define (promise? object)
+ (and (cell? object)
+ (object-type? (ucode-type delayed) (cell-contents object))))
+
+(define (make-promise object)
+ (if (promise? object)
+ object
+ (make-cell (system-pair-cons (ucode-type delayed) #t object))))
+
+(define (make-unforced-promise thunk)
+ ;(guarantee thunk? thunk 'make-unforced-promise)
+ (make-cell (system-pair-cons (ucode-type delayed) #f thunk)))
+
+(define (%promise-parts promise)
+ (without-interrupts
+ (lambda ()
+ (let ((p (cell-contents promise)))
+ (values (system-pair-car p)
+ (system-pair-cdr p))))))
+
+(define (promise-forced? promise)
+ (guarantee promise? promise 'promise-forced?)
+ (system-pair-car (cell-contents promise)))
+
+(define (promise-value promise)
+ (guarantee promise? promise 'promise-value)
+ (receive (forced? value) (%promise-parts promise)
+ (if (not forced?)
+ (error "Promise not yet forced:" promise))
+ value))
+
+(define (force promise)
+ (guarantee promise? promise 'force)
+ (%force promise))
+
+(define (%force promise)
+ (receive (forced? value) (%promise-parts promise)
+ (if forced?
+ value
+ (let ((promise* (value)))
+ (guarantee promise? promise* 'force)
+ (without-interrupts
+ (lambda ()
+ (let ((p (cell-contents promise)))
+ (if (not (system-pair-car p))
+ (let ((p* (cell-contents promise*)))
+ (system-pair-set-car! p (system-pair-car p*))
+ (system-pair-set-cdr! p (system-pair-cdr p*))
+ (set-cell-contents! promise* p))))))
+ (%force promise)))))
+\f
;;;; Miscellany
(define (object-constant? object)
(values (make-scode-combination (ucode-primitive force 1)
(list (make-evaluated-object promise)))
undefined-environment
- (let ((expr (promise-expression promise)))
- (case expr
- ((|#[(runtime microcode-data)forced]|) undefined-expression)
- ((|#[(runtime microcode-data)compiled]|) unknown-expression)
- (else (validate-subexpression frame expr)))))))
+ undefined-expression)))
(define ((method/application-frame index) frame)
(values (make-scode-combination
(list (cons 'name name) ...)))))
env))
+ (if (unbound? env 'delay-force)
+ (eval '(begin
+ (define-syntax delay-force
+ (syntax-rules ()
+ ((delay-force expression)
+ (make-unforced-promise (lambda () expression)))))
+ (define-syntax delay
+ (syntax-rules ()
+ ((delay expression)
+ (delay-force (make-promise expression))))))
+ env))
+
(if (unbound? env 'define-print-method)
(eval '(define (define-print-method predicate print-method)
unspecific)
(filter-potentially-dangerous (cdr aux-list))
(cons (car aux-list)
(filter-potentially-dangerous (cdr aux-list))))
- '())))
-
-;;;; Promises
-
-(define-integrable (promise? object)
- (object-type? (ucode-type delayed) object))
-
-(define (make-promise object)
- (if (promise? object)
- object
- (system-pair-cons (ucode-type delayed) #t object)))
-
-(define-integrable (%promise-forced? promise)
- (eq? #t (system-pair-car promise)))
-
-(define (promise-forced? promise)
- (guarantee promise? promise 'promise-forced?)
- (%promise-forced? promise))
-
-(define (promise-value promise)
- (guarantee promise? promise 'promise-value)
- (if (not (%promise-forced? promise))
- (error "Promise not yet forced:" promise))
- (system-pair-cdr promise))
-
-(define (promise-expression promise)
- (without-interrupts
- (lambda ()
- (case (system-pair-car promise)
- ((#t) '|#[(runtime microcode-data)forced]|)
- ((0) '|#[(runtime microcode-data)compiled]|)
- (else (system-pair-cdr promise))))))
-
-(define (force promise)
- (guarantee promise? promise 'force)
- (without-interrupts
- (lambda ()
- (case (system-pair-car promise)
- ((#t)
- (system-pair-cdr promise))
- ((0) ;compiled
- (let ((result ((system-pair-cdr promise))))
- (system-pair-set-cdr! promise result)
- (system-pair-set-car! promise #t)
- result))
- (else ;interpreted
- ((ucode-primitive force 1) promise))))))
\ No newline at end of file
+ '())))
\ No newline at end of file
(if (not condition)
(begin form ...)))))
+(define-syntax $delay-force
+ (syntax-rules ()
+ ((delay-force expression)
+ (make-unforced-promise (lambda () expression)))))
+
+(define-syntax $delay
+ (syntax-rules ()
+ ((delay expression)
+ (delay-force (make-promise expression)))))
+
(define $guard
(spar-transformer->runtime
(delay
(spar-push spar-arg:ctx)
(spar* (spar-subform spar-push-classified))
(spar-match-null)))))
-
-(define $delay
- (spar-classifier->runtime
- (delay
- (spar-call-with-values delay-item
- (spar-subform)
- (spar-push spar-arg:ctx)
- (spar-subform spar-push-deferred-classified)
- (spar-match-null)))))
\f
;;;; Definitions
(lambda ()
(output/declaration (classify)))))
-(define (delay-item ctx classify)
- (expr-item ctx
- (lambda ()
- (output/delay (compile-expr-item (classify))))))
-
(define (if-item ctx predicate consequent alternative)
(expr-item ctx
(lambda ()
define-print-method
error:not-a
error:not-a-list-of
+ force ;R7RS
gc-space-status
guarantee
guarantee-list-of
interrupt-mask/gc-ok
interrupt-mask/none
interrupt-mask/timer-ok
+ make-promise ;R7RS
+ make-unforced-promise
object-constant?
object-pure?
predicate->dispatch-tag
predicate?
+ promise-forced?
+ promise-value
+ promise? ;R7RS
register-predicate!
set-dispatch-tag<=!
set-predicate<=!
environment-extension-parent
environment-extension-procedure
environment-extension?
- force ;R7RS
interpreter-return-address?
- make-promise ;R7RS
make-return-address
microcode-error
microcode-return
microcode-termination
microcode-type
- promise-forced?
- promise-value
- promise? ;R7RS
return-address/code
return-address/name
return-address?
set-environment-extension-parent!
stack-address->index
stack-address-offset
- stack-address?)
- (export (runtime debugging-info)
- promise-expression))
+ stack-address?))
(define-package (runtime vector)
(files "vector")
output/constant
output/declaration
output/definition
- output/delay
output/disjunction
output/lambda
output/let
(begin $begin) ;R7RS
(declare $declare)
(define-syntax $define-syntax) ;R7RS
- (delay $delay) ;R7RS
(else $else) ;R7RS
(er-macro-transformer $er-macro-transformer)
(if $if) ;R7RS
(define-integrable $define-integrable)
(define-record-type $define-record-type)
(define-values $define-values) ;R7RS
+ (delay $delay) ;R7RS
+ (delay-force $delay-force) ;R7RS
(do $do) ;R7RS
(fluid-let $fluid-let)
(guard $guard) ;R7RS
(receive (required optional rest) (parse-mit-lambda-list lambda-list)
(make-lambda* name required optional rest body)))
-(define (output/delay expression)
- (make-scode-delay expression))
-
(define (output/unassigned-test name)
(make-scode-unassigned? name))
projects / mit-scheme.git / commitdiff