suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

just checking it in

Browse Source 
svn: r4426
This commit is contained in:
John Clements 2006-09-23 11:21:17 +00:00
parent 02d9fbd35c
commit fc7322a4b3
1 changed files with 21 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
collects/lazy/lazy.ss
View File

@ -50,6 +50,8 @@
(define (! x) (if (promise? x) (! (force x)) x)) (define (! x) (if (promise? x) (! (force x)) x))
;; the exposed `!' must be a special form ;; the exposed `!' must be a special form
(provide (rename special-form-! !)) (provide (rename special-form-! !))
;; hack to see if it solves a certificate problem:
(provide (rename ! crazythingthatwillneverbereferredto))
(defsubst (special-form-! x) (! x) special-form-! !) (defsubst (special-form-! x) (! x) special-form-! !)
;; These things are useful too, to write strict functions (with various ;; These things are useful too, to write strict functions (with various
@ -256,18 +258,26 @@
;; `!apply': provided as `apply' (no need to provide `~!apply', since all ;; `!apply': provided as `apply' (no need to provide `~!apply', since all
;; function calls are delayed by `#%app') ;; function calls are delayed by `#%app')
(define-syntax (jbc! stx)
(syntax-case stx (!)
[(_ arg) (syntax-property #`(! arg) 'stepper-skipto '(syntax-e cdr syntax-e cdr car))]))
(define-syntax (!*app stx) (define-syntax (!*app stx)
(syntax-case stx (~ ! !! !list !!list !values !!values) (syntax-case stx (~ ! !! !list !!list !values !!values)
[(_ f x ...) [(_ f x ...)
(let ([$$ (lambda (stx) (syntax-property stx 'stepper-skipto '(syntax-e cdr cdr both-l () (car))))]
[$ (lambda (stx) (syntax-property stx 'stepper-skipto '(syntax-e cdr syntax-e car)))])
(with-syntax ([(y ...) (generate-temporaries #'(x ...))]) (with-syntax ([(y ...) (generate-temporaries #'(x ...))])
(with-syntax ([(!y ...) (map (lambda (stx) (syntax-property stx 'stepper-skipto '(syntax-e cdr syntax-e cdr car)))
(syntax->list #`((! y) ...)))])
;; use syntax/loc for better errors etc ;; use syntax/loc for better errors etc
(with-syntax ([lazy (syntax/loc stx (p y ...))] (with-syntax ([lazy (quasisyntax/loc stx (p y ...))]
[strict (syntax/loc stx (p (! y) ...))]) [strict (quasisyntax/loc stx (p !y ...))])
(syntax/loc stx (quasisyntax/loc stx
(let ([p f] [y x] ...) (let ([p f] [y x] ...)
(if (lazy? p) lazy strict)))))])) #,($$ #`(if (lazy? p) lazy strict))))))))]))
(defsubst (!app f x ...) (!*app (! f) x ...)) (defsubst (!app f x ...) (!*app (jbc! f) x ...))
(defsubst (~!*app f x ...) (~ (!*app f x ...))) (defsubst (~!*app f x ...) (~ (!*app f x ...)))
(defsubst (~!app f x ...) (~ (!app f x ...))) (defsubst (~!app f x ...) (~ (!app f x ...)))
@ -768,7 +778,9 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
;; Initialize special evaluation hooks ;; Initialize special evaluation hooks
(let ([prim-eval (current-eval)]) ;; taking this out so that stepper test cases will work correctly:
#;(let ([prim-eval (current-eval)])
(current-eval (lambda (expr) (!! (prim-eval expr))))) (current-eval (lambda (expr) (!! (prim-eval expr)))))
) )