;; Object system, same as MzScheme version 103 and earlier.

;; This was a fairly simple implementation until it was extended to
;;  handle primitive classes (e.g., for MrEd). Now it's a mess.

(module class-old mzscheme
  (require-for-syntax (lib "stx.ss""syntax")
		      (lib "name.ss""syntax"))

  (define insp (current-inspector))

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

  (define-struct class (name
			object-make object-slot-ref object-slot-set!
			width method-prim-vec
			pos supers
			interface
			public-ht public-ids 
			init-old-indices    ;; rename
			init-define-indices ;; override, public
			replace-indices     ;; override
			init-new-indices    ;; inherit, override, public
			go go-arity
			struct:prim prop:dispatch prim-methods
			immediate-primitive?))
  ;; simplistic implementation for now:
  (define-struct interface (name supers public-ids class))

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

  (define object<%> (make-interface 'object% null null #f))
  (define object% (make-class 'object%
			      'make-obj 'slot-ref 'slot-set! 0 (vector)
			      0 (vector #f) 
			      object<%>
			      (make-hash-table) 
			      null null null null null 
			      (lambda ()
				(let ([object%-init (lambda () (void))])
				  object%-init))
			      0
			      #f #f #f #f))
  (set-interface-class! object<%> object%)
  (vector-set! (class-supers object%) 0 object%)
  (define-values (struct:obj make-obj)
    (let-values ([(struct:obj make-obj obj? obj-accessor obj-mutator)
		  (make-struct-type 'object #f 0 0 #f (list (cons prop:object (box object%))) insp)])
      (set-class-object-make! object% make-obj)
      (set-class-object-slot-ref! object% obj-accessor)
      (set-class-object-slot-set!! object% obj-mutator)
      (values struct:obj make-obj)))

  (define (obj-class o)
    (unbox (object-ref o)))
  (define (slot-ref o p)
    (unbox/prim-resolve ((class-object-slot-ref (unbox (object-ref o))) o p) o))

  (define (make-naming-constructor type name)
    (let-values ([(struct: make- ? -accessor -mutator)
		  (make-struct-type name type 0 0 #f null insp)])
      make-))

  (define skip (gensym))

  (define-struct lazy-prim-method (m))

  (define (unbox/prim-resolve b o)
    (let ([v (unbox b)])
      (if (lazy-prim-method? v)
	  (begin
	    (set-box! b (lambda r (apply (lazy-prim-method-m v) o r)))
	    (unbox b))
	  v)))

  (define (make-prim-class struct:prim prim-side-box prop:dispatch prim-init name super old-mnames new-mnames methods)
    (let ([c (compose-class name (or super object%) null
			    null          ;; rename
			    null          ;; inherit
			    old-mnames    ;; override
			    new-mnames    ;; public
			    (let ([lazys
				   (map make-lazy-prim-method
					methods)])
			      (lambda (this super-init . pub-defines+pub-mutables)
				(lambda args
				  (if super (super-init skip) (super-init))
				  (unless (and (pair? args)
					       (eq? (car args) skip))
				    (apply prim-init this args))
				  (unless (null? pub-defines+pub-mutables)
				    ;; "define" all methods with lazy tokens:
				    (let loop ([ms lazys]
					       [l pub-defines+pub-mutables]) ; longer than ms
				      (unless (null? ms)
					(let ([m (car ms)])
					  (set-box! (car l) m))
					(loop (cdr ms) (cdr l))))))))
			    (box 0)
			    (list struct:prim prop:dispatch methods))])
      (set-box! prim-side-box c)
      c))

  (define-struct (exn:object exn) ())

  (define (obj-error where . msg)
    (raise
     (make-exn:object
      (string-append
       (format "~a: " where)
       (apply format msg))
      (current-continuation-marks))))

  (define (for-class name)
    (if name (format " for class: ~a" name) ""))
  (define (for-intf name)
    (if name (format " for interface: ~a" name) ""))

  (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))))))

  (define (compose-class name super interfaces 
			 use-pre-ids   ;; rename
			 use-final-ids ;; inherit
			 replace-ids   ;; override
			 new-ids       ;; public
			 go go-arity
			 primitive)
    (unless (class? super)
      (obj-error 'class*/names "superclass expression returned a non-class: ~a~a" 
		 super
		 (for-class 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))))])
      (for-each
       (lambda (intf)
	 (unless (interface? intf)
	   (obj-error 'class*/names "interface expression returned a non-interface: ~a~a" 
		      intf
		      (for-class name))))
       interfaces)
      (let ([ht (make-hash-table)]
	    [super-public-ids (class-public-ids super)])
	;; Put superclass ids in table, with pos
	(let loop ([ids super-public-ids][p 0])
	  (unless (null? ids)
	    (hash-table-put! ht (car ids) p)
	    (loop (cdr ids) (add1 p))))
	;; Put new ids in table, with pos
	(let loop ([ids new-ids][p (class-width super)])
	  (unless (null? ids)
	    (when (hash-table-get ht (car ids) (lambda () #f))
	      (obj-error 'class*/names "superclass already contains ivar: ~a~a" 
			 (car ids)
			 (for-class name)))
	    (hash-table-put! ht (car ids) p)
	    (loop (cdr ids) (add1 p))))
	;; Check that superclass has expected ids, and get indices
	(let ([get-indices
	       (lambda (ids)
		 (map
		  (lambda (id)
		    (hash-table-get 
		     ht id
		     (lambda ()
		       (obj-error 'class*/names 
				  "superclass does not provide an expected ivar: ~a~a" 
				  id
				  (for-class name)))))
		  ids))]
	      [width (+ (class-width super) (length new-ids))]
	      [prop:dispatch (or (and primitive (cadr primitive))
				 (class-prop:dispatch super))]
	      [methods (and primitive 
			    (list->vector
			     (append (if (class-prim-methods super)
					 (vector->list (class-prim-methods super))
					 null)
				     (caddr primitive))))])
	  (let ([define-indices (get-indices (append replace-ids new-ids))]
		[use-pre-indices (get-indices use-pre-ids)]
		[use-final-indices (get-indices use-final-ids)]
		[replace-indices (get-indices replace-ids)]
		[new-indices (get-indices new-ids)]
		[method-prim-vec (make-vector width (and primitive #t))])

	    ;; Copy super's method prim flags:
	    (let ([svec (class-method-prim-vec super)])
	      (let loop ([i (class-width super)])
		(unless (zero? i)
		  (let ([i (sub1 i)])
		    (vector-set! method-prim-vec i (vector-ref svec i))
		    (loop i)))))
	    ;; If not prim, set prim-method flag for overridings
	    (unless primitive
	      (for-each (lambda (i)
			  (vector-set! method-prim-vec i #f))
			replace-indices))

	    ;; Check here that all interface ivars are satisfied
	    (for-each
	     (lambda (intf)
	       (for-each
		(lambda (var)
		  (unless (hash-table-get ht var (lambda () #f))
		    (obj-error 'class*/names 
			       "interface-required variable missing: ~a~a~a" 
			       var
			       (for-class name)
			       (for-intf (interface-name intf)))))
		(interface-public-ids intf)))
	     interfaces)
	    (let ([c (get-implement-requirement interfaces 'class*/names (for-class name))])
	      (when (and c (not (subclass? super c)))
		(obj-error 'class*/names 
			   "interface-required implementation not satisfied~a~a"
			   (for-class name)
			   (let ([r (class-name c)])
			     (if r
				 (format " required class: ~a" r)
				 "")))))
	    ;; Make the class and its interface
	    (let* ([class-make (if name
				   (make-naming-constructor 
				    struct:class 
				    (string->symbol (format "class:~a" name)))
				   make-class)]
		   [interface-make (if name
				       (make-naming-constructor 
					struct:interface
					(string->symbol (format "interface:~a" name)))
				       make-interface)]
		   [public-ids (append super-public-ids new-ids)]
		   [super-interfaces (cons (class-interface super) interfaces)]
		   [i (interface-make name super-interfaces public-ids #f)]
		   [struct:prim (or (and primitive (car primitive))
				    (class-struct:prim super))]
		   [c (class-make name
				  'object-make 'object-slot-ref 'object-slot-set!
				  width method-prim-vec
				  (add1 (class-pos super))
				  (list->vector (append (vector->list (class-supers super)) (list #f)))
				  i
				  ht public-ids
				  use-pre-indices ;; rename
				  define-indices  ;; override, public
				  replace-indices ;; override
				  (append use-final-indices replace-indices new-indices) ;; inherit, override, public
				  go (if (box? go-arity)
					 (make-arity-at-least (unbox go-arity))
					 go-arity)
				  struct:prim prop:dispatch methods
				  (and primitive #t))]
		   [obj-name (if name 
				 (string->symbol (format "object:~a" name))
				 'object)])
	      (let-values ([(struct:object object-make object-slot-ref object-slot-set!)
			    (let-values ([(t make p a m)
					  (make-struct-type obj-name
							    (or struct:prim #f)
							    0 ;; No init fields
							    ;; Unless prim, add uninit fields for slots:
							    (if primitive
								0
								width)
							    'uninitialized-slot ;; anything for uninit val
							    (append
							     (if (and struct:prim (not primitive))
								 ;; Need dispatcher
								 (list (cons prop:dispatch
									     (lambda (ivar-name)
									       (let ([pos (hash-table-get ht ivar-name)])
										 (if (vector-ref method-prim-vec pos)
										     #f
										     (lambda (o . args)
										       (apply (slot-ref o pos) args)))))))
								 null)
							     ;; Add/override backbox:
							     (list
							      (cons prop:object (box #f))))
							    insp)])
			      (values t
				      make
				      (if primitive
					  ;; No slots - selector always manufactures a value
					  (lambda (o p)
					    (box (lambda r (apply (vector-ref methods p) o r))))
					  ;; Normal object slots:
					  a)
				      m))])
		(set-box! (object-ref struct:object) c)
		(set-class-object-make! c object-make)
		(set-class-object-slot-ref! c object-slot-ref)
		(set-class-object-slot-set!! c object-slot-set!)
		(vector-set! (class-supers c) (class-pos c) c)
		(set-interface-class! i c)
		c)))))))

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

  (define (make-object c . args)
    (unless (class? c)
      (apply raise-type-error 'make-object "class" 0 c args))
    (let ([this ((class-object-make c))])
      (let ([slot-ref (class-object-slot-ref c)]
	    [slot-set! (class-object-slot-set! c)]
	    [making-prim? (class-immediate-primitive? c)])
	(unless (class-immediate-primitive? c)
	  (let loop ([n (class-width c)])
	    (unless (= n 0)
	      (slot-set! this (sub1 n) (box undefined))
	      (loop (sub1 n)))))
	(let ([setup (let setup-class ([c c])
		       (if (zero? (class-pos c))
			   (lambda ()
			     ((class-go c)))
			   (let ([super (vector-ref (class-supers c) 
						    (sub1 (class-pos c)))])
			     (let ([super-setup (setup-class super)])
			       (let ([old-boxes (map (lambda (i)
						       (slot-ref this i))
						     (class-init-old-indices c))])
				 (for-each (lambda (i)
					     (slot-set! this i (box undefined)))
					   (if making-prim?
					       null
					       (class-replace-indices c)))
				 (let ([define-boxes (map (lambda (i)
							    (slot-ref this i))
							  (if making-prim?
							      null
							      (class-init-define-indices c)))])
				   (lambda ()
				     (let ([new-boxes (map (lambda (i)
							     (slot-ref this i))
							   (if making-prim?
							       null
							       (class-init-new-indices c)))]
					   [super-init (super-setup)]
					   [super-called? #f])
				       (letrec ([init (apply
						       (class-go c)
						       this
						       (lambda args
							 (when super-called?
							   (obj-error (or (object-name init)
									  'object-init)
								      "multiple intializations of superclass"))
							 (set! super-called? #t)
							 (apply super-init args)
							 ;; Force lazy method boxes that might be used directly:
							 (when (and (class-struct:prim c)
								    (not (class-immediate-primitive? c)))
							   (for-each (lambda (b) (unbox/prim-resolve b this)) old-boxes)
							   (for-each (lambda (b) (unbox/prim-resolve b this)) new-boxes)))
						       (append
							define-boxes  ;; override, public
							old-boxes     ;; rename
							new-boxes))]) ;; inherit, override, public
					 (lambda args
					   (apply init args)
					   (unless super-called?
					     (obj-error 
					      (or (object-name init)
						  'object-init)
					      "initialization did not invoke superclass initializer"))))))))))))])
	  (apply (setup) args)
	  this))))

  (define (is-a? v c)
    (cond
     [(class? c)
      (and (object? v)
	   (subclass? (obj-class v) c))]
     [(interface? c)
      (and (object? v)
	   (implementation? (obj-class 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 class->interface class-interface)
  (define (object-interface o) (class-interface (obj-class o)))

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

  (define (interface-extension? v i)
    (unless (interface? i)
      (raise-type-error 'interface-extension? "interface" 1 v i))
    (and (interface? i)
	 (let loop ([v v])
	   (or (eq? v i)
	       (ormap loop (interface-supers v))))))

  (define (ivar-in-interface? s i)
    (unless (symbol? s)
      (raise-type-error 'ivar-in-interface? "symbol" 0 s i))
    (unless (interface? i)
      (raise-type-error 'ivar-in-interface? "interface" 1 s i))
    (and (memq s (interface-public-ids i)) #t))

  (define (interface->ivar-names i)
    (unless (interface? i)
      (raise-type-error 'interface->ivar-names "interface" i))
					; copy list
    (map values (interface-public-ids i)))

  (define (class-initialization-arity c)
    (unless (class? c)
      (raise-type-error 'class-initialization-arity "class" c))
    (class-go-arity c))

  (define (ivar/proc o n)
    (unless (object? o)
      (raise-type-error 'ivar/proc "object" 0 o n))
    (let ([c (obj-class o)])
      (let ([p (hash-table-get
		(class-public-ht c)
		n
		(lambda () #f))])
	(if p
	    (slot-ref o p)
	    (begin
	       (unless (symbol? n)
		 (raise-type-error 'ivar/proc "symbol" 1 o n))
	       (obj-error 'ivar 
			  "instance variable not found: ~e~a in: ~e" 
			  n 
			  (for-class (class-name c))
			  o))))))
  
  (define-syntax ivar
    (lambda (stx)
      (syntax-case stx ()
	[(_ o m)
	 (identifier? (syntax m))
	 (syntax (ivar/proc o 'm))])))

  (define-syntax send
    (lambda (stx)
      (syntax-case stx ()
	[(_ o m arg ...)
	 (identifier? (syntax m))
	 (syntax ((ivar o m) arg ...))])))

  (define-syntax send*
    (lambda (stx)
      (syntax-case stx ()
	[(_ obj (meth arg ...) ...)
	 (syntax/loc stx
		     (let ([o obj])
		       (send o meth arg ...)
		       ...))])))
  
  (define (make-generic/proc c n)
    (unless (or (class? c) (interface? c))
      (raise-type-error 'make-generic "class or interface" 0 c n))
    (unless (symbol? n)
      (raise-type-error 'make-generic/proc "symbol" 1 c n))
    (if (class? c)
	(let ([p (hash-table-get
		  (class-public-ht c)
		  n
		  (lambda () #f))])
	  (if p
	      (lambda (o)
		(unless (is-a? o c)
		  (let ([name (string->symbol (format "generic~a" (for-class (class-name c))))])
		    (if (object? o)
			(obj-error name
				   "object not an instance of the generic's class: ~e"
				   o)
			(raise-type-error
			 name
			 "object"
			 o))))
		(slot-ref o p))
	      (obj-error 'make-generic 
			 "instance variable not found: ~e~a" 
			 n 
			 (for-class (class-name c)))))
	(begin
	  (unless (memq n (interface-public-ids c))
	    (obj-error 'make-generic 
		       "instance variable not found: ~e~a" 
		       n 
		       (for-intf (interface-name c))))
	  (lambda (o)
	    (unless (is-a? o c)
	      (let ([name (string->symbol (format "generic~a" (for-intf (interface-name c))))])
		(if (object? o)
		    (obj-error name
			       "object not an instance of the generic's interface: ~e"
			       o)
		    (raise-type-error
		     name
		     "object"
		     o))))
	    (ivar/proc o n)))))

  (define-syntax make-generic
    (lambda (stx)
      (syntax-case stx ()
	[(_ c n)
	 (identifier? (syntax n))
	 (syntax
	  (make-generic/proc c 'n))])))

  (define needs-init (gensym))

  (define-syntax class*/names
    (lambda (stx)
      (syntax-case stx ()
	[(_ (this-id super-init-id)
	    super-expr
	    (interface-expr ...)
	    init-vars
	    clauses ...)
	 (let ([se (lambda (msg expr)
		     (raise-syntax-error #f msg stx expr))])
	   ;; Check this and super-init:
	   (unless (identifier? (syntax this-id))
	     (se "not an identifier" (syntax this-id)))
	   (unless (identifier? (syntax super-init-id))
	     (se "not an identifier" (syntax super-init-id)))
	   ;; Unpack init arguments, with default expressions:
	   (let-values ([(init-ids init-defs init-rest-id)
			 (let loop ([inits (syntax init-vars)][need-def? #f])
			   (syntax-case inits ()
			     [() (values null null #f)]
			     [id (identifier? (syntax id))
				 (values null null (syntax id))]
			     [(id . rest) (identifier? (syntax id))
			      (begin
				(when need-def?
				  (se "expected identifier with default value" (syntax id)))
				(let-values ([(ids defs rest) (loop (syntax rest) #f)])
				  (values (cons (syntax id) ids)
					  (cons #f defs)
					  rest)))]
			     [((id def) . rest) (identifier? (syntax id))
			      (let-values ([(ids defs rest) (loop (syntax rest) #f)])
				(values (cons (syntax id) ids)
					(cons (syntax def) defs)
					rest))]
			     [(first . rest)
			      (se "bad initialization declaration" (syntax first))]
			     [else (se "improper identifier list" (syntax init-vars))]))])
	     ;; Unpack all body clauses:
	     (let* ([extract-ivars
		     ;; Unpacks a public, private, or override clause
		     (lambda (kind can-rename? decls)
		       (map
			(lambda (decl)
			  (syntax-case decl ()
			    [id (identifier? (syntax id))
				(list kind (syntax id) (syntax id) (syntax (void)))]
			    [(id expr) (identifier? (syntax id))
			     (list kind (syntax id) (syntax id) (syntax expr))]
			    [(id) (and can-rename? (identifier? (syntax id)))
			     (list kind (syntax id) (syntax id) (syntax (void)))]
			    [((iid eid) expr) (and can-rename?
						   (identifier? (syntax iid))
						   (identifier? (syntax eid)))
			     (list kind (syntax iid) (syntax eid) (syntax expr))]
			    [else (se (format "bad ~a clause" kind) (syntax decl))]))
			(syntax->list decls)))]
		    [body 
		     ;; Make a list of normalized clause-like lists, e.g:
		     ;;  (list (list 'public internal-id extenal-id expr) ...)
		     (apply
		      append
		      (map
		       (lambda (clause)
			 (syntax-case clause (public override private rename inherit sequence)
			   [(public decl ...)
			    (extract-ivars 'public #t (syntax (decl ...)))]
			   [(override decl ...)
			    (extract-ivars 'override #t (syntax (decl ...)))]
			   [(private decl ...)
			    (extract-ivars 'private #f (syntax (decl ...)))]
			   [(rename (iid eid) ...)
			    (let ([iids (syntax->list (syntax (iid ...)))]
				  [eids (syntax->list (syntax (eid ...)))])
			      (for-each (lambda (s)
					  (unless (identifier? s)
					    (se "expected an identifier" s)))
					(append iids eids))
			      (map (lambda (iid eid)
				     (list 'rename iid eid))
				   iids eids))]
			   [(inherit id ...)
			    (map
			     (lambda (decl)
			       (syntax-case decl ()
				 [id (identifier? (syntax id))
				     (list 'inherit (syntax id) (syntax id))]
				 [(iid eid) (and (identifier? (syntax iid))
						 (identifier? (syntax eid)))
				  (list 'inherit (syntax iid) (syntax eid))]
				 [else (se "bad inherit clause" decl)]))
			     (syntax->list (syntax (id ...))))]
			   [(sequence expr ...)
			    (map
			     (lambda (expr)
			       (list 'sequence expr))
			     (syntax->list (syntax (expr ...))))]
			   [else (se "not a class clause" clause)]))
		       (syntax->list (syntax (clauses ...)))))]
		    [get-info (lambda (tags select)
				(let loop ([body body])
				  (cond
				   [(null? body) null]
				   [(memq (caar body) tags)
				    (cons (select (car body)) (loop (cdr body)))]
				   [else (loop (cdr body))])))])
	       ;; Extract internal and external ids, and create xformed body:
	       (let ([new-eids (get-info '(public) caddr)]
		     [use-pre-eids (get-info '(rename) caddr)]
		     [use-final-eids (get-info '(inherit) caddr)]
		     [replace-eids (get-info '(override) caddr)]
		     [inherited-ids (get-info '(inherit rename) cadr)]
		     [public-ids (get-info '(public override) cadr)]
		     [private-ids (get-info '(private) cadr)]
		     [immutable-boxed-ids (append (get-info '(rename) cadr) ;; order matters!
						  (get-info '(inherit) cadr))]
		     [mutable-boxed-ids (append (get-info '(override) cadr) ;; order matters!
						(get-info '(public) cadr))])
		 (let* ([define-eids (append replace-eids new-eids)]
			[define-iids (generate-temporaries define-eids)]
			[body-exprs 
			 (map
			  ;; Map each declaration clause to a set!:
			  (lambda (clause)
			    (if (eq? (car clause) 'sequence)
				(cadr clause)
				(with-syntax ([id (cadr clause)]
					      [expr (cadddr clause)])
				  (if (memq (car clause) '(public override))
				      (let ([eid (caddr clause)])
					(with-syntax ([nid (let loop ([de define-eids]
								      [di define-iids])
							     (if (eq? eid (car de))
								 (car di)
								 (loop (cdr de) (cdr di))))])
					  ;; let sets name for expr:
					  (syntax (set-box! nid (let ([id expr]) id)))))
				      (syntax (set! id expr))))))
			  (get-info '(public override private sequence) values))]
			[name (syntax-local-infer-name stx)])
		   ;; Check for duplicates:
		   (cond
		    [(check-duplicate-identifier 
		      (append new-eids use-final-eids replace-eids))
		     => (lambda (name)
			  (se "duplicate declaration of external name" name))]
		    [(check-duplicate-identifier 
		      (append init-ids (if init-rest-id (list init-rest-id) null)
			      public-ids inherited-ids private-ids))
		     => (lambda (name)
			  (se "duplicate declaration of identifier" name))]
		    [else (void)])
		   ;; ---------- build the result ----------
		   ;; References to non-private ivars are converted to box
		   ;; references.
		   (with-syntax ([use-pre-eids use-pre-eids]
				 [use-final-eids use-final-eids]
				 [replace-eids replace-eids]
				 [new-eids new-eids]
				 [define-eids define-eids]
				 [(define-iid ...) define-iids]
				 [(immutable-box-id ...) (generate-temporaries immutable-boxed-ids)]
				 [(mutable-box-id ...) (generate-temporaries mutable-boxed-ids)]
				 [(immutable-boxed-id ...) immutable-boxed-ids]
				 [(mutable-boxed-id ...) mutable-boxed-ids]
				 [(private-id ...) private-ids]
				 [body-exprs (if (null? body-exprs)
						 (syntax ((void)))
						 body-exprs)]
				 [init (datum->syntax-object
					#f
					(if name
					    (string->symbol (format "~a-init" name))
					    'init)
					#f)]
				 [name (datum->syntax-object #f name #f)])
		     (with-syntax ([go 
				    ;; Create a sequence of case-lambda
				    ;; clauses, to implement init variable defaults:
				    (let loop ([vars-so-far null]
					       [vars-w/def-so-far null]
					       [def-so-far null]
					       [init-ids init-ids]
					       [init-defs init-defs])
				      (cond
				       [(null? init-ids)
					(with-syntax ([(var ...) (reverse vars-so-far)]
						      [(maybe-inited ...) (generate-temporaries vars-w/def-so-far)]
						      [(dvar ...) (reverse vars-w/def-so-far)]
						      [(def ...) (reverse def-so-far)]
						      [rest-id (if init-rest-id
								   init-rest-id
								   null)])
					  (syntax
					   ([(var ... maybe-inited ... . rest-id)
					     (let ([dvar undefined] ...)
					       (set! dvar (if (eq? maybe-inited needs-init)
							      def
							      maybe-inited)) ...
							      .
							      body-exprs)])))]
				       [else
					(with-syntax ([rest (loop (if (car init-defs)
								      vars-so-far
								      (cons (car init-ids) vars-so-far))
								  (if (car init-defs)
								      (cons (car init-ids) vars-w/def-so-far)
								      null)
								  (if (car init-defs)
								      (cons (car init-defs) def-so-far)
								      null)
								  (cdr init-ids)
								  (cdr init-defs))])
					  (if (car init-defs)
					      (with-syntax ([(var ...) (reverse vars-so-far)]
							    [(wd-var ...) (reverse vars-w/def-so-far)])
						(syntax ([(var ... wd-var ...) (init var ... wd-var ... needs-init)]
							 . rest)))
					      (syntax rest)))]))]
				   [go-arity (datum->syntax-object
					      #f
					      (let ([req (let loop ([l init-defs][c 0])
							   (if (or (null? l) (car l))
							       c
							       (loop (cdr l) (add1 c))))]
						    [cnt (length init-ids)])
						(cond
						 [init-rest-id
						  (box req)]
						 [(< req cnt)
						  (let loop ([req req])
						    (if (= req cnt)
							(list req)
							(cons req (loop (add1 req)))))]
						 [else req]))
					      #f)])
		       ;; Assemble the result as a `compose-class-info' call,
		       ;; which does all the run-time checks, and knows how
		       ;; to allocate objects and pass boxes to the init
		       ;; function.
		       (syntax/loc
			stx
			(compose-class
			 'name
			 super-expr
			 (list interface-expr ...)
			 'use-pre-eids   ;; rename
			 'use-final-eids ;; inherit
			 'replace-eids   ;; override
			 'new-eids       ;; public
			 (lambda (this-id super-init-id 
					  define-iid ...        ;; override, public
					  immutable-box-id ...  ;; rename, inherit
					  mutable-box-id ...)   ;; override, public
			   (let-syntax ([immutable-boxed-id
					 (make-set!-transformer
					  (lambda (stx)
					    (syntax-case stx (set!)
					      [vr (identifier? (syntax vr)) 
						  (syntax (unbox immutable-box-id))]
					      [(set! vr val)
					       (raise-syntax-error
						#f
						"cannot mutate an inherit or rename variable"
						stx)]
					      [(vr . args) (syntax ((unbox immutable-box-id) . args))])))]
					...
					[mutable-boxed-id
					 (make-set!-transformer
					  (lambda (stx)
					    (syntax-case stx (set!)
					      [vr (identifier? (syntax vr)) 
						  (syntax (unbox mutable-box-id))]
					      [(set! vr val)
					       (syntax 
						(set-box! mutable-box-id 
							  ;; let vr gives val the right name
							  (let ([vr val]) vr)))]
					      [(vr . args) (syntax ((unbox mutable-box-id) . args))])))]
					...)
			     (let ([private-id undefined] ...)
			       (letrec ([init (case-lambda . go)])
				 init))))
			 'go-arity
			 #f)))))))))]
	;; Error cases
	;; --
	[(_ bad-this-super
	    super-expr
	    (interface-expr ...)
	    init-vars
	    clauses ...)
	 (raise-syntax-error 
	  #f
	  "bad this and super bindings"
	  stx
	  (syntax bad-this-super))]
	;; --
	[(_ this-super
	    super-expr
	    bad-interface-seq
	    init-vars
	    clauses ...)
	 (raise-syntax-error 
	  #f
	  "expected sequence of interface expressions"
	  stx
	  (syntax bad-interface-seq))]
	;;
	[(_ this-super
	    super-expr
	    interface-seq)
	 (raise-syntax-error 
	  #f
	  "missing initialization arguments"
	  stx
	  (syntax bad-this-super))]
	[(_ this-super
	    super-expr)
	 (raise-syntax-error 
	  #f
	  "missing interface expressions"
	  stx
	  (syntax bad-this-super))]
	[(_ this-super)
	 (raise-syntax-error 
	  #f
	  "missing this and super-init bindings"
	  stx
	  (syntax bad-this-super))])))

  (define-syntax class*
    (lambda (stx)
      (syntax-case stx ()
	[(_ super-expr
	    (interface-expr ...)
	    init-vars
	    clauses ...)
	 (with-syntax ([this (datum->syntax-object (stx-car stx) 'this stx)]
		       [super-init (datum->syntax-object (stx-car stx) 'super-init stx)])
	   (syntax/loc
	    stx
	    (class*/names (this super-init)
			  super-expr 
			  (interface-expr ...)
			  init-vars
			  clauses ...)))])))

  (define-syntax :class
    (lambda (stx)
      (syntax-case stx ()
	[(_ super-expr
	    init-vars
	    clauses ...)
	 (with-syntax ([class* (datum->syntax-object (stx-car stx) 'class* stx)])
	   (syntax/loc stx (class* super-expr () init-vars clauses ...)))])))

  (define-syntax class*-asi
    (lambda (stx)
      (syntax-case stx ()
	[(_ super (interface ...) body ...)
	 (syntax/loc stx (class* super (interface ...) args
			   body ...))])))

  (define-syntax class-asi
    (lambda (stx)
      (syntax-case stx ()
	[(_ super body ...)
	 (syntax/loc stx (class* super () args
			   body ...))])))
  
  (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)])
	     (syntax/loc
	      stx
	      (compose-interface
	       'name
	       (list interface-expr ...)
	       '(var ...)))))])))

  (provide (rename :class class) class* class*/names
	   class-asi class*-asi
	   (rename :interface interface)
	   make-object object? is-a? subclass? class? interface?
	   class->interface object-interface
	   implementation? interface-extension?
	   ivar-in-interface? interface->ivar-names
	   class-initialization-arity
	   ivar send send* make-generic
	   ivar/proc make-generic/proc
	   object% ;; object<%>
	   exn:object? struct:exn:object make-exn:object

	   prop:object make-prim-class))