1691 lines
57 KiB
Scheme
1691 lines
57 KiB
Scheme
|
|
(module class mzscheme
|
|
|
|
(require-for-syntax (lib "kerncase.ss" "syntax")
|
|
(lib "stx.ss" "syntax")
|
|
"private/classidmap.ss")
|
|
|
|
(define insp (current-inspector)) ; for all structures
|
|
|
|
;;--------------------------------------------------------------------
|
|
;; class macros
|
|
;;--------------------------------------------------------------------
|
|
|
|
(define-syntax class*/names
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(_ (this-id . supers) super-expression (interface-expr ...)
|
|
defn-or-expr
|
|
...)
|
|
(let-values ([(defn-and-exprs) (syntax->list (syntax (defn-or-expr ...)))]
|
|
[(this-id) (syntax this-id)]
|
|
[(the-obj) (datum->syntax-object (quote-syntax here) (gensym 'self))]
|
|
[(the-finder) (datum->syntax-object (quote-syntax here) (gensym 'find-self))]
|
|
[(super-instantiate-id super-make-object-id)
|
|
(let ([s (syntax supers)])
|
|
(if (stx-null? s)
|
|
(values (quote-syntax super-instantiate)
|
|
(quote-syntax super-make-object))
|
|
(values (stx-car s)
|
|
(let ([s2 (stx-cdr s)])
|
|
(if (stx-null? s2)
|
|
(quote-syntax super-make-object)
|
|
(begin0
|
|
(stx-car s2)
|
|
(unless (stx-null? (stx-cdr s2))
|
|
(when (and (identifier? (stx-car s))
|
|
(identifier? (stx-car s2)))
|
|
(raise-syntax-error
|
|
'class*/names
|
|
"extra forms following this, super-instantiate, and super-make-object"
|
|
stx)))))))))])
|
|
(unless (identifier? this-id)
|
|
(raise-syntax-error
|
|
'class*/names
|
|
"not an identifier for `this'"
|
|
stx
|
|
this-id))
|
|
(unless (identifier? super-instantiate-id)
|
|
(raise-syntax-error
|
|
'class*/names
|
|
"not an identifier for `super-instantiate'"
|
|
stx
|
|
super-instantiate-id))
|
|
(unless (identifier? super-make-object-id)
|
|
(raise-syntax-error
|
|
'class*/names
|
|
"not an identifier for `super-make-object'"
|
|
stx
|
|
super-make-object-id))
|
|
|
|
;; ----- Expand definitions -----
|
|
(let ([defn-and-exprs (let ([expand
|
|
(lambda (defn-or-expr)
|
|
(local-expand
|
|
defn-or-expr
|
|
'internal-define
|
|
(append
|
|
(kernel-form-identifier-list (quote-syntax here))
|
|
(list
|
|
(quote-syntax init)
|
|
(quote-syntax init-rest)
|
|
(quote-syntax field)
|
|
(quote-syntax init-field)
|
|
(quote-syntax inherit-field)
|
|
(quote-syntax private)
|
|
(quote-syntax public)
|
|
(quote-syntax override)
|
|
(quote-syntax public-final)
|
|
(quote-syntax override-final)
|
|
(quote-syntax rename)
|
|
(quote-syntax inherit)
|
|
this-id
|
|
super-instantiate-id
|
|
super-make-object-id))))])
|
|
(let loop ([l defn-and-exprs])
|
|
(if (null? l)
|
|
null
|
|
(let ([e (expand (car l))])
|
|
(syntax-case e (begin)
|
|
[(begin expr ...)
|
|
(loop (append
|
|
(syntax->list (syntax (expr ...)))
|
|
(cdr l)))]
|
|
[(begin . _)
|
|
(raise-syntax-error
|
|
'class*
|
|
"ill-formed begin expression"
|
|
e
|
|
stx)]
|
|
[_else (cons e (loop (cdr l)))])))))]
|
|
[bad (lambda (msg expr)
|
|
(raise-syntax-error 'class* msg stx expr))]
|
|
[class-name (let ([s (syntax-local-name)])
|
|
(if (syntax? s)
|
|
(syntax-e s)
|
|
s))])
|
|
|
|
;; ------ Basic syntax checks -----
|
|
(for-each (lambda (stx)
|
|
(syntax-case stx (init init-rest field init-field inherit-field
|
|
private public override
|
|
public-final override-final
|
|
rename inherit)
|
|
[(form idp ...)
|
|
(and (identifier? (syntax form))
|
|
(ormap (lambda (f) (module-identifier=? (syntax form) f))
|
|
(list (quote-syntax init)
|
|
(quote-syntax init-field))))
|
|
(let ([form (syntax-e (syntax form))])
|
|
(for-each
|
|
(lambda (idp)
|
|
(syntax-case idp ()
|
|
[id (identifier? (syntax id)) 'ok]
|
|
[(id expr) (identifier? (syntax id)) 'ok]
|
|
[else
|
|
(bad
|
|
(format
|
|
"~a element is not an identifier or identifier-expression pair"
|
|
form)
|
|
idp)]))
|
|
(syntax->list (syntax (idp ...)))))]
|
|
[(init . rest)
|
|
(bad "ill-formed init clause" stx)]
|
|
[(init-rest rest)
|
|
(identifier? (syntax rest))
|
|
'ok]
|
|
[(init-rest . rest)
|
|
(bad "ill-formed init-rest clause" stx)]
|
|
[(init-field . rest)
|
|
(bad "ill-formed init-field clause" stx)]
|
|
[(field idp ...)
|
|
(for-each (lambda (idp)
|
|
(syntax-case idp ()
|
|
[(id expr) (identifier? (syntax id)) 'ok]
|
|
[else
|
|
(bad
|
|
"field element is not an identifier-expression pair"
|
|
idp)]))
|
|
(syntax->list (syntax (idp ...))))]
|
|
[(field . rest)
|
|
(bad "ill-formed field clause" stx)]
|
|
[(inherit-field id ...)
|
|
(for-each
|
|
(lambda (id)
|
|
(unless (identifier? id)
|
|
(bad "inherit-field element is not an identifier" id)))
|
|
(syntax->list (syntax (id ...))))]
|
|
[(inherit-field . rest)
|
|
(bad "ill-formed inherit-field clause" stx)]
|
|
[(private id ...)
|
|
(for-each
|
|
(lambda (id)
|
|
(unless (identifier? id)
|
|
(bad "private element is not an identifier" id)))
|
|
(syntax->list (syntax (id ...))))]
|
|
[(private . rest)
|
|
(bad "ill-formed private clause" stx)]
|
|
[(form idp ...)
|
|
(ormap (lambda (f) (module-identifier=? (syntax form) f))
|
|
(list (quote-syntax public)
|
|
(quote-syntax override)
|
|
(quote-syntax public-final)
|
|
(quote-syntax override-final)
|
|
(quote-syntax inherit)))
|
|
(let ([form (syntax-e (syntax form))])
|
|
(for-each
|
|
(lambda (idp)
|
|
(syntax-case idp ()
|
|
[id (identifier? (syntax id)) 'ok]
|
|
[(iid eid) (and (identifier? (syntax id)) (identifier? (syntax eid))) 'ok]
|
|
[else
|
|
(bad
|
|
(format
|
|
"~a element is not an identifier or pair of identifiers"
|
|
form)
|
|
idp)]))
|
|
(syntax->list (syntax (idp ...)))))]
|
|
[(public . rest)
|
|
(bad "ill-formed public clause" stx)]
|
|
[(override . rest)
|
|
(bad "ill-formed override clause" stx)]
|
|
[(public-final . rest)
|
|
(bad "ill-formed public-final clause" stx)]
|
|
[(override-final . rest)
|
|
(bad "ill-formed override-final clause" stx)]
|
|
[(inherit . rest)
|
|
(bad "ill-formed inherit clause" stx)]
|
|
[(rename idp ...)
|
|
(for-each
|
|
(lambda (idp)
|
|
(syntax-case idp ()
|
|
[(iid eid) (and (identifier? (syntax id)) (identifier? (syntax eid))) 'ok]
|
|
[else
|
|
(bad
|
|
"rename element is not a pair of identifiers"
|
|
idp)]))
|
|
(syntax->list (syntax (idp ...))))]
|
|
[(rename . rest)
|
|
(bad "ill-formed rename clause" stx)]
|
|
[_ 'ok]))
|
|
defn-and-exprs)
|
|
|
|
;; ----- Sort body into different categories -----
|
|
(let ([extract (lambda (kws reverse?)
|
|
(let loop ([l defn-and-exprs])
|
|
(cond
|
|
[(null? l) null]
|
|
[(and (stx-pair? (car l))
|
|
(let ([id (stx-car (car l))])
|
|
(identifier? id)
|
|
(ormap (lambda (k) (module-identifier=? k id)) kws)))
|
|
(if reverse?
|
|
(loop (cdr l))
|
|
(cons (car l) (loop (cdr l))))]
|
|
[else
|
|
(if reverse?
|
|
(cons (car l) (loop (cdr l)))
|
|
(loop (cdr l)))])))]
|
|
[flatten (lambda (alone l)
|
|
(apply append
|
|
(map (lambda (i)
|
|
(let ([l (cdr (syntax->list i))])
|
|
(map (lambda (i)
|
|
(if (identifier? i)
|
|
(alone i)
|
|
(cons (stx-car i)
|
|
(stx-car (stx-cdr i)))))
|
|
l)))
|
|
l)))]
|
|
[pair (lambda (i) (cons i i))])
|
|
(let ([init-rest-decls (extract (list (quote-syntax init-rest)) #f)]
|
|
[inits (flatten values (extract (list (quote-syntax init)
|
|
(quote-syntax init-field))
|
|
#f))]
|
|
[plain-inits (flatten values (extract (list (quote-syntax init)
|
|
(quote-syntax init-rest))
|
|
#f))]
|
|
[plain-fields (flatten values (extract (list (quote-syntax field)) #f))]
|
|
[plain-init-fields (flatten values (extract (list (quote-syntax init-field)) #f))]
|
|
[inherit-fields (flatten values (extract (list (quote-syntax inherit-field)) #f))]
|
|
[privates (flatten pair (extract (list (quote-syntax private)) #f))]
|
|
[publics (flatten pair (extract (list (quote-syntax public)) #f))]
|
|
[overrides (flatten pair (extract (list (quote-syntax override)) #f))]
|
|
[public-finals (flatten pair (extract (list (quote-syntax public-final)) #f))]
|
|
[override-finals (flatten pair (extract (list (quote-syntax override-final)) #f))]
|
|
[renames (flatten pair (extract (list (quote-syntax rename)) #f))]
|
|
[inherits (flatten pair (extract (list (quote-syntax inherit)) #f))]
|
|
[exprs (extract (list (quote-syntax inherit-field)
|
|
(quote-syntax private)
|
|
(quote-syntax public)
|
|
(quote-syntax override)
|
|
(quote-syntax public-final)
|
|
(quote-syntax override-final)
|
|
(quote-syntax rename)
|
|
(quote-syntax inherit))
|
|
#t)])
|
|
|
|
(unless (or (null? init-rest-decls)
|
|
(null? (cdr init-rest-decls)))
|
|
(bad "multiple init-rest clauses" (cadr init-rest-decls)))
|
|
|
|
;; --- Check initialization on inits: ---
|
|
(let loop ([inits inits])
|
|
(unless (null? inits)
|
|
(if (identifier? (car inits))
|
|
(loop (cdr inits))
|
|
(let loop ([inits (cdr inits)])
|
|
(unless (null? inits)
|
|
(if (identifier? (car inits))
|
|
(bad "initializer without default follows an initializer with default"
|
|
(car inits))
|
|
(loop (cdr inits))))))))
|
|
|
|
;; ----- Extract method definitions; check that they look like procs -----
|
|
;; Optionally transform them, can expand even if not transforming.
|
|
(let* ([local-public-normal-names (map car (append publics overrides))]
|
|
[local-public-names (append (map car (append public-finals override-finals))
|
|
local-public-normal-names)]
|
|
[local-method-names (append (map car privates) local-public-names)]
|
|
[expand-stop-names (append
|
|
local-method-names
|
|
(list
|
|
this-id
|
|
super-instantiate-id
|
|
super-make-object-id)
|
|
(kernel-form-identifier-list
|
|
(quote-syntax here)))]
|
|
[proc-shape (lambda (name expr xform?)
|
|
;; expands an expression so we can check whether
|
|
;; it has the right form
|
|
(define (expand expr locals)
|
|
(local-expand
|
|
expr
|
|
'expression
|
|
(append locals expand-stop-names)))
|
|
;; Checks whether the vars sequence is well-formed
|
|
(define (vars-ok? vars)
|
|
(or (identifier? vars)
|
|
(stx-null? vars)
|
|
(and (stx-pair? vars)
|
|
(identifier? (stx-car vars))
|
|
(vars-ok? (stx-cdr vars)))))
|
|
;; mk-name: constructs a method name
|
|
;; for error reporting, etc.
|
|
(define (mk-name name)
|
|
(datum->syntax-object
|
|
#f
|
|
(string->symbol (format "~a method~a~a"
|
|
(syntax-e name)
|
|
(if class-name
|
|
" in "
|
|
"")
|
|
(or class-name
|
|
"")))
|
|
#f))
|
|
;; -- tranform loop starts here --
|
|
(let loop ([stx expr][can-expand? #t][name name][locals null])
|
|
(syntax-case stx (lambda case-lambda letrec-values let-values)
|
|
[(lambda vars body1 body ...)
|
|
(vars-ok? (syntax vars))
|
|
(if xform?
|
|
(with-syntax ([the-obj the-obj]
|
|
[the-finder the-finder]
|
|
[name (mk-name name)])
|
|
(syntax/loc stx
|
|
(let ([name
|
|
(lambda (the-obj . vars)
|
|
(fluid-let-syntax ([the-finder (quote-syntax the-obj)])
|
|
body1 body ...))])
|
|
name)))
|
|
stx)]
|
|
[(lambda . _)
|
|
(bad "ill-formed lambda expression for method" stx)]
|
|
[(case-lambda [vars body1 body ...] ...)
|
|
(andmap vars-ok? (syntax->list (syntax (vars ...))))
|
|
(if xform?
|
|
(with-syntax ([the-obj the-obj]
|
|
[the-finder the-finder]
|
|
[name (mk-name name)])
|
|
(syntax/loc stx
|
|
(let ([name
|
|
(case-lambda [(the-obj . vars)
|
|
(fluid-let-syntax ([the-finder (quote-syntax the-obj)])
|
|
body1 body ...)] ...)])
|
|
name)))
|
|
stx)]
|
|
[(case-lambda . _)
|
|
(bad "ill-formed case-lambda expression for method" stx)]
|
|
[(let- ([(id) expr] ...) let-body)
|
|
(and (or (module-identifier=? (syntax let-)
|
|
(quote-syntax let-values))
|
|
(module-identifier=? (syntax let-)
|
|
(quote-syntax letrec-values)))
|
|
(andmap identifier? (syntax->list (syntax (id ...)))))
|
|
(let* ([letrec? (module-identifier=? (syntax let-)
|
|
(quote-syntax letrec-values))]
|
|
[ids (syntax->list (syntax (id ...)))]
|
|
[new-ids (if xform?
|
|
(map
|
|
(lambda (id)
|
|
(datum->syntax-object
|
|
#f
|
|
(gensym (syntax-e id))))
|
|
ids)
|
|
ids)]
|
|
[body-locals (append ids locals)]
|
|
[exprs (map (lambda (expr id)
|
|
(loop expr #t id (if letrec?
|
|
body-locals
|
|
locals)))
|
|
(syntax->list (syntax (expr ...)))
|
|
ids)]
|
|
[body (let ([body (syntax let-body)])
|
|
(if (identifier? body)
|
|
(ormap (lambda (id new-id)
|
|
(and (bound-identifier=? body id)
|
|
new-id))
|
|
ids new-ids)
|
|
(loop body #t name body-locals)))])
|
|
(unless body
|
|
(bad "bad form for method definition" stx))
|
|
(with-syntax ([(proc ...) exprs]
|
|
[(new-id ...) new-ids]
|
|
[mappings
|
|
(if xform?
|
|
(map
|
|
(lambda (old-id new-id)
|
|
(with-syntax ([old-id old-id]
|
|
[new-id new-id]
|
|
[the-obj the-obj]
|
|
[the-finder the-finder])
|
|
(syntax (old-id (make-direct-method-map
|
|
(quote-syntax the-finder)
|
|
(quote the-obj)
|
|
(quote new-id))))))
|
|
ids new-ids)
|
|
null)]
|
|
[body body])
|
|
(if xform?
|
|
(if letrec?
|
|
(syntax/loc stx (letrec-syntax mappings
|
|
(let- ([(new-id) proc] ...)
|
|
body)))
|
|
(syntax/loc stx (let- ([(new-id) proc] ...)
|
|
(letrec-syntax mappings
|
|
body))))
|
|
(syntax/loc stx (let- ([(new-id) proc] ...)
|
|
body)))))]
|
|
[_else
|
|
(if can-expand?
|
|
(loop (expand stx locals) #f name locals)
|
|
(bad "bad form for method definition" stx))])))])
|
|
;; Do the extraction:
|
|
(let-values ([(methods private-methods exprs)
|
|
(let loop ([exprs exprs][ms null][pms null][es null])
|
|
(if (null? exprs)
|
|
(values (reverse! ms) (reverse! pms) (reverse! es))
|
|
(syntax-case (car exprs) (define-values)
|
|
[(define-values (id ...) expr)
|
|
(let ([ids (syntax->list (syntax (id ...)))])
|
|
;; Check form:
|
|
(for-each (lambda (id)
|
|
(unless (identifier? id)
|
|
(bad "not an identifier for definition" id)))
|
|
ids)
|
|
;; method defn? (id in the list of privates/publics/overrides?)
|
|
(if (ormap (lambda (id)
|
|
(ormap (lambda (i) (bound-identifier=? i id))
|
|
local-method-names))
|
|
ids)
|
|
;; Yes, it's a method:
|
|
(begin
|
|
(unless (null? (cdr ids))
|
|
(bad "each method variable needs its own definition"
|
|
(car exprs)))
|
|
(let ([expr (proc-shape #f (syntax expr) #f)]
|
|
[public? (ormap (lambda (i)
|
|
(bound-identifier=? i (car ids)))
|
|
local-public-names)])
|
|
(loop (cdr exprs)
|
|
(if public?
|
|
(cons (cons (car ids) expr) ms)
|
|
ms)
|
|
(if public?
|
|
pms
|
|
(cons (cons (car ids) expr) pms))
|
|
es)))
|
|
;; Non-method defn:
|
|
(loop (cdr exprs) ms pms (cons (car exprs) es))))]
|
|
[(define-values . _)
|
|
(bad "ill-formed definition" (car exprs))]
|
|
[_else
|
|
(loop (cdr exprs) ms pms (cons (car exprs) es))])))])
|
|
|
|
;; ---- Extract all defined names, including field accessors and mutators ---
|
|
(let ([defined-method-names (append (map car methods)
|
|
(map car private-methods))]
|
|
[private-field-names (let loop ([l exprs])
|
|
(if (null? l)
|
|
null
|
|
(syntax-case (car l) (define-values)
|
|
[(define-values (id ...) expr)
|
|
(append (syntax->list (syntax (id ...)))
|
|
(loop (cdr l)))]
|
|
[_else (loop (cdr l))])))]
|
|
[field-names (map
|
|
(lambda (i)
|
|
(if (identifier? i)
|
|
i
|
|
(stx-car i)))
|
|
(append plain-fields plain-init-fields))]
|
|
[inherit-field-names inherit-fields]
|
|
[plain-init-names (map
|
|
(lambda (i)
|
|
(if (identifier? i)
|
|
i
|
|
(stx-car i)))
|
|
plain-inits)])
|
|
;; -- Look for duplicates --
|
|
(let ([dup (check-duplicate-identifier
|
|
(append defined-method-names
|
|
private-field-names
|
|
field-names
|
|
inherit-field-names
|
|
plain-init-names
|
|
(map car inherits)
|
|
(map car renames)
|
|
(list this-id super-instantiate-id super-make-object-id)))])
|
|
(when dup
|
|
(bad "duplicate declared identifier" dup)))
|
|
|
|
;; -- Could still have duplicates within private/public/override --
|
|
(let ([dup (check-duplicate-identifier local-method-names)])
|
|
(when dup
|
|
(bad "duplicate declared identifier" dup)))
|
|
|
|
;; -- Check that private/public/override are defined --
|
|
(let ([ht (make-hash-table)])
|
|
(for-each
|
|
(lambda (defined-name)
|
|
(let ([l (hash-table-get ht (syntax-e defined-name) (lambda () null))])
|
|
(hash-table-put! ht (syntax-e defined-name) (cons defined-name l))))
|
|
defined-method-names)
|
|
(for-each
|
|
(lambda (pubovr-name)
|
|
(let ([l (hash-table-get ht (syntax-e pubovr-name) (lambda () null))])
|
|
(unless (ormap (lambda (i) (bound-identifier=? i pubovr-name)) l)
|
|
(bad
|
|
"method declared but not defined"
|
|
pubovr-name))))
|
|
local-method-names))
|
|
|
|
;; ---- Convert expressions ----
|
|
;; Non-method definitions to set!
|
|
;; Initializations args access/set!
|
|
(let ([exprs (map (lambda (e)
|
|
(syntax-case e (define-values field init-rest)
|
|
[(define-values (id ...) expr)
|
|
(syntax/loc e (set!-values (id ...) expr))]
|
|
[(-init idp ...)
|
|
(ormap (lambda (it) (module-identifier=? it (syntax -init)))
|
|
(list (quote-syntax init) (quote-syntax init-field)))
|
|
(let ([ids (map
|
|
(lambda (idp)
|
|
(if (identifier? idp)
|
|
idp
|
|
(stx-car idp)))
|
|
(syntax->list (syntax (idp ...))))])
|
|
(with-syntax ([(id ...) ids]
|
|
[(idpos ...)
|
|
(map
|
|
(lambda (id)
|
|
(if (null? init-rest-decls)
|
|
;; Normal mode: find by id
|
|
id
|
|
;; By-pos mode: compute position of id
|
|
(let loop ([l inits][p 0])
|
|
(if (bound-identifier=?
|
|
id
|
|
(if (identifier? (car l))
|
|
(car l)
|
|
(stx-car (car l))))
|
|
p
|
|
(loop (cdr l) (add1 p))))))
|
|
ids)]
|
|
[(defval ...)
|
|
(map (lambda (idp)
|
|
(if (identifier? idp)
|
|
(syntax #f)
|
|
(with-syntax ([defexp (stx-car (stx-cdr idp))])
|
|
(syntax (lambda () defexp)))))
|
|
(syntax->list (syntax (idp ...))))]
|
|
[class-name class-name])
|
|
(syntax/loc e
|
|
(begin
|
|
(set! id (extract-arg 'class-name 'idpos init-args defval))
|
|
...))))]
|
|
[(field idp ...)
|
|
(syntax/loc e (begin
|
|
(set! . idp)
|
|
...))]
|
|
[(init-rest id)
|
|
(with-syntax ([n (+ (length plain-inits)
|
|
(length plain-init-fields)
|
|
-1)])
|
|
(syntax/loc e (set! id (extract-rest-args n init-args))))]
|
|
[_else e]))
|
|
exprs)]
|
|
[mk-method-temp
|
|
(lambda (id-stx)
|
|
(datum->syntax-object (quote-syntax here)
|
|
(gensym (syntax-e id-stx))))])
|
|
|
|
;; ---- set up field and method mappings ----
|
|
(with-syntax ([(rename-orig ...) (map car renames)]
|
|
[(rename-temp ...) (generate-temporaries (map car renames))]
|
|
[(private-name ...) (map car privates)]
|
|
[(private-temp ...) (map mk-method-temp (map car privates))]
|
|
[(public-final-name ...) (map car public-finals)]
|
|
[(override-final-name ...) (map car override-finals)]
|
|
[(public-final-temp ...) (map
|
|
mk-method-temp
|
|
(map car public-finals))]
|
|
[(override-final-temp ...) (map
|
|
mk-method-temp
|
|
(map car override-finals))]
|
|
[(method-name ...) (append local-public-normal-names
|
|
(map car inherits))]
|
|
[(method-accessor ...) (generate-temporaries
|
|
(map car
|
|
(append publics
|
|
overrides
|
|
inherits)))]
|
|
[(field-accessor ...) (generate-temporaries
|
|
(map (lambda (id)
|
|
(format "get-~a"
|
|
(syntax-e id)))
|
|
(append inherit-field-names
|
|
field-names
|
|
private-field-names)))]
|
|
[(field-mutator ...) (generate-temporaries
|
|
(map (lambda (id)
|
|
(format "set-~a!"
|
|
(syntax-e id)))
|
|
(append inherit-field-names
|
|
field-names
|
|
private-field-names)))]
|
|
[(all-field ...) (append inherit-field-names
|
|
field-names
|
|
private-field-names)]
|
|
[(plain-init-name ...) (map (lambda (i)
|
|
(if (identifier? i)
|
|
i
|
|
(car i)))
|
|
plain-inits)])
|
|
(let ([mappings
|
|
;; make-XXX-map is supplied by private/classidmap.ss
|
|
(with-syntax ([the-obj the-obj]
|
|
[the-finder the-finder]
|
|
[this-id this-id])
|
|
(syntax
|
|
([this-id
|
|
(make-this-map (quote-syntax the-finder)
|
|
(quote the-obj))]
|
|
[all-field
|
|
(make-field-map (quote-syntax the-finder)
|
|
(quote the-obj)
|
|
(quote-syntax field-accessor)
|
|
(quote-syntax field-mutator))]
|
|
...
|
|
[rename-orig
|
|
(make-rename-map (quote-syntax the-finder)
|
|
(quote the-obj)
|
|
(quote rename-temp))]
|
|
...
|
|
[method-name
|
|
(make-method-map (quote-syntax the-finder)
|
|
(quote the-obj)
|
|
(quote-syntax method-accessor))]
|
|
...
|
|
[private-name
|
|
(make-direct-method-map (quote-syntax the-finder)
|
|
(quote the-obj)
|
|
(quote private-temp))]
|
|
...
|
|
[public-final-name
|
|
(make-direct-method-map (quote-syntax the-finder)
|
|
(quote the-obj)
|
|
(quote public-final-temp))]
|
|
...
|
|
[override-final-name
|
|
(make-direct-method-map (quote-syntax the-finder)
|
|
(quote the-obj)
|
|
(quote override-final-temp))]
|
|
...)))]
|
|
[extra-init-mappings
|
|
(with-syntax ([super-instantiate-id super-instantiate-id]
|
|
[super-make-object-id super-make-object-id])
|
|
(syntax
|
|
([plain-init-name init-error-map]
|
|
...
|
|
[super-instantiate-id super-error-map]
|
|
[super-make-object-id super-error-map])))])
|
|
|
|
(let ([find-method
|
|
(lambda (methods)
|
|
(lambda (name)
|
|
(ormap
|
|
(lambda (m)
|
|
(and (bound-identifier=? (car m) name)
|
|
(with-syntax ([proc (proc-shape (car m) (cdr m) #t)]
|
|
[extra-init-mappings extra-init-mappings])
|
|
(syntax
|
|
(letrec-syntax extra-init-mappings
|
|
proc)))))
|
|
methods)))])
|
|
|
|
;; ---- build final result ----
|
|
(with-syntax ([public-names (map cdr publics)]
|
|
[override-names (map cdr overrides)]
|
|
[public-final-names (map cdr public-finals)]
|
|
[override-final-names (map cdr override-finals)]
|
|
[rename-names (map cdr renames)]
|
|
[inherit-names (map cdr inherits)]
|
|
[num-fields (datum->syntax-object
|
|
(quote-syntax here)
|
|
(+ (length private-field-names)
|
|
(length plain-init-fields)
|
|
(length plain-fields)))]
|
|
[field-names (map (lambda (i)
|
|
(if (identifier? i)
|
|
i
|
|
(car i)))
|
|
(append
|
|
plain-fields
|
|
plain-init-fields))]
|
|
[inherit-field-names inherit-field-names]
|
|
[init-names (if (null? init-rest-decls)
|
|
(map (lambda (i)
|
|
(if (identifier? i)
|
|
i
|
|
(car i)))
|
|
inits)
|
|
#f)]
|
|
[(private-method ...) (map (find-method private-methods) (map car privates))]
|
|
[public-methods (map (find-method methods) (map car publics))]
|
|
[override-methods (map (find-method methods) (map car overrides))]
|
|
[(public-final-method ...) (map (find-method methods) (map car public-finals))]
|
|
[(override-final-method ...) (map (find-method methods) (map car override-finals))]
|
|
[mappings mappings]
|
|
|
|
[extra-init-mappings extra-init-mappings]
|
|
[exprs exprs]
|
|
[the-obj the-obj]
|
|
[the-finder the-finder]
|
|
[super-instantiate-id super-instantiate-id]
|
|
[super-make-object-id super-make-object-id]
|
|
[name class-name])
|
|
|
|
(syntax
|
|
(let ([superclass super-expression]
|
|
[interfaces (list interface-expr ...)])
|
|
(compose-class
|
|
'name superclass interfaces
|
|
;; Field count:
|
|
num-fields
|
|
;; Field names:
|
|
(quote field-names)
|
|
(quote inherit-field-names)
|
|
;; Method names:
|
|
(quote rename-names)
|
|
(quote public-final-names)
|
|
(quote public-names)
|
|
(quote override-final-names)
|
|
(quote override-names)
|
|
(quote inherit-names)
|
|
(quote (public-final-name ... override-final-name ...))
|
|
;; Init arg names (in order)
|
|
(quote init-names)
|
|
;; Methods (when given needed super-methods, etc.):
|
|
(lambda (field-accessor ... ; inherit, public, private
|
|
field-mutator ...
|
|
rename-temp ...
|
|
method-accessor ...) ; public, override, inherit
|
|
(letrec-syntax mappings
|
|
(letrec ([private-temp private-method]
|
|
...
|
|
[public-final-temp public-final-method]
|
|
...
|
|
[override-final-temp override-final-method]
|
|
...)
|
|
(values
|
|
(list public-final-temp ... . public-methods)
|
|
(list override-final-temp ... . override-methods)
|
|
;; Initialization
|
|
(lambda (the-obj super-id init-args)
|
|
(fluid-let-syntax ([the-finder (quote-syntax the-obj)])
|
|
(letrec-syntax ([super-instantiate-id
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(_ (arg (... ...)) (kw kwarg) (... ...))
|
|
(syntax (-instantiate super-id _ #f (list arg (... ...)) (kw kwarg) (... ...)))]))])
|
|
(let ([super-make-object-id
|
|
(lambda args
|
|
(super-id #f args null))])
|
|
(let ([plain-init-name undefined]
|
|
...)
|
|
(void) ; in case the body is empty
|
|
. exprs)))))))))
|
|
;; Not primitive:
|
|
#f)))))))))))))))])))
|
|
|
|
(define-syntax class*
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(form super-expression (interface-expr ...)
|
|
defn-or-expr
|
|
...)
|
|
(with-syntax ([this (datum->syntax-object (syntax form) 'this stx)]
|
|
[super-init (datum->syntax-object (syntax form) 'super-instantiate stx)]
|
|
[super-make (datum->syntax-object (syntax form) 'super-make-object stx)])
|
|
(syntax/loc stx
|
|
(class*/names (this super-init super-make) super-expression (interface-expr ...)
|
|
defn-or-expr
|
|
...)))])))
|
|
|
|
(define-syntax class
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(form super-expression
|
|
defn-or-expr
|
|
...)
|
|
(with-syntax ([class* (datum->syntax-object (syntax form) 'class* stx)])
|
|
(syntax/loc stx
|
|
(class* super-expression ()
|
|
defn-or-expr
|
|
...)))])))
|
|
|
|
;;--------------------------------------------------------------------
|
|
;; class implementation
|
|
;;--------------------------------------------------------------------
|
|
|
|
(define-struct class (name
|
|
pos supers ; pos is subclass depth, supers is vector
|
|
>interface ; self interface
|
|
|
|
method-width ; total number of methods
|
|
method-ht ; maps public names to vector positions
|
|
method-ids ; reverse-ordered list of public method names
|
|
|
|
methods ; vector of methods
|
|
meth-flags ; vector: #f => primitive-implemented
|
|
; 'final => final
|
|
|
|
field-width ; total number of fields
|
|
field-ht ; maps public field names to (cons accessor mutator)
|
|
field-ids ; list of public field names
|
|
|
|
struct:object ; structure type for instances
|
|
object? ; predicate
|
|
make-object ; constructor
|
|
field-ref ; accessor
|
|
field-set! ; mutator
|
|
|
|
init-args ; list of symbols in order; #f => only by position
|
|
|
|
init ; initializer
|
|
|
|
no-super-init?); #t => no super-init needed
|
|
insp)
|
|
|
|
(define (compose-class name ; symbol
|
|
super ; class
|
|
interfaces ; list of interfaces
|
|
|
|
num-fields ; total fields (public & private)
|
|
public-field-names ; list of symbols (shorter than num-fields)
|
|
inherit-field-names ; list of symbols (not included in num-fields)
|
|
|
|
rename-names ; list of symbols
|
|
public-final-names
|
|
public-normal-names
|
|
override-final-names
|
|
override-normal-names
|
|
inherit-names
|
|
final-names ; subset of public + override
|
|
|
|
init-args ; list of symbols in order
|
|
|
|
make-methods ; takes field and method accessors
|
|
make-struct:prim) ; see "primitive classes", below
|
|
|
|
;; -- Check superclass --
|
|
(unless (class? super)
|
|
(obj-error 'class* "superclass expression returned a non-class: ~a~a"
|
|
super
|
|
(for-class name)))
|
|
;; -- Create new class's name --
|
|
(let* ([name (or name
|
|
(let ([s (class-name super)])
|
|
(and s
|
|
(not (eq? super object%))
|
|
(if (symbol? s)
|
|
(format "derived-from-~a" s)
|
|
s))))]
|
|
;; Combine method lists
|
|
[public-names (append public-final-names public-normal-names)]
|
|
[override-names (append override-final-names override-normal-names)]
|
|
;; Mis utilities
|
|
[no-new-methods? (null? public-names)]
|
|
[no-method-changes? (and (null? public-names)
|
|
(null? override-names))]
|
|
[no-new-fields? (null? public-field-names)]
|
|
[xappend (lambda (a b) (if (null? b) a (append a b)))])
|
|
|
|
;; -- Check interfaces ---
|
|
(for-each
|
|
(lambda (intf)
|
|
(unless (interface? intf)
|
|
(obj-error 'class*/names "interface expression returned a non-interface: ~a~a"
|
|
intf
|
|
(for-class name))))
|
|
interfaces)
|
|
|
|
;; -- Match method and field names to indices --
|
|
(let ([method-ht (if no-new-methods?
|
|
(class-method-ht super)
|
|
(make-hash-table))]
|
|
[field-ht (if no-new-fields?
|
|
(class-field-ht super)
|
|
(make-hash-table))]
|
|
[super-method-ids (class-method-ids super)]
|
|
[super-field-ids (class-field-ids super)]
|
|
[super-field-ht (class-field-ht super)])
|
|
|
|
;; Put superclass ids in tables, with pos
|
|
(unless no-new-methods?
|
|
(let loop ([ids super-method-ids][p (sub1 (class-method-width super))])
|
|
(unless (null? ids)
|
|
(hash-table-put! method-ht (car ids) p)
|
|
(loop (cdr ids) (sub1 p)))))
|
|
(unless no-new-fields?
|
|
(let loop ([ids super-field-ids])
|
|
(unless (null? ids)
|
|
(hash-table-put! field-ht (car ids) (hash-table-get super-field-ht (car ids)))
|
|
(loop (cdr ids)))))
|
|
|
|
;; Put new ids in table, with pos (replace field pos with accessor info later)
|
|
(unless no-new-methods?
|
|
(let loop ([ids public-names][p (class-method-width super)])
|
|
(unless (null? ids)
|
|
(when (hash-table-get method-ht (car ids) (lambda () #f))
|
|
(obj-error 'class*/names "superclass already contains method: ~a~a"
|
|
(car ids)
|
|
(for-class name)))
|
|
(hash-table-put! method-ht (car ids) p)
|
|
(loop (cdr ids) (add1 p)))))
|
|
(unless no-new-fields?
|
|
(let loop ([ids public-field-names][p (class-field-width super)])
|
|
(unless (null? ids)
|
|
(when (hash-table-get field-ht (car ids) (lambda () #f))
|
|
(obj-error 'class*/names "superclass already contains field: ~a~a"
|
|
(car ids)
|
|
(for-class name)))
|
|
(hash-table-put! field-ht (car ids) p)
|
|
(loop (cdr ids) (add1 p)))))
|
|
|
|
;; Check that superclass has expected fields
|
|
(for-each (lambda (id)
|
|
(unless (hash-table-get field-ht id (lambda () #f))
|
|
(obj-error 'class*/names "superclass does not provide field: ~a~a"
|
|
id
|
|
(for-class name))))
|
|
inherit-field-names)
|
|
|
|
;; Check that superclass has expected methods, and get indices
|
|
(let ([get-indices
|
|
(lambda (ids)
|
|
(map
|
|
(lambda (id)
|
|
(hash-table-get
|
|
method-ht id
|
|
(lambda ()
|
|
(obj-error 'class*/names
|
|
"superclass does not provide an expected method: ~a~a"
|
|
id
|
|
(for-class name)))))
|
|
ids))]
|
|
[method-width (+ (class-method-width super) (length public-names))]
|
|
[field-width (+ (class-field-width super) num-fields)])
|
|
(let ([rename-indices (get-indices rename-names)]
|
|
[inherit-indices (get-indices inherit-names)]
|
|
[replace-final-indices (get-indices override-final-names)]
|
|
[replace-normal-indices (get-indices override-normal-names)]
|
|
[new-final-indices (get-indices public-final-names)]
|
|
[new-normal-indices (get-indices public-normal-names)])
|
|
|
|
;; -- Check that all interfaces are satisfied --
|
|
(for-each
|
|
(lambda (intf)
|
|
(for-each
|
|
(lambda (var)
|
|
(unless (hash-table-get method-ht var (lambda () #f))
|
|
(obj-error 'class*/names
|
|
"interface-required method missing: ~a~a~a"
|
|
var
|
|
(for-class name)
|
|
(for-intf (interface-name intf)))))
|
|
(interface-public-ids intf)))
|
|
interfaces)
|
|
(let ([c (get-implement-requirement interfaces 'class*/names (for-class name))])
|
|
(when (and c (not (subclass? super c)))
|
|
(obj-error 'class*/names
|
|
"interface-required implementation not satisfied~a~a"
|
|
(for-class name)
|
|
(let ([r (class-name c)])
|
|
(if r
|
|
(format " required class: ~a" r)
|
|
"")))))
|
|
|
|
;; ---- Make the class and its interface ----
|
|
(let* ([class-make (if name
|
|
(make-naming-constructor
|
|
struct:class
|
|
(string->symbol (format "class:~a" name)))
|
|
make-class)]
|
|
[interface-make (if name
|
|
(make-naming-constructor
|
|
struct:interface
|
|
(string->symbol (format "interface:~a" name)))
|
|
make-interface)]
|
|
[method-names (append (reverse public-names) super-method-ids)]
|
|
[field-names (append public-field-names super-field-ids)]
|
|
[super-interfaces (cons (class->interface super) interfaces)]
|
|
[i (interface-make name super-interfaces method-names #f)]
|
|
[methods (if no-method-changes?
|
|
(class-methods super)
|
|
(make-vector method-width))]
|
|
[meth-flags (if no-method-changes?
|
|
(class-meth-flags super)
|
|
(make-vector method-width))]
|
|
[c (class-make name
|
|
(add1 (class-pos super))
|
|
(list->vector (append (vector->list (class-supers super)) (list #f)))
|
|
i
|
|
method-width method-ht method-names
|
|
methods meth-flags
|
|
field-width field-ht field-names
|
|
'struct:object 'object? 'make-object 'field-ref 'field-set!
|
|
init-args
|
|
'init
|
|
(and make-struct:prim #t))]
|
|
[obj-name (if name
|
|
(string->symbol (format "object:~a" name))
|
|
'object)]
|
|
;; Used only for prim classes
|
|
[dispatcher (lambda (obj box)
|
|
(when (symbol? (unbox box))
|
|
;; Map symbol to number:
|
|
(set-box! box (hash-table-get method-ht (unbox box))))
|
|
(let ([c (object-ref obj)]
|
|
[n (unbox box)])
|
|
(if (vector-ref (class-meth-flags c) n)
|
|
(vector-ref (class-methods c) n)
|
|
#f)))])
|
|
(vector-set! (class-supers c) (add1 (class-pos super)) c)
|
|
|
|
;; --- Make the new object struct ---
|
|
(let*-values ([(prim-tagged-object-make prim-object? struct:prim-object)
|
|
(if make-struct:prim
|
|
(make-struct:prim c prop:object dispatcher)
|
|
(values #f #f #f))]
|
|
[(struct:object object-make object? object-field-ref object-field-set!)
|
|
(if make-struct:prim
|
|
;; Use prim struct:
|
|
(values struct:prim-object #f prim-object? #f #f)
|
|
;; Normal struct creation:
|
|
(make-struct-type obj-name
|
|
(class-struct:object super)
|
|
0 ;; No init fields
|
|
;; Fields for new slots:
|
|
num-fields undefined
|
|
null
|
|
insp))]
|
|
;; The second structure associates prop:object with the class.
|
|
;; Other classes extend struct:object, so we can't put the
|
|
;; property there.
|
|
[(struct:tagged-object tagged-object-make tagged-object? -ref -set!)
|
|
(if make-struct:prim
|
|
;; Use prim struct:
|
|
(values #f prim-tagged-object-make #f #f #f)
|
|
;; Normal second-struct creation:
|
|
(make-struct-type obj-name
|
|
struct:object
|
|
0 0 #f
|
|
;; Map object property to class:
|
|
(list (cons prop:object c))
|
|
insp))])
|
|
(set-class-struct:object! c struct:object)
|
|
(set-class-object?! c object?)
|
|
(set-class-make-object! c tagged-object-make)
|
|
(set-class-field-ref! c object-field-ref)
|
|
(set-class-field-set!! c object-field-set!)
|
|
|
|
;; --- Build field accessors and mutators ---
|
|
;; Use public field names to name the accessors and mutators
|
|
(let-values ([(accessors mutators)
|
|
(let ([rev-fields (reverse public-field-names)])
|
|
(let ([mk
|
|
(lambda (mk obj-)
|
|
(let loop ([n num-fields]
|
|
[l null]
|
|
[skip (- num-fields (length public-field-names))]
|
|
[field-ids rev-fields])
|
|
(if (zero? n)
|
|
l
|
|
(loop (sub1 n)
|
|
(cons (apply
|
|
mk obj- (sub1 n)
|
|
(if (zero? skip)
|
|
(list (car field-ids))
|
|
null))
|
|
l)
|
|
(max 0 (sub1 skip))
|
|
(if (zero? skip)
|
|
(cdr field-ids)
|
|
field-ids)))))])
|
|
(values
|
|
(append (map (lambda (id) (make-class-field-accessor super id))
|
|
inherit-field-names)
|
|
(mk make-struct-field-accessor object-field-ref))
|
|
(append (map (lambda (id) (make-class-field-mutator super id))
|
|
inherit-field-names)
|
|
(mk make-struct-field-mutator object-field-set!)))))])
|
|
;; -- Reset field table to register accessor and mutator info --
|
|
;; There are more accessors and mutators than public fields...
|
|
(let loop ([ids public-field-names][pos 0])
|
|
(unless (null? ids)
|
|
(hash-table-put! field-ht (car ids) (cons c pos))
|
|
(loop (cdr ids) (add1 pos))))
|
|
|
|
;; -- Extract superclass methods ---
|
|
(let ([renames (map (lambda (index)
|
|
(vector-ref (class-methods super) index))
|
|
rename-indices)])
|
|
;; -- Create method accessors --
|
|
(let ([method-accessors (map (lambda (index)
|
|
(lambda (obj)
|
|
(vector-ref (class-methods (object-ref obj)) index)))
|
|
(append new-normal-indices
|
|
replace-normal-indices
|
|
inherit-indices))])
|
|
|
|
;; -- Get new methods and initializers --
|
|
(let-values ([(new-methods override-methods init)
|
|
(apply make-methods
|
|
(append accessors
|
|
mutators
|
|
renames
|
|
method-accessors))])
|
|
;; -- Fill in method tables --
|
|
;; First copy old methods
|
|
(unless no-method-changes?
|
|
(hash-table-for-each
|
|
(class-method-ht super)
|
|
(lambda (name index)
|
|
(vector-set! methods index (vector-ref (class-methods super) index))
|
|
(vector-set! meth-flags index (vector-ref (class-meth-flags super) index)))))
|
|
;; Add new methods:
|
|
(for-each (lambda (index method)
|
|
(vector-set! methods index method)
|
|
(vector-set! meth-flags index (not make-struct:prim)))
|
|
(append new-final-indices new-normal-indices)
|
|
new-methods)
|
|
;; Override old methods:
|
|
(for-each (lambda (index method id)
|
|
(when (eq? 'final (vector-ref meth-flags index))
|
|
(obj-error 'class*/names
|
|
"cannot override final method: ~a~a"
|
|
id
|
|
(for-class name)))
|
|
(vector-set! methods index method)
|
|
(vector-set! meth-flags index (not make-struct:prim)))
|
|
(append replace-final-indices replace-normal-indices)
|
|
override-methods
|
|
override-names)
|
|
;; Mark final methods:
|
|
(for-each (lambda (id)
|
|
(vector-set! meth-flags (hash-table-get method-ht id) 'final))
|
|
final-names)
|
|
|
|
;; --- Install initializer into class ---
|
|
(set-class-init! c init)
|
|
|
|
;; -- result is the class ---
|
|
c)))))))))))
|
|
|
|
(define-values (prop:object object? object-ref) (make-struct-type-property 'object))
|
|
|
|
;;--------------------------------------------------------------------
|
|
;; interfaces
|
|
;;--------------------------------------------------------------------
|
|
|
|
;; >> Simplistic implementation for now <<
|
|
|
|
(define-syntax interface
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(_ (interface-expr ...) var ...)
|
|
(let ([vars (syntax->list (syntax (var ...)))]
|
|
[name (syntax-local-name)])
|
|
(for-each
|
|
(lambda (v)
|
|
(unless (identifier? v)
|
|
(raise-syntax-error 'interface
|
|
"not an identifier"
|
|
stx
|
|
v)))
|
|
vars)
|
|
(let ([dup (check-duplicate-identifier vars)])
|
|
(when dup
|
|
(raise-syntax-error 'interface
|
|
"duplicate name"
|
|
stx
|
|
dup)))
|
|
(with-syntax ([name (datum->syntax-object #f name #f)])
|
|
(syntax/loc
|
|
stx
|
|
(compose-interface
|
|
'name
|
|
(list interface-expr ...)
|
|
'(var ...)))))])))
|
|
|
|
(define-struct interface (name supers public-ids class) insp)
|
|
|
|
(define (compose-interface name supers vars)
|
|
(for-each
|
|
(lambda (intf)
|
|
(unless (interface? intf)
|
|
(obj-error 'interface
|
|
"superinterface expression returned a non-interface: ~a~a"
|
|
intf
|
|
(for-intf name))))
|
|
supers)
|
|
(let ([ht (make-hash-table)])
|
|
(for-each
|
|
(lambda (var)
|
|
(hash-table-put! ht var #t))
|
|
vars)
|
|
;; Check that vars don't already exist in supers:
|
|
(for-each
|
|
(lambda (super)
|
|
(for-each
|
|
(lambda (var)
|
|
(when (hash-table-get ht var (lambda () #f))
|
|
(obj-error 'interface "variable already in superinterface: ~a~a~a"
|
|
var
|
|
(for-intf name)
|
|
(let ([r (interface-name super)])
|
|
(if r
|
|
(format " already in: ~a" r)
|
|
"")))))
|
|
(interface-public-ids super)))
|
|
supers)
|
|
;; Check for [conflicting] implementation requirements
|
|
(let ([class (get-implement-requirement supers 'interface (for-intf name))]
|
|
[interface-make (if name
|
|
(make-naming-constructor
|
|
struct:interface
|
|
(string->symbol (format "interface:~a" name)))
|
|
make-interface)])
|
|
;; Add supervars to table:
|
|
(for-each
|
|
(lambda (super)
|
|
(for-each
|
|
(lambda (var) (hash-table-put! ht var #t))
|
|
(interface-public-ids super)))
|
|
supers)
|
|
;; Done
|
|
(interface-make name supers (hash-table-map ht (lambda (k v) k)) class))))
|
|
|
|
(define (get-implement-requirement interfaces where for)
|
|
(let loop ([class #f]
|
|
[supers interfaces])
|
|
(if (null? supers)
|
|
class
|
|
(let ([c (interface-class (car supers))])
|
|
(loop
|
|
(cond
|
|
[(not c) class]
|
|
[(not class) c]
|
|
[(subclass? c class) class]
|
|
[(subclass? class c) c]
|
|
[else
|
|
(obj-error
|
|
where
|
|
"conflicting class implementation requirements in superinterfaces~a"
|
|
for)])
|
|
(cdr supers))))))
|
|
|
|
;;--------------------------------------------------------------------
|
|
;; object%
|
|
;;--------------------------------------------------------------------
|
|
|
|
(define (make-naming-constructor type name)
|
|
(let-values ([(struct: make- ? -accessor -mutator)
|
|
(make-struct-type name type 0 0 #f null insp)])
|
|
make-))
|
|
|
|
(define object<%> ((make-naming-constructor struct:interface 'interface:object%)
|
|
'object% null null #f))
|
|
(define object% ((make-naming-constructor struct:class 'class:object%)
|
|
'object%
|
|
0 (vector #f)
|
|
object<%>
|
|
|
|
0 (make-hash-table) null
|
|
(vector) (vector)
|
|
|
|
0 (make-hash-table) null
|
|
|
|
'struct:object object? 'make-object
|
|
'field-ref-not-needed 'field-set!-not-needed
|
|
|
|
null
|
|
|
|
(lambda (this super-init args)
|
|
(unless (null? args)
|
|
(obj-error "make-object" "unused initialization arguments: ~e" args))
|
|
(void))
|
|
|
|
#t)) ; no super-init
|
|
|
|
(vector-set! (class-supers object%) 0 object%)
|
|
(let*-values ([(struct:obj make-obj obj? -get -set!)
|
|
(make-struct-type 'object #f 0 0 #f null insp)]
|
|
[(struct:tagged-obj make-tagged-obj tagged-obj? -get -set!)
|
|
(make-struct-type 'object struct:obj 0 0 #f (list (cons prop:object object%)) insp)])
|
|
(set-class-struct:object! object% struct:obj)
|
|
(set-class-make-object! object% make-tagged-obj))
|
|
(set-class-object?! object% object?) ; don't use struct pred; it wouldn't work with prim classes
|
|
|
|
(set-interface-class! object<%> object%)
|
|
|
|
;;--------------------------------------------------------------------
|
|
;; instantiation
|
|
;;--------------------------------------------------------------------
|
|
|
|
(define make-object
|
|
(lambda (class . args)
|
|
(do-make-object class args null)))
|
|
|
|
(define-syntax instantiate
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(form class (arg ...) . x)
|
|
(syntax (-instantiate do-make-object form class (list arg ...) . x))])))
|
|
|
|
;; Helper; used by instantiate and super-instantiate
|
|
(define-syntax -instantiate
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(_ do-make-object form class args (kw arg) ...)
|
|
(andmap identifier? (syntax->list (syntax (kw ...))))
|
|
(syntax (do-make-object class
|
|
args
|
|
(list (cons 'kw arg)
|
|
...)))]
|
|
[(_ super-make-object form class args kwarg ...)
|
|
;; some kwarg must be bad:
|
|
(for-each (lambda (kwarg)
|
|
(syntax-case kwarg ()
|
|
[(kw arg)
|
|
(identifier? (syntax kw))
|
|
'ok]
|
|
[(kw arg)
|
|
(raise-syntax-error
|
|
(syntax-e (syntax form))
|
|
"keyword-based argument does not start with an identifier"
|
|
kwarg)]
|
|
[_else
|
|
(raise-syntax-error
|
|
(syntax-e (syntax form))
|
|
"ill-formed keyword-based argument"
|
|
kwarg)]))
|
|
(syntax->list (syntax (kwarg ...))))])))
|
|
|
|
(define (do-make-object class by-pos-args named-args)
|
|
(unless (class? class)
|
|
(raise-type-error 'make-object "class" class))
|
|
(let ([o ((class-make-object class))])
|
|
;; Initialize it:
|
|
(let loop ([c class][by-pos-args by-pos-args][named-args named-args])
|
|
(let ([by-pos-only? (not (class-init-args c))])
|
|
;; Primitive class with by-pos arguments?
|
|
(when by-pos-only?
|
|
(unless (null? named-args)
|
|
(obj-error
|
|
"make-object"
|
|
"class has only by-position initializers, but given keyword-based arguments: ~e~a"
|
|
named-args
|
|
(for-class (class-name c)))))
|
|
;; Merge by-pos into named args:
|
|
(let ([named-args (if (not by-pos-only?)
|
|
;; Normal merge
|
|
(let loop ([al by-pos-args][nl (class-init-args c)])
|
|
(cond
|
|
[(null? al) named-args]
|
|
[(null? nl) (obj-error "make-object" "too many initialization arguments: ~e~a"
|
|
by-pos-args
|
|
(for-class (class-name c)))]
|
|
[else (cons (cons (car nl) (car al))
|
|
(loop (cdr al) (cdr nl)))]))
|
|
;; Fake merge for by-position initializers:
|
|
by-pos-args)])
|
|
;; Check for duplicate arguments
|
|
(unless by-pos-only?
|
|
(unless (null? named-args)
|
|
(let loop ([l named-args])
|
|
(unless (null? (cdr l))
|
|
(if (assq (caar l) (cdr l))
|
|
(obj-error "make-object" "duplicate initialization argument: ~a in: ~e~a"
|
|
(caar l)
|
|
named-args
|
|
(for-class (class-name c)))
|
|
(loop (cdr l)))))))
|
|
(let ([inited? (class-no-super-init? c)])
|
|
((class-init c)
|
|
o
|
|
;; ----- This is the super-init function -----
|
|
(lambda (ignore-false by-pos-args new-named-args)
|
|
(when inited?
|
|
(obj-error "make-object" "superclass already initialized by class initialization~a"
|
|
(for-class (class-name c))))
|
|
(set! inited? #t)
|
|
(let ([named-args (if by-pos-only?
|
|
;; all old args must have been used up
|
|
new-named-args
|
|
;; Normal mode: merge leftover keyowrd-based args with new ones
|
|
(let loop ([l named-args])
|
|
(cond
|
|
[(null? l) new-named-args]
|
|
[(memq (caar l) (class-init-args c))
|
|
(loop (cdr l))]
|
|
[else (cons (car l) (loop (cdr l)))])))])
|
|
(loop (vector-ref (class-supers c) (sub1 (class-pos c))) by-pos-args named-args)))
|
|
named-args)
|
|
(unless inited?
|
|
(obj-error "make-object" "superclass initialization not invoked by initialization~a"
|
|
(for-class (class-name c))))))))
|
|
o))
|
|
|
|
(define (extract-arg class-name name arguments default)
|
|
(if (symbol? name)
|
|
;; Normal mode
|
|
(let ([a (assq name arguments)])
|
|
(cond
|
|
[a (cdr a)]
|
|
[default (default)]
|
|
[else (obj-error "make-object" "no argument for required init variable: ~a~a" name
|
|
(if class-name (format " in class: ~a" class-name) ""))]))
|
|
;; By-position mode
|
|
(cond
|
|
[(< name (length arguments))
|
|
(list-ref arguments name)]
|
|
[default (default)]
|
|
[else (obj-error "make-object" "too few initialization arguments")])))
|
|
|
|
(define (extract-rest-args skip arguments)
|
|
(if (< skip (length arguments))
|
|
(list-tail arguments skip)
|
|
null))
|
|
|
|
;;--------------------------------------------------------------------
|
|
;; methods and fields
|
|
;;--------------------------------------------------------------------
|
|
|
|
(define-syntax send
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(_ obj name . args)
|
|
(begin
|
|
(unless (identifier? (syntax name))
|
|
(raise-syntax-error
|
|
'send
|
|
"method name is not an identifier"
|
|
stx
|
|
(syntax name)))
|
|
(if (stx-list? (syntax args))
|
|
(syntax (let ([this obj])
|
|
((find-method this 'name) this . args)))
|
|
(with-syntax ([args (flatten-args (syntax args))])
|
|
(syntax (let ([this obj])
|
|
(apply (find-method this 'name) this . args))))))])))
|
|
|
|
(define-syntax send*
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(_ obj (meth . args) ...)
|
|
(syntax/loc stx
|
|
(let ([o obj])
|
|
(send o meth . args)
|
|
...))])))
|
|
|
|
(define (find-method object name)
|
|
(unless (object? object)
|
|
(obj-error 'send "target is not an object: ~e for method: ~a"
|
|
object name))
|
|
(let* ([c (object-ref object)]
|
|
[pos (hash-table-get (class-method-ht c) name (lambda () #f))])
|
|
(if pos
|
|
(vector-ref (class-methods c) pos)
|
|
(obj-error 'send "no such method: ~a~a"
|
|
name
|
|
(for-class (class-name c))))))
|
|
|
|
|
|
(define (class-field-X who which cwhich class name)
|
|
(unless (class? class)
|
|
(raise-type-error who "class" class))
|
|
(unless (symbol? name)
|
|
(raise-type-error who "symbol" name))
|
|
(let ([p (hash-table-get (class-field-ht class) name
|
|
(lambda ()
|
|
(obj-error who "no such field: ~a~a"
|
|
name
|
|
(for-class (class-name class)))))])
|
|
(which (cwhich (car p)) (cdr p))))
|
|
|
|
(define (make-class-field-accessor class name)
|
|
(class-field-X 'make-class-field-accessor
|
|
make-struct-field-accessor class-field-ref
|
|
class name))
|
|
|
|
(define (make-class-field-mutator class name)
|
|
(class-field-X 'make-class-field-mutator
|
|
make-struct-field-mutator class-field-set!
|
|
class name))
|
|
|
|
(define-struct generic (applicable))
|
|
|
|
(define (make-generic/proc class name)
|
|
(unless (or (class? class) (interface? class))
|
|
(raise-type-error 'make-generic "class or interface" class))
|
|
(unless (symbol? name)
|
|
(raise-type-error 'make-generic "symbol" name))
|
|
(make-generic
|
|
(if (interface? class)
|
|
(let ([intf class])
|
|
(unless (method-in-interface? name intf)
|
|
(obj-error 'make-generic "no such method: ~a~a"
|
|
name
|
|
(for-intf (interface-name intf))))
|
|
(lambda (obj)
|
|
(unless (is-a? obj intf)
|
|
(raise-type-error
|
|
(symbol->string (format "generic:~a~a" name (for-intf (interface-name intf))))
|
|
(format "instance~a" (for-intf (interface-name intf)))
|
|
obj))
|
|
(find-method obj name)))
|
|
(let ([pos (hash-table-get (class-method-ht class) name
|
|
(lambda ()
|
|
(obj-error 'make-generic "no such method: ~a~a"
|
|
name
|
|
(for-class (class-name class)))))])
|
|
(lambda (obj)
|
|
(unless ((class-object? class) obj)
|
|
(raise-type-error
|
|
(symbol->string (format "generic:~a~a" name (for-class (class-name class))))
|
|
(format "instance~a" (for-class (class-name class)))
|
|
obj))
|
|
(vector-ref (class-methods (object-ref obj)) pos))))))
|
|
|
|
(define-syntax send-generic
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(_ obj generic . args)
|
|
(if (stx-list? (syntax args))
|
|
(syntax (let ([this obj])
|
|
(((generic-applicable generic) this) this . args)))
|
|
(with-syntax ([args (flatten-args (syntax args))])
|
|
(syntax (let ([this obj])
|
|
(apply ((generic-applicable generic) this) this . args)))))])))
|
|
|
|
|
|
;;--------------------------------------------------------------------
|
|
;; class, interface, and object properties
|
|
;;--------------------------------------------------------------------
|
|
|
|
(define (is-a? v c)
|
|
(cond
|
|
[(class? c) ((class-object? c) v)]
|
|
[(interface? c)
|
|
(and (object? v)
|
|
(implementation? (object-ref v) c))]
|
|
[else (raise-type-error 'is-a? "class or interface" 1 v c)]))
|
|
|
|
(define (subclass? v c)
|
|
(unless (class? c)
|
|
(raise-type-error 'subclass? "class" 1 v c))
|
|
(and (class? v)
|
|
(let ([p (class-pos c)])
|
|
(and (<= p (class-pos v))
|
|
(eq? c (vector-ref (class-supers v) p))))))
|
|
|
|
(define (object-interface o) (class->interface (object-ref o)))
|
|
|
|
(define (implementation? v i)
|
|
(unless (interface? i)
|
|
(raise-type-error 'implementation? "interface" 1 v i))
|
|
(and (class? v)
|
|
(interface-extension? (class->interface v) i)))
|
|
|
|
(define (interface-extension? v i)
|
|
(unless (interface? i)
|
|
(raise-type-error 'interface-extension? "interface" 1 v i))
|
|
(and (interface? i)
|
|
(let loop ([v v])
|
|
(or (eq? v i)
|
|
(ormap loop (interface-supers v))))))
|
|
|
|
(define (method-in-interface? s i)
|
|
(unless (symbol? s)
|
|
(raise-type-error 'method-in-interface? "symbol" 0 s i))
|
|
(unless (interface? i)
|
|
(raise-type-error 'method-in-interface? "interface" 1 s i))
|
|
(and (memq s (interface-public-ids i)) #t))
|
|
|
|
(define (interface->method-names i)
|
|
(unless (interface? i)
|
|
(raise-type-error 'interface->method-names "interface" i))
|
|
;; copy list
|
|
(map values (interface-public-ids i)))
|
|
|
|
;;--------------------------------------------------------------------
|
|
;; primitive classes
|
|
;;--------------------------------------------------------------------
|
|
|
|
(define (make-primitive-class
|
|
make-struct:prim ; see below
|
|
prim-init ; primitive initializer: takes obj and list of name-arg pairs
|
|
name ; symbol
|
|
super ; superclass
|
|
override-names ; overridden method names
|
|
new-names ; new (public) method names
|
|
override-methods ; list of methods
|
|
new-methods) ; list of methods
|
|
|
|
; The `make-struct:prim' function takes prop:object, a
|
|
; class, and a dispatcher function, and produces:
|
|
; * a struct constructor (must have prop:object)
|
|
; * a struct predicate
|
|
; * a struct type for derived classes (mustn't have prop:object)
|
|
;
|
|
; The supplied dispatched takes an object and a boxed symbol/num
|
|
; (converts a symbol to a num first time) and returns a method if the
|
|
; corresponding method is overridden in the object's class relative to
|
|
; the primitive class, #f otherwise.
|
|
;
|
|
; When a primitive class have a primitive superclass, the
|
|
; struct:prim maker is responsible for ensuring that the returned
|
|
; struct items match the supertype predicate.
|
|
|
|
(compose-class name
|
|
(or super object%)
|
|
null
|
|
|
|
0 null null ; no fields
|
|
|
|
null ; no renames
|
|
null new-names
|
|
null override-names
|
|
null ; no inherits
|
|
null ; no finals
|
|
|
|
#f ; => init args by position only
|
|
|
|
(lambda ignored
|
|
(values
|
|
new-methods
|
|
override-methods
|
|
(lambda (this super/ignored init-args)
|
|
(apply prim-init this init-args))))
|
|
|
|
make-struct:prim))
|
|
|
|
;;--------------------------------------------------------------------
|
|
;; misc utils
|
|
;;--------------------------------------------------------------------
|
|
|
|
(define undefined (letrec ([x x]) x))
|
|
|
|
(define-struct (exn:object struct:exn) () insp)
|
|
|
|
(define (obj-error where . msg)
|
|
(raise
|
|
(make-exn:object
|
|
(string-append
|
|
(format "~a: " where)
|
|
(apply format msg))
|
|
(current-continuation-marks))))
|
|
|
|
(define (for-class name)
|
|
(if name (format " for class: ~a" name) ""))
|
|
(define (for-intf name)
|
|
(if name (format " for interface: ~a" name) ""))
|
|
|
|
|
|
(provide class class* class*/names class?
|
|
interface interface?
|
|
object% object?
|
|
make-object instantiate
|
|
send send* make-class-field-accessor make-class-field-mutator
|
|
(rename make-generic/proc make-generic) send-generic
|
|
is-a? subclass? implementation? interface-extension?
|
|
object-interface
|
|
method-in-interface? interface->method-names class->interface
|
|
exn:object? struct:exn:object make-exn:object
|
|
make-primitive-class))
|
|
|