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

Change from (module ...) -> #lang and also move any mzscheme -> scheme/base.

Browse Source 
svn: r16563
This commit is contained in:
Stevie Strickland 2009-11-05 17:18:54 +00:00
parent ad438ef63f
commit c993533814
4 changed files with 4258 additions and 4259 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
collects/scheme/class.ss
View File

@ -1,11 +1,11 @@
(module class mzscheme #lang scheme/base
(require "contract/private/object.ss") (require "contract/private/object.ss")
(provide (all-from "contract/private/object.ss")) (provide (all-from-out "contract/private/object.ss"))
;; All of the implementation is actually in private/class-internal.ss, ;; All of the implementation is actually in private/class-internal.ss,
;; which provides extra (private) functionality to contract.ss. ;; which provides extra (private) functionality to contract.ss.
(require "private/class-internal.ss") (require "private/class-internal.ss")
(provide-public-names) (provide-public-names)
(provide generic?)) (provide generic?)

47
collects/scheme/private/class-events.ss
View File

@ -1,10 +1,10 @@
#lang scheme/base
(module class-events mzscheme (require (for-syntax scheme/base
scheme/stxparam))
(require scheme/stxparam)
(require-for-syntax mzlib/stxparam) (provide current-class-event-handler
(require mzlib/stxparam)
(provide current-class-event-handler
define-traced define-traced
trace-begin trace-begin
trace trace
@ -16,16 +16,16 @@
get-event get-event
) )
(define current-class-event-handler (define current-class-event-handler
(make-parameter void)) (make-parameter void))
;; ---------------------------------------------------------------------- ;; ----------------------------------------------------------------------
;; Definitions for traced vs untraced functions ;; Definitions for traced vs untraced functions
;; ---------------------------------------------------------------------- ;; ----------------------------------------------------------------------
(define-syntax-parameter trace? #f) (define-syntax-parameter trace? #f)
(define-syntax trace (define-syntax trace
(make-set!-transformer (make-set!-transformer
(lambda (stx) (lambda (stx)
(raise-syntax-error (raise-syntax-error
@ -33,7 +33,7 @@
"trace used outside a trace-begin" "trace used outside a trace-begin"
stx)))) stx))))
(define-syntax (trace-begin stx) (define-syntax (trace-begin stx)
(syntax-case stx (trace) (syntax-case stx (trace)
[(form (trace expr) ...) [(form (trace expr) ...)
(raise-syntax-error (raise-syntax-error
@ -51,13 +51,13 @@
[(form expr rest ...) [(form expr rest ...)
(syntax/loc stx (begin expr (form rest ...)))])) (syntax/loc stx (begin expr (form rest ...)))]))
(define-syntax (define-traced stx) (define-syntax (define-traced stx)
(syntax-case stx () (syntax-case stx ()
[(form (name . args) . body) [(form (name . args) . body)
(syntax/loc stx (form name (lambda args . body)))] (syntax/loc stx (form name (lambda args . body)))]
[(form name body ...) [(form name body ...)
(with-syntax ([name-traced (with-syntax ([name-traced
(datum->syntax-object (datum->syntax
(syntax name) (syntax name)
(string->symbol (string->symbol
(string-append (string-append
@ -73,39 +73,38 @@
(syntax-parameterize ([trace? #t]) (syntax-parameterize ([trace? #t])
body ...)))))])) body ...)))))]))
(define current-class-event-stack (define current-class-event-stack
(make-parameter null)) (make-parameter null))
(define (initialize-event event . args) (define (initialize-event event . args)
(current-class-event-stack (current-class-event-stack
(cons (cons
(apply (current-class-event-handler) event args) (apply (current-class-event-handler) event args)
(current-class-event-stack)))) (current-class-event-stack))))
(define (finalize-event event . args) (define (finalize-event event . args)
(let* ([stack (current-class-event-stack)] (let* ([stack (current-class-event-stack)]
[head (car stack)] [head (car stack)]
[tail (cdr stack)]) [tail (cdr stack)])
(when (procedure? head) (apply head args)) (when (procedure? head) (apply head args))
(current-class-event-stack tail))) (current-class-event-stack tail)))
(define (new-event class obj fields) (define (new-event class obj fields)
((current-class-event-handler) 'new class obj fields)) ((current-class-event-handler) 'new class obj fields))
(define (initialize-call-event obj method args) (define (initialize-call-event obj method args)
(initialize-event 'call obj method args)) (initialize-event 'call obj method args))
(define (finalize-call-event . returned) (define (finalize-call-event . returned)
(apply finalize-event 'call returned) (apply finalize-event 'call returned)
(apply values returned)) (apply values returned))
(define (inspect-event obj) (define (inspect-event obj)
((current-class-event-handler) 'inspect obj)) ((current-class-event-handler) 'inspect obj))
(define (set-event obj field value) (define (set-event obj field value)
((current-class-event-handler) 'set obj field value)) ((current-class-event-handler) 'set obj field value))
(define (get-event obj field) (define (get-event obj field)
((current-class-event-handler) 'get obj field)) ((current-class-event-handler) 'get obj field))
)

424
collects/scheme/private/class-internal.ss
View File

File diff suppressed because it is too large Load Diff

62
collects/scheme/private/classidmap.ss
View File

@ -1,16 +1,16 @@
#lang scheme/base
(module classidmap scheme/base (require syntax/stx
(require syntax/stx
(for-syntax scheme/base) (for-syntax scheme/base)
(for-template scheme/base "class-events.ss")) (for-template scheme/base "class-events.ss"))
(define-values (struct:s!t make-s!t s!t? s!t-ref s!t-set!) (define-values (struct:s!t make-s!t s!t? s!t-ref s!t-set!)
(make-struct-type 'set!-transformer #f 2 0 #f null (current-inspector) 0)) (make-struct-type 'set!-transformer #f 2 0 #f null (current-inspector) 0))
(define (mk-set!-trans old-id proc) (define (mk-set!-trans old-id proc)
(make-set!-transformer (make-s!t proc old-id))) (make-set!-transformer (make-s!t proc old-id)))
(define (make-method-apply id this orig-args) (define (make-method-apply id this orig-args)
(let loop ([args orig-args][accum null]) (let loop ([args orig-args][accum null])
(cond (cond
[(stx-null? args) [(stx-null? args)
@ -20,16 +20,16 @@
[else [else
(list* 'apply id this (reverse (cons args accum)))]))) (list* 'apply id this (reverse (cons args accum)))])))
(define (find the-finder name src) (define (find the-finder name src)
(let ([this-id (syntax-local-value (syntax-local-get-shadower the-finder))]) (let ([this-id (syntax-local-value (syntax-local-get-shadower the-finder))])
(datum->syntax this-id name src))) (datum->syntax this-id name src)))
;; Check Syntax binding info: ;; Check Syntax binding info:
(define (binding from to stx) (define (binding from to stx)
stx) stx)
(define (make-this-map orig-id the-finder the-obj) (define (make-this-map orig-id the-finder the-obj)
(let ([set!-stx (datum->syntax the-finder 'set!)]) (let ([set!-stx (datum->syntax the-finder 'set!)])
(mk-set!-trans (mk-set!-trans
orig-id orig-id
@ -45,7 +45,7 @@
stx)] stx)]
[id (find the-finder the-obj stx)]))))) [id (find the-finder the-obj stx)])))))
(define (make-field-map trace-flag the-finder the-obj the-binder the-binder-localized (define (make-field-map trace-flag the-finder the-obj the-binder the-binder-localized
field-accessor field-mutator field-pos/null) field-accessor field-mutator field-pos/null)
(let ([set!-stx (datum->syntax the-finder 'set!)]) (let ([set!-stx (datum->syntax the-finder 'set!)])
(mk-set!-trans (mk-set!-trans
@ -82,7 +82,7 @@
(syntax/loc stx (let* bindings trace get)) (syntax/loc stx (let* bindings trace get))
(syntax/loc stx (let* bindings get))))])))))) (syntax/loc stx (let* bindings get))))]))))))
(define (make-method-map the-finder the-obj the-binder the-binder-localized method-accessor) (define (make-method-map the-finder the-obj the-binder the-binder-localized method-accessor)
(let ([set!-stx (datum->syntax the-finder 'set!)]) (let ([set!-stx (datum->syntax the-finder 'set!)])
(mk-set!-trans (mk-set!-trans
the-binder-localized the-binder-localized
@ -107,9 +107,9 @@
"misuse of method (not in application)" "misuse of method (not in application)"
stx)]))))) stx)])))))
;; For methods that are dirrectly available via their names ;; For methods that are dirrectly available via their names
;; (e.g., private methods) ;; (e.g., private methods)
(define (make-direct-method-map the-finder the-obj the-binder the-binder-localized new-name) (define (make-direct-method-map the-finder the-obj the-binder the-binder-localized new-name)
(let ([set!-stx (datum->syntax the-finder 'set!)]) (let ([set!-stx (datum->syntax the-finder 'set!)])
(mk-set!-trans (mk-set!-trans
the-binder-localized the-binder-localized
@ -131,7 +131,7 @@
"misuse of method (not in application)" "misuse of method (not in application)"
stx)]))))) stx)])))))
(define (make-rename-super-map the-finder the-obj the-binder the-binder-localized rename-temp) (define (make-rename-super-map the-finder the-obj the-binder the-binder-localized rename-temp)
(let ([set!-stx (datum->syntax the-finder 'set!)]) (let ([set!-stx (datum->syntax the-finder 'set!)])
(mk-set!-trans (mk-set!-trans
the-binder-localized the-binder-localized
@ -153,7 +153,7 @@
"misuse of super method (not in application)" "misuse of super method (not in application)"
stx)]))))) stx)])))))
(define (make-rename-inner-map the-finder the-obj the-binder the-binder-localized rename-temp) (define (make-rename-inner-map the-finder the-obj the-binder the-binder-localized rename-temp)
(let ([set!-stx (datum->syntax the-finder 'set!)] (let ([set!-stx (datum->syntax the-finder 'set!)]
[lambda-stx (datum->syntax the-finder 'lambda)]) [lambda-stx (datum->syntax the-finder 'lambda)])
(mk-set!-trans (mk-set!-trans
@ -196,7 +196,7 @@
"misuse of inner method (not in application)" "misuse of inner method (not in application)"
stx)]))))) stx)])))))
(define (generate-super-call stx the-finder the-obj rename-temp args) (define (generate-super-call stx the-finder the-obj rename-temp args)
(datum->syntax (datum->syntax
the-finder the-finder
(make-method-apply (find the-finder rename-temp stx) (make-method-apply (find the-finder rename-temp stx)
@ -204,7 +204,7 @@
args) args)
stx)) stx))
(define (generate-inner-call stx the-finder the-obj default-expr rename-temp args) (define (generate-inner-call stx the-finder the-obj default-expr rename-temp args)
(datum->syntax (datum->syntax
the-finder the-finder
(let ([target (find the-finder the-obj stx)]) (let ([target (find the-finder the-obj stx)])
@ -217,7 +217,7 @@
stx)) stx))
stx)) stx))
(define (make-init-error-map localized-id) (define (make-init-error-map localized-id)
(mk-set!-trans (mk-set!-trans
localized-id localized-id
(lambda (stx) (lambda (stx)
@ -226,7 +226,7 @@
"cannot use non-field init variable in a method" "cannot use non-field init variable in a method"
stx)))) stx))))
(define (make-init-redirect set!-stx #%app-stx local-id localized-id) (define (make-init-redirect set!-stx #%app-stx local-id localized-id)
(mk-set!-trans (mk-set!-trans
localized-id localized-id
(lambda (stx) (lambda (stx)
@ -245,14 +245,14 @@
stx stx
stx)])))) stx)]))))
(define super-error-map (define super-error-map
(lambda (stx) (lambda (stx)
(raise-syntax-error (raise-syntax-error
'class 'class
"cannot use superclass initialization form in a method" "cannot use superclass initialization form in a method"
stx))) stx)))
(define (make-with-method-map trace-flag set!-stx id-stx (define (make-with-method-map trace-flag set!-stx id-stx
method-stx method-obj-stx unwrap-stx) method-stx method-obj-stx unwrap-stx)
(make-set!-transformer (make-set!-transformer
(lambda (stx) (lambda (stx)
@ -282,7 +282,7 @@
"misuse of method (not in application)" "misuse of method (not in application)"
stx)])))) stx)]))))
(define (flatten-args orig-args) (define (flatten-args orig-args)
(let loop ([args orig-args][accum null]) (let loop ([args orig-args][accum null])
(cond (cond
[(stx-null? args) orig-args] [(stx-null? args) orig-args]
@ -291,7 +291,7 @@
[else [else
(reverse (cons args accum))]))) (reverse (cons args accum))])))
(define-struct private-name (orig-id gen-id) (define-struct private-name (orig-id gen-id)
#:property prop:procedure (lambda (self stx) #:property prop:procedure (lambda (self stx)
(if (not (eq? (syntax-local-context) 'expression)) (if (not (eq? (syntax-local-context) 'expression))
#`(#%expression #,stx) #`(#%expression #,stx)
@ -300,7 +300,7 @@
"unbound local member name" "unbound local member name"
stx)))) stx))))
(define (do-localize orig-id validate-local-member-stx) (define (do-localize orig-id validate-local-member-stx)
(let loop ([id orig-id]) (let loop ([id orig-id])
(let ([v (syntax-local-value id (lambda () #f))]) (let ([v (syntax-local-value id (lambda () #f))])
(cond (cond
@ -316,20 +316,20 @@
(s!t-ref (set!-transformer-procedure v) 1)] (s!t-ref (set!-transformer-procedure v) 1)]
[else orig-id])))) [else orig-id]))))
(define-struct class-context ()) (define-struct class-context ())
(define (generate-class-expand-context) (define (generate-class-expand-context)
(let ([c (syntax-local-context)] (let ([c (syntax-local-context)]
[v (make-class-context)]) [v (make-class-context)])
(if (pair? c) (if (pair? c)
(cons v c) (cons v c)
(list v)))) (list v))))
(define (class-top-level-context? ctx) (define (class-top-level-context? ctx)
(and (pair? ctx) (and (pair? ctx)
(class-context? (car ctx)))) (class-context? (car ctx))))
(define (make-method-call traced? source-stx object-stx unwrap-stx (define (make-method-call traced? source-stx object-stx unwrap-stx
method-proc-stx method-name-stx args-stx rest-arg?) method-proc-stx method-name-stx args-stx rest-arg?)
(define-syntax (qstx stx) (define-syntax (qstx stx)
@ -356,7 +356,7 @@
finalize-call-event)))) finalize-call-event))))
(qstx (app method object . args))))) (qstx (app method object . args)))))
(provide (protect-out make-this-map make-field-map make-method-map (provide (protect-out make-this-map make-field-map make-method-map
make-direct-method-map make-direct-method-map
make-rename-super-map make-rename-inner-map make-rename-super-map make-rename-inner-map
make-init-error-map make-init-redirect super-error-map make-init-error-map make-init-redirect super-error-map
@ -364,4 +364,4 @@
flatten-args make-method-call flatten-args make-method-call
do-localize make-private-name do-localize make-private-name
generate-super-call generate-inner-call generate-super-call generate-inner-call
generate-class-expand-context class-top-level-context?))) generate-class-expand-context class-top-level-context?))