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

propagate some changes: special evaluation of toplevel expressions etc

Browse Source 
svn: r4527
This commit is contained in:
Eli Barzilay 2006-10-09 03:45:18 +00:00
parent e3c1b3022a
commit bcd850ac32
1 changed files with 27 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
collects/lazy/lazy.ss
View File

@ -204,8 +204,8 @@
'stepper-skipto '(syntax-e cdr syntax-e car)))]) 'stepper-skipto '(syntax-e cdr syntax-e car)))])
(with-syntax ([(y ...) (generate-temporaries #'(x ...))]) (with-syntax ([(y ...) (generate-temporaries #'(x ...))])
;; use syntax/loc for better errors etc ;; use syntax/loc for better errors etc
(with-syntax ([lazy (quasisyntax/loc stx (p y ...))] (with-syntax ([lazy (syntax/loc stx (p y ...))]
[strict (quasisyntax/loc stx (p (hidden-! y) ...))]) [strict (syntax/loc stx (p (hidden-! y) ...))])
(quasisyntax/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)))))))]))
@ -214,6 +214,10 @@
(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 ...)))
(define-for-syntax (toplevel?)
(memq (syntax-local-context)
'(top-level module module-begin))) ; not sure about module-begin
(provide (rename ~!%app #%app)) ; all applications are delayed (provide (rename ~!%app #%app)) ; all applications are delayed
(define-syntax (~!%app stx) ; provided as #%app (define-syntax (~!%app stx) ; provided as #%app
(define (unwinder stx rec) (define (unwinder stx rec)
@ -236,7 +240,11 @@
[(_ !!list x) (syntax/loc stx (!!list x))] [(_ !!list x) (syntax/loc stx (!!list x))]
[(_ !values x) (syntax/loc stx (!values x))] [(_ !values x) (syntax/loc stx (!values x))]
[(_ !!values x) (syntax/loc stx (!!values x))] [(_ !!values x) (syntax/loc stx (!!values x))]
[(_ f x ...) (stepper-annotate (syntax/loc stx (~!app f x ...)))])) [(_ f x ...)
(if (toplevel?)
;; toplevel expressions are always forced
(syntax/loc stx (! (!app f x ...)))
(stepper-annotate (syntax/loc stx (~!app f x ...))))]))
(define (!*apply f . xs) (define (!*apply f . xs)
(let ([xs (!list (apply list* xs))]) (let ([xs (!list (apply list* xs))])
@ -249,6 +257,12 @@
(provide (rename !apply apply)) ; can only be used through #%app => delayed (provide (rename !apply apply)) ; can only be used through #%app => delayed
;; do the same special treatment for toplevel variable expressions
(provide (rename !top #%top))
(define-syntax (!top stx)
(syntax-case stx ()
[(_ . id) (if (toplevel?) #'(! (#%top . id)) #'(#%top . id))]))
;; used for explicitly strict/lazy calls ;; used for explicitly strict/lazy calls
(defsubst (strict-call f x ...) (~ (f (! x) ...))) (defsubst (strict-call f x ...) (~ (f (! x) ...)))
(defsubst (lazy-call f x ...) (~ (f x ...))) (defsubst (lazy-call f x ...) (~ (f x ...)))
@ -625,12 +639,9 @@
(if (! (pred x)) (cons x xs) xs))) (if (! (pred x)) (cons x xs) xs)))
(else (error 'filter "not a proper list: ~e" list))))) (else (error 'filter "not a proper list: ~e" list)))))
(require (rename (lib "list.ss") !quicksort quicksort) (require (rename (lib "list.ss") !sort sort))
(rename (lib "list.ss") !mergesort mergesort)) (define* (sort list less-than)
(define* (quicksort list less-than) (!sort (!list list) (! less-than)))
(!quicksort (!list list) (! less-than)))
(define* (mergesort list less-than)
(!mergesort (!list list) (! less-than)))
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
;; (lib "etc.ss") functionality ;; (lib "etc.ss") functionality
@ -678,7 +689,7 @@
[~id (string->symbol (string-append "~" str))]) [~id (string->symbol (string-append "~" str))])
(datum->syntax-object id ~id id))) (datum->syntax-object id ~id id)))
(syntax->list #'(id ...)))]) (syntax->list #'(id ...)))])
#'(provide (all-from-except mzscheme module #%app apply id ...) #'(provide (all-from-except mzscheme module #%app apply #%top id ...)
(rename ~id id) ...))])) (rename ~id id) ...))]))
(renaming-provide (renaming-provide
lambda define let let* letrec parameterize lambda define let let* letrec parameterize
@ -702,21 +713,12 @@
;; `list' stuff ;; `list' stuff
first second third fourth fifth sixth seventh eighth rest cons? empty empty? first second third fourth fifth sixth seventh eighth rest cons? empty empty?
foldl foldr last-pair remove remq remv remove* remq* remv* memf assf filter foldl foldr last-pair remove remq remv remove* remq* remv* memf assf filter
quicksort mergesort sort
;; `etc' stuff ;; `etc' stuff
true false boolean=? symbol=? identity compose build-list true false boolean=? symbol=? identity compose build-list
;; extra stuff for lazy Scheme ;; extra stuff for lazy Scheme
take cycle) take cycle)
;; --------------------------------------------------------------------------
;; Initialize special evaluation hooks
;; taking this out so that stepper test cases will work correctly:
#;
(let ([prim-eval (current-eval)])
(current-eval (lambda (expr) (!! (prim-eval expr)))))
) )
#| #|