Remove the mzlib/class100 library.
Uses of mzlib/class100 have already been removed. The library's removal was promised in the release notes for Racket v5.3.2.
This commit is contained in:
Asumu Takikawa
parent
9fb6f1947b
commit
5711e9002f
|
|
@ -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].}
|
||||
|
||||
|
|
@ -54,10 +54,6 @@ constructors.
|
|||
|
||||
@; ----------------------------------------------------------------------
|
||||
|
||||
@include-section["class100.scrbl"]
|
||||
|
||||
@; ----------------------------------------------------------------------
|
||||
|
||||
@mzlib[cm]
|
||||
|
||||
@deprecated[@racketmodname[compiler/cm]]{}
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
Loading…
Reference in New Issue
Block a user