#lang scheme/base

(require (for-syntax scheme/base)
         mzlib/list
         mzlib/etc
         mzlib/stxparam
         "class-events.ss"
         "serialize-structs.ss"
         (for-syntax syntax/kerncase
                     syntax/stx
                     syntax/name
                     syntax/context
                     syntax/define
                     syntax/flatten-begin
                     syntax/private/boundmap
                     mzlib/stxparam
                     "classidmap.ss"))

(define insp (current-inspector)) ; for all opaque structures

;;--------------------------------------------------------------------
;;  spec for external interface
;;--------------------------------------------------------------------

(provide provide-public-names 
         ;; needed for Typed Scheme
         (protect-out do-make-object find-method/who))
(define-syntax-rule (provide-public-names)
  (provide class class* class/derived
           define-serializable-class define-serializable-class*
           class?
           mixin
           interface interface* interface?
           object% object? externalizable<%> printable<%> equal<%>
           object=?
           new make-object instantiate
           send send/apply send* class-field-accessor class-field-mutator with-method
           get-field field-bound? field-names
           private* public*  pubment*
           override* overment*
           augride* augment*
           public-final* override-final* augment-final*
           define/private define/public define/pubment
           define/override define/overment
           define/augride define/augment
           define/public-final define/override-final define/augment-final
           define-local-member-name define-member-name 
           member-name-key generate-member-key 
           member-name-key? member-name-key=? member-name-key-hash-code
           generic make-generic send-generic
           is-a? subclass? implementation? interface-extension?
           object-interface object-info object->vector
           object-method-arity-includes?
           method-in-interface? interface->method-names class->interface class-info
           (struct-out exn:fail:object)
           make-primitive-class
           
           ;; "keywords":
           private public override augment
           pubment overment augride
           public-final override-final augment-final
           field init init-field init-rest
           rename-super rename-inner inherit inherit/super inherit/inner inherit-field
           this super inner
           super-make-object super-instantiate super-new
           inspect))


;;--------------------------------------------------------------------
;;  keyword setup
;;--------------------------------------------------------------------

(define-for-syntax (do-class-keyword stx)
  (if (identifier? stx)
      (raise-syntax-error
       #f
       "illegal (unparenthesized) use of a class keyword"
       stx)
      (raise-syntax-error
       #f
       "use of a class keyword is not in a class top-level"
       stx)))

(define-syntax provide-class-keyword
  (syntax-rules ()
    [(_ id ...)
     (begin
       (define-syntax (id stx) (do-class-keyword stx))
       ...
       (provide id ...))]))

(provide-class-keyword private public override augride
                       pubment overment augment
                       public-final override-final augment-final
                       rename-super rename-inner inherit inherit-field
                       inherit/super inherit/inner
                       inspect
                       init-rest)

(define-for-syntax (do-define-like-internal stx)
  (syntax-case stx ()
    [(_ orig . __)
     (raise-syntax-error
      #f
      "use of a class keyword is not in a class top-level"
      #'orig)]))

(define-for-syntax (do-define-like stx internal-id)
  (syntax-case stx ()
    [(_ elem ...)
     (syntax-property
      #`(#,internal-id #,stx
                       #,@(map (lambda (e)
                                 (if (identifier? e)
                                     e
                                     (syntax-property
                                      (syntax-case e ()
                                        [((n1 n2) . expr)
                                         (quasisyntax/loc e
                                           (#,(syntax-property
                                               #'(n1 n2)
                                               'certify-mode 'transparent)
                                            . expr))]
                                        [_else e])
                                      'certify-mode 'transparent)))
                               (syntax-e #'(elem ...))))
      'certify-mode
      'transparent)]
    [(_ . elems)
     #`(#,internal-id #,stx . elems)]
    [_else 
     (raise-syntax-error #f "illegal (unparenthesized) use of class keyword" stx)]))

(define-syntax provide-class-define-like-keyword
  (syntax-rules ()
    [(_ [internal-id id] ...)
     (begin
       (define-syntax (internal-id stx) (do-define-like-internal stx))
       ...
       (define-syntax (id stx) (do-define-like stx #'internal-id))
       ...
       (provide id ...))]))

(provide-class-define-like-keyword 
 [-field field]
 [-init init]
 [-init-field init-field])


(define-for-syntax not-in-a-class
  (lambda (stx)
    (if (eq? (syntax-local-context) 'expression)
        (raise-syntax-error
         #f
         "use of a class keyword is not in a class"
         stx)
        (quasisyntax/loc stx (#%expression #,stx)))))

(define-syntax define/provide-context-keyword
  (syntax-rules ()
    [(_ (id param-id) ...)
     (begin
       (begin
         (provide id)
         (define-syntax-parameter param-id 
           (make-set!-transformer not-in-a-class))
         (define-syntax id
           (make-parameter-rename-transformer #'param-id)))
       ...)]))

(define/provide-context-keyword
  [this this-param]
  [super super-param]
  [inner inner-param]
  [super-make-object super-make-object-param]
  [super-instantiate super-instantiate-param]
  [super-new super-new-param])

;;--------------------------------------------------------------------
;;  local member name lookup
;;--------------------------------------------------------------------

(define-for-syntax (localize orig-id)
  (do-localize orig-id #'validate-local-member))

(define (validate-local-member orig s)
  (if (symbol? s)
      s
      (error 'local-member-name
             "used before its definition: ~a"
             orig)))

;;--------------------------------------------------------------------
;;  class macros
;;--------------------------------------------------------------------

(define-syntaxes (class* _class class/derived
                   class*-traced class-traced class/derived-traced)
  (let ()
    ;; Start with Helper functions
    
    (define (expand-all-forms stx defn-and-exprs def-ctx bind-local-id)
      (let* ([stop-forms
              (append
               (kernel-form-identifier-list)
               (list 
                (quote-syntax #%app) ; scheme/base app, as opposed to #%plain-app
                (quote-syntax lambda) ; scheme/base lambda, as opposed to #%plain-lambda
                (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 augride)
                (quote-syntax public-final)
                (quote-syntax override-final)
                (quote-syntax augment-final)
                (quote-syntax pubment)
                (quote-syntax overment)
                (quote-syntax augment)
                (quote-syntax rename-super)
                (quote-syntax inherit)
                (quote-syntax inherit/super)
                (quote-syntax inherit/inner)
                (quote-syntax rename-inner)
                (quote-syntax super)
                (quote-syntax inner)
                (quote-syntax this)
                (quote-syntax super-instantiate)
                (quote-syntax super-make-object)
                (quote-syntax super-new)
                (quote-syntax inspect)))]
             [expand-context (generate-class-expand-context)]
             [expand
              (lambda (defn-or-expr)
                (local-expand
                 defn-or-expr
                 expand-context
                 stop-forms
                 def-ctx))])
        (let loop ([l defn-and-exprs])
          (if (null? l)
              null
              (let ([e (expand (car l))])
                (syntax-case e (begin define-syntaxes define-values)
                  [(begin . _)
                   (loop (append
                          (flatten-begin e)
                          (cdr l)))]
                  [(define-syntaxes (id ...) rhs)
                   (andmap identifier? (syntax->list #'(id ...)))
                   (begin
                     (with-syntax ([rhs (local-transformer-expand
                                         #'rhs
                                         'expression
                                         null)])
                       (syntax-local-bind-syntaxes (syntax->list #'(id ...)) #'rhs def-ctx)
                       (cons #'(define-syntaxes (id ...) rhs) (loop (cdr l)))))]
                  [(define-values (id ...) rhs)
                   (andmap identifier? (syntax->list #'(id ...)))
                   (begin
                     (map bind-local-id (syntax->list #'(id ...)))
                     (cons e (loop (cdr l))))]
                  [(begin . _)
                   (raise-syntax-error 
                    #f
                    "ill-formed begin expression"
                    e)]
                  [_else (cons e (loop (cdr l)))]))))))
    
    ;; returns two lists: expressions that start with an identifier in
    ;; `kws', and expressions that don't
    (define (extract kws l out-cons)
      (let loop ([l l])
        (if (null? l)
            (values null null)
            (let-values ([(in out) (loop (cdr l))])
              (cond
                [(and (stx-pair? (car l))
                      (let ([id (stx-car (car l))])
                        (and (identifier? id)
                             (ormap (lambda (k) (free-identifier=? k id)) kws))))
                 (values (cons (car l) in) out)]
                [else
                 (values in (out-cons (car l) out))])))))
    
    (define (extract* kws l)
      (let-values ([(in out) (extract kws l void)])
        in))
    
    (define (flatten alone l)
      (apply append
             (map (lambda (i)
                    (let ([l (let ([l (syntax->list i)])
                               (if (ormap (lambda (i)
                                            (free-identifier=? (car l) i))
                                          (syntax-e (quote-syntax (-init -init-field -field))))
                                   (cddr l)
                                   (cdr l)))])
                      (if alone
                          (map (lambda (i)
                                 (if (identifier? i)
                                     (alone i)
                                     (cons (stx-car i)
                                           (stx-car (stx-cdr i)))))
                               l)
                          l)))
                  l)))
    
    ;; Used with flatten:
    (define (pair i) (cons i i))
    
    (define (normalize-init/field i)
      ;; Put i in ((iid eid) optional-expr) form
      (cond
        [(identifier? i) (list (list i i))]
        [else (let ([a (stx-car i)])
                (if (identifier? a)
                    (cons (list a a) (stx-cdr i))
                    i))]))
    
    (define (norm-init/field-iid norm) (stx-car (stx-car norm)))
    (define (norm-init/field-eid norm) (stx-car (stx-cdr (stx-car norm))))
    
    ;; expands an expression enough that we can check whether it has
    ;; the right form for a method; must use local syntax definitions
    (define (proc-shape name orig-stx xform? 
                        the-obj the-finder
                        bad class-name expand-stop-names
                        def-ctx lookup-localize)
      (define (expand expr locals)
        (local-expand
         expr
         'expression
         (append locals expand-stop-names)
         def-ctx))
      ;; 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)))))
      (define (kw-vars-ok? vars)
        (or (identifier? vars)
            (stx-null? vars)
            (and (stx-pair? vars)
                 (let ([a (stx-car vars)]
                       [opt-arg-ok?
                        (lambda (a)
                          (or (identifier? a)
                              (and (stx-pair? a)
                                   (identifier? (stx-car a))
                                   (stx-pair? (stx-cdr a))
                                   (stx-null? (stx-cdr (stx-cdr a))))))])
                   (or (and (opt-arg-ok? a)
                            (kw-vars-ok? (stx-cdr vars)))
                       (and (keyword? (syntax-e a))
                            (stx-pair? (stx-cdr vars))
                            (opt-arg-ok? (stx-car (stx-cdr vars)))
                            (kw-vars-ok? (stx-cdr (stx-cdr vars)))))))))
      ;; mk-name: constructs a method name
      ;; for error reporting, etc.
      (define (mk-name name)
        (datum->syntax 
         #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 orig-stx][can-expand? #t][name name][locals null])
        (syntax-case stx (#%plain-lambda lambda case-lambda letrec-values let-values)
          [(lam vars body1 body ...)
           (or (and (free-identifier=? #'lam #'#%plain-lambda)
                    (vars-ok? (syntax vars)))
               (and (free-identifier=? #'lam #'lambda)
                    (kw-vars-ok? (syntax vars))))
           (if xform?
               (with-syntax ([the-obj the-obj]
                             [the-finder the-finder]
                             [name (mk-name name)])
                 (with-syntax ([vars (if (free-identifier=? #'lam #'lambda)
                                         (let loop ([vars #'vars])
                                           (cond
                                             [(identifier? vars) vars]
                                             [(syntax? vars)
                                              (datum->syntax vars
                                                             (loop (syntax-e vars))
                                                             vars
                                                             vars)]
                                             [(pair? vars)
                                              (syntax-case (car vars) ()
                                                [(id expr)
                                                 (identifier? #'id)
                                                 ;; optional argument; need to wrap arg expression
                                                 (cons
                                                  (with-syntax ([expr (syntax/loc #'expr
                                                                        (let-syntax ([the-finder (quote-syntax the-obj)])
                                                                          (#%expression expr)))])
                                                    (syntax/loc (car vars)
                                                      (id expr)))
                                                  (loop (cdr vars)))]
                                                [_ (cons (car vars) (loop (cdr vars)))])]
                                             [else vars]))
                                         #'vars)])
                   (let ([l (syntax/loc stx 
                              (lambda (the-obj . vars) 
                                (let-syntax ([the-finder (quote-syntax the-obj)])
                                  body1 body ...)))])
                     (with-syntax ([l (recertify (add-method-property l) stx)])
                       (syntax/loc stx 
                         (let ([name l]) name))))))
               stx)]
          [(#%plain-lambda . _)
           (bad "ill-formed lambda expression for method" 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)])
                 (let ([cl (syntax/loc stx
                             (case-lambda [(the-obj . vars) 
                                           (let-syntax ([the-finder (quote-syntax the-obj)])
                                             body1 body ...)] ...))])
                   (with-syntax ([cl (recertify (add-method-property cl) stx)])
                     (syntax/loc stx
                       (let ([name cl]) name)))))
               stx)]
          [(case-lambda . _)
           (bad "ill-formed case-lambda expression for method" stx)]
          [(let- ([(id) expr] ...) let-body)
           (and (or (free-identifier=? (syntax let-) 
                                       (quote-syntax let-values))
                    (free-identifier=? (syntax let-) 
                                       (quote-syntax letrec-values)))
                (andmap identifier? (syntax->list (syntax (id ...)))))
           (let* ([letrec? (free-identifier=? (syntax let-) 
                                              (quote-syntax letrec-values))]
                  [ids (syntax->list (syntax (id ...)))]
                  [new-ids (if xform?
                               (map
                                (lambda (id)
                                  (datum->syntax
                                   #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" orig-stx))
             (with-syntax ([(proc ...) exprs]
                           [(new-id ...) new-ids]
                           [mappings
                            (if xform?
                                (map
                                 (lambda (old-id new-id)
                                   (with-syntax ([old-id old-id]
                                                 [old-id-localized (lookup-localize (localize 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-syntax old-id)
                                                      (quote-syntax old-id-localized)
                                                      (quote new-id))))))
                                 ids new-ids)
                                null)]
                           [body body])
               (recertify
                (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)))
                stx)))]
          [_else 
           (if can-expand?
               (loop (expand stx locals) #f name locals)
               (bad "bad form for method definition" orig-stx))])))
    
    (define (add-method-property l)
      (syntax-property l 'method-arity-error #t))
    
    (define method-insp (current-code-inspector))
    
    (define (recertify new old)
      (syntax-recertify new old method-insp #f))
    
    ;; --------------------------------------------------------------------------------
    ;; Start here:
    
    (define (main stx trace-flag super-expr deserialize-id-expr name-id interface-exprs defn-and-exprs)
      (let-values ([(this-id) #'this-id]
                   [(the-obj) (datum->syntax (quote-syntax here) (gensym 'self))]
                   [(the-finder) (datum->syntax (quote-syntax here) (gensym 'find-self))])
        
        (let* ([def-ctx (syntax-local-make-definition-context)]
               [localized-map (make-bound-identifier-mapping)]
               [any-localized? #f]
               [localize/set-flag (lambda (id)
                                    (let ([id2 (localize id)])
                                      (unless (eq? id id2)
                                        (set! any-localized? #t))
                                      id2))]
               [bind-local-id (lambda (id)
                                (let ([l (localize/set-flag id)])
                                  (syntax-local-bind-syntaxes (list id) #f def-ctx)
                                  (bound-identifier-mapping-put!
                                   localized-map
                                   id
                                   l)))]
               [lookup-localize (lambda (id)
                                  (bound-identifier-mapping-get
                                   localized-map
                                   id
                                   (lambda ()
                                     ;; If internal & external names are distinguished,
                                     ;; we need to fall back to localize:
                                     (localize id))))])
          
          ;; ----- Expand definitions -----
          (let ([defn-and-exprs (expand-all-forms stx defn-and-exprs def-ctx bind-local-id)]
                [bad (lambda (msg expr)
                       (raise-syntax-error #f msg stx expr))]
                [class-name (if name-id
                                (syntax-e name-id)
                                (let ([s (syntax-local-infer-name stx)])
                                  (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 augride
                                                public-final override-final augment-final
                                                pubment overment augment
                                                rename-super inherit inherit/super inherit/inner rename-inner
                                                inspect)
                          [(form orig idp ...)
                           (and (identifier? (syntax form))
                                (or (free-identifier=? (syntax form) (quote-syntax -init))
                                    (free-identifier=? (syntax form) (quote-syntax -init-field))))
                           
                           (let ([form (syntax-e (stx-car (syntax orig)))])
                             (for-each 
                              (lambda (idp)
                                (syntax-case idp ()
                                  [id (identifier? (syntax id)) 'ok]
                                  [((iid eid)) (and (identifier? (syntax iid))
                                                    (identifier? (syntax eid))) 'ok]
                                  [(id expr) (identifier? (syntax id)) 'ok]
                                  [((iid eid) expr) (and (identifier? (syntax iid))
                                                         (identifier? (syntax eid))) 'ok]
                                  [else
                                   (bad 
                                    (format
                                     "~a element is not an optionally renamed identifier or identifier-expression pair"
                                     form)
                                    idp)]))
                              (syntax->list (syntax (idp ...)))))]
                          [(inspect expr)
                           'ok]
                          [(inspect . rest)
                           (bad "ill-formed inspect clause" stx)]
                          [(-init orig . rest)
                           (bad "ill-formed init clause" #'orig)]
                          [(init-rest)
                           'ok]
                          [(init-rest rest)
                           (identifier? (syntax rest))
                           'ok]
                          [(init-rest . rest)
                           (bad "ill-formed init-rest clause" stx)]
                          [(-init-field orig . rest)
                           (bad "ill-formed init-field clause" #'orig)]
                          [(-field orig idp ...)
                           (for-each (lambda (idp)
                                       (syntax-case idp ()
                                         [(id expr) (identifier? (syntax id)) 'ok]
                                         [((iid eid) expr) (and (identifier? (syntax iid))
                                                                (identifier? (syntax eid)))
                                                           'ok]
                                         [else
                                          (bad 
                                           "field element is not an optionally renamed identifier-expression pair"
                                           idp)]))
                                     (syntax->list (syntax (idp ...))))]
                          [(-field orig . rest)
                           (bad "ill-formed field clause" #'orig)]
                          [(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 ...)
                           (and (identifier? (syntax form))
                                (ormap (lambda (f) (free-identifier=? (syntax form) f))
                                       (syntax-e (quote-syntax (public
                                                                 override
                                                                 augride
                                                                 public-final
                                                                 override-final
                                                                 augment-final
                                                                 pubment
                                                                 overment
                                                                 augment
                                                                 inherit
                                                                 inherit/super
                                                                 inherit/inner
                                                                 inherit-field)))))
                           (let ([form (syntax-e (syntax form))])
                             (for-each
                              (lambda (idp)
                                (syntax-case idp ()
                                  [id (identifier? (syntax id)) 'ok]
                                  [(iid eid) (and (identifier? (syntax iid)) (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)]
                          [(augride . rest)
                           (bad "ill-formed augride clause" stx)]
                          [(public-final . rest)
                           (bad "ill-formed public-final clause" stx)]
                          [(override-final . rest)
                           (bad "ill-formed override-final clause" stx)]
                          [(augment-final . rest)
                           (bad "ill-formed augment-final clause" stx)]
                          [(pubment . rest)
                           (bad "ill-formed pubment clause" stx)]
                          [(overment . rest)
                           (bad "ill-formed overment clause" stx)]
                          [(augment . rest)
                           (bad "ill-formed augment clause" stx)]
                          [(inherit . rest)
                           (bad "ill-formed inherit clause" stx)]
                          [(inherit/super . rest)
                           (bad "ill-formed inherit/super clause" stx)]
                          [(inherit/inner . rest)
                           (bad "ill-formed inherit/inner clause" stx)]
                          [(inherit-field . rest)
                           (bad "ill-formed inherit-field clause" stx)]
                          [(kw idp ...)
                           (and (identifier? #'kw)
                                (or (free-identifier=? #'rename-super #'kw)
                                    (free-identifier=? #'rename-inner #'kw)))
                           (for-each 
                            (lambda (idp)
                              (syntax-case idp ()
                                [(iid eid) (and (identifier? (syntax iid)) (identifier? (syntax eid))) 'ok]
                                [else
                                 (bad 
                                  (format "~a element is not a pair of identifiers" (syntax-e #'kw))
                                  idp)]))
                            (syntax->list (syntax (idp ...))))]
                          [(rename-super . rest)
                           (bad "ill-formed rename-super clause" stx)]
                          [(rename-inner . rest)
                           (bad "ill-formed rename-inner clause" stx)]
                          [_ 'ok]))
                      defn-and-exprs)
            
            ;; ----- Sort body into different categories -----
            (let*-values ([(decls exprs)
                           (extract (syntax-e (quote-syntax (inherit-field
                                                             private
                                                             public
                                                             override
                                                             augride
                                                             public-final
                                                             override-final
                                                             augment-final
                                                             pubment
                                                             overment
                                                             augment
                                                             rename-super
                                                             inherit
                                                             inherit/super
                                                             inherit/inner
                                                             rename-inner)))
                                    defn-and-exprs
                                    cons)]
                          [(inspect-decls exprs)
                           (extract (list (quote-syntax inspect))
                                    exprs
                                    cons)]
                          [(plain-inits)
                           ;; Normalize after, but keep un-normal for error reporting
                           (flatten #f (extract* (syntax-e 
                                                  (quote-syntax (-init init-rest)))
                                                 exprs))]
                          [(normal-plain-inits) (map normalize-init/field plain-inits)]
                          [(init-rest-decls _)
                           (extract (list (quote-syntax init-rest))
                                    exprs
                                    void)]
                          [(inits)
                           (flatten #f (extract* (syntax-e 
                                                  (quote-syntax (-init -init-field)))
                                                 exprs))]
                          [(normal-inits)
                           (map normalize-init/field inits)]
                          [(plain-fields)
                           (flatten #f (extract* (list (quote-syntax -field)) exprs))]
                          [(normal-plain-fields)
                           (map normalize-init/field plain-fields)]
                          [(plain-init-fields)
                           (flatten #f (extract* (list (quote-syntax -init-field)) exprs))]
                          [(normal-plain-init-fields)
                           (map normalize-init/field plain-init-fields)]
                          [(inherit-fields)
                           (flatten pair (extract* (list (quote-syntax inherit-field)) decls))]
                          [(privates)
                           (flatten pair (extract* (list (quote-syntax private)) decls))]
                          [(publics)
                           (flatten pair (extract* (list (quote-syntax public)) decls))]
                          [(overrides)
                           (flatten pair (extract* (list (quote-syntax override)) decls))]
                          [(augrides)
                           (flatten pair (extract* (list (quote-syntax augride)) decls))]
                          [(public-finals)
                           (flatten pair (extract* (list (quote-syntax public-final)) decls))]
                          [(override-finals)
                           (flatten pair (extract* (list (quote-syntax override-final)) decls))]
                          [(pubments)
                           (flatten pair (extract* (list (quote-syntax pubment)) decls))]
                          [(overments)
                           (flatten pair (extract* (list (quote-syntax overment)) decls))]
                          [(augments)
                           (flatten pair (extract* (list (quote-syntax augment)) decls))]
                          [(augment-finals)
                           (flatten pair (extract* (list (quote-syntax augment-final)) decls))]
                          [(rename-supers)
                           (flatten pair (extract* (list (quote-syntax rename-super)) decls))]
                          [(inherits)
                           (flatten pair (extract* (list (quote-syntax inherit)) decls))]
                          [(inherit/supers)
                           (flatten pair (extract* (list (quote-syntax inherit/super)) decls))]
                          [(inherit/inners)
                           (flatten pair (extract* (list (quote-syntax inherit/inner)) decls))]
                          [(rename-inners)
                           (flatten pair (extract* (list (quote-syntax rename-inner)) decls))])
              
              ;; At most one inspect:
              (unless (or (null? inspect-decls)
                          (null? (cdr inspect-decls)))
                (bad "multiple inspect clauses" (cadr inspect-decls)))
              
              ;; At most one init-rest:
              (unless (or (null? init-rest-decls)
                          (null? (cdr init-rest-decls)))
                (bad "multiple init-rest clauses" (cadr init-rest-decls)))
              
              ;; Make sure init-rest is last
              (unless (null? init-rest-decls)
                (let loop ([l exprs] [saw-rest? #f])
                  (unless (null? l)
                    (cond
                      [(and (stx-pair? (car l))
                            (identifier? (stx-car (car l))))
                       (let ([form (stx-car (car l))])
                         (cond
                           [(free-identifier=? #'init-rest form)
                            (loop (cdr l) #t)]
                           [(not saw-rest?) (loop (cdr l) #f)]
                           [(free-identifier=? #'-init form)
                            (bad "init clause follows init-rest clause" (stx-car (stx-cdr (car l))))]
                           [(free-identifier=? #'-init-field form)
                            (bad "init-field clause follows init-rest clause" (stx-car (stx-cdr (car l))))]
                           [else (loop (cdr l) #t)]))]
                      [else (loop (cdr l) saw-rest?)]))))
              
              ;; --- Check initialization on inits: ---
              (let loop ([inits inits] [normal-inits normal-inits])
                (unless (null? normal-inits)
                  (if (stx-null? (stx-cdr (car normal-inits)))
                      (loop (cdr inits)(cdr normal-inits))
                      (let loop ([inits (cdr inits)] [normal-inits (cdr normal-inits)])
                        (unless (null? inits)
                          (if (stx-null? (stx-cdr (car normal-inits)))
                              (bad "initializer without default follows an initializer with default"
                                   (car inits))
                              (loop (cdr inits) (cdr normal-inits))))))))
              
              ;; ----- Extract method definitions; check that they look like procs -----
              ;;  Optionally transform them, can expand even if not transforming.
              (let* ([field-names (map norm-init/field-iid
                                       (append normal-plain-fields normal-plain-init-fields))]
                     [inherit-field-names (map car inherit-fields)]
                     [plain-init-names (map norm-init/field-iid normal-plain-inits)]
                     [inherit-names (map car inherits)]
                     [inherit/super-names (map car inherit/supers)]
                     [inherit/inner-names (map car inherit/inners)]
                     [rename-super-names (map car rename-supers)]
                     [rename-inner-names (map car rename-inners)]
                     [local-public-dynamic-names (map car (append publics overrides augrides
                                                                  overments augments
                                                                  override-finals augment-finals))]
                     [local-public-names (append (map car (append pubments public-finals))
                                                 local-public-dynamic-names)]
                     [local-method-names (append (map car privates) local-public-names)]
                     [expand-stop-names (append
                                         local-method-names
                                         field-names
                                         inherit-field-names
                                         plain-init-names
                                         inherit-names
                                         inherit/super-names
                                         inherit/inner-names
                                         rename-super-names
                                         rename-inner-names
                                         (kernel-form-identifier-list))])
                ;; Do the extraction:
                (let-values ([(methods          ; (listof (cons id stx))
                               private-methods  ; (listof (cons id stx))
                               exprs            ; (listof stx)
                               stx-defines)     ; (listof (cons (listof id) stx))
                              (let loop ([exprs exprs][ms null][pms null][es null][sd null])
                                (if (null? exprs)
                                    (values (reverse ms) (reverse pms) (reverse es) (reverse sd))
                                    (syntax-case (car exprs) (define-values define-syntaxes)
                                      [(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/augrides?)
                                         (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 
                                                                       the-obj the-finder
                                                                       bad class-name expand-stop-names
                                                                       def-ctx lookup-localize)]
                                                     [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
                                                       sd)))
                                             ;; Non-method defn:
                                             (loop (cdr exprs) ms pms (cons (car exprs) es) sd)))]
                                      [(define-values . _)
                                       (bad "ill-formed definition" (car exprs))]
                                      [(define-syntaxes (id ...) expr)
                                       (let ([ids (syntax->list (syntax (id ...)))])
                                         (for-each (lambda (id) (unless (identifier? id)
                                                                  (bad "syntax name is not an identifier" id)))
                                                   ids)
                                         (loop (cdr exprs) ms pms es (cons (cons ids (car exprs)) sd)))]
                                      [(define-syntaxes . _)
                                       (bad "ill-formed syntax definition" (car exprs))]
                                      [_else
                                       (loop (cdr exprs) ms pms (cons (car exprs) es) sd)])))])
                  
                  ;; ---- Extract all defined names, including field accessors and mutators ---
                  (let ([defined-syntax-names (apply append (map car stx-defines))]
                        [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))])))]
                        [init-mode (cond
                                     [(null? init-rest-decls) 'normal]
                                     [(stx-null? (stx-cdr (car init-rest-decls))) 'stop]
                                     [else 'list])])
                    
                    ;; -- Look for duplicates --
                    (let ([dup (check-duplicate-identifier
                                (append defined-syntax-names
                                        defined-method-names
                                        private-field-names
                                        field-names
                                        inherit-field-names
                                        plain-init-names
                                        inherit-names
                                        inherit/super-names
                                        inherit/inner-names
                                        rename-super-names
                                        rename-inner-names))])
                      (when dup
                        (bad "duplicate declared identifier" dup)))
                    
                    ;; -- Could still have duplicates within private/public/override/augride --
                    (let ([dup (check-duplicate-identifier local-method-names)])
                      (when dup
                        (bad "duplicate declared identifier" dup)))
                    
                    ;; -- Check for duplicate external method names, init names, or field names
                    (let ([check-dup
                           (lambda (what l)
                             (let ([ht (make-hasheq)])
                               (for-each (lambda (id)
                                           (when (hash-ref ht (syntax-e id) #f)
                                             (bad (format "duplicate declared external ~a name" what) id))
                                           (hash-set! ht (syntax-e id) #t))
                                         l)))])
                      ;; method names
                      (check-dup "method" (map cdr (append publics overrides augrides
                                                           pubments overments augments
                                                           public-finals override-finals augment-finals)))
                      ;; inits
                      (check-dup "init" (map norm-init/field-eid (append normal-inits)))
                      ;; fields
                      (check-dup "field" (map norm-init/field-eid (append normal-plain-fields normal-plain-init-fields))))
                    
                    ;; -- Check that private/public/override/augride are defined --
                    (let ([ht (make-hasheq)]
                          [stx-ht (make-hasheq)])
                      (for-each
                       (lambda (defined-name)
                         (let ([l (hash-ref ht (syntax-e defined-name) null)])
                           (hash-set! ht (syntax-e defined-name) (cons defined-name l))))
                       defined-method-names)
                      (for-each
                       (lambda (defined-name)
                         (let ([l (hash-ref stx-ht (syntax-e defined-name) null)])
                           (hash-set! stx-ht (syntax-e defined-name) (cons defined-name l))))
                       defined-syntax-names)
                      (for-each
                       (lambda (pubovr-name)
                         (let ([l (hash-ref ht (syntax-e pubovr-name) null)])
                           (unless (ormap (lambda (i) (bound-identifier=? i pubovr-name)) l)
                             ;; Either undefined or defined as syntax:
                             (let ([stx-l (hash-ref stx-ht (syntax-e pubovr-name) null)])
                               (if (ormap (lambda (i) (bound-identifier=? i pubovr-name)) stx-l)
                                   (bad 
                                    "method declared but defined as syntax"
                                    pubovr-name)
                                   (bad 
                                    "method declared but not defined"
                                    pubovr-name))))))
                       local-method-names))
                    
                    ;; ---- Check that rename-inner doesn't have a non-final decl ---
                    (unless (null? rename-inners)
                      (let ([ht (make-hasheq)])
                        (for-each (lambda (pub)
                                    (hash-set! ht (syntax-e (cdr pub)) #t))
                                  (append publics public-finals overrides override-finals augrides))
                        (for-each (lambda (inn)
                                    (when (hash-ref ht (syntax-e (cdr inn)) #f)
                                      (bad
                                       "inner method is locally declared as public, override, public-final, override-final, or augride"
                                       (cdr inn))))
                                  rename-inners)))
                    
                    ;; ---- 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 orig idp ...)
                                           (and (identifier? (syntax _init))
                                                (ormap (lambda (it) 
                                                         (free-identifier=? it (syntax _init)))
                                                       (syntax-e (quote-syntax (-init
                                                                                -init-field)))))
                                           (let* ([norms (map normalize-init/field
                                                              (syntax->list (syntax (idp ...))))]
                                                  [iids (map norm-init/field-iid norms)]
                                                  [exids (map norm-init/field-eid norms)])
                                             (with-syntax ([(id ...) iids]
                                                           [(idpos ...) (map localize/set-flag exids)]
                                                           [(defval ...) 
                                                            (map (lambda (norm)
                                                                   (if (stx-null? (stx-cdr norm))
                                                                       (syntax #f)
                                                                       (with-syntax ([defexp (stx-car (stx-cdr norm))])
                                                                         (syntax (lambda () defexp)))))
                                                                 norms)]
                                                           [class-name class-name])
                                               (syntax/loc e 
                                                 (begin 
                                                   1 ; to ensure a non-empty body
                                                   (set! id (extract-arg 'class-name `idpos init-args defval))
                                                   ...))))]
                                          [(-field orig idp ...)
                                           (with-syntax ([(((iid eid) expr) ...)
                                                          (map normalize-init/field (syntax->list #'(idp ...)))])
                                             (syntax/loc e (begin 
                                                             1 ; to ensure a non-empty body
                                                             (set! iid expr)
                                                             ...)))]
                                          [(init-rest id/rename)
                                           (with-syntax ([n (+ (length plain-inits)
                                                               (length plain-init-fields)
                                                               -1)]
                                                         [id (if (identifier? #'id/rename)
                                                                 #'id/rename
                                                                 (stx-car #'id/rename))])
                                             (syntax/loc e (set! id (extract-rest-args n init-args))))]
                                          [(init-rest)
                                           (syntax (void))]
                                          [_else e]))
                                      exprs)]
                          [mk-method-temp
                           (lambda (id-stx)
                             (datum->syntax (quote-syntax here)
                                            (gensym (syntax-e id-stx))))]
                          [rename-super-extras (append overments overrides override-finals inherit/supers)]
                          [rename-inner-extras (append pubments overments augments inherit/inners)]
                          [all-rename-inners (append (map car rename-inners)
                                                     (generate-temporaries (map car pubments))
                                                     (generate-temporaries (map car overments))
                                                     (generate-temporaries (map car augments))
                                                     (generate-temporaries (map car inherit/inners)))]
                          [all-inherits (append inherits inherit/supers inherit/inners)]
                          [definify (lambda (l)
                                      (map bind-local-id l)
                                      l)])
                      
                      ;; ---- set up field and method mappings ----
                      (with-syntax ([(rename-super-orig ...) (definify (map car rename-supers))]
                                    [(rename-super-orig-localized ...) (map lookup-localize (map car rename-supers))]
                                    [(rename-super-extra-orig ...) (map car rename-super-extras)]
                                    [(rename-super-temp ...) (definify (generate-temporaries (map car rename-supers)))]
                                    [(rename-super-extra-temp ...) (generate-temporaries (map car rename-super-extras))]
                                    [(rename-inner-orig ...) (definify (map car rename-inners))]
                                    [(rename-inner-orig-localized ...) (map lookup-localize (map car rename-inners))]
                                    [(rename-inner-extra-orig ...) (map car rename-inner-extras)]
                                    [(rename-inner-temp ...) (generate-temporaries (map car rename-inners))]
                                    [(rename-inner-extra-temp ...) (generate-temporaries (map car rename-inner-extras))]
                                    [(private-name ...) (map car privates)]
                                    [(private-name-localized ...) (map lookup-localize (map car privates))]
                                    [(private-temp ...) (map mk-method-temp (map car privates))]
                                    [(pubment-name ...) (map car pubments)]
                                    [(pubment-name-localized ...) (map lookup-localize (map car pubments))]
                                    [(pubment-temp ...) (map
                                                         mk-method-temp
                                                         (map car pubments))]
                                    [(public-final-name ...) (map car public-finals)]
                                    [(public-final-name-localized ...) (map lookup-localize (map car public-finals))]
                                    [(public-final-temp ...) (map
                                                              mk-method-temp
                                                              (map car public-finals))]
                                    [(method-name ...) (append local-public-dynamic-names
                                                               (map car all-inherits))]
                                    [(method-name-localized ...) (map lookup-localize
                                                                      (append local-public-dynamic-names
                                                                              (map car all-inherits)))]
                                    [(method-accessor ...) (generate-temporaries
                                                            (map car
                                                                 (append publics overrides augrides
                                                                         overments augments
                                                                         override-finals augment-finals
                                                                         all-inherits)))]
                                    [(inherit-field-accessor ...) (generate-temporaries
                                                                   (map (lambda (id)
                                                                          (format "get-~a"
                                                                                  (syntax-e id)))
                                                                        inherit-field-names))]
                                    [(inherit-field-mutator ...) (generate-temporaries
                                                                  (map (lambda (id)
                                                                         (format "set-~a!"
                                                                                 (syntax-e id)))
                                                                       inherit-field-names))]
                                    [(inherit-name ...) (definify (map car all-inherits))]
                                    [(inherit-field-name ...) (definify inherit-field-names)]
                                    [(inherit-field-name-localized ...) (map lookup-localize inherit-field-names)]
                                    [(local-field ...) (definify
                                                         (append field-names
                                                                 private-field-names))]
                                    [(local-field-localized ...) (map lookup-localize
                                                                      (append field-names
                                                                              private-field-names))]
                                    [(local-field-pos ...) (let loop ([pos 0][l (append field-names
                                                                                        private-field-names)])
                                                             (if (null? l)
                                                                 null
                                                                 (cons pos (loop (add1 pos) (cdr l)))))]
                                    [(local-field-accessor ...) (generate-temporaries (append field-names private-field-names))]
                                    [(local-field-mutator ...) (generate-temporaries (append field-names private-field-names))]
                                    [(plain-init-name ...) (definify plain-init-names)]
                                    [(plain-init-name-localized ...) (map lookup-localize plain-init-names)]
                                    [(local-plain-init-name ...) (generate-temporaries plain-init-names)])
                        (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]
                                             [trace-flag (if trace-flag (syntax #t) (syntax #f))])
                                 (syntax 
                                  ([(inherit-field-name ...
                                     local-field ...
                                     rename-super-orig ...
                                     rename-inner-orig ...
                                     method-name ...
                                     private-name ...
                                     public-final-name ...
                                     pubment-name ...)
                                    (values
                                     (make-field-map trace-flag
                                                     (quote-syntax the-finder)
                                                     (quote the-obj)
                                                     (quote-syntax inherit-field-name)
                                                     (quote-syntax inherit-field-name-localized)
                                                     (quote-syntax inherit-field-accessor)
                                                     (quote-syntax inherit-field-mutator)
                                                     '())
                                     ...
                                     (make-field-map trace-flag
                                                     (quote-syntax the-finder)
                                                     (quote the-obj)
                                                     (quote-syntax local-field)
                                                     (quote-syntax local-field-localized)
                                                     (quote-syntax local-field-accessor)
                                                     (quote-syntax local-field-mutator)
                                                     '())
                                     ...
                                     (make-rename-super-map (quote-syntax the-finder)
                                                            (quote the-obj)
                                                            (quote-syntax rename-super-orig)
                                                            (quote-syntax rename-super-orig-localized)
                                                            (quote-syntax rename-super-temp))
                                     ...
                                     (make-rename-inner-map (quote-syntax the-finder)
                                                            (quote the-obj)
                                                            (quote-syntax rename-inner-orig)
                                                            (quote-syntax rename-inner-orig-localized)
                                                            (quote-syntax rename-inner-temp))
                                     ...
                                     (make-method-map (quote-syntax the-finder)
                                                      (quote the-obj)
                                                      (quote-syntax method-name)
                                                      (quote-syntax method-name-localized)
                                                      (quote-syntax method-accessor))
                                     ...
                                     (make-direct-method-map (quote-syntax the-finder)
                                                             (quote the-obj)
                                                             (quote-syntax private-name)
                                                             (quote-syntax private-name-localized)
                                                             (quote private-temp))
                                     ...
                                     (make-direct-method-map (quote-syntax the-finder)
                                                             (quote the-obj)
                                                             (quote-syntax public-final-name)
                                                             (quote-syntax public-final-name-localized)
                                                             (quote public-final-temp))
                                     ...
                                     (make-direct-method-map (quote-syntax the-finder)
                                                             (quote the-obj)
                                                             (quote-syntax pubment-name)
                                                             (quote-syntax pubment-name-localized)
                                                             (quote pubment-temp))
                                     ...)])))]
                              [extra-init-mappings (syntax 
                                                    ([(plain-init-name ...)
                                                      (values
                                                       (make-init-error-map (quote-syntax plain-init-name-localized))
                                                       ...)]))])
                          
                          (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 
                                                                             the-obj the-finder
                                                                             bad class-name expand-stop-names
                                                                             def-ctx lookup-localize)]
                                                           [extra-init-mappings extra-init-mappings])
                                               (syntax
                                                (syntax-parameterize 
                                                 ([super-instantiate-param super-error-map]
                                                  [super-make-object-param super-error-map]
                                                  [super-new-param super-error-map])
                                                 (letrec-syntaxes+values extra-init-mappings ()
                                                   proc))))))
                                      methods)))]
                                [lookup-localize-cdr (lambda (p) (lookup-localize (cdr p)))])
                            
                            (internal-definition-context-seal def-ctx)
                            
                            ;; ---- build final result ----
                            (with-syntax ([public-names (map lookup-localize-cdr publics)]
                                          [public-final-names (map lookup-localize-cdr public-finals)]
                                          [override-names (map lookup-localize-cdr overrides)]
                                          [override-final-names (map lookup-localize-cdr override-finals)]
                                          [augride-names (map lookup-localize-cdr augrides)]
                                          [pubment-names (map lookup-localize-cdr pubments)]
                                          [overment-names (map lookup-localize-cdr overments)]
                                          [augment-names (map lookup-localize-cdr augments)]
                                          [augment-final-names (map lookup-localize-cdr augment-finals)]
                                          [(rename-super-name ...) (map lookup-localize-cdr rename-supers)]
                                          [(rename-super-extra-name ...) (map lookup-localize-cdr rename-super-extras)]
                                          [(rename-inner-name ...) (map lookup-localize-cdr rename-inners)]
                                          [(rename-inner-extra-name ...) (map lookup-localize-cdr rename-inner-extras)]
                                          [inherit-names (map lookup-localize-cdr all-inherits)]
                                          [num-fields (datum->syntax
                                                       (quote-syntax here)
                                                       (+ (length private-field-names)
                                                          (length plain-init-fields)
                                                          (length plain-fields)))]
                                          [field-names (map (lambda (norm)
                                                              (lookup-localize (norm-init/field-eid norm)))
                                                            (append
                                                             normal-plain-fields
                                                             normal-plain-init-fields))]
                                          [inherit-field-names (map lookup-localize (map cdr inherit-fields))]
                                          [init-names (map (lambda (norm)
                                                             (lookup-localize
                                                              (norm-init/field-eid norm)))
                                                           normal-inits)]
                                          [init-mode init-mode]
                                          [(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 (append overments
                                                                                                        override-finals
                                                                                                        overrides)))]
                                          [augride-methods (map (find-method methods) (map car (append augments
                                                                                                       augment-finals
                                                                                                       augrides)))]
                                          [(pubment-method ...) (map (find-method methods) (map car pubments))]
                                          [(public-final-method ...) (map (find-method methods) (map car public-finals))]
                                          [mappings mappings]
                                          
                                          [exprs exprs]
                                          [the-obj the-obj]
                                          [the-finder the-finder]
                                          [name class-name]
                                          [(stx-def ...) (map cdr stx-defines)]
                                          [super-expression super-expr]
                                          [(interface-expression ...) interface-exprs]
                                          [inspector (if (pair? inspect-decls)
                                                         (stx-car (stx-cdr (car inspect-decls)))
                                                         #'(current-inspector))]
                                          [deserialize-id-expr deserialize-id-expr])
                              
                              (quasisyntax/loc stx
                                (let ([superclass super-expression]
                                      [interfaces (list interface-expression ...)])
                                  (compose-class 
                                   'name superclass interfaces inspector deserialize-id-expr #,any-localized?
                                   ;; Field count:
                                   num-fields
                                   ;; Field names:
                                   `field-names
                                   `inherit-field-names
                                   ;; Method names:
                                   `(rename-super-name ... rename-super-extra-name ...)
                                   `(rename-inner-name ... rename-inner-extra-name ...)
                                   `pubment-names
                                   `public-final-names
                                   `public-names
                                   `overment-names
                                   `override-final-names
                                   `override-names
                                   `augment-names
                                   `augment-final-names
                                   `augride-names
                                   `inherit-names
                                   ;; Init arg names (in order)
                                   `init-names
                                   (quote init-mode)
                                   ;; Methods (when given needed super-methods, etc.):
                                   #, ;; Attach srcloc (useful for profiling)
                                   (quasisyntax/loc stx
                                     (lambda (local-accessor
                                              local-mutator
                                              inherit-field-accessor ...  ; inherit
                                              inherit-field-mutator ...
                                              rename-super-temp ... rename-super-extra-temp ...
                                              rename-inner-temp ... rename-inner-extra-temp ...
                                              method-accessor ...) ; for a local call that needs a dynamic lookup
                                       (let ([local-field-accessor (make-struct-field-accessor local-accessor local-field-pos #f)]
                                             ...
                                             [local-field-mutator (make-struct-field-mutator local-mutator local-field-pos #f)]
                                             ...)
                                         (syntax-parameterize
                                          ([this-param (make-this-map (quote-syntax this-id)
                                                                      (quote-syntax the-finder)
                                                                      (quote the-obj))])
                                          (let-syntaxes
                                           mappings
                                           (syntax-parameterize 
                                            ([super-param
                                              (lambda (stx)
                                                (syntax-case stx (rename-super-extra-orig ...)
                                                  [(_ rename-super-extra-orig . args) 
                                                   (generate-super-call 
                                                    stx
                                                    (quote-syntax the-finder)
                                                    (quote the-obj)
                                                    (quote-syntax rename-super-extra-temp)
                                                    (syntax args))]
                                                  ...
                                                  [(_ id . args)
                                                   (identifier? #'id)
                                                   (raise-syntax-error
                                                    #f
                                                    (string-append
                                                     "identifier for super call does not have an override, "
                                                     "override-final, overment, or inherit/super declaration")
                                                    stx
                                                    #'id)]
                                                  [_else
                                                   (raise-syntax-error
                                                    #f
                                                    "expected an identifier after the keyword"
                                                    stx)]))]
                                             [inner-param
                                              (lambda (stx)
                                                (syntax-case stx (rename-inner-extra-orig ...)
                                                  [(_ default-expr rename-inner-extra-orig . args)
                                                   (generate-inner-call 
                                                    stx
                                                    (quote-syntax the-finder)
                                                    (quote the-obj)
                                                    (syntax default-expr)
                                                    (quote-syntax rename-inner-extra-temp)
                                                    (syntax args))]
                                                  ...
                                                  [(_ default-expr id . args)
                                                   (identifier? #'id)
                                                   (raise-syntax-error
                                                    #f
                                                    (string-append
                                                     "identifier for inner call does not have a pubment, augment, "
                                                     "overment, or inherit/inner declaration")
                                                    stx
                                                    #'id)]
                                                  [(_)
                                                   (raise-syntax-error
                                                    #f
                                                    "expected a default-value expression after the keyword"
                                                    stx
                                                    #'id)]
                                                  [_else
                                                   (raise-syntax-error
                                                    #f
                                                    "expected an identifier after the keyword and default-value expression"
                                                    stx)]))])
                                            stx-def ...
                                            (letrec ([private-temp private-method]
                                                     ...
                                                     [pubment-temp pubment-method]
                                                     ...
                                                     [public-final-temp public-final-method]
                                                     ...)
                                              (values
                                               (list pubment-temp ... public-final-temp ... . public-methods)
                                               (list . override-methods)
                                               (list . augride-methods)
                                               ;; Initialization
                                               #, ;; Attach srcloc (useful for profiling)
                                               (quasisyntax/loc stx
                                                 (lambda (the-obj super-go si_c si_inited? si_leftovers init-args)
                                                   (let-syntax ([the-finder (quote-syntax the-obj)])
                                                     (syntax-parameterize
                                                      ([super-instantiate-param
                                                        (lambda (stx)
                                                          (syntax-case stx () 
                                                            [(_ (arg (... ...)) (kw kwarg) (... ...))
                                                             (with-syntax ([stx stx])
                                                               (syntax (-instantiate super-go stx (the-obj si_c si_inited? 
                                                                                                           si_leftovers)
                                                                                     (list arg (... ...)) 
                                                                                     (kw kwarg) (... ...))))]))]
                                                       [super-new-param
                                                        (lambda (stx)
                                                          (syntax-case stx () 
                                                            [(_ (kw kwarg) (... ...))
                                                             (with-syntax ([stx stx])
                                                               (syntax (-instantiate super-go stx (the-obj si_c si_inited? 
                                                                                                           si_leftovers)
                                                                                     null
                                                                                     (kw kwarg) (... ...))))]))]
                                                       [super-make-object-param
                                                        (lambda (stx)
                                                          (let ([code 
                                                                 (quote-syntax
                                                                  (lambda args
                                                                    (super-go the-obj si_c si_inited? si_leftovers args null)))])
                                                            (if (identifier? stx)
                                                                code
                                                                (datum->syntax
                                                                 code
                                                                 (cons code
                                                                       (cdr (syntax-e stx)))))))])
                                                      (letrec-syntaxes+values
                                                          ([(plain-init-name) (make-init-redirect 
                                                                               (quote-syntax set!)
                                                                               (quote-syntax #%plain-app)
                                                                               (quote-syntax local-plain-init-name)
                                                                               (quote-syntax plain-init-name-localized))] ...)
                                                        ([(local-plain-init-name) undefined] ...)
                                                        (void) ; in case the body is empty
                                                        . exprs)))))))))))))
                                   ;; Not primitive:
                                   #f))))))))))))))))
    
    (define (core-class* trace-flag)
      (lambda (stx)
        (syntax-case stx ()
          [(_  super-expression (interface-expr ...)
               defn-or-expr
               ...)
           (main stx trace-flag
                 #'super-expression 
                 #f #f
                 (syntax->list #'(interface-expr ...))
                 (syntax->list #'(defn-or-expr ...)))])))
    
    (define (core-class trace-flag)
      (lambda (stx)
        (syntax-case stx ()
          [(_ super-expression
              defn-or-expr
              ...)
           (main stx trace-flag
                 #'super-expression 
                 #f #f
                 null
                 (syntax->list #'(defn-or-expr ...)))])))
    
    (define (core-class/derived trace-flag)
      (lambda (stx)
        (syntax-case stx ()
          [(_  orig-stx
               [name-id super-expression (interface-expr ...) deserialize-id-expr]
               defn-or-expr
               ...)
           (main #'orig-stx trace-flag
                 #'super-expression 
                 #'deserialize-id-expr 
                 (and (syntax-e #'name-id) #'name-id)
                 (syntax->list #'(interface-expr ...))
                 (syntax->list #'(defn-or-expr ...)))])))
    
    ;; The class* and class entry points:
    (values
     ;; class*
     (core-class* #f)
     ;; class
     (core-class #f)
     ;; class/derived
     (core-class/derived #f)
     ;; class*-traced
     (core-class* #t)
     ;; class-traced
     (core-class #t)
     ;; class/derived-traced
     (core-class/derived #t)
     )))

(define-syntax (-define-serializable-class stx)
  (syntax-case stx ()
    [(_ orig-stx name super-expression (interface-expr ...)
        defn-or-expr ...)
     (let ([deserialize-name-info (datum->syntax
                                   #'name
                                   (string->symbol
                                    (format "deserialize-info:~a" (syntax-e #'name)))
                                   #'name)])
       (unless (memq (syntax-local-context) '(top-level module))
         (raise-syntax-error
          #f
          "allowed only at the top level or within a module top level"
          #'orig-stx))
       (with-syntax ([deserialize-name-info deserialize-name-info]
                     [(provision ...) (if (eq? (syntax-local-context) 'module)
                                          #`((provide #,deserialize-name-info))
                                          #'())])
         #'(begin
             (define-values (name deserialize-name-info)
               (class/derived orig-stx [name
                                        super-expression 
                                        (interface-expr ...)
                                        #'deserialize-name-info]
                              defn-or-expr ...))
             provision ...)))]))

(define-syntax (define-serializable-class* stx)
  (syntax-case stx ()
    [(_ name super-expression (interface-expr ...)
        defn-or-expr ...)
     (with-syntax ([orig-stx stx])
       #'(-define-serializable-class orig-stx
                                     name
                                     super-expression
                                     (interface-expr ...)
                                     defn-or-expr ...))]))

(define-syntax (define-serializable-class stx)
  (syntax-case stx ()
    [(_ name super-expression
        defn-or-expr ...)
     (with-syntax ([orig-stx stx])
       #'(-define-serializable-class orig-stx
                                     name
                                     super-expression
                                     ()
                                     defn-or-expr ...))]))


(define-syntaxes (private* public* pubment* override* overment* augride* augment*
                           public-final* override-final* augment-final*)
  (let ([mk
         (lambda (who decl-form)
           (lambda (stx)
             (unless (class-top-level-context? (syntax-local-context))
               (raise-syntax-error
                #f
                "use of a class keyword is not in a class top-level"
                stx))
             (syntax-case stx ()
               [(_ binding ...)
                (let ([bindings (syntax->list (syntax (binding ...)))])
                  (let ([name-exprs
                         (map (lambda (binding)
                                (syntax-case binding ()
                                  [(name expr)
                                   (identifier? (syntax name))
                                   (cons (syntax name) (syntax expr))]
                                  [_else
                                   (identifier? (syntax name))
                                   (raise-syntax-error
                                    #f
                                    "expected an identifier and expression"
                                    stx
                                    binding)]))
                              bindings)])
                    (with-syntax ([(name ...) (map car name-exprs)]
                                  [(expr ...) (map cdr name-exprs)]
                                  [decl-form decl-form])
                      (syntax
                       (begin
                         (decl-form name ...)
                         (define name expr)
                         ...)))))])))])
    (values
     (mk 'private* (syntax private))
     (mk 'public* (syntax public))
     (mk 'pubment* (syntax pubment))
     (mk 'override* (syntax override))
     (mk 'overment* (syntax overment))
     (mk 'augride* (syntax augride))
     (mk 'augment* (syntax augment))
     (mk 'public-final* (syntax public-final))
     (mk 'override-final* (syntax override-final))
     (mk 'augment-final* (syntax augment)))))

(define-syntaxes (define/private define/public define/pubment 
                   define/override define/overment
                   define/augride define/augment
                   define/public-final define/override-final define/augment-final)
  (let ([mk
         (lambda (decl-form)
           (lambda (stx)
             (unless (class-top-level-context? (syntax-local-context))
               (raise-syntax-error
                #f
                "use of a class keyword is not in a class top-level"
                stx))
             (let-values ([(id rhs) (normalize-definition stx #'lambda #f #t)])
               (quasisyntax/loc stx
                 (begin
                   (#,decl-form #,id)
                   (define #,id #,rhs))))))])
    (values
     (mk #'private)
     (mk #'public)
     (mk #'pubment)
     (mk #'override)
     (mk #'overment)
     (mk #'augride)
     (mk #'augment)
     (mk #'public-final)
     (mk #'override-final)
     (mk #'augment-final))))

(define-syntax (define-local-member-name stx)
  (syntax-case stx ()
    [(_ id ...)
     (let ([ids (syntax->list (syntax (id ...)))])
       (for-each (lambda (id)
                   (unless (identifier? id)
                     (raise-syntax-error
                      #f
                      "expected an identifier"
                      stx
                      id)))
                 ids)
       (let ([dup (check-duplicate-identifier ids)])
         (when dup
           (raise-syntax-error
            #f
            "duplicate identifier"
            stx
            dup)))
       (if (eq? (syntax-local-context) 'top-level)
           ;; Does nothing in particular at the top level:
           (syntax/loc stx (define-syntaxes (id ...) (values 'id ...)))
           ;; Map names to private indicators, which are made private
           ;;  simply by introduction:
           (with-syntax ([(gen-id ...) (generate-temporaries ids)])
             (with-syntax ([stx-defs
                            ;; Need to attach srcloc to this definition:
                            (syntax/loc stx
                              (define-syntaxes (id ...)
                                (values (make-private-name (quote-syntax id) (quote-syntax gen-id))
                                        ...)))])
               (syntax/loc stx
                 (begin
                   (define-values (gen-id ...)
                     (values (generate-local-member-name 'id) ...))
                   stx-defs))))))]))

(define-syntax (define-member-name stx)
  (syntax-case stx ()
    [(_ id expr)
     (let ([name #'id])
       (unless (identifier? name)
         (raise-syntax-error
          #f
          "expected an identifier for definition"
          stx
          name))
       (with-syntax ([stx-def
                      ;; Need to attach srcloc to this definition:
                      (syntax/loc stx
                        (define-syntax id
                          (make-private-name (quote-syntax id) 
                                             ((syntax-local-certifier) (quote-syntax member-name)))))])
         #'(begin
             (define member-name (check-member-key 'id expr))
             stx-def)))]))

(define (generate-local-member-name id)
  (string->uninterned-symbol
   (symbol->string id)))


(define-values (struct:member-key make-member-key member-name-key? member-key-ref member-key-set!)
  (make-struct-type 'member-name-key
                    #f
                    1 0 #f
                    (list
                     (cons prop:custom-write 
                           (lambda (v p write?)
                             (fprintf p "#<member-key:~a>" (member-key-id v)))))))

(define member-key-id (make-struct-field-accessor member-key-ref 0))

(define (check-member-key id v)
  (unless (member-name-key? v)
    (error 'define-local-member-name "not a member key for ~a: ~e" id v))
  (member-key-id v))

(define-syntax (member-name-key stx)
  (syntax-case stx ()
    [(_ id)
     (identifier? #'id)
     (with-syntax ([id (localize #'id)])
       (syntax/loc stx (make-member-key `id)))]
    [(_ x)
     (raise-syntax-error
      #f
      "not an identifier"
      stx
      #'x)]))

(define (generate-member-key)
  (make-member-key (generate-local-member-name (gensym 'member))))

(define (member-name-key=? a b)
  (if (and (member-name-key? a)
           (member-name-key? b))
      (eq? (member-key-id a) (member-key-id b))
      (eq? a b)))

(define (member-name-key-hash-code a)
  (unless (member-name-key? a)
    (raise-type-error
     'member-name-key-hash-code
     "member name key"
     a))
  (eq-hash-code (member-key-id a)))

;;--------------------------------------------------------------------
;;  class implementation
;;--------------------------------------------------------------------

(define-struct class (name
                      pos supers     ; pos is subclass depth, supers is vector
                      self-interface ; self interface
                      insp-mk        ; dummy struct maker to control inspection access
                      
                      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
                      beta-methods   ; vector of vector of methods
                      meth-flags     ; vector: #f => primitive-implemented
                      ;         'final => final
                      ;         'augmentable => can augment
                      
                      field-width    ; total number of fields
                      field-ht       ; maps public field names to (cons class pos)
                      field-ids      ; list of public field names
                      
                      [struct:object ; structure type for instances
                       #:mutable]
                      [object?       ; predicate
                       #:mutable]
                      [make-object   ; : (-> object), constructor that creates an uninitialized object
                          #:mutable]
                      [field-ref     ; accessor
                       #:mutable]
                      [field-set!    ; mutator
                       #:mutable]
                      
                      init-args      ; list of symbols in order; #f => only by position
                      init-mode      ; 'normal, 'stop (don't accept by-pos for super), or 'list
                      
                      [init          ; initializer
                       #:mutable]    ; :   object
                      ;     (object class (box boolean) leftover-args new-by-pos-args new-named-args 
                      ;      -> void) // always continue-make-super?
                      ;     class
                      ;     (box boolean)
                      ;     leftover-args
                      ;     named-args
                      ;  -> void
                      
                      [serializer    ; proc => serializer, #f => not serializable
                       #:mutable]
                      [fixup         ; for deserialization
                       #:mutable]
                      
                      no-super-init?); #t => no super-init needed
  #:inspector insp)

;; compose-class: produces one result if `deserialize-id' is #f, two
;;                results if `deserialize-id' is not #f
(define (compose-class name                ; symbol
                       super               ; class
                       interfaces          ; list of interfaces
                       inspector           ; inspector or #f
                       deserialize-id      ; identifier or #f
                       any-localized?      ; #t => need to double-check distinct external names
                       
                       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-super-names  ; list of symbols
                       rename-inner-names
                       pubment-names
                       public-final-names
                       public-normal-names
                       overment-names
                       override-final-names
                       override-normal-names
                       augment-names
                       augment-final-names
                       augride-normal-names
                       inherit-names
                       
                       init-args           ; list of symbols in order, or #f
                       init-mode           ; 'normal, 'stop, or 'list
                       
                       make-methods        ; takes field and method accessors
                       make-struct:prim)   ; see "primitive classes", below
  
  ;; -- Check superclass --
  (unless (class? super)
    (obj-error 'class* "superclass expression ~e returned a non-class: ~a" 
               super
               (for-class name)))
  
  (when any-localized?
    (check-still-unique name
                        init-args
                        "initialization argument names")
    ;; We intentionally leave inherited names out of the lists below,
    ;;  on the threory that it's ok to decide to inherit from
    ;;  yourself:
    (check-still-unique name
                        (append public-field-names)
                        "field names")
    (check-still-unique name
                        (append pubment-names public-final-names public-normal-names
                                overment-names override-final-names override-normal-names
                                augment-names augment-final-names augride-normal-names)
                        "method names"))
  
  ;; -- 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 pubment-names public-final-names public-normal-names)]
         [override-names (append overment-names override-final-names override-normal-names)]
         [augride-names (append augment-names augment-final-names augride-normal-names)]
         [final-names (append public-final-names override-final-names augment-final-names)]
         [augonly-names (append pubment-names overment-names augment-names)]
         ;; Mis utilities
         [no-new-methods? (null? public-names)]
         [no-method-changes? (and (null? public-names)
                                  (null? override-names)
                                  (null? augride-names)
                                  (null? final-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* "interface expression returned a non-interface: ~a~a" 
                    intf
                    (for-class name))))
     interfaces)
    
    ;; -- Check inspectors ---
    (when inspector
      (unless (inspector? inspector)
        (obj-error 'class* "inspect class result is not an inspector or #f: ~a~a" 
                   inspector
                   (for-class name))))
    
    ;; -- Match method and field names to indices --
    (let ([method-ht (if no-new-methods?
                         (class-method-ht super)
                         (make-hasheq))]
          [field-ht (if no-new-fields?
                        (class-field-ht super)
                        (make-hasheq))]
          [super-method-ht (class-method-ht super)]
          [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-set! method-ht (car ids) p)
            (loop (cdr ids) (sub1 p)))))
      (unless no-new-fields?
        (let loop ([ids super-field-ids])
          (unless (null? ids)
            (hash-set! field-ht (car ids) (hash-ref 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-ref method-ht (car ids) #f)
              (obj-error 'class* "superclass ~e already contains method: ~a~a" 
                         super
                         (car ids)
                         (for-class name)))
            (hash-set! 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-ref field-ht (car ids) #f)
              (obj-error 'class* "superclass ~e already contains field: ~a~a" 
                         super
                         (car ids)
                         (for-class name)))
            (hash-set! field-ht (car ids) p)
            (loop (cdr ids) (add1 p)))))
      
      ;; Check that superclass has expected fields
      (for-each (lambda (id)
                  (unless (hash-ref field-ht id #f)
                    (obj-error 'class* "superclass ~e does not provide field: ~a~a" 
                               super
                               id
                               (for-class name))))
                inherit-field-names)
      
      ;; Check that superclass has expected methods, and get indices
      (let ([get-indices
             (lambda (method-ht what ids)
               (map
                (lambda (id)
                  (hash-ref 
                   method-ht id
                   (lambda ()
                     (obj-error 'class* 
                                "~a does not provide an expected method for ~a: ~a~a" 
                                (if (eq? method-ht super-method-ht) "superclass" "class")
                                what
                                id
                                (for-class name)))))
                ids))]
            [method-width (+ (class-method-width super) (length public-names))]
            [field-width (+ (class-field-width super) num-fields)])
        (let ([inherit-indices (get-indices super-method-ht "inherit" inherit-names)]
              [replace-augonly-indices (get-indices super-method-ht "overment" overment-names)]
              [replace-final-indices (get-indices super-method-ht "override-final" override-final-names)]
              [replace-normal-indices (get-indices super-method-ht "override" override-normal-names)]
              [refine-augonly-indices (get-indices super-method-ht "augment" augment-names)]
              [refine-final-indices (get-indices super-method-ht "augment-final" augment-final-names)]
              [refine-normal-indices (get-indices super-method-ht "augride" augride-normal-names)]
              [rename-super-indices (get-indices super-method-ht "rename-super" rename-super-names)]
              [rename-inner-indices (get-indices method-ht "rename-inner" rename-inner-names)]
              [new-augonly-indices (get-indices method-ht "pubment" pubment-names)]
              [new-final-indices (get-indices method-ht "public-final" public-final-names)]
              [new-normal-indices (get-indices method-ht "public" public-normal-names)])
          
          ;; -- Check that all interfaces are satisfied --
          (for-each
           (lambda (intf)
             (for-each
              (lambda (var)
                (unless (hash-ref method-ht var #f)
                  (obj-error 'class* 
                             "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* (for-class name))])
            (when (and c (not (subclass? super c)))
              (obj-error 'class* 
                         "interface-required implementation not satisfied~a~a"
                         (for-class name)
                         (let ([r (class-name c)])
                           (if r
                               (format " required class: ~a" r)
                               "")))))
          
          ;; -- For serialization, check that the superclass is compatible --
          (when deserialize-id
            (unless (class-serializer super)
              (obj-error 'class*
                         "superclass is not serialiazable, not transparent, and does not implement externalizable<%>: ~e~a"
                         super
                         (for-class name))))
          
          ;; ---- 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-self-interface super) interfaces)]
                 [i (interface-make name super-interfaces #f method-names #f null)]
                 [methods (if no-method-changes?
                              (class-methods super)
                              (make-vector method-width))]
                 [beta-methods (if no-method-changes?
                                   (class-beta-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
                                (let-values ([(struct: make- ? -ref -set) (make-struct-type 'insp #f 0 0 #f null inspector)])
                                  make-)
                                method-width method-ht method-names
                                methods beta-methods meth-flags
                                field-width field-ht field-names
                                'struct:object 'object? 'make-object 'field-ref 'field-set!
                                init-args
                                init-mode
                                'init
                                #f #f ; serializer is set later
                                (and make-struct:prim #t))]
                 [obj-name (if name
                               (string->symbol (format "object:~a" name))
                               'object)]
                 ;; Used only for prim classes
                 [preparer (lambda (name)
                             ;; Map symbol to number:
                             (hash-ref method-ht name))]
                 [dispatcher (lambda (obj n)
                               ;; Extract method:
                               (vector-ref (class-methods (object-ref obj)) n))])
            
            (setup-all-implemented! i)
            (vector-set! (class-supers c) (add1 (class-pos super)) c)
            
            ;; --- Make the new object struct ---
            (let*-values ([(prim-object-make prim-object? struct:prim-object)
                           (if make-struct:prim
                               (make-struct:prim c prop:object preparer dispatcher (get-properties interfaces))
                               (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 prim-object-make prim-object? #f #f)
                               ;; Normal struct creation:
                               (make-struct-type obj-name
                                                 (add-properties (class-struct:object super) interfaces)
                                                 0 ;; No init fields
                                                 ;; Fields for new slots:
                                                 num-fields undefined
                                                 ;; Map object property to class:
                                                 (append
                                                  (list (cons prop:object c))
                                                  (if deserialize-id
                                                      (list
                                                       (cons prop:serializable
                                                             ;; Serialization:
                                                             (make-serialize-info
                                                              (lambda (obj) 
                                                                ((class-serializer c) obj))
                                                              deserialize-id
                                                              (and (not inspector)
                                                                   (not (interface-extension? i externalizable<%>))
                                                                   (eq? #t (class-serializer super)))
                                                              (or (current-load-relative-directory) 
                                                                  (current-directory)))))
                                                      null))
                                                 inspector))])
              (set-class-struct:object! c struct:object)
              (set-class-object?! c object?)
              (set-class-make-object! c object-make)
              (unless (zero? num-fields)
                ;; We need these only if there are fields, used for for public-field
                ;; access or for inspection:
                (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 ([(inh-accessors inh-mutators)
                            (values
                             (map (lambda (id) (make-class-field-accessor super id #f))
                                  inherit-field-names)
                             (map (lambda (id) (make-class-field-mutator super id #f))
                                  inherit-field-names))])
                ;; -- 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-set! field-ht (car ids) (cons c pos))
                    (loop (cdr ids) (add1 pos))))
                
                ;; -- Extract superclass methods and make rename-inners ---
                (let ([rename-supers (map (lambda (index mname)
                                            (let ([vec (vector-ref (class-beta-methods super) index)])
                                              (if (positive? (vector-length vec))
                                                  (or (vector-ref vec (sub1 (vector-length vec)))
                                                      (obj-error 'class* 
                                                                 (string-append
                                                                  "superclass ~e method for override, overment, inherit/super, "
                                                                  "or rename-super is not overrideable: ~a~a")
                                                                 super
                                                                 mname
                                                                 (for-class name)))
                                                  (vector-ref (class-methods super) index))))
                                          rename-super-indices
                                          rename-super-names)]
                      [rename-inners (let ([new-augonly (make-vector method-width #f)])
                                       (define (get-depth index)
                                         (+ (if (index . < . (class-method-width super))
                                                (vector-length (vector-ref (class-beta-methods super) 
                                                                           index))
                                                0)
                                            (if (vector-ref new-augonly index) 0 -1)))
                                       ;; To compute `rename-inner' indices, we need to know which methods
                                       ;;  are augonly in this new class.
                                       (for-each (lambda (id)
                                                   (vector-set! new-augonly (hash-ref method-ht id) #t))
                                                 (append pubment-names overment-names))
                                       (let ([check-aug
                                              (lambda (maybe-here?)
                                                (lambda (mname index)
                                                  (let ([aug-ok?
                                                         (or (if (index . < . (class-method-width super))
                                                                 (eq? (vector-ref (class-meth-flags super) index) 'augmentable)
                                                                 #f)
                                                             (and maybe-here?
                                                                  (or (memq mname pubment-names)
                                                                      (memq mname overment-names))))])
                                                    (unless aug-ok?
                                                      (obj-error 'class* 
                                                                 (string-append
                                                                  "superclass ~e method for augride, augment, inherit/inner, "
                                                                  "or rename-inner method is not augmentable: ~a~a")
                                                                 super
                                                                 mname
                                                                 (for-class name))))))])
                                         (for-each (check-aug #f) 
                                                   augride-normal-names
                                                   (get-indices method-ht "augride" augride-normal-names))
                                         (for-each (check-aug #f) 
                                                   augment-final-names
                                                   refine-final-indices)
                                         (for-each (check-aug #t) 
                                                   rename-inner-names
                                                   rename-inner-indices))
                                       ;; Now that checking is done, add `augment':
                                       (for-each (lambda (id)
                                                   (vector-set! new-augonly (hash-ref method-ht id) #t))
                                                 augment-names)
                                       (map (lambda (mname index)
                                              (let ([depth (get-depth index)])
                                                (lambda (obj)
                                                  (vector-ref (vector-ref (class-beta-methods (object-ref obj)) 
                                                                          index)
                                                              depth))))
                                            rename-inner-names
                                            rename-inner-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 refine-normal-indices
                                                       replace-augonly-indices refine-augonly-indices
                                                       replace-final-indices refine-final-indices
                                                       inherit-indices))])
                    
                    ;; -- Get new methods and initializers --
                    (let-values ([(new-methods override-methods augride-methods init)
                                  (apply make-methods
                                         object-field-ref
                                         object-field-set!
                                         (append inh-accessors
                                                 inh-mutators
                                                 rename-supers
                                                 rename-inners
                                                 method-accessors))])
                      ;; -- Fill in method tables --
                      ;;  First copy old methods
                      (unless no-method-changes?
                        (hash-for-each
                         super-method-ht
                         (lambda (name index)
                           (vector-set! methods index (vector-ref (class-methods super) index))
                           (vector-set! beta-methods index (vector-ref (class-beta-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! beta-methods index (vector)))
                                (append new-augonly-indices 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* 
                                               "cannot override or augment final method: ~a~a"
                                               id
                                               (for-class name)))
                                  (let ([v (vector-ref beta-methods index)])
                                    (if (zero? (vector-length v))
                                        ;; Normal mode - set vtable entry
                                        (vector-set! methods index method)
                                        ;; Under final mode - set extended vtable entry
                                        (let ([v (list->vector (vector->list v))])
                                          (vector-set! v (sub1 (vector-length v)) method)
                                          (vector-set! beta-methods index v))))
                                  (when (not (vector-ref meth-flags index))
                                    (vector-set! meth-flags index (not make-struct:prim))))
                                (append replace-augonly-indices replace-final-indices replace-normal-indices
                                        refine-augonly-indices refine-final-indices refine-normal-indices)
                                (append override-methods augride-methods)
                                (append override-names augride-names))
                      ;; Update 'augmentable flags:
                      (unless no-method-changes?
                        (for-each (lambda (id)
                                    (vector-set! meth-flags (hash-ref method-ht id) 'augmentable))
                                  (append overment-names pubment-names))
                        (for-each (lambda (id)
                                    (vector-set! meth-flags (hash-ref method-ht id) #t))
                                  augride-normal-names))
                      ;; Expand `rename-inner' vector, adding a #f to indicate that
                      ;;  no rename-inner function is available, so far
                      (for-each (lambda (id)
                                  (let ([index (hash-ref method-ht id)])
                                    (let ([v (list->vector (append (vector->list (vector-ref beta-methods index))
                                                                   (list #f)))])
                                      (vector-set! beta-methods index v))))
                                augonly-names)
                      ;; Mark final methods:
                      (for-each (lambda (id)
                                  (let ([index (hash-ref method-ht id)])
                                    (vector-set! meth-flags index 'final)))
                                final-names)
                      
                      ;; --- Install serialize info into class --
                      (set-class-serializer!
                       c
                       (cond
                         [(interface-extension? i externalizable<%>)
                          (let ([index (car (get-indices method-ht "???" '(externalize)))])
                            (lambda (obj)
                              (vector ((vector-ref methods index) obj))))]
                         [(and (or deserialize-id
                                   (not inspector))
                               (class-serializer super))
                          => (lambda (ss)
                               (lambda (obj)
                                 (vector (cons (ss obj)
                                               (let loop ([i 0])
                                                 (if (= i num-fields)
                                                     null
                                                     (cons (object-field-ref obj i)
                                                           (loop (add1 i)))))))))]
                         [else #f]))
                      
                      (set-class-fixup!
                       c
                       ;; Used only for non-externalizable:
                       (lambda (o args)
                         (if (pair? args)
                             (begin
                               ((class-fixup super) o (vector-ref (car args) 0))
                               (let loop ([i 0][args (cdr args)])
                                 (unless (= i num-fields)
                                   (object-field-set! o i (car args))
                                   (loop (add1 i) (cdr args)))))
                             (begin
                               ((class-fixup super) o args)
                               (let loop ([i 0])
                                 (unless (= i num-fields)
                                   (object-field-set! o i (object-field-ref args i))
                                   (loop (add1 i))))))))
                      
                      ;; --- Install initializer into class ---
                      (set-class-init! c init)
                      
                      ;; -- result is the class, and maybe deserialize-info ---
                      (if deserialize-id
                          (values c (make-deserialize-info
                                     (if (interface-extension? i externalizable<%>)
                                         (lambda (args)
                                           (let ([o (make-object c)])
                                             (send o internalize args)
                                             o))
                                         (lambda (args)
                                           (let ([o (object-make)])
                                             ((class-fixup c) o args)
                                             o)))
                                     (if (interface-extension? i externalizable<%>)
                                         (lambda ()
                                           (error 'deserialize "cannot deserialize instance with cycles~a"
                                                  (for-class name)))
                                         (lambda ()
                                           (let ([o (object-make)])
                                             (values o
                                                     (lambda (o2)
                                                       ((class-fixup c) o o2))))))))
                          c))))))))))))

(define (check-still-unique name syms what)
  (let ([ht (make-hasheq)])
    (for-each (lambda (s)
                (when (hash-ref ht s 
                                (lambda ()
                                  (hash-set! ht s #t)
                                  #f))
                  (obj-error 'class* "external ~a mapped to overlapping keys~a" 
                             what
                             (for-class name))))
              syms)))

(define (get-properties intfs)
  (if (ormap (lambda (i)
               (pair? (interface-properties i)))
             intfs)
      (let ([ht (make-hash)])
        ;; Hash on gensym to avoid providing the same property multiple
        ;; times when it originated from a single interface.
        (for-each (lambda (i)
                    (for-each (lambda (p)
                                (hash-set! ht (vector-ref p 0) p))
                              (interface-properties i)))
                  intfs)
        (hash-map ht (lambda (k v) (cons (vector-ref v 1)
                                         (vector-ref v 2)))))
      ;; No properties to add:
      null))

(define (add-properties struct-type intfs)
  (let ([props (get-properties intfs)])
    (if (null? props)
        struct-type
        ;; Create a new structure type to house the properties, so
        ;; that they can't see any fields directly via guards:
        (let-values ([(struct: make- ? -ref -set!)
                      (make-struct-type 'props struct-type 0 0 #f props #f)])
          struct:))))

(define-values (prop:object object? object-ref) (make-struct-type-property 'object))

;;--------------------------------------------------------------------
;;  interfaces
;;--------------------------------------------------------------------

;; >> Simplistic implementation for now <<

(define-for-syntax do-interface
  (lambda (stx m-stx)
    (syntax-case m-stx ()
      [((interface-expr ...) ([prop prop-val] ...) var ...)
       (let ([vars (syntax->list (syntax (var ...)))]
             [name (syntax-local-infer-name stx)])
         (for-each
          (lambda (v)
            (unless (identifier? v)
              (raise-syntax-error #f
                                  "not an identifier"
                                  stx
                                  v)))
          vars)
         (let ([dup (check-duplicate-identifier vars)])
           (when dup
             (raise-syntax-error #f
                                 "duplicate name"
                                 stx
                                 dup)))
         (with-syntax ([name (datum->syntax #f name #f)]
                       [(var ...) (map localize vars)])
           (syntax/loc
               stx
             (compose-interface
              'name
              (list interface-expr ...)
              `(var ...)
              (list prop ...)
              (list prop-val ...)))))])))

(define-syntax (_interface stx)
  (syntax-case stx ()
    [(_ (interface-expr ...) var ...)
     (do-interface stx #'((interface-expr ...) () var ...))]))

(define-syntax (interface* stx)
  (syntax-case stx ()
    [(_ (interface-expr ...) ([prop prop-val] ...) var ...)
     (do-interface stx #'((interface-expr ...) ([prop prop-val] ...) var ...))]
    [(_ (interface-expr ...) (prop+val ...) var ...)
     (for-each (lambda (p+v)
                 (syntax-case p+v ()
                   [(p v) (void)]
                   [_ (raise-syntax-error #f
                                          "expected `[<prop-expr> <val-expr>]'"
                                          stx
                                          p+v)]))
               (syntax->list #'(prop+val ...)))]
    [(_ (interface-expr ...) prop+vals . _)
     (raise-syntax-error #f
                         "expected `([<prop-expr> <val-expr>] ...)'"
                         stx
                         #'prop+vals)]))

(define-struct interface 
  (name             ; symbol
   supers           ; (listof interface)
   [all-implemented ; hash-table: interface -> #t
    #:mutable]
   public-ids       ; (listof symbol) (in any order?!?)
   [class           ; (union #f class) -- means that anything implementing
       #:mutable]      ; this interface must be derived from this class
   properties)      ; (listof (vector gensym prop val))
  #:inspector insp)

(define (compose-interface name supers vars props vals)
  (for-each
   (lambda (intf)
     (unless (interface? intf)
       (obj-error 'interface 
                  "superinterface expression returned a non-interface: ~e~a" 
                  intf
                  (for-intf name))))
   supers)
  (for-each
   (lambda (p)
     (unless (struct-type-property? p)
       (obj-error 'interface
                  "property expression returned a non-property: ~e~a"
                  p
                  (for-intf name))))
   props)
  (let ([ht (make-hasheq)])
    (for-each
     (lambda (var)
       (hash-set! ht var #t))
     vars)
    ;; Check that vars don't already exist in supers:
    (for-each
     (lambda (super)
       (for-each
        (lambda (var)
          (when (hash-ref ht var #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)
    ;; Merge properties:
    (let ([prop-ht (make-hash)])
      ;; Hash on gensym to avoid providing the same property multiple
      ;; times when it originated from a single interface.
      (for-each (lambda (i)
                  (for-each (lambda (p)
                              (hash-set! prop-ht (vector-ref p 0) p))
                            (interface-properties i)))
                supers)
      (for-each (lambda (p v)
                  (let ([g (gensym)])
                    (hash-set! prop-ht g (vector g p v))))
                props vals)
      ;; 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-set! ht var #t))
            (interface-public-ids super)))
         supers)
        ;; Done
        (let ([i (interface-make name supers #f (hash-map ht (lambda (k v) k)) class 
                                 (hash-map prop-ht (lambda (k v) v)))])
          (setup-all-implemented! i)
          i)))))

;; setup-all-implemented! : interface -> void
;;  Creates the hash table for all implemented interfaces
(define (setup-all-implemented! i)
  (let ([ht (make-hasheq)])
    (hash-set! ht i #t)
    (for-each (lambda (si)
                (hash-for-each
                 (interface-all-implemented si)
                 (lambda (k v)
                   (hash-set! ht k #t))))
              (interface-supers i))
    (set-interface-all-implemented! i ht)))

(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 #f null #f null))
(setup-all-implemented! object<%>)
(define object% ((make-naming-constructor struct:class 'class:object%)
                 'object%
                 0 (vector #f) 
                 object<%>
                 void ; never inspectable
                 
                 0 (make-hasheq) null
                 (vector) (vector) (vector)
                 
                 0 (make-hasheq) null
                 
                 'struct:object object? 'make-object
                 'field-ref-not-needed 'field-set!-not-needed
                 
                 null
                 'normal
                 
                 (lambda (this super-init si_c si_inited? si_leftovers args) 
                   (unless (null? args)
                     (unused-args-error this args))
                   (void))
                 
                 (lambda (obj) #(()))        ; serialize
                 (lambda (obj args) (void))  ; deserialize-fixup
                 
                 #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 (list (cons prop:object object%)) #f)])
  (set-class-struct:object! object% struct:obj)
  (set-class-make-object! object% make-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-syntaxes (new new-traced)
  
  (let* ([core-new
          (lambda (instantiate-stx stx)
            (syntax-case stx ()
              [(_ cls (id arg) ...)
               (andmap identifier? (syntax->list (syntax (id ...))))
               (quasisyntax/loc stx
                 ((unsyntax instantiate-stx) cls () (id arg) ...))]
              [(_ cls (id arg) ...)
               (for-each (lambda (id)
                           (unless (identifier? id)
                             (raise-syntax-error 'new "expected identifier" stx id)))
                         (syntax->list (syntax (id ...))))]
              [(_ cls pr ...)
               (for-each
                (lambda (pr)
                  (syntax-case pr ()
                    [(x y) (void)]
                    [else (raise-syntax-error 'new "expected name and value binding" stx pr)]))
                (syntax->list (syntax (pr ...))))]))])
    
    (values
     (lambda (stx) (core-new (syntax/loc stx instantiate) stx))
     (lambda (stx) (core-new (syntax/loc stx instantiate-traced) stx)))))

(define make-object 
  (lambda (class . args)
    (do-make-object class args null)))

(define make-object-traced
  (lambda (class . args)
    (do-make-object-traced class args null)))

(define-syntaxes (instantiate instantiate-traced)
  
  (let* ([core-instantiate
          (lambda (do-make-object-stx stx)
            (syntax-case stx ()
              [(form class (arg ...) . x)
               (with-syntax ([orig-stx stx])
                 (quasisyntax/loc stx 
                   (-instantiate (unsyntax do-make-object-stx)
                                 orig-stx (class) (list arg ...) . x)))]))])
    
    (values
     (lambda (stx)
       (core-instantiate (syntax/loc stx do-make-object) stx))
     (lambda (stx)
       (core-instantiate (syntax/loc stx do-make-object-traced) stx)))))

;; Helper; used by instantiate and super-instantiate
(define-syntax -instantiate
  (lambda (stx)
    (syntax-case stx ()
      [(_ do-make-object orig-stx (maker-arg ...) args (kw arg) ...)
       (andmap identifier? (syntax->list (syntax (kw ...))))
       (with-syntax ([(kw ...) (map localize (syntax->list (syntax (kw ...))))])
         (syntax/loc stx
           (do-make-object maker-arg ...
                           args
                           (list (cons `kw arg)
                                 ...))))]
      [(_ super-make-object orig-stx (make-arg ...) 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
                       #f
                       "by-name argument does not start with an identifier"
                       (syntax orig-stx)
                       kwarg)]
                     [_else
                      (raise-syntax-error
                       #f
                       "ill-formed by-name argument"
                       (syntax orig-stx)
                       kwarg)]))
                 (syntax->list (syntax (kwarg ...))))])))

(define (alist->sexp alist)
  (map (lambda (pair) (list (car pair) (cdr pair))) alist))

(define-traced (do-make-object class by-pos-args named-args)
  (unless (class? class)
    (raise-type-error 'instantiate "class" class))
  (let ([o ((class-make-object class))])
    (trace-begin
     ;; Initialize it:
     (trace (new-event class o (alist->sexp (get-field-alist o))))
     (trace (initialize-call-event
             o (string->symbol "(constructor)")
             (cons (alist->sexp named-args) by-pos-args)))
     (continue-make-object o class by-pos-args named-args #t)
     (trace (finalize-call-event o))
     o)))

(define (get-field-alist obj)
  (map (lambda (id) (cons id (get-field/proc id obj)))
       (field-names obj)))

(define (continue-make-object o c by-pos-args named-args explict-named-args?)
  (let ([by-pos-only? (not (class-init-args c))])
    ;; When a superclass has #f for init-args (meaning "by-pos args with no names"),
    ;; some propagated named args may have #f keys; move them to by-position args.
    (let-values ([(by-pos-args named-args)
                  (if by-pos-only?
                      (let ([l (filter (lambda (x) (not (car x))) named-args)])
                        (if (pair? l)
                            (values (append by-pos-args (map cdr l))
                                    (filter car named-args))
                            (values by-pos-args named-args)))
                      (values by-pos-args named-args))])
      ;; Primitive class with by-pos arguments?
      (when by-pos-only?
        (unless (null? named-args)
          (if explict-named-args?
              (obj-error 
               'instantiate
               "class has only by-position initializers, but given by-name arguments:~a~a" 
               (make-named-arg-string named-args)
               (for-class (class-name c)))
              ;; If args were implicit from subclass, should report as unused:
              (unused-args-error o named-args))))
      ;; Merge by-pos into named args:
      (let* ([named-args (if (not by-pos-only?)
                             ;; Normal merge
                             (do-merge by-pos-args (class-init-args c) c named-args by-pos-args c)
                             ;; Non-merge for by-position initializers
                             by-pos-args)]
             [leftovers (if (not by-pos-only?)
                            (get-leftovers named-args (class-init-args c))
                            null)])
        ;; In 'list mode, make sure no by-name arguments are left over
        (when (eq? 'list (class-init-mode c))
          (unless (or (null? leftovers)
                      (not (ormap car leftovers)))
            (unused-args-error o (filter car leftovers))))
        (unless (and (eq? c object%)
                     (null? named-args))
          (let ([inited? (box (class-no-super-init? c))])
            ;; ----- Execute the class body -----
            ((class-init c)
             o 
             continue-make-super
             c inited? leftovers ; merely passed through to continue-make-super
             named-args)
            (unless (unbox inited?)
              (obj-error 'instantiate "superclass initialization not invoked by initialization~a"
                         (for-class (class-name c))))))))))

(define (continue-make-super o c inited? leftovers by-pos-args new-named-args)
  (when (unbox inited?)
    (obj-error 'instantiate "superclass already initialized by class initialization~a"
               (for-class (class-name c))))
  (set-box! inited? #t)
  (let ([named-args (if (eq? 'list (class-init-mode c))
                        ;; all old args must have been used up
                        new-named-args
                        ;; Normal mode: merge leftover keyword-based args with new ones
                        (append
                         new-named-args
                         leftovers))])
    (continue-make-object o
                          (vector-ref (class-supers c) (sub1 (class-pos c))) 
                          by-pos-args 
                          named-args
                          (pair? new-named-args))))

(define (do-merge al nl ic named-args by-pos-args c)
  (cond
    [(null? al) named-args]
    [(null? nl)
     ;; continue mapping with superclass init args, if allowed
     (let ([super (and (eq? 'normal (class-init-mode ic))
                       (positive? (class-pos ic))
                       (vector-ref (class-supers ic) (sub1 (class-pos ic))))])
       (cond
         [super 
          (if (class-init-args super)
              (do-merge al (class-init-args super) super named-args by-pos-args c)
              ;; Like 'list mode:
              (append (map (lambda (x) (cons #f x)) al)
                      named-args))]
         [(eq? 'list (class-init-mode ic))
          ;; All unconsumed named-args must have #f
          ;;  "name"s, otherwise an error is raised in
          ;;  the leftovers checking.
          (if (null? al)
              named-args
              (append (map (lambda (x) (cons #f x)) al)
                      named-args))]
         [else
          (obj-error 'instantiate 
                     "too many initialization arguments:~a~a" 
                     (make-pos-arg-string by-pos-args)
                     (for-class (class-name c)))]))]
    [else (cons (cons (car nl) (car al))
                (do-merge (cdr al) (cdr nl) ic named-args by-pos-args c))]))

(define (get-leftovers l names)
  (cond
    [(null? l) null]
    [(memq (caar l) names)
     (get-leftovers (cdr l) (remq (caar l) names))]
    [else (cons (car l) (get-leftovers (cdr l) names))]))

(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 (missing-argument-error class-name name)]))
      ;; By-position mode
      (cond
        [(< name (length arguments))
         (cdr (list-ref arguments name))]
        [default (default)]
        [else (obj-error 'instantiate "too few initialization arguments")])))

(define (extract-rest-args skip arguments)
  (if (< skip (length arguments))
      (map cdr (list-tail arguments skip))
      null))

(define (make-pos-arg-string args)
  (let ([len (length args)])
    (apply string-append
           (map (lambda (a)
                  (format " ~e" a))
                args))))

(define (make-named-arg-string args)
  (let loop ([args args][count 0])
    (cond
      [(null? args) ""]
      [(= count 3) " ..."]
      [else (let ([rest (loop (cdr args) (add1 count))])
              (format " (~a ~e)~a"
                      (caar args)
                      (cdar args)
                      rest))])))

(define (unused-args-error this args)
  (let ([arg-string (make-named-arg-string args)])
    (obj-error 'instantiate "unused initialization arguments:~a~a" 
               arg-string
               (for-class/which "instantiated" (class-name (object-ref this))))))

(define (missing-argument-error class-name name)
  (obj-error 'instantiate "no argument for required init variable: ~a~a"
             name
             (if class-name (format " in class: ~a" class-name) "")))

;;--------------------------------------------------------------------
;;  methods and fields
;;--------------------------------------------------------------------

(define-syntaxes (send send/apply send-traced send/apply-traced)
  (let ()
    
    (define (do-method traced? stx form obj name args rest-arg?)
      (with-syntax ([(sym method receiver)
                     (generate-temporaries (syntax (1 2 3)))])
        (quasisyntax/loc stx
          (let*-values ([(sym) (quasiquote (unsyntax (localize name)))]
                        [(method receiver)
                         (find-method/who '(unsyntax form)
                                          (unsyntax obj)
                                          sym)])
            (unsyntax
             (make-method-call
              traced?
              stx
              (syntax/loc stx receiver)
              (syntax/loc stx unwrap-object)
              (syntax/loc stx method)
              (syntax/loc stx sym)
              args
              rest-arg?))))))
    
    (define (core-send traced? apply?)
      (lambda (stx)
        (syntax-case stx ()
          [(form obj name . args)
           (identifier? (syntax name))
           (if (stx-list? (syntax args))
               ;; (send obj name arg ...) or (send/apply obj name arg ...)
               (do-method traced? stx #'form #'obj #'name #'args apply?)
               (if apply?
                   ;; (send/apply obj name arg ... . rest)
                   (raise-syntax-error
                    #f "bad syntax (illegal use of `.')" stx)
                   ;; (send obj name arg ... . rest)
                   (do-method traced? stx #'form #'obj #'name
                              (flatten-args #'args) #t)))]
          [(form obj name . args)
           (raise-syntax-error
            #f "method name is not an identifier" stx #'name)])))
    
    (values
     ;; send
     (core-send #f #f)
     ;; send/apply
     (core-send #f #t)
     ;; send-traced
     (core-send #t #f)
     ;; send/apply-traced
     (core-send #t #t))))

(define-syntaxes (send* send*-traced)
  (let* ([core-send*
          (lambda (traced?)
            (lambda (stx)
              (syntax-case stx ()
                [(form obj clause ...)
                 (quasisyntax/loc stx
                   (let* ([o obj])
                     (unsyntax-splicing
                      (map
                       (lambda (clause-stx)
                         (syntax-case clause-stx ()
                           [(meth . args)
                            (quasisyntax/loc stx
                              ((unsyntax (if traced?
                                             (syntax/loc stx send-traced)
                                             (syntax/loc stx send)))
                               o meth . args))]
                           [_ (raise-syntax-error
                               #f "bad method call" stx clause-stx)]))
                       (syntax->list (syntax (clause ...)))))))])))])
    (values (core-send* #f) (core-send* #t))))

;; find-method/who : symbol[top-level-form/proc-name]
;;                   any[object] 
;;                   symbol[method-name] 
;;               -> (values method-proc object)
;; returns the method's procedure and a function to unwrap `this' in the case
;; that this is a wrapper object that is just "falling thru".
(define (find-method/who who in-object name)
  (unless (object? in-object)
    (obj-error who "target is not an object: ~e for method: ~a"
               in-object name))
  
  (let-syntax ([loop-body
                (lambda (stx)
                  (syntax-case stx ()
                    [(_ abs-object wrapper-case)
                     (identifier? (syntax abs-object))
                     (syntax
                      (let* ([c (object-ref abs-object)]
                             [pos (hash-ref (class-method-ht c) name #f)])
                        (cond
                          [pos (values (vector-ref (class-methods c) pos) abs-object)]
                          [(wrapper-object? abs-object) wrapper-case]
                          [else
                           (obj-error who "no such method: ~a~a"
                                      name
                                      (for-class (class-name c)))])))]))])
    (loop-body
     in-object
     (let loop ([loop-object in-object])
       (loop-body
        loop-object
        (loop (wrapper-object-wrapped loop-object)))))))


(define (class-field-X who which cwhich class name proc-field-name)
  (unless (class? class)
    (raise-type-error who "class" class))
  (unless (symbol? name)
    (raise-type-error who "symbol" name))
  (let ([p (hash-ref (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) proc-field-name)))

(define (make-class-field-accessor class name keep-name?)
  (class-field-X 'class-field-accessor
                 make-struct-field-accessor class-field-ref
                 class name (and keep-name? name)))

(define (make-class-field-mutator class name keep-name?)
  (class-field-X 'class-field-mutator 
                 make-struct-field-mutator class-field-set!
                 class name (and keep-name? name)))

(define-struct generic (name applicable))

;; Internally, make-generic comes from the struct def.
;; Externally, make-generic is the following procedure.
;; The extra `let' gives it the right name.
(define make-generic/proc
  (let ([make-generic
         (lambda (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
            name
            (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 
                       (string->symbol (format "generic:~a~a" name (for-intf (interface-name intf))))
                       (format "instance~a" (for-intf (interface-name intf)))
                       obj))
                    (let-values ([(mth ths) (find-method/who 'make-generic obj name)])
                      mth)))
                (let* ([pos (hash-ref (class-method-ht class) name
                                      (lambda ()
                                        (obj-error 'make-generic "no such method: ~a~a"
                                                   name
                                                   (for-class (class-name class)))))]
                       [instance? (class-object? class)]
                       [dynamic-generic
                        (lambda (obj)
                          (unless (instance? obj)
                            (raise-type-error 
                             (string->symbol (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))])
                  (if (eq? 'final (vector-ref (class-meth-flags class) pos))
                      (let ([method (vector-ref (class-methods class) pos)])
                        (lambda (obj)
                          (unless (instance? obj)
                            (dynamic-generic obj))
                          method))
                      dynamic-generic)))))])
    make-generic))

(define-syntaxes (send-generic send-generic-traced)
  (let ()
    (define (core-send-generic traced?)
      (lambda (stx)
        (syntax-case stx ()
          [(_ object generic . args)
           (let* ([args-stx (syntax args)]
                  [proper? (stx-list? args-stx)]
                  [flat-stx (if proper? args-stx (flatten-args args-stx))])
             (with-syntax ([(gen obj)
                            (generate-temporaries (syntax (generic object)))])
               (quasisyntax/loc stx
                 (let* ([obj object]
                        [gen generic])
                   (unsyntax
                    (make-method-call
                     traced?
                     stx
                     (syntax obj)
                     (syntax/loc stx unwrap-object)
                     (syntax/loc stx ((generic-applicable gen) obj))
                     (syntax/loc stx (generic-name gen))
                     flat-stx
                     (not proper?)))))))])))
    (values (core-send-generic #f) (core-send-generic #t))))

(define-syntaxes (class-field-accessor class-field-mutator generic/form)
  (let ([mk
         (lambda (make targets extra-args)
           (lambda (stx)
             (syntax-case stx ()
               [(_ class-expr name)
                (let ([name (syntax name)])
                  (unless (identifier? name)
                    (raise-syntax-error
                     #f
                     "expected an indentifier"
                     stx
                     name))
                  (with-syntax ([name (localize name)]
                                [make make]
                                [extra-args extra-args])
                    (syntax/loc stx (make class-expr `name . extra-args))))]
               [(_ class-expr)
                (raise-syntax-error
                 #f
                 (format "expected a field name after the ~a expression"
                         targets)
                 stx)])))])
    (values
     (mk (quote-syntax make-class-field-accessor) "class" (list #'#t))
     (mk (quote-syntax make-class-field-mutator) "class" (list #'#t))
     (mk (quote-syntax make-generic/proc) "class or interface" null))))

(define-syntax (class-field-accessor-traced stx)
  (syntax-case stx ()
    [(form class name)
     (syntax/loc stx
       (let* ([accessor (class-field-accessor class name)])
         (lambda (obj)
           (begin0 (accessor obj)
                   (get-event obj 'name)))))]))

(define-syntax (class-field-mutator-traced stx)
  (syntax-case stx ()
    [(form class name)
     (syntax/loc stx
       (let* ([mutator (class-field-mutator class name)])
         (lambda (obj value)
           (begin0 (mutator obj value)
                   (set-event obj 'name value)))))]))

(define-syntaxes (get-field get-field-traced)
  (let ()
    (define (core-get-field traced?)
      (lambda (stx)
        (syntax-case stx ()
          [(_ name obj)
           (identifier? (syntax name))
           (with-syntax ([get (if traced?
                                  (syntax get-field/proc-traced)
                                  (syntax get-field/proc))]
                         [localized (localize (syntax name))])
             (syntax (get `localized obj)))]
          [(_ name obj)
           (raise-syntax-error
            'get-field "expected a field name as first argument"
            stx (syntax name))])))
    (values (core-get-field #f) (core-get-field #t))))

(define-traced (get-field/proc id obj)
  (unless (object? obj)
    (raise-mismatch-error 
     'get-field
     "expected an object, got "
     obj))
  (trace-begin
   (trace (get-event obj id))
   (let loop ([obj obj])
     (let* ([cls (object-ref obj)]
            [field-ht (class-field-ht cls)]
            [index (hash-ref 
                    field-ht
                    id
                    #f)])
       (cond
         [index
          ((class-field-ref (car index)) obj (cdr index))]
         [(wrapper-object? obj)
          (loop (wrapper-object-wrapped obj))]
         [else
          (raise-mismatch-error 
           'get-field
           (format "expected an object that has a field named ~s, got " id)
           obj)])))))

(define-syntaxes (field-bound? field-bound?-traced)
  (let ()
    (define (core-field-bound? traced?)
      (lambda (stx)
        (syntax-case stx ()
          [(_ name obj)
           (identifier? (syntax name))
           (with-syntax ([localized (localize (syntax name))]
                         [bound? (if traced?
                                     (syntax field-bound?/proc-traced)
                                     (syntax field-bound?/proc))])
             (syntax (bound? `localized obj)))]
          [(_ name obj)
           (raise-syntax-error
            'field-bound? "expected a field name as first argument"
            stx (syntax name))])))
    (values (core-field-bound? #f) (core-field-bound? #t))))

(define-traced (field-bound?/proc id obj)
  (unless (object? obj)
    (raise-mismatch-error 
     'field-bound?
     "expected an object, got "
     obj))
  (trace-begin
   (trace (inspect-event obj))
   (let loop ([obj obj])
     (let* ([cls (object-ref obj)]
            [field-ht (class-field-ht cls)])
       (or (and (hash-ref field-ht id #f)
                #t) ;; ensure that only #t and #f leak out, not bindings in ht
           (and (wrapper-object? obj)
                (loop (wrapper-object-wrapped obj))))))))

(define-traced (field-names obj)
  (unless (object? obj)
    (raise-mismatch-error 
     'field-names
     "expected an object, got "
     obj))
  (trace-begin
   (trace (inspect-event obj))
   (let loop ([obj obj])
     (let* ([cls (object-ref obj)]
            [field-ht (class-field-ht cls)]
            [flds (filter interned? (hash-map field-ht (lambda (x y) x)))])
       (if (wrapper-object? obj)
           (append flds (loop (wrapper-object-wrapped obj)))
           flds)))))

(define-syntaxes (with-method with-method-traced)
  (let ()
    (define (core-with-method traced?)
      (lambda (stx)
        (syntax-case stx ()
          [(_ ([id (obj-expr name)] ...) body0 body1 ...)
           (let ([ids (syntax->list (syntax (id ...)))]
                 [names (syntax->list (syntax (name ...)))])
             (for-each (lambda (id name)
                         (unless (identifier? id)
                           (raise-syntax-error #f
                                               "not an identifier for binding"
                                               stx
                                               id))
                         (unless (identifier? name)
                           (raise-syntax-error #f
                                               "not an identifier for method name"
                                               stx
                                               name)))
                       ids names)
             (with-syntax ([(method ...) (generate-temporaries ids)]
                           [(method-obj ...) (generate-temporaries ids)]
                           [(name ...) (map localize names)]
                           [trace-flag (if traced? (syntax/loc stx #t) (syntax/loc stx #f))])
               (syntax/loc stx (let-values ([(method method-obj)
                                             (let ([obj obj-expr])
                                               (find-method/who 'with-method obj `name))]
                                            ...)
                                 (letrec-syntaxes+values ([(id) (make-with-method-map
                                                                 trace-flag
                                                                 (quote-syntax set!)
                                                                 (quote-syntax id)
                                                                 (quote-syntax method)
                                                                 (quote-syntax method-obj)
                                                                 (syntax unwrap-object))]
                                                          ...)
                                   ()
                                   body0 body1 ...)))))]
          ;; Error cases:
          [(_ (clause ...) . body)
           (begin
             (for-each (lambda (clause)
                         (syntax-case clause ()
                           [(id (obj-expr name))
                            (and (identifier? (syntax id))
                                 (identifier? (syntax name)))
                            'ok]
                           [_else
                            (raise-syntax-error 
                             #f
                             "binding clause is not of the form (identifier (object-expr method-identifier))"
                             stx
                             clause)]))
                       (syntax->list (syntax (clause ...))))
             ;; If we get here, the body must be bad
             (if (stx-null? (syntax body))
                 (raise-syntax-error 
                  #f
                  "empty body"
                  stx)
                 (raise-syntax-error 
                  #f
                  "bad syntax (illegal use of `.')"
                  stx)))]
          [(_ x . rest)
           (raise-syntax-error 
            #f
            "not a binding sequence"
            stx
            (syntax x))])))
    
    (values
     ;; with-method
     (core-with-method #f)
     ;; with-method-traced
     (core-with-method #t))))


;;--------------------------------------------------------------------
;;  class, interface, and object properties
;;--------------------------------------------------------------------

(define-traced (is-a? v c)
  (trace-begin
   (trace (when (object? v)
            (inspect-event v)))
   (cond
     [(class? c) ((class-object? c) (unwrap-object v))]
     [(interface? c)
      (and (object? v)
           (implementation? (object-ref (unwrap-object 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-traced (object-interface o)
  (unless (object? o)
    (raise-type-error 'object-interface "object" o))
  (trace-begin
   (trace (inspect-event o))
   (class-self-interface (object-ref (unwrap-object o)))))

(define-traced (object-method-arity-includes? o name cnt)
  (unless (object? o)
    (raise-type-error 'object-method-arity-includes? "object" o))
  (unless (symbol? name)
    (raise-type-error 'object-method-arity-includes? "symbol" name))
  (unless (and (integer? cnt)
               (exact? cnt)
               (not (negative? cnt)))
    (raise-type-error 'object-method-arity-includes? "non-negative exact integer" cnt))
  (trace-begin
   (trace (inspect-event o))
   (let loop ([o o])
     (let* ([c (object-ref o)]
            [pos (hash-ref (class-method-ht c) name #f)])
       (cond
         [pos (procedure-arity-includes? (vector-ref (class-methods c) pos) 
                                         (add1 cnt))]
         [(wrapper-object? o) (loop (wrapper-object-wrapped o))]
         [else #f])))))

(define (implementation? v i)
  (unless (interface? i)
    (raise-type-error 'implementation? "interface" 1 v i))
  (and (class? v)
       (interface-extension? (class-self-interface v) i)))

(define (interface-extension? v i)
  (unless (interface? i)
    (raise-type-error 'interface-extension? "interface" 1 v i))
  (and (interface? i)
       (hash-ref (interface-all-implemented v) i #f)))

(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 (class->interface c)
  (unless (class? c)
    (raise-type-error 'class->interface "class" c))
  (class-self-interface c))

(define (interned? sym)
  (eq? sym (string->symbol (symbol->string sym))))

(define (interface->method-names i)
  (unless (interface? i)
    (raise-type-error 'interface->method-names "interface" i))
  (filter interned? (interface-public-ids i)))


(define-traced (object-info o)
  (unless (object? o)
    (raise-type-error 'object-info "object" o))
  (trace-begin
   (trace (inspect-event o))
   (let loop ([c (object-ref (unwrap-object o))]
              [skipped? #f])
     (if (struct? ((class-insp-mk c)))
         ;; current inspector can inspect this object
         (values c skipped?)
         (if (zero? (class-pos c))
             (values #f #t)
             (loop (vector-ref (class-supers c) (sub1 (class-pos c))) #t))))))

(define (to-sym s)
  (if (string? s)
      (string->symbol s)
      s))

(define (class-info c)
  (unless (class? c)
    (raise-type-error 'class-info "class" c))
  (if (struct? ((class-insp-mk c)))
      (let ([super (vector-ref (class-supers c) (sub1 (class-pos c)))])
        (let loop ([next super][skipped? #f])
          (if (or (not next)
                  (struct? ((class-insp-mk next))))
              (values (to-sym (class-name c))
                      (- (class-field-width c) (class-field-width super))
                      (filter interned? (class-field-ids c))
                      (class-field-ref c)
                      (class-field-set! c)
                      next
                      skipped?)
              (if (zero? (class-pos next))
                  (loop #f #t)
                  (loop (vector-ref (class-supers next) (sub1 (class-pos next))) #t)))))
      (raise-mismatch-error 'class-info "current inspector cannot inspect class: " c)))

(define-traced object->vector
  (opt-lambda (in-o [opaque-v '...])
    (unless (object? in-o)
      (raise-type-error 'object->vector "object" in-o))
    (trace-begin
     (trace (inspect-event in-o))
     (let ([o (unwrap-object in-o)])
       (list->vector
        (cons
         (string->symbol (format "object:~a" (class-name (object-ref o))))
         (reverse
          (let-values ([(c skipped?) (object-info o)])
            (let loop ([c c][skipped? skipped?])
              (cond
                [(not c) (if skipped? (list opaque-v) null)]
                [else (let-values ([(name num-fields field-ids field-ref
                                          field-set next next-skipped?)
                                    (class-info c)])
                        (let ([rest (loop next next-skipped?)]
                              [here (let loop ([n num-fields])
                                      (if (zero? n)
                                          null
                                          (cons (field-ref o (sub1 n))
                                                (loop (sub1 n)))))])
                          (append (if skipped? (list opaque-v) null)
                                  here
                                  rest)))]))))))))))

(define (object=? o1 o2)
  (unless (object? o1)
    (raise-type-error 'object=? "object" o1))
  (unless (object? o2)
    (raise-type-error 'object=? "object" o2))
  (eq? (unwrap-object o1)
       (unwrap-object o2)))

;;--------------------------------------------------------------------
;;  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
         intfs                ; interfaces
         init-arg-names       ; #f or list of syms and sym--value lists
         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, a preparer, a dispatcher function, and a property assoc list, 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 preparer takes a symbol and returns a num.
  ; 
  ; The supplied dispatcher takes an object and a num and returns a method.
  ;
  ; When a primitive class has a superclass, the struct:prim maker
  ;  is responsible for ensuring that the returned struct items match
  ;  the supertype predicate.
  
  (compose-class name
                 (or super object%)
                 intfs
                 #f
                 #f
                 #f
                 
                 0 null null ; no fields
                 
                 null ; no rename-supers
                 null ; no rename-inners
                 null null new-names
                 null null override-names
                 null null null ; no augrides
                 null ; no inherits
                 
                 ; #f => init args by position only
                 ; sym => required arg
                 ; sym--value list => optional arg
                 (and init-arg-names  
                      (map (lambda (s)
                             (if (symbol? s) s (car s)))
                           init-arg-names))
                 'stop
                 
                 (lambda ignored
                   (values
                    new-methods
                    override-methods
                    null ; no augride-methods
                    (lambda (this super-go/ignored si_c/ignored si_inited?/ignored si_leftovers/ignored init-args)
                      (apply prim-init this 
                             (if init-arg-names
                                 (extract-primitive-args this name init-arg-names init-args)
                                 init-args)))))
                 
                 make-struct:prim))

(define (extract-primitive-args this class-name init-arg-names init-args)
  (let loop ([names init-arg-names][args init-args])
    (cond
      [(null? names)
       (unless (null? args)
         (unused-args-error this args))
       null]
      [else (let* ([name (car names)]
                   [id (if (symbol? name)
                           name
                           (car name))])
              (let ([arg (assq id args)])
                (cond
                  [arg 
                   (cons (cdr arg) (loop (cdr names) (remq arg args)))]
                  [(symbol? name)
                   (missing-argument-error class-name name)]
                  [else
                   (cons (cadr name) (loop (cdr names) args))])))])))

;;--------------------------------------------------------------------
;;  wrapper for contracts
;;--------------------------------------------------------------------

(define-struct wrapper-field (name ctc-stx))
(define-struct wrapper-method (name mth-stx))

(define-values (wrapper-object? wrapper-object-wrapped set-wrapper-object-wrapped! struct:wrapper-object)
  (let-values ([(struct:wrapper-object make-wrapper-object wrapper-object? ref set!)
                (make-struct-type 'raw-wrapper-object
                                  #f
                                  0
                                  1)])
    (values wrapper-object?
            (lambda (v) (ref v 0))
            (lambda (o v) (set! o 0 v))
            struct:wrapper-object)))

;; unwrap-object : (union wrapper-object object) -> object
(define (unwrap-object o)
  (let loop ([o o])
    (if (wrapper-object? o)
        (loop (wrapper-object-wrapped o))
        o)))

;; make-wrapper-class :   symbol
;;                        (listof symbol)
;;                        method-spec [depends on the boolean what it is]
;;                        (listof symbol)
;;                        boolean
;;                     -> class
;; the resulting class is the "proxy" class for the contracted version of an
;; object with contracts on the method-ids. 

;; Overall, objects of this class have one field for the original object,
;; one field per method in the contract and one field per field in the contract.
;; Each of the methods (passed in) just accesses the initial (method) fields
;; (which contain procedures) and calls them and returns their results.
;; Those fields do not show up from outside of this file, via the usual
;; field accessors. In addition, the class has one field per field that
;; will contain the contracted versions of the input fields.
;; The class accepts one initialization argument per method and
;; one init arg per field (in that order) using the make-object style
;; initialization.
(define (make-wrapper-class class-name method-ids methods field-ids old-style?)
  (let* ([supers (vector object% #f)]
         [method-ht (make-hasheq)]
         [method-count (length method-ids)]
         [methods-vec (make-vector method-count #f)]
         
         [field-ht (make-hasheq)]
         [field-count (length field-ids)]
         
         [cls
          (make-class class-name
                      1
                      supers
                      'bogus-self-interface
                      void  ; nothing can be inspected
                      
                      method-count
                      method-ht
                      (reverse method-ids)
                      
                      methods-vec
                      (list->vector (map (lambda (x) 'final) method-ids))
                      'dont-use-me!
                      
                      (if old-style?
                          (+ field-count method-count 1)
                          field-count)
                      field-ht
                      field-ids
                      
                      #f; struct:object
                      #f; object?
                      #f; make-object ;; -> void
                      #f; field-ref
                      #f; field-set!
                      
                      #f ;; only by position arguments
                      'normal ; init-mode - ??
                      
                      #f ; init
                      #f #f ; not serializable
                      #f)])
    (let-values ([(struct:object make-object object? field-ref field-set!)
                  (make-struct-type 'wrapper-object
                                    struct:wrapper-object
                                    0
                                    (if old-style?
                                        (+ (length field-ids) (length method-ids))
                                        (length field-ids))
                                    undefined
                                    (list (cons prop:object cls))
                                    insp)])
      (set-class-struct:object! cls struct:object)
      (set-class-object?! cls object?)
      (set-class-make-object! cls make-object)
      (set-class-field-ref! cls field-ref)
      (set-class-field-set!! cls field-set!)
      
      (let ([init
             (lambda (o continue-make-super c inited? named-args leftover-args)
               ;; leftover args will contain the original object and new field values
               ;; fill the original object in and then fill in the fields.
               (set-wrapper-object-wrapped! o (car leftover-args))
               (let loop ([leftover-args (cdr leftover-args)]
                          [i 0])
                 (unless (null? leftover-args)
                   (field-set! o i (car leftover-args))
                   (loop (cdr leftover-args)
                         (+ i 1))))
               (continue-make-super o c inited? '() '() '()))])
        (set-class-init! cls init))
      
      ;; fill in the methods vector & methods-ht
      (let loop ([i 0]
                 [methods methods]
                 [method-ids method-ids])
        (when (< i method-count)
          (vector-set! methods-vec i (if old-style? 
                                         ((car methods) field-ref)
                                         (car methods)))
          (hash-set! method-ht (car method-ids) i)
          (loop (+ i 1)
                (cdr methods)
                (cdr method-ids))))
      
      ;; fill in the fields-ht
      (let loop ([i 0]
                 [field-ids field-ids])
        (when (< i field-count)
          (hash-set! field-ht (car field-ids) (cons cls i))
          (loop (+ i 1)
                (cdr field-ids))))
      
      ;; fill in the supers vector
      (vector-set! supers 1 cls)
      
      cls)))

; extract-vtable : object -> (vectorof method-proc[this args ... -> res])
(define (extract-vtable o) (class-methods (object-ref o)))

; extract-method-ht : object -> hash-table[sym -> number]
(define (extract-method-ht o) (class-method-ht (object-ref o)))

;;--------------------------------------------------------------------
;;  misc utils
;;--------------------------------------------------------------------

(define undefined (letrec ([x x]) x))

(define-struct (exn:fail:object exn:fail) () #:inspector insp)

(define (obj-error where . msg)
  (raise (make-exn:fail: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-class/which which name)
  (if name (format " for ~a class: ~a" which name) ""))
(define (for-intf name)
  (if name (format " for interface: ~a" name) ""))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; mixin
;;

(define (check-mixin-super mixin-name super% from-ids)
  (let ([mixin-name (or mixin-name 'mixin)])
    (unless (class? super%)
      (error mixin-name "argument is not a class: ~e" super%))
    (for-each (lambda (from-id)
                (unless (implementation? super% from-id)
                  (error mixin-name "argument does not implement ~e: ~e" from-id super%)))
              from-ids)))

(define (check-mixin-from-interfaces all-from)
  (for-each (lambda (from-id)
              (unless (interface? from-id)
                (error 'mixin
                       "expected from-interface, got: ~e; others ~e"
                       from-id
                       all-from)))
            all-from))

(define (check-mixin-to-interfaces all-to)
  (for-each (lambda (to-id)
              (unless (interface? to-id)
                (error 'mixin
                       "expected to-interface, got: ~e; others ~e"
                       to-id
                       all-to)))
            all-to))


(define (check-interface-includes xs from-ids)
  (for-each
   (lambda (x)
     (unless (ormap (lambda (i) (method-in-interface? x i)) from-ids)
       (error 'mixin
              "method `~a' was referenced in definition, but is not in any of the from-interfaces: ~e"
              x from-ids)))
   xs))

(define-syntax (mixin stx)
  (syntax-case stx ()
    [(_ (from ...) (to ...) clauses ...)
     (let ([extract-renamed-names
            (λ (x)
              (map (λ (x) (syntax-case x ()
                            [(internal-name external-name) (syntax external-name)]
                            [else x]))
                   (syntax->list x)))])
       (define (get-super-names stx)
         (syntax-case stx (inherit rename 
                                   override overment override-final
                                   define/override define/overment define/override-final
                                   augment augride augment-final
                                   define/augment define/augride define/augment-final)
           [(inherit names ...) (extract-renamed-names (syntax (names ...)))]
           [(rename [x names] ...) (syntax->list (syntax (names ...)))]
           [(override names ...) (extract-renamed-names (syntax (names ...)))]
           [(overment names ...) (extract-renamed-names (syntax (names ...)))]
           [(override-final names ...) (extract-renamed-names (syntax (names ...)))]
           [(augment names ...) (extract-renamed-names (syntax (names ...)))]
           [(augride names ...) (extract-renamed-names (syntax (names ...)))]
           [(augment-final names ...) (extract-renamed-names (syntax (names ...)))]
           
           [(define/augment (name . names) . rest) (extract-renamed-names (syntax (name)))]
           [(define/augment name . rest) (identifier? (syntax name)) (extract-renamed-names (syntax (name)))]
           [(define/augride (name . names) . rest) (extract-renamed-names (syntax (name)))]
           [(define/augride name . rest) (identifier? (syntax name)) (extract-renamed-names (syntax (name)))]
           [(define/augment-final (name . names) . rest) (extract-renamed-names (syntax (name)))]
           [(define/augment-final name . rest) (identifier? (syntax name)) (extract-renamed-names (syntax (name)))]
           [(define/override (name . names) . rest) (extract-renamed-names (syntax (name)))]
           [(define/override name . rest) (identifier? (syntax name)) (extract-renamed-names (syntax (name)))]
           [(define/overment (name . names) . rest) (extract-renamed-names (syntax (name)))]
           [(define/overment name . rest) (identifier? (syntax name)) (extract-renamed-names (syntax (name)))]
           [(define/override-final (name . names) . rest) (extract-renamed-names (syntax (name)))]
           [(define/override-final name . rest) (identifier? (syntax name)) (extract-renamed-names (syntax (name)))]
           [else null]))
       (with-syntax ([(from-ids ...) (generate-temporaries (syntax (from ...)))]
                     [(to-ids ...) (generate-temporaries (syntax (to ...)))]
                     [(super-vars ...)
                      (apply
                       append
                       (map get-super-names
                            (syntax->list (syntax (clauses ...)))))]
                     [mixin-name (or (with-syntax ([tmp (syntax-local-name)])
                                       (syntax (quote tmp)))
                                     (syntax (quote mixin)))])
         
         ;; Build the class expression first, to give it a good src location:
         (with-syntax ([class-expr
                        (with-syntax ([orig-stx stx])
                          (syntax/loc stx
                            (class/derived orig-stx [#f super% (to-ids ...) #f]
                                           clauses ...)))])
           
           ;; Now build mixin proc, again to give it a good src location:
           (with-syntax ([mixin-expr
                          (syntax/loc stx
                            (λ (super%)
                              (check-mixin-super mixin-name super% (list from-ids ...))
                              class-expr))])
             
             ;; Finally, build the complete mixin expression:
             (syntax/loc stx
               (let ([from-ids from] ...)
                 (let ([to-ids to] ...)
                   (check-mixin-from-interfaces (list from-ids ...))
                   (check-mixin-to-interfaces (list to-ids ...))
                   (check-interface-includes (list (quote super-vars) ...)
                                             (list from-ids ...))
                   mixin-expr)))))))]))

(define externalizable<%>
  (_interface () externalize internalize))

(define printable<%>
  (interface* () 
              ([prop:custom-write (lambda (obj port write?)
                                    (if write?
                                        (send obj custom-write port)
                                        (send obj custom-display port)))])
              custom-write custom-display))

(define equal<%>
  (interface* () 
              ([prop:equal+hash (list
                                 (lambda (obj obj2 base-equal?)
                                   (send obj equal-to? obj2 base-equal?))
                                 (lambda (obj base-hash-code)
                                   (send obj equal-hash-code-of base-hash-code))
                                 (lambda (obj base-hash2-code)
                                   (send obj equal-secondary-hash-code-of base-hash2-code)))])
              equal-to? equal-hash-code-of equal-secondary-hash-code-of))

;; Providing traced versions:
(provide class-traced
         class*-traced
         class/derived-traced
         (rename-out [define-serializable-class define-serializable-class-traced]
                     [define-serializable-class* define-serializable-class*-traced]
                     [mixin mixin-traced])
         new-traced
         make-object-traced
         instantiate-traced
         send-traced
         send/apply-traced
         send*-traced
         class-field-accessor-traced
         class-field-mutator-traced
         with-method-traced
         get-field-traced
         field-bound?-traced
         field-names-traced
         (rename-out [generic/form generic-traced]
                     [make-generic/proc make-generic-traced])
         send-generic-traced
         is-a?-traced
         object-interface-traced
         object-info-traced
         object->vector-traced
         object-method-arity-includes?-traced
         )

;; Providing normal functionality:
(provide (protect-out make-wrapper-class
                      wrapper-object-wrapped
                      extract-vtable
                      extract-method-ht
                      get-field/proc)
         
         (rename-out [_class class]) class* class/derived
         define-serializable-class define-serializable-class*
         class?
         mixin
         (rename-out [_interface interface]) interface* interface?
         object% object? object=? externalizable<%> printable<%> equal<%>
         new make-object instantiate
         get-field field-bound? field-names
         send send/apply send* class-field-accessor class-field-mutator with-method
         private* public*  pubment*
         override* overment*
         augride* augment*
         public-final* override-final* augment-final*
         define/private define/public define/pubment 
         define/override define/overment
         define/augride define/augment
         define/public-final define/override-final define/augment-final
         define-local-member-name define-member-name 
         member-name-key generate-member-key member-name-key? member-name-key=? member-name-key-hash-code
         (rename-out [generic/form generic]) (rename-out [make-generic/proc make-generic]) send-generic generic?
         is-a? subclass? implementation? interface-extension?
         object-interface object-info object->vector
         object-method-arity-includes?
         method-in-interface? interface->method-names class->interface class-info
         (struct-out exn:fail:object)
         make-primitive-class)

