diff --git a/pkgs/compatibility-pkgs/compatibility-doc/mzlib/scribblings/class100.scrbl b/pkgs/compatibility-pkgs/compatibility-doc/mzlib/scribblings/class100.scrbl deleted file mode 100644 index c466e6d2d6..0000000000 --- a/pkgs/compatibility-pkgs/compatibility-doc/mzlib/scribblings/class100.scrbl +++ /dev/null @@ -1,86 +0,0 @@ -#lang scribble/doc -@(require "common.rkt" - (for-label mzlib/class100 - mzlib/class - scheme/contract)) - -@mzlib[#:mode title class100] - -@deprecated[@racketmodname[racket/class]]{This library will be -removed in a future version.} - -The @racket[class100] and @racket[class100*] forms provide a syntax -close to that of @racket[class] and @racket[class*] in Racket -versions 100 through 103, but with the semantics of the current -@racketmodname[scheme/class]-based class system. For a class defined -with @racket[class100], keyword-based initialization arguments can be -propagated to the superclass, but by-position arguments are not (i.e., -the expansion of @racket[class100] to @racket[class] always includes -an @racket[init-rest] clause). - -The @racket[class100] form uses keywords (e.g., @racket[public]) that -are defined by the @racketmodname[mzlib/class] library, so typically -@racketmodname[scheme/class] must be imported into any context that -imports @racketmodname[mzlib/class100]. - - -@defform/subs[ -#:literals (sequence public override augment pubment - overment augride private private-field inherit - rename) -(class100* superclass-expr (interface-expr ...) init-ids - class100-clause - ...) -([init-ids id - (id ... id-with-default ...) - (id ... id-with-default ... . id) ] - [id-with-default (id default-expr) ] - [class100-clause (sequence expr ...) - (public public-method-decl ...) - (override public-method-decl ...) - (augment public-method-decl ...) - (pubment public-method-decl ...) - (overment public-method-decl ...) - (augride public-method-decl ...) - (private private-method-decl ...) - (private-field private-var-decl ...) - (inherit inherit-method-decl ...) - (rename rename-method-decl ...) ] - [public-method-decl ((internal-id external-id) method-procedure) - (id method-procedure)] - [private-method-decl (id method-procedure)] - [private-var-decl (id initial-value-expr) - (id) - id] - [inherit-method-decl id - (internal-instance-id external-inherited-id)] - [rename-method-decl (internal-id external-id)])] - - -@defform[ -(class100 superclass-expr init-ids - class100-clause - ...) -]{ - -Like @racket[class100*], but without @racket[interface-expr]s.} - - -@defform[(class100-asi superclass instance-id-clause ...)]{ - -Like @racket[class100], but all initialization arguments are -automatically passed on to the superclass initialization procedure by -position.} - - -@defform[(class100*-asi superclass interfaces instance-id-clause ...)]{ - -Like @racket[class100*], but all initialization arguments are -automatically passed on to the superclass initialization procedure by -position.} - - -@defform[(super-init init-arg-expr ...)]{ - -An alias for @racket[super-make-object].} - diff --git a/pkgs/compatibility-pkgs/compatibility-doc/mzlib/scribblings/mzlib.scrbl b/pkgs/compatibility-pkgs/compatibility-doc/mzlib/scribblings/mzlib.scrbl index 8fc9b1c636..2dcc8708b3 100644 --- a/pkgs/compatibility-pkgs/compatibility-doc/mzlib/scribblings/mzlib.scrbl +++ b/pkgs/compatibility-pkgs/compatibility-doc/mzlib/scribblings/mzlib.scrbl @@ -54,10 +54,6 @@ constructors. @; ---------------------------------------------------------------------- -@include-section["class100.scrbl"] - -@; ---------------------------------------------------------------------- - @mzlib[cm] @deprecated[@racketmodname[compiler/cm]]{} diff --git a/pkgs/compatibility-pkgs/compatibility-lib/mzlib/class100.rkt b/pkgs/compatibility-pkgs/compatibility-lib/mzlib/class100.rkt deleted file mode 100644 index 7687fd0ade..0000000000 --- a/pkgs/compatibility-pkgs/compatibility-lib/mzlib/class100.rkt +++ /dev/null @@ -1,257 +0,0 @@ - -(module class100 mzscheme - (require "class.rkt") - - (require-for-syntax syntax/stx) - - (define-syntax super-init (make-rename-transformer #'super-make-object)) - - (define-syntax class100* - (lambda (stx) - (let ([main - (lambda (stx) - (syntax-case stx () - [(_ super-expr - (interface-expr ...) - init-vars - clauses ...) - (let ([se (lambda (msg expr) - (raise-syntax-error #f msg stx expr))]) - ;; Unpack init arguments, with default expressions: - (let-values ([(init-ids init-defs init-rest-id) - (let loop ([inits (syntax init-vars)][need-def? #f]) - (syntax-case inits () - [() (values null null #f)] - [id - (identifier? (syntax id)) - (values null null (syntax id))] - [(id . rest) - (identifier? (syntax id)) - (begin - (when need-def? - (se "expected identifier with default value" (syntax id))) - (let-values ([(ids defs rest) (loop (syntax rest) #f)]) - (values (cons (syntax id) ids) - (cons #f defs) - rest)))] - [((id def) . rest) - (identifier? (syntax id)) - (let-values ([(ids defs rest) (loop (syntax rest) #f)]) - (values (cons (syntax id) ids) - (cons (syntax def) defs) - rest))] - [(first . rest) - (se "bad initialization declaration" (syntax first))] - [else (se "improper identifier list" (syntax init-vars))]))]) - ;; Unpack all body clauses: - (let* ([extract-ivars - ;; Unpacks a public, private, or override clause - (lambda (kind can-rename? decls) - (map - (lambda (decl) - (syntax-case decl () - [id (identifier? (syntax id)) - (list kind (syntax id) (syntax id) (syntax/loc (syntax id) (void)))] - [(id expr) (identifier? (syntax id)) - (list kind (syntax id) (syntax id) (syntax expr))] - [(id) (and can-rename? (identifier? (syntax id))) - (list kind (syntax id) (syntax id) (syntax/loc (syntax id) (void)))] - [((iid eid) expr) (and can-rename? - (identifier? (syntax iid)) - (identifier? (syntax eid))) - (list kind (syntax iid) (syntax eid) (syntax expr))] - [else (se (format "bad ~a clause" kind) decl)])) - (syntax->list decls)))] - [body - ;; Make a list of normalized clause-like lists, e.g: - ;; (list (list 'public internal-id extenal-id expr) ...) - (apply - append - (map - (lambda (clause) - (syntax-case clause (public pubment - override augment - augride overment - private private-field - rename inherit sequence) - [(public decl ...) - (extract-ivars 'public #t (syntax (decl ...)))] - [(pubment decl ...) - (extract-ivars 'pubment #t (syntax (decl ...)))] - [(override decl ...) - (extract-ivars 'override #t (syntax (decl ...)))] - [(augment decl ...) - (extract-ivars 'augment #t (syntax (decl ...)))] - [(overment decl ...) - (extract-ivars 'overment #t (syntax (decl ...)))] - [(augride decl ...) - (extract-ivars 'augride #t (syntax (decl ...)))] - [(private decl ...) - (extract-ivars 'private #f (syntax (decl ...)))] - [(private-field decl ...) - (extract-ivars 'private-field #f (syntax (decl ...)))] - [(rename (iid eid) ...) - (let ([iids (syntax->list (syntax (iid ...)))] - [eids (syntax->list (syntax (eid ...)))]) - (for-each (lambda (s) - (unless (identifier? s) - (se "expected an identifier" s))) - (append iids eids)) - (map (lambda (iid eid) - (list 'rename iid eid)) - iids eids))] - [(inherit id ...) - (map - (lambda (decl) - (syntax-case decl () - [id (identifier? (syntax id)) - (list 'inherit (syntax id) (syntax id))] - [(iid eid) (and (identifier? (syntax iid)) - (identifier? (syntax eid))) - (list 'inherit (syntax iid) (syntax eid))] - [else (se "bad inherit clause" decl)])) - (syntax->list (syntax (id ...))))] - [(sequence expr ...) - (map - (lambda (expr) - (list 'sequence expr)) - (syntax->list (syntax (expr ...))))] - [else (se "not a class100 clause" clause)])) - (syntax->list (syntax (clauses ...)))))] - [get-info (lambda (tags select) - (let loop ([body body]) - (cond - [(null? body) null] - [(memq (caar body) tags) - (cons (select (car body)) (loop (cdr body)))] - [else (loop (cdr body))])))] - [make-idp (lambda (x) (list (cadr x) (caddr x)))] - [make-decl (lambda (x) (with-syntax ([name (cadr x)] - [expr (cadddr x)]) - (syntax (define-values (name) expr))))] - [make-seq (lambda (x) (if (eq? (car x) 'private-field) - (with-syntax ([name (cadr x)] - [expr (cadddr x)]) - (syntax (define-values (name) expr))) - (cadr x)))]) - ;; Extract internal and external ids, and create xformed body: - (with-syntax ([public-ipds (get-info '(public) make-idp)] - [pubment-ipds (get-info '(pubment) make-idp)] - [override-ipds (get-info '(override) make-idp)] - [augment-ipds (get-info '(augment) make-idp)] - [overment-ipds (get-info '(overment) make-idp)] - [augride-ipds (get-info '(augride) make-idp)] - [rename-ipds (get-info '(rename) make-idp)] - [inherit-ipds (get-info '(inherit) make-idp)] - [private-ids (get-info '(private) (lambda (x) (cadr x)))] - - [(method-decl ...) (get-info '(public override augment - pubment overment augride - private) - make-decl)] - [(expr ...) (get-info '(private-field sequence) make-seq)] - [(init-expr ...) (let loop ([init-ids init-ids] - [init-defs init-defs]) - (cond - [(null? init-ids) - (if init-rest-id - (with-syntax ([init-rest-id init-rest-id]) - (list (syntax (init-rest init-rest-id)))) - (list (syntax (init-rest))))] - [(car init-defs) - (with-syntax ([id (car init-ids)] - [def (car init-defs)]) - (cons (syntax (init [id def])) - (loop (cdr init-ids) - (cdr init-defs))))] - [else - (with-syntax ([id (car init-ids)]) - (cons (syntax (init id)) - (loop (cdr init-ids) - (cdr init-defs))))]))] - [super-instantiate-id (if (stx-pair? #'optional-super-inst-id) - (stx-car #'optional-super-inst-id) - 'super-instantiate)]) - (syntax/loc stx - (class* super-expr (interface-expr ...) - init-expr ... - (private . private-ids) - (public . public-ipds) - (pubment . pubment-ipds) - (override . override-ipds) - (augment . augment-ipds) - (overment . overment-ipds) - (augride . augride-ipds) - (rename-super . rename-ipds) - (inherit . inherit-ipds) - method-decl ... - expr ...))))))]))]) - - (syntax-case stx () - [(_ super-expr - (interface-expr ...) - init-vars - clauses ...) - (main stx)] - - ;; Error cases - ;; -- - ;; -- - [(_ super-expr - bad-interface-seq - init-vars - clauses ...) - (raise-syntax-error - #f - "expected sequence of interface expressions" - stx - (syntax bad-interface-seq))] - ;; - [(_ super-expr - interface-seq) - (raise-syntax-error - #f - "missing initialization arguments" - stx - (syntax bad-this-super))] - [(_ super-expr) - (raise-syntax-error - #f - "missing interface expressions" - stx - (syntax bad-this-super))] - [(_) - (raise-syntax-error - #f - "missing superclass expression and interface expressions" - stx - (syntax bad-this-super))])))) - - (define-syntax class100 - (lambda (stx) - (syntax-case stx () - [(_ super-expr - init-vars - clauses ...) - (syntax/loc stx - (class100* super-expr () init-vars - clauses ...))]))) - - (define-syntax class100*-asi - (lambda (stx) - (syntax-case stx () - [(_ super (interface ...) body ...) - (syntax/loc stx - (class100* super (interface ...) args - body ... (sequence (apply super-init args))))]))) - - (define-syntax class100-asi - (lambda (stx) - (syntax-case stx () - [(_ super body ...) - (syntax/loc stx - (class100* super () args - body ... (sequence (apply super-init args))))]))) - - (provide class100 class100* - class100-asi class100*-asi super-init))