diff --git a/collects/mzlib/surrogate.ss b/collects/mzlib/surrogate.ss deleted file mode 100644 index 23f8a90..0000000 --- a/collects/mzlib/surrogate.ss +++ /dev/null @@ -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<%>))))])))