
(module class-internal mzscheme
  (require (lib "list.ss")
           (lib "etc.ss")
	   (lib "stxparam.ss")
	   "serialize-structs.ss")
  (require-for-syntax (lib "kerncase.ss" "syntax")
		      (lib "stx.ss" "syntax")
		      (lib "name.ss" "syntax")
		      (lib "context.ss" "syntax")
		      (lib "define.ss" "syntax")
		      (lib "boundmap.ss" "syntax" "private")
		      (lib "stxparam.ss")
		      "classidmap.ss")

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

  ;;--------------------------------------------------------------------
  ;;  keyword setup
  ;;--------------------------------------------------------------------
  
  (define-syntax provide-class-keyword
    (syntax-rules ()
      [(_ id ...)
       (begin
	 (define-syntax (id stx)
	   (raise-syntax-error
	    #f
	    "use of a class keyword is not in a class top-level"
	    stx))
	 ...
	 (provide id ...))]))
  
  (provide-class-keyword private public override augride
			 pubment overment augment
			 public-final override-final augment-final
			 field init init-field
			 rename-super rename-inner inherit inherit-field
			 inspect)

  (define-syntax define/provide-context-keyword
    (syntax-rules ()
      [(_ (id param-id) ...)
       (begin
	 (begin
	   (provide id)
	   (define-syntax-parameter param-id 
	     (make-set!-transformer
	      (lambda (stx)
		(raise-syntax-error
		 #f
		 "use of a class keyword is not in a class"
		 stx))))
	   (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])

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

  (define-syntaxes (class* _class class/derived)
    (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 (quote-syntax here))
		 (list 
		  (quote-syntax init)
		  (quote-syntax init-rest)
		  (quote-syntax field)
		  (quote-syntax init-field)
		  (quote-syntax inherit-field)
		  (quote-syntax private)
		  (quote-syntax public)
		  (quote-syntax override)
		  (quote-syntax 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 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 expr ...)
		     (loop (append
			    (syntax->list (syntax (expr ...)))
			    (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) (module-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 (cdr (syntax->list i))])
			(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)))))
	;; mk-name: constructs a method name
	;; for error reporting, etc.
	(define (mk-name name)
	  (datum->syntax-object 
	   #f 
	   (string->symbol (format "~a method~a~a" 
				   (syntax-e name)
				   (if class-name
				       " in "
				       "")
				   (or class-name 
				       ""))) 
	   #f))
	;; -- tranform loop starts here --
	(let loop ([stx orig-stx][can-expand? #t][name name][locals null])
	  (syntax-case stx (lambda case-lambda letrec-values let-values)
	    [(lambda vars body1 body ...)
	     (vars-ok? (syntax vars))
	     (if xform?
		 (with-syntax ([the-obj the-obj]
			       [the-finder the-finder]
			       [name (mk-name name)])
		   (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)]
	    [(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 (module-identifier=? (syntax let-) 
					   (quote-syntax let-values))
		      (module-identifier=? (syntax let-) 
					   (quote-syntax letrec-values)))
		  (andmap identifier? (syntax->list (syntax (id ...)))))
	     (let* ([letrec? (module-identifier=? (syntax let-) 
						  (quote-syntax letrec-values))]
		    [ids (syntax->list (syntax (id ...)))]
		    [new-ids (if xform?
				 (map
				  (lambda (id)
				    (datum->syntax-object
				     #f
				     (gensym (syntax-e id))))
				  ids)
				 ids)]
		    [body-locals (append ids locals)]
		    [exprs (map (lambda (expr id)
				  (loop expr #t id (if letrec?
						       body-locals
						       locals)))
				(syntax->list (syntax (expr ...)))
				ids)]
		    [body (let ([body (syntax let-body)])
			    (if (identifier? body)
				(ormap (lambda (id new-id)
					 (and (bound-identifier=? body id)
					      new-id))
				       ids new-ids)
				(loop body #t name body-locals)))])
	       (unless body
		 (bad "bad form for method definition" 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 super-expr deserialize-id-expr name-id interface-exprs defn-and-exprs)
	(let-values ([(this-id) #'this-id]
		     [(the-obj) (datum->syntax-object (quote-syntax here) (gensym 'self))]
		     [(the-finder) (datum->syntax-object (quote-syntax here) (gensym 'find-self))])

	  (let* ([def-ctx (syntax-local-make-definition-context)]
		 [localized-map (make-bound-identifier-mapping)]
		 [bind-local-id (lambda (id)
				  (let ([l (localize 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 () 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 rename-inner
						 inspect)
			    [(form idp ...)
			     (and (identifier? (syntax form))
				  (or (module-identifier=? (syntax form) (quote-syntax init))
				      (module-identifier=? (syntax form) (quote-syntax init-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]
				    [(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 . rest)
			     (bad "ill-formed init clause" stx)]
			    [(init-rest)
			     'ok]
			    [(init-rest rest)
			     (identifier? (syntax rest))
			     'ok]
			    [(init-rest . rest)
			     (bad "ill-formed init-rest clause" stx)]
			    [(init-field . rest)
			     (bad "ill-formed init-field clause" stx)]
			    [(field idp ...)
			     (for-each (lambda (idp)
					 (syntax-case idp ()
					   [(id expr) (identifier? (syntax id)) 'ok]
					   [((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 . rest)
			     (bad "ill-formed field clause" stx)]
			    [(private id ...)
			     (for-each
			      (lambda (id)
				(unless (identifier? id)
				  (bad "private element is not an identifier" id)))
			      (syntax->list (syntax (id ...))))]
			    [(private . rest)
			     (bad "ill-formed private clause" stx)]
			    [(form idp ...)
			     (and (identifier? (syntax form))
				  (ormap (lambda (f) (module-identifier=? (syntax form) f))
					 (syntax-e (quote-syntax (public
								   override
								   augride
								   public-final
								   override-final
								   augment-final
								   pubment
								   overment
								   augment
								   inherit
								   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-field . rest)
			     (bad "ill-formed inherit-field clause" stx)]
			    [(kw idp ...)
			     (and (identifier? #'kw)
				  (or (module-identifier=? #'rename-super #'kw)
				      (module-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
							       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))]
			    [(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
			   [(module-identifier=? #'init-rest form)
			    (loop (cdr l) #t)]
			   [(not saw-rest?) (loop (cdr l) #f)]
			   [(module-identifier=? #'init form)
			    (bad "init clause follows init-rest clause" (car l))]
			   [(module-identifier=? #'init-field form)
			    (bad "init-field clause follows init-rest clause" (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)]
		       [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
					   rename-super-names
					   rename-inner-names
					   (kernel-form-identifier-list
					    (quote-syntax here)))])
		  ;; 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
					  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-hash-table)])
				 (for-each (lambda (id)
					     (when (hash-table-get ht (syntax-e id) (lambda () #f))
					       (bad (format "duplicate declared external ~a name" what) id))
					     (hash-table-put! 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-hash-table)]
			    [stx-ht (make-hash-table)])
			(for-each
			 (lambda (defined-name)
			   (let ([l (hash-table-get ht (syntax-e defined-name) (lambda () null))])
			     (hash-table-put! ht (syntax-e defined-name) (cons defined-name l))))
			 defined-method-names)
			(for-each
			 (lambda (defined-name)
			   (let ([l (hash-table-get stx-ht (syntax-e defined-name) (lambda () null))])
			     (hash-table-put! stx-ht (syntax-e defined-name) (cons defined-name l))))
			 defined-syntax-names)
			(for-each
			 (lambda (pubovr-name)
			   (let ([l (hash-table-get ht (syntax-e pubovr-name) (lambda () null))])
			     (unless (ormap (lambda (i) (bound-identifier=? i pubovr-name)) l)
			       ;; Either undefined or defined as syntax:
			       (let ([stx-l (hash-table-get stx-ht (syntax-e pubovr-name) (lambda () 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-hash-table)])
			  (for-each (lambda (pub)
				      (hash-table-put! ht (syntax-e (cdr pub)) #t))
				    (append publics public-finals overrides override-finals augrides))
			  (for-each (lambda (inn)
				      (when (hash-table-get ht (syntax-e (cdr inn)) (lambda () #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 idp ...)
					     (and (identifier? (syntax -init))
						  (ormap (lambda (it) 
							   (module-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 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 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-object (quote-syntax here)
						     (gensym (syntax-e id-stx))))]
			    [rename-super-extras (append overments overrides override-finals)]
			    [rename-inner-extras (append pubments overments augments)]
			    [all-rename-inners (append (map car rename-inners)
						       (generate-temporaries (map car pubments))
						       (generate-temporaries (map car overments))
						       (generate-temporaries (map car augments)))]
			    [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-temp ...) (map
								mk-method-temp
								(map car public-finals))]
				      [(method-name ...) (append local-public-dynamic-names
								 (map car inherits))]
				      [(method-name-localized ...) (map lookup-localize
									(append local-public-dynamic-names
										(map car inherits)))]
				      [(method-accessor ...) (generate-temporaries
							      (map car
								   (append publics overrides augrides
									   overments augments
									   override-finals augment-finals
									   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-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)))))]
				      [(plain-init-name ...) (definify 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])
				   (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 (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 (quote-syntax the-finder)
						       (quote the-obj)
						       (quote-syntax local-field)
						       (quote-syntax local-field-localized)
						       (quote-syntax local-accessor)
						       (quote-syntax local-mutator)
						       '(local-field-pos))
				       ...
				       (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
				 (with-syntax ([(init-error-map ...)
						(map (lambda (x)
						       (syntax init-error-map))
						     plain-inits)])
				   (syntax 
				    ([(plain-init-name ...)
				      (values
				       init-error-map
				       ...)])))])
			    
			    (let ([find-method 
				   (lambda (methods)
				     (lambda (name)
				       (ormap 
					(lambda (m)
					  (and (bound-identifier=? (car m) name)
					       (with-syntax ([proc (proc-shape (car m) (cdr m) #t 
									       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)))])
			      
			      ;; ---- 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 inherits)]
					    [num-fields (datum->syntax-object
							 (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
				     ;; 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
					 (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, or overment 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, "
						     "or overment 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-object
								 code
								 (cons code
								       (cdr (syntax-e stx)))))))])
						      (letrec-syntaxes+values () ([(plain-init-name) undefined]
										  ...)
							(void) ; in case the body is empty
							. exprs))))))))))))
				     ;; Not primitive:
				     #f))))))))))))))))

      ;; The class* and class entry points:
      (values
       ;; class*
       (lambda (stx)
	 (syntax-case stx ()
	   [(_  super-expression (interface-expr ...)
		defn-or-expr
		...)
	    (main stx 
		  #'super-expression 
		  #f #f
		  (syntax->list #'(interface-expr ...))
		  (syntax->list #'(defn-or-expr ...)))]))
       ;; class
       (lambda (stx)
	 (syntax-case stx ()
	   [(_ super-expression
	       defn-or-expr
	       ...)
	    (main stx 
		  #'super-expression 
		  #f #f
		  null
		  (syntax->list #'(defn-or-expr ...)))]))
       ;; class/derived
       (lambda (stx)
	 (syntax-case stx ()
	   [(_  orig-stx
		[name-id super-expression (interface-expr ...) deserialize-id-expr]
		defn-or-expr
		...)
	    (main #'orig-stx 
		  #'super-expression 
		  #'deserialize-id-expr 
		  (and (syntax-e #'name-id) #'name-id)
		  (syntax->list #'(interface-expr ...))
		  (syntax->list #'(defn-or-expr ...)))])))))

  (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-object
				     #'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)])
		 (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) 
							     ((syntax-local-certifier) (quote-syntax gen-id)))
					  ...)))])
		 (syntax/loc stx
		   (begin
		     (define-values (gen-id ...)
		       (values (generate-local-member-name 'id) ...))
		     stx-defs))))))]))

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

  ;;--------------------------------------------------------------------
  ;;  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

			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
			object?        ; predicate
			make-object    ; : (-> object), constructor that creates an uninitialized object
			field-ref      ; accessor
			field-set!     ; mutator

			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
                                       ; :   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
			fixup          ; for deserialization

			no-super-init?); #t => no super-init needed
                    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

			 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
			 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 returned a non-class: ~a~a" 
		 super
		 (for-class name)))
    ;; -- Create new class's name --
    (let* ([name (or name
		     (let ([s (class-name super)])
		       (and s 
			    (not (eq? super object%))
			    (if (symbol? s)
				(format "derived-from-~a" s)
				s))))]
	   ;; Combine method lists
	   [public-names (append 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))]
	   [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-hash-table))]
	    [field-ht (if no-new-fields?
			  (class-field-ht super)
			  (make-hash-table))]
	    [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-table-put! method-ht (car ids) p)
	      (loop (cdr ids) (sub1 p)))))
	(unless no-new-fields?
	  (let loop ([ids super-field-ids])
	    (unless (null? ids)
	      (hash-table-put! field-ht (car ids) (hash-table-get super-field-ht (car ids)))
	      (loop (cdr ids)))))

	;; Put new ids in table, with pos (replace field pos with accessor info later)
	(unless no-new-methods?
	  (let loop ([ids public-names][p (class-method-width super)])
	    (unless (null? ids)
	      (when (hash-table-get method-ht (car ids) (lambda () #f))
		(obj-error 'class* "superclass already contains method: ~a~a" 
			   (car ids)
			   (for-class name)))
	      (hash-table-put! method-ht (car ids) p)
	      (loop (cdr ids) (add1 p)))))
	(unless no-new-fields?
	  (let loop ([ids public-field-names][p (class-field-width super)])
	    (unless (null? ids)
	      (when (hash-table-get field-ht (car ids) (lambda () #f))
		(obj-error 'class* "superclass already contains field: ~a~a" 
			   (car ids)
			   (for-class name)))
	      (hash-table-put! field-ht (car ids) p)
	      (loop (cdr ids) (add1 p)))))

	;; Check that superclass has expected fields
	(for-each (lambda (id)
		    (unless (hash-table-get field-ht id (lambda () #f))
		      (obj-error 'class* "superclass does not provide field: ~a~a" 
				 id
				 (for-class name))))
		  inherit-field-names)

	;; Check that superclass has expected methods, and get indices
	(let ([get-indices
	       (lambda (method-ht what ids)
		 (map
		  (lambda (id)
		    (hash-table-get 
		     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-table-get method-ht var (lambda () #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)]
		   [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-table-get 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)
				 (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
						   (class-struct:object super)
						   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))
				    inherit-field-names)
			       (map (lambda (id) (make-class-field-mutator super id))
				    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-table-put! 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 method for override, overment, "
							      "or rename-super is not overrideable: ~a~a")
							     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-table-get method-ht id) #t))
						   (append pubment-names overment-names))
					 (for-each (lambda (mname index)
						     (let ([depth (get-depth index)])
						       (when (negative? depth)
							 (obj-error 'class* 
								    (string-append
								     "superclass method for augride, augment, "
								     "or rename-inner method is not augmentable: ~a~a")
								    mname
								    (for-class name)))))
						   (append augride-normal-names
							   augment-final-names
							   rename-inner-names)
						   (append (get-indices method-ht "augride" augride-normal-names)
							   refine-final-indices
							   rename-inner-indices))
					 ;; Now that checking is done, add `augment':
					 (for-each (lambda (id)
						     (vector-set! new-augonly (hash-table-get method-ht id) #t))
						   augment-names)
					 (map (lambda (mname index)
						(let ([depth (get-depth index)])
						  (lambda (obj default)
						    (let* ([rename-inner (vector-ref (vector-ref (class-beta-methods (object-ref obj)) 
												 index)
										     depth)])
						      (or rename-inner
							  (lambda args default))))))
					      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-table-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))))
				    (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))
			;; 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-table-get 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-table-get 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-values (prop:object object? object-ref) (make-struct-type-property 'object))

  ;;--------------------------------------------------------------------
  ;;  interfaces
  ;;--------------------------------------------------------------------
  
  ;; >> Simplistic implementation for now <<

  (define-syntax _interface
    (lambda (stx)
      (syntax-case stx ()
	[(_ (interface-expr ...) var ...)
	 (let ([vars (syntax->list (syntax (var ...)))]
	       [name (syntax-local-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-object #f name #f)]
			 [(var ...) (map localize vars)])
	     (syntax/loc
	      stx
	      (compose-interface
	       'name
	       (list interface-expr ...)
	       `(var ...)))))])))

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

  (define (compose-interface name supers vars)
    (for-each
     (lambda (intf)
       (unless (interface? intf)
	 (obj-error 'interface 
		    "superinterface expression returned a non-interface: ~a~a" 
		    intf
		    (for-intf name))))
     supers)
    (let ([ht (make-hash-table)])
      (for-each
       (lambda (var)
	 (hash-table-put! ht var #t))
       vars)
      ;; Check that vars don't already exist in supers:
      (for-each
       (lambda (super)
	 (for-each
	  (lambda (var)
	    (when (hash-table-get ht var (lambda () #f))
	      (obj-error 'interface "variable already in superinterface: ~a~a~a" 
			 var
			 (for-intf name)
			 (let ([r (interface-name super)])
			   (if r
			       (format " already in: ~a" r)
			       "")))))
	  (interface-public-ids super)))
       supers)
      ;; Check for [conflicting] implementation requirements
      (let ([class (get-implement-requirement supers 'interface (for-intf name))]
	    [interface-make (if name
				(make-naming-constructor 
				 struct:interface
				 (string->symbol (format "interface:~a" name)))
				make-interface)])
	;; Add supervars to table:
	(for-each
	 (lambda (super)
	   (for-each
	    (lambda (var) (hash-table-put! ht var #t))
	    (interface-public-ids super)))
	 supers)
	;; Done
	(let ([i (interface-make name supers #f (hash-table-map ht (lambda (k v) k)) class)])
	  (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-hash-table)])
      (hash-table-put! ht i #t)
      (for-each (lambda (si)
		  (hash-table-for-each
		   (interface-all-implemented si)
		   (lambda (k v)
		     (hash-table-put! 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))
  (setup-all-implemented! object<%>)
  (define object% ((make-naming-constructor struct:class 'class:object%)
		   'object%
		   0 (vector #f) 
		   object<%>
		   void ; never inspectable

		   0 (make-hash-table) null
		   (vector) (vector) (vector)
		   
		   0 (make-hash-table) 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-syntax (new stx)
    (syntax-case stx ()
      [(_ cls (id arg) ...)
       (andmap identifier? (syntax->list (syntax (id ...))))
       (syntax/loc stx (instantiate 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 ...))))]))
  
  (define make-object 
    (lambda (class . args)
      (do-make-object class args null)))
  
  (define-syntax instantiate
    (lambda (stx)
      (syntax-case stx ()
	[(form class (arg ...) . x)
	 (with-syntax ([orig-stx stx])
	   (syntax/loc stx 
             (-instantiate do-make-object orig-stx (class) (list arg ...) . x)))])))

  ;; 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 (do-make-object class by-pos-args named-args)
    (unless (class? class)
      (raise-type-error 'instantiate "class" class))
    (let ([o ((class-make-object class))])
      ;; Initialize it:
      (continue-make-object o class by-pos-args named-args #t)
      o))

  (define (continue-make-object o c by-pos-args named-args explict-named-args?)
    (let ([by-pos-only? (not (class-init-args c))])
      ;; Primitive class with by-pos arguments?
      (when by-pos-only?
	(unless (null? named-args)
	  (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
	 [(and super (class-init-args super))
	  (do-merge al (class-init-args super) super named-args by-pos-args c)]
	 [(eq? 'list (class-init-mode ic))
	  ;; All unconsumed named-args must have #f
	  ;;  "name"s, otherwise an error is raised in
	  ;;  the leftovers checking.
	  (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)
    (let ([mk
	   (lambda (flatten?)
	     (lambda (stx)
	       (syntax-case stx ()
		 [(_ obj name . args)
		  (begin
		    (unless (identifier? (syntax name))
		      (raise-syntax-error
		       #f
		       "method name is not an identifier"
		       stx
		       (syntax name)))
		    (with-syntax ([name (localize (syntax name))])
		      (if flatten?
			  (if (stx-list? (syntax args))
			      (syntax (let-values ([(mth unwrapped-this)
						    (find-method/who 'send obj `name)])
					(apply mth unwrapped-this . args)))
			      (raise-syntax-error
			       #f
			       "bad syntax (illegal use of `.')"
			       stx))
			  (if (stx-list? (syntax args))
			      (syntax/loc stx
				(let-values ([(mth unwrapped-this)
					      (find-method/who 'send obj `name)])
				    (mth unwrapped-this . args)))
			      (with-syntax ([args (flatten-args (syntax args))])
				(syntax/loc stx
				  (let-values ([(mth unwrapped-this)
						(find-method/who 'send obj `name)])
				    (apply mth unwrapped-this . args))))))))])))])
      (values (mk #f) (mk #t))))
  
  (define-syntax send*
    (lambda (stx)
      (syntax-case stx ()
	[(_ obj s ...)
	 (with-syntax ([sends (map (lambda (s)
				     (syntax-case s ()
				       [(meth . args)
					(syntax/loc s (send o meth . args))]
				       [_else (raise-syntax-error
					       #f
					       "bad method call"
					       stx
					       s)]))
				   (syntax->list (syntax (s ...))))])
	   (syntax/loc stx
	     (let ([o obj])
	       . sends)))])))
    
  ;; 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-table-get (class-method-ht c) name (lambda () #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)
    (unless (class? class)
      (raise-type-error who "class" class))
    (unless (symbol? name)
      (raise-type-error who "symbol" name))
    (let ([p (hash-table-get (class-field-ht class) name
			     (lambda ()
			       (obj-error who "no such field: ~a~a"
					  name
					  (for-class (class-name class)))))])
      (which (cwhich (car p)) (cdr p))))
  
  (define (make-class-field-accessor class name)
    (class-field-X 'class-field-accessor
		   make-struct-field-accessor class-field-ref
		   class name))
  
  (define (make-class-field-mutator class name)
    (class-field-X 'class-field-mutator 
		   make-struct-field-mutator class-field-set!
		   class name))

  (define-struct generic (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
	      (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-table-get (class-method-ht class) name
					     (lambda ()
					       (obj-error 'make-generic "no such method: ~a~a"
							  name
							  (for-class (class-name class)))))])
		    (lambda (obj)
		      (unless ((class-object? class) obj)
			(raise-type-error 
			 (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))))))])
      make-generic))

  (define-syntax send-generic
    (lambda (stx)
      (syntax-case stx ()
	[(_ obj generic . args)
	 (if (stx-list? (syntax args))
	     (with-syntax ([call (syntax/loc stx
				   (((generic-applicable generic) this) this . args))])
	       (syntax/loc stx (let ([this obj])
				 call)))
	     (with-syntax ([args (flatten-args (syntax args))])
	       (with-syntax ([call (syntax/loc stx
				     (apply ((generic-applicable generic) this) this . args))])
		 (syntax (let ([this obj])
			   call)))))])))
  
  (define-syntaxes (class-field-accessor class-field-mutator generic/form)
    (let ([mk
	   (lambda (make targets)
	     (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])
		      (syntax/loc stx (make class-expr `name))))]
		 [(_ 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")
       (mk (quote-syntax make-class-field-mutator) "class")
       (mk (quote-syntax make-generic/proc) "class or interface"))))

  (define-syntax (get-field stx)
    (syntax-case stx ()
      [(_ name obj)
       (identifier? (syntax name))
       (with-syntax ([localized (localize (syntax name))])
         (syntax (get-field/proc `localized obj)))]
      [(_ name obj)
       (raise-syntax-error 'get-field "expected a field name as first argument" stx (syntax name))]))
  
  (define (get-field/proc id obj)
    (unless (object? obj)
      (raise-mismatch-error 
       'get-field
       "expected an object, got "
       obj))
    (let loop ([obj obj])
      (let* ([cls (object-ref obj)]
             [field-ht (class-field-ht cls)]
             [index (hash-table-get 
                     field-ht
                     id
                     (lambda () #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-syntax (field-bound? stx)
    (syntax-case stx ()
      [(_ name obj)
       (identifier? (syntax name))
       (with-syntax ([localized (localize (syntax name))])
         (syntax (field-bound?/proc `localized obj)))]
      [(_ name obj)
       (raise-syntax-error 'field-bound? "expected a field name as first argument" stx (syntax name))]))
  
  (define (field-bound?/proc id obj)
    (unless (object? obj)
      (raise-mismatch-error 
       'field-bound?
       "expected an object, got "
       obj))
    (let loop ([obj obj])
      (let* ([cls (object-ref obj)]
             [field-ht (class-field-ht cls)])
        (or (and (hash-table-get field-ht id (lambda () #f))
                 #t) ;; ensure that only #t and #f leak out, not bindings in ht
            (and (wrapper-object? obj)
                 (loop (wrapper-object-wrapped obj)))))))
  
  (define (field-names obj)
    (unless (object? obj)
      (raise-mismatch-error 
       'field-names
       "expected an object, got "
       obj))
    (let loop ([obj obj])
      (let* ([cls (object-ref obj)]
             [field-ht (class-field-ht cls)]
             [flds (filter interned? (hash-table-map field-ht (lambda (x y) x)))])
        (if (wrapper-object? obj)
            (append flds (loop (wrapper-object-wrapped obj)))
            flds))))
    
  (define-syntax with-method
    (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)])
	     (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
							       (quote-syntax set!)
							       (quote-syntax id)
							       (quote-syntax method)
							       (quote-syntax method-obj))]
							...)
				   ()
				 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))])))
  
  ;;--------------------------------------------------------------------
  ;;  class, interface, and object properties
  ;;--------------------------------------------------------------------
  
  (define (is-a? v c)
    (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 (object-interface o)
    (unless (object? o)
      (raise-type-error 'object-interface "object" o))
    (class-self-interface (object-ref (unwrap-object o))))

  (define (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))
    (let loop ([o o])
      (let* ([c (object-ref o)]
	     [pos (hash-table-get (class-method-ht c) name (lambda () #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-table-get (interface-all-implemented v) i (lambda () #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))
    ;; copy list, and also filter private (interned) methods:
    (apply list-immutable (filter interned? (interface-public-ids i))))

  
  (define (object-info o)
    (unless (object? o)
      (raise-type-error 'object-info "object" 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 (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 (class-name c)
			(- (class-field-width c) (class-field-width super))
			(apply list-immutable (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 object->vector
    (opt-lambda (in-o [opaque-v '...])
      (unless (object? in-o)
	(raise-type-error 'object->vector "object" 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
	   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, and a dispatcher function, and produces:
    ;    * a struct constructor (must have prop:object)
    ;    * a struct predicate
    ;    * a struct type for derived classes (mustn't have prop:object)
    ;
    ; The supplied 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%)
		   null
		   #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)
  ;;                        (listof (selector -> method-func-spec[object args -> result]))
  ;;                        (listof symbol)
  ;;                     -> 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)
    (let* ([supers (vector object% #f)]
           [method-ht (make-hash-table)]
           [method-count (length method-ids)]
           [methods-vec (make-vector method-count #f)]
           
           [field-ht (make-hash-table)]
           [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!
                        
                        (+ 1 field-count method-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
                                      (+ (length field-ids) (length method-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,
                 ;; all of the contract-ized versions of the methods,
                 ;; and all of the contract-ized versions of the fields
                 ;; just fill them into `o'.
                 (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
        (let loop ([i 0]
                   [methods methods])
          (when (< i method-count)
            (vector-set! methods-vec i ((car methods) field-ref))
            (loop (+ i 1)
                  (cdr methods))))
        
        ;; fill in the methods-ht
        (let loop ([i 0]
                   [method-ids method-ids])
          (when (< i method-count)
            (hash-table-put! method-ht (car method-ids) i)
            (loop (+ i 1)
                  (cdr method-ids))))
        
        ;; fill in the fields-ht
        (let loop ([i 0]
                   [field-ids field-ids])
          (when (< i field-count)
            (hash-table-put! field-ht (car field-ids) (cons cls (+ i method-count)))
            (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) () insp)

  (define (obj-error where . msg)
    (raise
     (make-exn:fail:object
      (string->immutable-string
       (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
                          (syntax/loc stx
                            (class* super% (to-ids ...)
                              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))
  
  (provide (protect make-wrapper-class
		    wrapper-object-wrapped
		    extract-vtable
		    extract-method-ht)
           
           (rename _class class) class* class/derived
           define-serializable-class define-serializable-class*
           class?
           mixin
	   (rename _interface interface) interface?
	   object% object? object=? externalizable<%>
           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
	   (rename generic/form generic) (rename make-generic/proc 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 exn:fail:object ())
	   make-primitive-class))

