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

moved the surrogate library to scheme/ (out of mzlib/)

Browse Source 
svn: r9554

original commit: baa9ed726a8943cb496cc13f45e2cd85d4a825f3
This commit is contained in:
Robby Findler 2008-05-01 02:51:52 +00:00
parent a46a903637
commit 0dba7207a8
1 changed files with 0 additions and 188 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

188
collects/mzlib/surrogate.ss
View File

@ -1,188 +0,0 @@
(module surrogate mzscheme
(require mzlib/class)
(provide surrogate)
(define-syntax (surrogate stx)
(define (make-empty-method method-spec)
(syntax-case method-spec (override augment)
[(override name argspec ...)
(identifier? (syntax name))
(make-empty-method-from-argspec #'name (syntax (argspec ...)))]
[(augment def-expr name argspec ...)
(identifier? (syntax name))
(make-empty-method-from-argspec #'name (syntax (argspec ...)))]))
(define (make-empty-method-from-argspec name argspecs)
(with-syntax ([(cases ...) (map make-empty-lambda-case
(syntax->list argspecs))]
[name name])
(syntax
(begin
(define/public name
(case-lambda cases ...))))))
(define (make-empty-lambda-case spec)
(syntax-case spec ()
[(id ...) (syntax [(ths super-call id ...) (super-call id ...)])]
[id
(identifier? (syntax id))
(syntax [(ths super-call . name) (apply super-call name)])]))
(define (make-overriding-method method-spec)
(syntax-case method-spec (override augment)
[(override name argspec ...)
(identifier? (syntax name))
(make-overriding-method-with-inner-default
#'name #f #'(argspec ...))]
[(augment def-expr name argspec ...)
(identifier? (syntax name))
(make-overriding-method-with-inner-default
#'name #'def-expr #'(argspec ...))]))
(define (make-overriding-method-with-inner-default name def-expr argspecs)
;; (not def-expr) => normal override
;; def-expr => beta override
(let ([super-call-name
(datum->syntax-object
name
(string->symbol
(string-append
(if def-expr
"inner-proc-"
"super-proc-")
(symbol->string
(syntax-object->datum
name)))))])
(with-syntax ([(cases ...)
(map (make-lambda-case name
super-call-name)
(syntax->list argspecs))]
[(super-proc-cases ...)
(map (make-super-proc-case name def-expr)
(syntax->list argspecs))]
[super-call-name super-call-name]
[name name]
[ren/inn (if def-expr
#'inner
#'rename)]
[define/override/fnl (if def-expr
#'define/augment
#'define/override)])
(syntax
(begin
(field [super-call-name
(case-lambda super-proc-cases ...)])
(define/override/fnl name
(case-lambda cases ...)))))))
(define ((extract-id stx) method-spec)
(syntax-case method-spec (override augment)
[(override name argspec ...)
(identifier? #'name)
(syntax name)]
[(augment result-expr name argspec ...)
(identifier? #'name)
(syntax name)]
[else (raise-syntax-error
#f
"bad method specification"
stx
method-spec)]))
(define (make-super-proc-case name def-expr)
(lambda (spec)
(with-syntax ([name name])
(syntax-case spec ()
;; Not a rest arg: normal mode
[(id ...) (quasisyntax [(id ...)
(#,@(if def-expr
(list #'inner def-expr)
(list #'super))
name
id ...)])]
;; A rest arg: take args as list
[id
(identifier? (syntax id))
(quasisyntax [(id) (#,@(if def-expr
(list #'inner def-expr)
(list #'super))
name
. id)])]))))
(define (make-lambda-case name super-call)
(with-syntax ([name name]
[super-call super-call])
(lambda (spec)
(syntax-case spec ()
;; Not a rest arg: normal mode for super-call
[(id ...) (syntax [(id ...)
(if surrogate
(send surrogate name this super-call id ...)
(super-call id ...))])]
;; A rest arg: super-class takes args as a list
[id
(identifier? (syntax id))
(syntax [name
(if surrogate
(send surrogate name this (lambda args (super-call args)) . id)
(super-call id))])]))))
(syntax-case stx ()
[(_ method-spec ...)
(with-syntax ([(ids ...) (map (extract-id stx) (syntax->list (syntax (method-spec ...))))]
[(overriding-methods ...)
(map make-overriding-method
(syntax->list
(syntax (method-spec ...))))]
[(empty-methods ...)
(map make-empty-method
(syntax->list
(syntax (method-spec ...))))])
(syntax/loc stx
(let ([surrogate<%>
(interface ()
on-disable-surrogate
on-enable-surrogate
ids ...)]
[host<%>
(interface ()
set-surrogate
get-surrogate
ids ...)])
(values
(lambda (super%)
(class* super% (host<%>)
(field [surrogate #f])
(define/public (set-surrogate d)
(when surrogate
(send surrogate on-disable-surrogate this))
;; error checking
(when d
(unless (object? d)
(error 'set-surrogate "expected an object, got: ~e" d))
(let ([methods-to-impl '(on-enable-surrogate on-disable-surrogate ids ...)]
[i (object-interface d)])
(for-each (lambda (x)
(unless (method-in-interface? x i)
(error 'set-surrogate "expected object to implement an ~s method" x)))
methods-to-impl)))
(set! surrogate d)
(when surrogate
(send surrogate on-enable-surrogate this)))
(define/public (get-surrogate) surrogate)
overriding-methods ...
(super-new)))
host<%>
(class* object% (surrogate<%>)
(define/public (on-enable-surrogate x) (void))
(define/public (on-disable-surrogate x) (void))
empty-methods ...
(super-new))
surrogate<%>))))])))