module: define-classes
rcs-header: $Header: /home/cvsroot/gd/src/d2c/compiler/convert/defclass.dylan,v 1.2 1998/09/09 13:40:19 andreas Exp $
copyright: Copyright (c) 1994  Carnegie Mellon University
	   All rights reserved.



//======================================================================
//
// Copyright (c) 1995, 1996, 1997  Carnegie Mellon University
// Copyright (c) 1998 Matthias Hölzl
// All rights reserved.
// 
// Use and copying of this software and preparation of derivative
// works based on this software are permitted, including commercial
// use, provided that the following conditions are observed:
// 
// 1. This copyright notice must be retained in full on any copies
//    and on appropriate parts of any derivative works.
// 2. Documentation (paper or online) accompanying any system that
//    incorporates this software, or any part of it, must acknowledge
//    the contribution of the Gwydion Project at Carnegie Mellon
//    University.
// 
// This software is made available "as is".  Neither the authors nor
// Carnegie Mellon University make any warranty about the software,
// its performance, or its conformity to any specification.
// 
// Bug reports, questions, comments, and suggestions should be sent by
// E-mail to the Internet address "gwydion-bugs@cs.cmu.edu".
//
//======================================================================

// <definition-parse>   		../parser/parse-tree.dylan
//   <define-class-parse>
//
// <abstract-slot-parse>
//   <slot-parse>
//   <inherited-slot-parse>
//   <init-arg-parse>
//
// <class-definition>        		../base/defns.dylan
//   <real-class-definition>
//     <local-class-definition>
//
// <slot-defn>
// <override-defn>
//
// <abstract-method-definition>		../front/func-defns.dylan
//   <maker-function-definition>
//   <init-function-definition>
//
// <parse-fragment-description>
//   <class-parse-fragment-descr>
//   <slot-parse-fragment-descr>
//
// <parse-description>
//   <class-parse-description>
//   <slot-parse-description>
//

// Parse tree stuff.
// ================

// <define-class-parse>
//
define class <define-class-parse> (<definition-parse>)
  constant slot defclass-name :: <identifier-token>,
    required-init-keyword: name:;
  constant slot defclass-superclass-exprs :: <simple-object-vector>,
    required-init-keyword: superclass-exprs:;
  constant slot defclass-slots :: <simple-object-vector>,
    required-init-keyword: slots:;
  constant slot defclass-options :: <simple-object-vector>,
    required-init-keyword: options:;
end class <define-class-parse>;


// make-define-class
//
// See macro `class-definer' in ../main/bootstrap.dylan.
//
define-procedural-expander
  (#"make-define-class",
   method (generator :: <expansion-generator>, name-frag :: <fragment>,
	   supers-frag :: <fragment>, slots-frag :: <fragment>,
	   options-frag :: <fragment>)
       => ();
     generate-fragment
       (generator,
	make-parsed-fragment
	  (make(<define-class-parse>,
		name: extract-name(name-frag),
		superclass-exprs: map(expression-from-fragment,
				      split-fragment-at-commas(supers-frag)),
		slots: map(extract-slot, split-fragment-at-commas(slots-frag)),
		options: parse-property-list(make(<fragment-tokenizer>,
						  fragment: options-frag))),
	   source-location: generate-token-source-location(generator)));
   end method);


// extract-slot -- internal.
//
// Checks whether `frag' is a slot parse and returns the token parse
// tree of `frag'.
//
define function extract-slot (frag :: <fragment>)
    => res :: <abstract-slot-parse>;
  if (instance?(frag, <token-fragment>)
	& frag.fragment-token.token-kind == $error-token
	& instance?(frag.fragment-token, <pre-parsed-token>)
	& instance?(frag.fragment-token.token-parse-tree,
		    <abstract-slot-parse>))
    frag.fragment-token.token-parse-tree;
  else
    error("bug in define class macro: %= isn't a slot parse", frag);
  end if;
end function extract-slot;


// <abstract-slot-parse>
//
define abstract class <abstract-slot-parse> (<object>)
end class <abstract-slot-parse>;


// <slot-parse>
//
define class <slot-parse> (<abstract-slot-parse>)
  constant slot slot-parse-name :: <identifier-token>,
    required-init-keyword: name:;
  constant slot slot-parse-options :: <simple-object-vector>,
    required-init-keyword: options:;
end class <slot-parse>;


// make-slot
//
// See macro `class-definer' in ../main/bootstrap.dylan.
//
define-procedural-expander
  (#"make-slot",
   method (generator :: <expansion-generator>, name-frag :: <fragment>,
	   options-frag :: <fragment>)
    => ();
     generate-fragment
       (generator,
	make-magic-fragment
	  (make(<slot-parse>,
		name: extract-name(name-frag),
		options: parse-property-list(make(<fragment-tokenizer>,
						  fragment: options-frag))),
	   source-location: generate-token-source-location(generator)))
   end method);


// <inherited-slot-parse>
//
define class <inherited-slot-parse> (<abstract-slot-parse>)
  constant slot inherited-slot-parse-name :: <identifier-token>,
    required-init-keyword: name:;
  constant slot inherited-slot-parse-options :: <simple-object-vector>,
    required-init-keyword: options:;
end class <inherited-slot-parse>;


// make-inherited-slot
//
// See macro `class-definer' in ../main/bootstrap.dylan.
//
define-procedural-expander
  (#"make-inherited-slot",
   method (generator :: <expansion-generator>, name-frag :: <fragment>,
	   options-frag :: <fragment>)
    => ();
     generate-fragment
       (generator,
	make-magic-fragment
	  (make(<inherited-slot-parse>,
		name: extract-name(name-frag),
		options: parse-property-list(make(<fragment-tokenizer>,
						  fragment: options-frag))),
	   source-location: generate-token-source-location(generator)))
   end method);


// <init-arg-parse>
//
define class <init-arg-parse> (<abstract-slot-parse>)
  constant slot init-arg-parse-keyword :: <symbol>,
    required-init-keyword: keyword:;
  constant slot init-arg-parse-options :: <simple-object-vector>,
    required-init-keyword: options:;
end class <init-arg-parse>;


// make-init-arg
//
// See macro `class-definer' in ../main/bootstrap.dylan.
//
define-procedural-expander
  (#"make-init-arg",
   method (generator :: <expansion-generator>, keyword-frag :: <fragment>,
	   options-frag :: <fragment>)
    => ();
     generate-fragment
       (generator,
	make-magic-fragment
	  (make(<init-arg-parse>,
		keyword: extract-keyword(keyword-frag),
		options: parse-property-list(make(<fragment-tokenizer>,
						  fragment: options-frag))),
	   source-location: generate-token-source-location(generator)))
   end method);


// extract-keyword -- internal.
//
// Checks whether `frag' is a keyword and returns its literal value.
//
define function extract-keyword (frag :: <fragment>)
    => keyword :: <symbol>;
  if (instance?(frag, <token-fragment>)
	& frag.fragment-token.token-kind == $symbol-token)
    frag.fragment-token.token-literal.literal-value;
  else
    error("Bug in define class macro: %= isn't a keyword.", frag);
  end if;
end function extract-keyword;

// <real-class-definition> 
//
define class <real-class-definition> (<class-definition>)
  //
  // The <cclass> for this class definition, #f if unknown (e.g. non-constant
  // superclasses), #"not-computed-yet" if we haven't computed it yet, or
  // #"computing" if we are actively working on it.
  slot class-defn-cclass
    :: type-union(<cclass>, one-of(#f, #"not-computed-yet", #"computing")),
    init-value: #"not-computed-yet", init-keyword: class:;
  //
  // Defered evaluations function, of #f if there isn't one.
  slot %class-defn-defered-evaluations-function
    :: type-union(<ct-function>, one-of(#f, #"not-computed-yet")),
    init-value: #"not-computed-yet";
  //
  // The maker function, of #f if there isn't one.
  slot %class-defn-maker-function
    :: type-union(<ct-function>, one-of(#f, #"not-computed-yet")),
    init-value: #"not-computed-yet";
end;


// defn-type  -- method on exported GF.
//
// Return the compile-time-value for <class>.
//
define method defn-type (defn :: <real-class-definition>) => res :: <cclass>;
  dylan-value(#"<class>");
end;


// <local-class-definition>
//
define class <local-class-definition> (<real-class-definition>)
  // 
  // Vector of <expression-parse>s for the superclasses.
  slot class-defn-supers :: <simple-object-vector>,
    required-init-keyword: supers:;
  //
  // Several boolean flags, just what the names say.
  slot class-defn-functional? :: <boolean>,
    required-init-keyword: functional:;
  slot class-defn-sealed? :: <boolean>,
    required-init-keyword: sealed:;
  slot class-defn-abstract? :: <boolean>,
    required-init-keyword: abstract:;
  slot class-defn-primary? :: <boolean>,
    required-init-keyword: primary:;
  //
  // Vector of the slots.
  slot class-defn-slots :: <simple-object-vector>,
    required-init-keyword: slots:;
  //
  // Vector of slot init value overrides.
  slot class-defn-overrides :: <simple-object-vector>,
    required-init-keyword: overrides:;
end;  


// <slot-defn>
//
define class <slot-defn> (<object>)
  //
  // The class that introduces this slot.
  slot slot-defn-class :: <real-class-definition>;
  //
  // #t if this slot is sealed, #f if not.  This really means that the getter
  // generic function is sealed on this class and the setter (if any) is sealed
  // on object and this class.
  slot slot-defn-sealed? :: <boolean>,
    required-init-keyword: sealed:;
  //
  // The allocation of this slot.
  slot slot-defn-allocation :: <slot-allocation>,
    required-init-keyword: allocation:;
  //
  // The expression to compute the type.
  slot slot-defn-type :: false-or(<expression-parse>),
    required-init-keyword: type:;
  //
  // The name of the getter generic function.
  slot slot-defn-getter-name :: <name>,
    required-init-keyword: getter-name:;
  //
  // The getter method.  Filled in when computed.
  slot slot-defn-getter :: <getter-method-definition>;
  //
  // The name of the setter generic function, or #f if there is no setter.
  slot slot-defn-setter-name :: false-or(<name>),
    required-init-keyword: setter-name:;
  //
  // The setter method.  Filled in when computed.
  slot slot-defn-setter :: false-or(<setter-method-definition>);
  //
  // The init-value expression, or #f if one wasn't supplied.
  slot slot-defn-init-value :: false-or(<expression-parse>),
    init-value: #f, init-keyword: init-value:;
  //
  // The init-function, or #f if there isn't one.
  slot slot-defn-init-function :: false-or(<expression-parse>),
    init-value: #f, init-keyword: init-function:;
  //
  // The init-keyword, or #f if there isn't one.
  slot slot-defn-init-keyword :: false-or(<symbol>),
    init-value: #f, init-keyword: init-keyword:;
  //
  // #t if the init-keyword is required, #f if not.
  slot slot-defn-init-keyword-required? :: <boolean>,
    init-value: #f, init-keyword: init-keyword-required:;
  //
  // The sizer slot defn.
  slot slot-defn-sizer-defn :: false-or(<slot-defn>),
    init-value: #f, init-keyword: sizer-defn:;

  // The slot-info for this slot, or #f if we haven't computed it or don't know
  // enough about the class to compute it at all.
  slot slot-defn-info :: false-or(<slot-info>),
    init-value: #f;
end;


// <override-defn>
//
define class <override-defn> (<object>)
  //
  // The class that introduces this override.
  slot override-defn-class :: <real-class-definition>;
  //
  // The name of the getter.
  slot override-defn-getter-name :: <name>,
    required-init-keyword: getter-name:;
  //
  // The init-value expression, or #f if none.
  slot override-defn-init-value :: false-or(<expression-parse>),
    init-value: #f, init-keyword: init-value:;
  //
  // The init-function expression, or #f if none.
  slot override-defn-init-function :: false-or(<expression-parse>),
    init-value: #f, init-keyword: init-function:;
  //
  // The <override-info> for this override, or #f if we haven't computed it
  // or don't know enough about the class to compute it at all.
  slot override-defn-info :: false-or(<override-info>),
    init-value: #f;
end;


// <maker-function-definition>
//
define class <maker-function-definition> (<abstract-method-definition>)
  slot maker-func-defn-class-defn :: <class-definition>,
    init-keyword: class-defn:;
end class <maker-function-definition>;

define sealed domain make (singleton(<maker-function-definition>));
define sealed domain initialize (<maker-function-definition>);


// <init-function-definition>
//
define class <init-function-definition> (<abstract-method-definition>)
  slot init-func-defn-method-parse :: false-or(<method-parse>),
    init-value: #f, init-keyword: method-parse:;
end class <init-function-definition>;


// Parse descriptions.
// ==================
//
// When processing top level forms we need to gather a lot of
// information about the form on which we are currently working.  If
// we store this information into local variables we have long
// argument lists and therefore strong coupling between the functions
// that work on the form and we make it unnecessarily hard to factor
// out subtasks because we need to figure out exactly which
// information each task needs.  To avoid this we define some classes
// that hold all this data.  These classes are not generally useful,
// they just faciliate the following functions.
//
// We use two classes for each parse: a <parse-fragment-description>
// that holds the raw fragments, and a <parse-description> which is
// built from the <parse-fragment-description> and some other
// information and stores the "abstract" information that is more
// commonly needed during processing of the top level form.

// <parse-fragment-description> -- internal.
//
// Subclasses of <parse-fragment-description> are mostly needed to
// build instances of <parse-description> and for error reporting.
//
define abstract class <parse-fragment-description> (<object>)
end class;


// make-parse-fragment-descr -- internal GF.
//
// Generate a <parse-fragment-description>.  Not sure yet about the
// correct constraint on `parse'.
//
define generic make-parse-fragment-descr (parse :: <object>)
 => (fragment-description :: <parse-fragment-description>);


// <parse-description> -- internal.
//
// During the processing of top-level forms we pass around an instance
// of a subclasses of <parse-description> that holds all information
// about the tlf in question.  Note that there is not generic
// `make-parse-descr' since every type of <parse-description> needs
// different additional info.
//
define abstract class <parse-description> (<object>)
end class;


// <class-parse-fragment-descri> -- internal.
//
// Fragment description for <define-class-parse>.
//
define class <class-parse-fragment-descr> (<parse-fragment-description>)
  slot functional?-fragment :: false-or(<fragment>),
    init-keyword: functional?-fragment:;
  slot sealed?-fragment :: false-or(<fragment>),
    init-keyword: sealed?-fragment:;
  slot primary?-fragment :: false-or(<fragment>),
    init-keyword: primary?-fragment:;
  slot abstract?-fragment :: false-or(<fragment>),
    init-keyword: abstract?-fragment:;
end class <class-parse-fragment-descr>;


// make-parse-fragment-descr {<define-class-parse>} -- internal.
//
define method make-parse-fragment-descr
    (class-parse :: <define-class-parse>)
 => (fragment-description :: <class-parse-fragment-descr>);
  let (class-functional?-frag, class-sealed?-frag, class-primary?-frag,
       class-abstract?-frag)
    = extract-properties(class-parse.defclass-options,
			 #"functional", #"sealed",
			 #"primary", #"abstract");
  make(<class-parse-fragment-descr>,
       functional?-fragment: class-functional?-frag,
       sealed?-fragment: class-sealed?-frag,
       primary?-fragment: class-primary?-frag,
       abstract?-fragment: class-abstract?-frag);
end method make-parse-fragment-descr;


// <class-parse-description> -- internal.
//
// A helper class that contains all the infomation that
// `process-top-level-form' needs about a class parse.
//
define class <class-parse-description> (<parse-description>)
  slot name :: <symbol>,
    init-keyword: name:;
  slot is-functional? :: <boolean>,
    init-keyword: is-functional?:;
  slot is-sealed? :: <boolean>,
    init-keyword: is-sealed?:;
  slot is-primary? :: <boolean>,
    init-keyword: is-primary?:;
  slot is-abstract? :: <boolean>,
    init-keyword: is-abstract?:;
  slot slots :: <stretchy-vector>,
    init-keyword: slots:;
  slot overrides :: <stretchy-vector>,
    init-keyword: overrides:;
end class <class-parse-description>;


// make-class-parse-description -- internal.
//
// Create a <class-parse-description> from a <define-class-parse> and
// a <class-parse-fragment-descr>.
//
define inline function make-class-parse-description
    (class-parse :: <define-class-parse>,
     descr ::  <class-parse-fragment-descr>)
 => (description :: <class-parse-description>);
  make(<class-parse-description>,
       name: class-parse.defclass-name.token-symbol,
       is-functional?:
	 descr.functional?-fragment
	 & extract-boolean(descr.functional?-fragment),
       is-sealed?:
	 ~descr.sealed?-fragment
	 | extract-boolean(descr.sealed?-fragment),
       is-primary?:
	 descr.primary?-fragment
	 & extract-boolean(descr.primary?-fragment),
       is-abstract?:
	 descr.abstract?-fragment
	 & extract-boolean(descr.abstract?-fragment),
       slots: make(<stretchy-vector>),
       overrides: make(<stretchy-vector>));
end function make-class-parse-description;


// <slot-parse-fragment-descr>
//
define class <slot-parse-fragment-descr> (<parse-fragment-description>)
  slot  sealed?-fragment :: false-or(<fragment>),
    init-keyword:  sealed?-fragment:;
  slot  allocation-fragment :: false-or(<fragment>),
    init-keyword:  allocation-fragment:;
  slot  type-fragment :: false-or(<fragment>),
    init-keyword:  type-fragment:;
  slot  setter-fragment :: false-or(<fragment>),
    init-keyword:  setter-fragment:;
  slot  init-keyword-fragment :: false-or(<fragment>),
    init-keyword:  init-keyword-fragment:;
  slot  req-init-keyword-fragment :: false-or(<fragment>),
    init-keyword:  req-init-keyword-fragment:;
  slot  init-value-fragment :: false-or(<fragment>),
    init-keyword:  init-value-fragment:;
  slot  init-expr-fragment :: false-or(<fragment>),
    init-keyword:  init-expr-fragment:;
  slot  init-function-fragment :: false-or(<fragment>),
    init-keyword:  init-function-fragment:;
  slot  sizer-fragment :: false-or(<fragment>),
    init-keyword:  sizer-fragment:;
  slot  size-init-keyword-fragment :: false-or(<fragment>),
    init-keyword:  size-init-keyword-fragment:;
  slot  req-size-init-keyword-fragment :: false-or(<fragment>),
    init-keyword:  req-size-init-keyword-fragment:;
  slot  size-init-value-fragment :: false-or(<fragment>),
    init-keyword:  size-init-value-fragment:;
  slot size-init-function-fragment :: false-or(<fragment>),
    init-keyword: size-init-function-fragment:;
end class <slot-parse-fragment-descr>;


// make-parse-fragment-descr {<abstract-slot-parse>} -- internal.
//
define method make-parse-fragment-descr
    (slot :: <abstract-slot-parse>)
 => (fragment-description :: <slot-parse-fragment-descr>);
  let (sealed?-frag, allocation-frag, type-frag, setter-frag,
       init-keyword-frag, req-init-keyword-frag, init-value-frag,
       init-expr-frag, init-function-frag, sizer-frag,
       size-init-keyword-frag, req-size-init-keyword-frag,
       size-init-value-frag, size-init-function-frag)
    = extract-properties(slot.slot-parse-options,
			 sealed:, allocation:, type:, setter:,
			 init-keyword:, required-init-keyword:,
			 init-value:, init-expr:, init-function:,
			 sizer:, size-init-keyword:,
			 required-size-init-keyword:,
			 size-init-value:, size-init-function:);
  make(<slot-parse-fragment-descr>,
       sealed?-fragment: sealed?-frag,
       allocation-fragment:  allocation-frag,
       type-fragment: type-frag,
       setter-fragment: setter-frag,
       init-keyword-fragment: init-keyword-frag,
       req-init-keyword-fragment: req-init-keyword-frag,
       init-value-fragment: init-value-frag,
       init-expr-fragment: init-expr-frag,
       init-function-fragment: init-function-frag,
       sizer-fragment: sizer-frag,
       size-init-keyword-fragment: size-init-keyword-frag,
       req-size-init-keyword-fragment: req-size-init-keyword-frag,
       size-init-value-fragment: size-init-value-frag,
       size-init-function-fragment: size-init-function-frag);
end method make-parse-fragment-descr;


// <slot-parse-description>
//
// Info about a slot parse.
//
define class <slot-parse-description> (<parse-description>)
  slot getter :: <symbol>,
    init-keyword: getter:;
  slot is-sealed? :: <boolean>,
    init-keyword: is-sealed?:;
  slot allocation :: <symbol>,
    init-keyword: allocation:;
  slot type :: false-or(<expression-parse>),
    init-keyword: type:;
  slot setter :: false-or(<symbol>),
    init-keyword: setter:;
  slot init-keyword :: false-or(<symbol>),
    init-keyword: init-keyword:;
  slot req-init-keyword :: false-or(<symbol>),
    init-keyword: req-init-keyword:;
  slot init-value :: false-or(<expression-parse>),
    init-keyword: init-value:;
  slot init-expr :: false-or(<expression-parse>),
    init-keyword: init-expr:;
  slot init-function :: false-or(<expression-parse>),
    init-keyword: init-function:;
  slot sizer :: false-or(<symbol>),
    init-keyword: sizer:;
  slot size-init-keyword :: false-or(<symbol>),
    init-keyword: size-init-keyword:;
  slot req-size-init-keyword :: false-or(<symbol>),
    init-keyword: req-size-init-keyword:;
  slot size-init-value :: false-or(<expression-parse>),
    init-keyword: size-init-value:;
  slot size-init-function :: false-or(<expression-parse>),
    init-keyword: size-init-function:;
end class <slot-parse-description>;


// make-slot-parse-descr
//
define inline function make-slot-parse-descr
    (class :: <class-parse-description>,
     slot :: <abstract-slot-parse>,
     fragment :: <slot-parse-fragment-descr>)
 => (description :: <slot-parse-description>);
  let allocation :: <symbol>
    = if (fragment.allocation-fragment)
	extract-identifier(fragment.allocation-fragment).token-symbol;
      else
	#"instance";
      end;
  let getter :: <symbol> = slot.slot-parse-name.token-symbol;

  make(<slot-parse-description>,
       getter: getter,
       is-sealed?:
	 fragment.sealed?-fragment
	 & extract-boolean(fragment.sealed?-fragment),
       allocation: allocation,
       type:
	 fragment.type-fragment
	 & expression-from-fragment(fragment.type-fragment),
       setter:
	 if (class.is-functional? & allocation == #"instance")
	   let id
	     = fragment.setter-fragment
	     & extract-identifier-or-false(fragment.setter-fragment);
	   if (id)
	     compiler-warning-location
	       (id,
		"Instance allocation slots in functional classes can't"
		  " have a setter.");
	   end;
	   #f;
	 elseif (fragment.setter-fragment)
	   let id = extract-identifier-or-false(fragment.setter-fragment);
	   id & id.token-symbol;
	 else
	   symcat(getter, "-setter");
	 end,
       init-keyword:
	 (fragment.init-keyword-fragment
	    & extract-keyword(fragment.init-keyword-fragment)),
       req-init-keyword:
	 (fragment.req-init-keyword-fragment
	    & extract-keyword(fragment.req-init-keyword-fragment)),
       init-value:
	 (fragment.init-value-fragment
	    & expression-from-fragment(fragment.init-value-fragment)),
       init-expr:
	 (fragment.init-expr-fragment
	    & expression-from-fragment(fragment.init-expr-fragment)),
       init-function:
	 (fragment.init-function-fragment
	    & expression-from-fragment(fragment.init-function-fragment)),
       sizer:
	 (fragment.sizer-fragment
	    & extract-identifier(fragment.sizer-fragment).token-symbol),
       size-init-keyword:
	 (fragment.size-init-keyword-fragment
	    & extract-keyword(fragment.size-init-keyword-fragment)),
       req-size-init-keyword:
	 (fragment.req-size-init-keyword-fragment
	    & extract-keyword(fragment.req-size-init-keyword-fragment)),
       size-init-value:
	 (fragment.size-init-value-fragment
	    & expression-from-fragment(fragment.size-init-value-fragment)),
       size-init-function:
	 (fragment.size-init-function-fragment
	    & expression-from-fragment(fragment.size-init-function-fragment)));
end function make-slot-parse-descr;


// extract-identifier-or-false -- internal.
//
define function extract-identifier-or-false (fragment :: <token-fragment>)
    => res :: false-or(<identifier-token>);
  let token = fragment.fragment-token;
  select (token.token-kind)
    $false-token =>
      #f;
    $raw-ordinary-word-token, $ordinary-define-body-word-token,
    $ordinary-define-list-word-token, $quoted-name-token =>
      token;
    otherwise =>
      compiler-fatal-error
	("invalid identifier: %s", token);
  end select;
end function extract-identifier-or-false;


// extract-identifier -- internal.
//
define function extract-identifier (fragment :: <token-fragment>)
    => res :: false-or(<identifier-token>);
  let token = fragment.fragment-token;
  select (token.token-kind)
    $raw-ordinary-word-token, $ordinary-define-body-word-token,
    $ordinary-define-list-word-token, $quoted-name-token =>
      token;
    otherwise =>
      compiler-fatal-error
	("invalid identifier: %s", token);
  end select;
end function extract-identifier;

// Top level form processing.
// =========================

// During top level form processing, we parse the `define class' form
// and build the necessary <local-class-definition>, <slot-defn>, and
// <override-defn> objects.  We only check for syntactic errors and
// local semantic errors.  By local semantic errors, I mean errors
// that can be detected by looking at nothing more than this class
// itself.
//
// We also note the class definition and any implicit definitions for
// slot accessors.

// process-top-level-form {<define-class-parse>}
//    -- method on imported GF.
//
define method process-top-level-form (form :: <define-class-parse>) => ();
  let class-fragments :: <class-parse-fragment-descr>
    = make-parse-fragment-descr(form);
  let class :: <class-parse-description>
    = make-class-parse-description(form, class-fragments);
  
  add-%object-class-override(form, class);
  process-slots(form, class);

  let defn
    = make-local-class-definition(form, class);
  implicitly-define-generics(class.slots, defn);
  assign-override-classes(class.overrides, defn);

  note-variable-definition(defn);
  add!(*Top-Level-Forms*, make(<define-class-tlf>, defn: defn));
end method process-top-level-form;


// add-%object-class-override -- internal.
//
// If `class' is not abstract and has superclasses we add an override
// for the `%object-class' slot.
//
define inline function add-%object-class-override
    (class-parse :: <define-class-parse>,
     class :: <class-parse-description>)
 => ();
  unless (class.is-abstract? | empty?(class-parse.defclass-superclass-exprs))
    add!(class.overrides,
	 make(<override-defn>,
	      getter-name: make(<basic-name>,
				symbol: #"%object-class",
				module: $Dylan-Module),
	      init-value: make(<varref-parse>,
			       id: class-parse.defclass-name)));
  end;
end function add-%object-class-override;


// process-slots -- internal.
//
define inline function process-slots
    (class-parse :: <define-class-parse>,
     class :: <class-parse-description>)
 => ();
  for (option in class-parse.defclass-slots)
    block ()
      process-slot(class, option);
    exception (<fatal-error-recovery-restart>)
      #f;
    end block;
  end for;
end function process-slots;


// make-local-class-definition -- internal.
//
define inline function make-local-class-definition
    (class-parse :: <define-class-parse>,
     class :: <class-parse-description>)
 => (definition :: <local-class-definition>);
  
  let slots = as(<simple-object-vector>, class.slots);
  let overrides = as(<simple-object-vector>, class.overrides);

  make(<local-class-definition>,
       name: make(<basic-name>,
		  symbol: class.name,
		  module: *Current-Module*),
       library: *Current-Library*,
       supers: class-parse.defclass-superclass-exprs,
       functional: class.is-functional?,
       sealed: class.is-sealed?,
       primary: class.is-primary?,
       abstract: class.is-abstract?,
       slots: slots,
       overrides: overrides);
end function make-local-class-definition;


// implicitly-define-generics -- internal.
//
// Create the implicit definitions for the accessor generic functions.
//
define inline function  implicitly-define-generics
    (slots :: <stretchy-vector>, defn :: <local-class-definition>)
 => ()
  for (slot in slots)
    slot.slot-defn-class := defn;
    //
    // Implicity define the accessor generics.
    if (slot.slot-defn-sizer-defn)
      implicitly-define-generic
	(*Current-Library*, slot.slot-defn-getter-name, 2, #f, #f);
      if (slot.slot-defn-setter-name)
	implicitly-define-generic
	  (*Current-Library*, slot.slot-defn-setter-name, 3, #f, #f);
      end;
    else
      implicitly-define-generic
	(*Current-Library*, slot.slot-defn-getter-name, 1, #f, #f);
      if (slot.slot-defn-setter-name)
	implicitly-define-generic
	  (*Current-Library*, slot.slot-defn-setter-name, 2, #f, #f);
      end;
    end;
  end;
end function implicitly-define-generics;


// assign-override-classes -- internal
//
define inline function assign-override-classes
    (overrides :: <stretchy-vector>, defn :: <local-class-definition>);
  for (override in overrides)
    override.override-defn-class := defn;
  end for;
end function assign-override-classes;

// Processing slots.
// ================

// process-slot -- internal GF.
//
define generic process-slot
    (parse :: <parse-description>, slot :: <abstract-slot-parse>)
 => ();


// process-slot {<slot-parse>} -- internal.
//
define method process-slot
    (class :: <class-parse-description>,
     slot :: <slot-parse>)
    => ();
  let slot-fragment-descr :: <slot-parse-fragment-descr>
    = make-parse-fragment-descr(slot);
  let slot-descr :: <slot-parse-description>
    = make-slot-parse-descr(class, slot, slot-fragment-descr);
  check-slot-inits(slot-descr, slot-fragment-descr);

  let getter-name
    = make(<basic-name>, symbol: slot-descr.getter,
	   module: *Current-Module*);
  let setter-name
    = slot-descr.setter
      & make(<basic-name>, symbol: slot-descr.setter,
	     module: *Current-Module*);
  let size-defn :: false-or(<slot-defn>)
    = make-sizer-slot-definition(class, slot-descr, slot-fragment-descr);
  
  let slot = make(<slot-defn>,
		  sealed: slot-descr.is-sealed? & #t,
		  allocation: slot-descr.allocation,
		  type: slot-descr.type,
		  getter-name: getter-name,
		  setter-name: setter-name,
		  init-value: slot-descr.init-value,
		  init-function: slot-descr.init-function,
		  init-keyword:
		    slot-descr.init-keyword
		    | slot-descr.req-init-keyword,
		  sizer-defn: size-defn,
		  init-keyword-required:
		    slot-descr.req-init-keyword & #t);
  add!(class.slots, slot);
end method process-slot;


// check-slot-inits -- internal.
//
// Check whether the init value, keyword and function arguments for
// `slot-descr' are allowed.  `Fragment-descr' is only used to find
// the location when we repor an error.
//
define inline function check-slot-inits
    (slot-descr :: <slot-parse-description>,
     fragment-descr :: <slot-parse-fragment-descr>)
 => ();
  if (slot-descr.init-value)
    if (slot-descr.init-expr)
      compiler-fatal-error-location
	(slot-descr.init-value,
	 "Can't supply both an init-value: and an init-expression.");
    end if;
    if (slot-descr.init-function)
      compiler-fatal-error-location
	(slot-descr.init-value,
	 "Can't supply both an init-value: and an init-function:.");
    end;
    if (slot-descr.req-init-keyword)
      compiler-fatal-error-location
	(slot-descr.init-value,
	 "Can't supply both an init-value: and a required-init-keyword:.");
    end;
  elseif (slot-descr.init-expr)
    if (slot-descr.init-function)
      compiler-fatal-error-location
	(slot-descr.init-expr,
	 "Can't supply both an init-function: and an init-expression.");
    end if;
    if (slot-descr.req-init-keyword)
      compiler-fatal-error-location
	(slot-descr.init-expr,
	 "Can't supply both an init-value: and a required-init-keyword:.");
    end;
    if (instance?(slot-descr.init-expr, <literal-ref-parse>))
      slot-descr.init-value := slot-descr.init-expr;
    else
      slot-descr.init-function
	:= make(<method-ref-parse>,
		method: make(<method-parse>,
			     parameters: make(<parameter-list>, fixed: #[]),
			     body: slot-descr.init-expr));
    end if;
  elseif (slot-descr.init-function)
    if (slot-descr.req-init-keyword)
      compiler-fatal-error-location
	(slot-descr.init-function,
	 "Can't supply both an init-function: and a "
	   "required-init-keyword:.");
    end;
  end;
  if (slot-descr.init-keyword & slot-descr.req-init-keyword)
    compiler-fatal-error-location
      (simplify-source-location
	 (fragment-descr.init-keyword-fragment.source-location),
       "Can't supply both an init-keyword: and a required-init-keyword:.");
  end;
end function;


// make-sizer-slot-definition -- internal.
//
// If `class' has a variable sized slot we check its arguments and add
// a slot definition to `class', otherwise we check whether any
// arguments for the sizer slot are provided and report an error if
// this is the case.
//
define inline function make-sizer-slot-definition
    (class :: <class-parse-description>,
     slot-descr :: <slot-parse-description>,
     fragment-descr :: <slot-parse-fragment-descr>)
 => (sizer-definition :: false-or(<slot-defn>));
  if (slot-descr.sizer)
    let sizer-name
      = make(<basic-name>,
	     symbol: slot-descr.sizer,
	     module: *Current-Module*);
    
    check-for-sizer-slot-error(slot-descr, fragment-descr);
    let slot :: <slot-defn>
      = make(<slot-defn>,
	     sealed: slot-descr.is-sealed?,
	     allocation: #"instance",
	     type:
	       make(<varref-parse>,
		    id: make(<identifier-token>,
			     kind: $raw-ordinary-word-token,
			     symbol: #"<integer>",
			     module: $Dylan-Module,
			     uniquifier: make(<uniquifier>))),
	     getter-name: sizer-name,
	     setter-name: #f,
	     init-value: slot-descr.size-init-value,
	     init-function: slot-descr.size-init-function,
	     init-keyword:
	       slot-descr.size-init-keyword
	       | slot-descr.req-size-init-keyword,
	     init-keyword-required:
	       slot-descr.req-size-init-keyword & #t);
    add!(class.slots, slot);
    slot;
  else
    check-for-no-sizer-slot-error(slot-descr, fragment-descr);
    #f;
  end;
end function make-sizer-slot-definition;


// check-for-sizer-slot-error -- internal.
//
// Do the error checking for `make-sizer-slot-definition' in the case
// that the class has a sizer slot.
//
define inline function check-for-sizer-slot-error
    (slot-descr :: <slot-parse-description>,
     fragment-descr :: <slot-parse-fragment-descr>)
 => ();
  unless (slot-descr.allocation == #"instance")
    compiler-fatal-error-location
      (simplify-source-location(sizer-fragment.source-location),
       "Only instance allocation slots can be variable length, but "
	 "%s has %s allocation",
       slot-descr.getter, slot-descr.allocation);
  end unless;
  
  if (slot-descr.size-init-value)
    if (slot-descr.size-init-function)
      compiler-fatal-error-location
	(slot-descr.size-init-value,
	 "Can't have both a size-init-value: and size-init-function:");
    end if;
  elseif (~(slot-descr.size-init-function
	      | slot-descr.req-size-init-keyword))
    compiler-fatal-error
      ("The Initial size for vector slot %s must be supplied somehow.",
       slot-descr.getter);
  end if;
  
  if (slot-descr.size-init-keyword
	& slot-descr.req-size-init-keyword)
    compiler-fatal-error-location
      (simplify-source-location
	 (fragment-descr.size-init-keyword-fragment.source-location),
       "Can't have both a size-init-keyword: and a "
	 "required-size-init-keyword:");
  end if;
end function check-for-sizer-slot-error;


// check-for-sizer-slot-error -- internal.
//
// Do the error checking for `make-sizer-slot-definition' in the case
// that the class does not have a sizer slot.
//
define inline function check-for-no-sizer-slot-error
    (slot-descr :: <slot-parse-description>,
     fragment-descr :: <slot-parse-fragment-descr>)
 => ();
  if (slot-descr.size-init-value)
    compiler-fatal-error-location
      (slot-descr.size-init-value,
       "Can't supply a size-init-value: without a sizer: generic "
	 "function");
  end;
  if (slot-descr.size-init-function)
    compiler-fatal-error-location
      (slot-descr.size-init-function,
       "Can't supply a size-init-function: without a "
	 "sizer: generic function");
  end;
  if (slot-descr.size-init-keyword)
    compiler-fatal-error-location
      (simplify-source-location
	 (fragment-descr.size-init-keyword-fragment.source-location),
       "Can't supply a size-init-keyword: without a "
	 "sizer: generic function");
  end;
  if (slot-descr.req-size-init-keyword)
    compiler-fatal-error-location
      (simplify-source-location
	 (fragment-descr.req-size-init-keyword-fragment.source-location),
       "Can't supply a required-size-init-keyword: "
	 "without a sizer: generic function");
  end;
end function check-for-no-sizer-slot-error;


// process-slot {<inherited-slot-parse>} -- internal.
//
define method process-slot
    (class :: <class-parse-description>,
     slot :: <inherited-slot-parse>)
    => ();
  let (init-value-frag, init-expr-frag, init-function-frag)
    = extract-properties(slot.inherited-slot-parse-options,
			 init-value:, init-expr:, init-function:);

  let init-value
    = init-value-frag & expression-from-fragment(init-value-frag);
  let init-expr
    = init-expr-frag & expression-from-fragment(init-expr-frag);
  let init-function
    = init-function-frag & expression-from-fragment(init-function-frag);

  if (init-value)
    if (init-expr)
      compiler-fatal-error-location
	(init-expr,
	 "Can't supply both an init-value: and an init-expression.");
    end if;
    if (init-function)
      compiler-fatal-error-location
	(init-function,
	 "Can't supply both an init-value: and an init-function:.");
    end;
  elseif (init-expr)
    if (init-function)
      compiler-fatal-error-location
	(init-function,
	 "Can't supply both an init-function: and an init-expression.");
    end if;
    if (instance?(init-expr, <literal-ref-parse>))
      init-value := init-expr;
    else
      init-function
	:= make(<method-ref-parse>,
		method: make(<method-parse>,
			     parameters: make(<parameter-list>, fixed: #[]),
			     body: init-expr));
    end if;
  end;

  add!(class.overrides,
       make(<override-defn>,
	    getter-name:
	      make(<basic-name>,
		   symbol: slot.inherited-slot-parse-name.token-symbol,
		   module: *Current-Module*),
	    init-value: init-value,
	    init-function: init-function));
end method process-slot;


// process-slot {<init-arg-parse>} -- internal.
//
define method process-slot
    (class :: <class-parse-description>,
     slot :: <init-arg-parse>)
 => ();
  let (required?-frag, type-frag, init-value-frag, init-function-frag)
    = extract-properties(slot.init-arg-parse-options,
			 required:, type:, init-value:, init-function:);

  let required? = required?-frag & extract-boolean(required?-frag);
  let type = type-frag & expression-from-fragment(type-frag);
  let init-value = init-value-frag & expression-from-fragment(init-value-frag);
  let init-function
    = init-function-frag & expression-from-fragment(init-function-frag);

  if (required?)
    if (init-value)
      compiler-fatal-error-location
	(init-value,
	 "Can't supply an init-value: for required keyword init arg specs");
    end;
    if (init-function)
      compiler-fatal-error-location
	(init-function,
	 "Can't supply an init-function: for required keyword init arg specs");
    end;
  elseif (init-value)
    if (init-function)
      compiler-fatal-error-location
	(init-value,
	 "Can't supply both an init-value: and an "
	   "init-function: for keyword init arg specs");
    end;
  end;
  // ### Need to do something with it.
end method process-slot;

// CT-Values.
// =========

// ct-value {<real-class-definition>}
//    -- method on exported GF.
//
// Return the compile-time value for a class definition, computing it
// if necessary.  This is the <cclass> object of a class definition.
// If we can't compute that for some reason, return #f to indicate
// that this class doesn't have a compile-time value.
//
define method ct-value (defn :: <real-class-definition>)
    => res :: false-or(<cclass>);
  select (defn.class-defn-cclass)
    #"not-computed-yet" =>
      defn.class-defn-cclass := compute-cclass(defn);
    #"computing" =>
      compiler-error-location
	(defn,
	 "class %s circularly defined.",
	 defn.defn-name.name-symbol);
      #f;
    otherwise =>
      defn.class-defn-cclass;
  end;
end;


// compute-cclass  -- internal.
//
// Compute the <cclass> for `defn'.
//
define function compute-cclass (defn :: <local-class-definition>)
    => res :: false-or(<cclass>);
  //
  // Mark that we are trying to compute this class.
  defn.class-defn-cclass := #"computing";
  //
  // Evaluate the superclasses, and check them for validity.
  let super-exprs = defn.class-defn-supers;
  let nsupers = super-exprs.size;
  let supers = make(<simple-object-vector>, size: nsupers);
  let closest-super = #f;
  let closest-primary = #f;
  let bogus? = #f;
  local
    method check-class-for-violations
	(super :: false-or(<ct-value>),
	 super-expr :: <constituent-parse>,
	 index :: <integer>)
     => ();
      //
      // Store the superclass.
      supers[index] := super;
      
      error-if-sealing-violation(super, super-expr);
      warning-if-illegal-abstract-superclass(super, super-expr);
      //
      // Check that everything is okay with the functional adjective.
      if (defn.class-defn-functional?)
	error-if-non-functional-superclass(super, super-expr);
      else
	error-if-functional-superclass(super, super-expr);
      end if;
      error-if-unrelated-primaries(super, super-expr);
    end method check-class-for-violations,
    //
    // error-if-sealing-violation
    //
    method error-if-sealing-violation
	(super :: false-or(<ct-value>),
	 super-expr :: <constituent-parse>)
     => ();
      //
      // Make sure we arn't trying to inherit from a sealed class.
      if (super.sealed? & super.loaded?)
	compiler-error-location
	  (super-expr.source-location,
	   "%s can't inherit from %s because %s is sealed.",
	   defn.defn-name, super, super);
	bogus? := #t;
      end if;
    end method error-if-sealing-violation,
    //
    // warning-if-illegal-abstract-superclass
    //
    method warning-if-illegal-abstract-superclass
	(super :: false-or(<ct-value>),
	 super-expr :: <constituent-parse>)
     => ();
      //
      // Check that everything is okay with the abstract adjective.
      if (defn.class-defn-abstract? & ~super.abstract?)
	compiler-warning-location
	  (super-expr.source-location,
	   "abstract class %s can't inherit from %s because "
	     "%s is concrete -- ignoring abstract abjective.",
	   defn.defn-name, super, super);
	defn.class-defn-abstract? := #f;
      end if;
    end method warning-if-illegal-abstract-superclass,
    //
    // error-if-non-functional-superclass
    //
    method error-if-non-functional-superclass
	(super :: false-or(<ct-value>),
	 super-expr :: <constituent-parse>)
     => ();
      //
      // Make sure we arn't trying to inherit from anything we can't.
      if (super.not-functional?)
	compiler-error-location
	  (super-expr.source-location,
	   "functional class %s can't inherit from %s "
	     "because %s %s and is not functional.",
	   defn.defn-name, super, super,
	   if (super.abstract?)
	     "has instance slots";
	   else
	     "is concrete";
	   end if);
	bogus? := #t;
      end if;
    end method error-if-non-functional-superclass,
    //
    // error-if-functional-superclass
    //
    method error-if-functional-superclass
	(super :: false-or(<ct-value>),
	 super-expr :: <constituent-parse>)
     => ();
      //
      // It isn't a functional class, so make sure we arn't trying to
      // inherit from a functional class.
      if (super.functional?)
	compiler-error-location
	  (super-expr.source-location,
	   "class %s can't inherit from %s because %s is functional.",
	   defn.defn-name, super, super);
	bogus? := #t;
      end if;
    end method error-if-functional-superclass,
    //
    // error-if-unrelated-primaries
    //
    method error-if-unrelated-primaries
	(super :: false-or(<ct-value>),
	 super-expr :: <constituent-parse>)
     => ();
      //
      // Check to see if this superclass's closest-primary-superclass
      // is closer than any of the others so far.
      let other-primary = super.closest-primary-superclass;
      if (~closest-primary | csubtype?(other-primary, closest-primary))
	closest-super := super;
	closest-primary := other-primary;
      elseif (~csubtype?(closest-primary, other-primary))
	local method describe (primary, super)
		if (primary == super)
		  as(<string>, primary.cclass-name.name-symbol);
		else
		  format-to-string("%s (inherited via %s)",
				   primary.cclass-name.name-symbol,
				   super.cclass-name.name-symbol);
		end;
	      end;
	compiler-error-location
	  (super-expr.source-location,
	   "%s can't inherit from %s and %s because they are both primary "
	     "and neither is a subclass of the other.",
	   defn.defn-name,
	   describe(closest-primary, closest-super),
	   describe(other-primary, super));
	bogus? := #t;
      end if;
    end method error-if-unrelated-primaries,
    //
    // superclass-not-cclass-error
    //
    method superclass-not-cclass-error
	(super :: false-or(<ct-value>),
	 super-expr :: <constituent-parse>,
	 index :: <integer>)
     => ();
      if (super)
	compiler-error-location
	  (super-expr.source-location,
	   "%s superclass of %s is not a class: %s.",
	   integer-to-english(index + 1, as: #"ordinal"),
	   defn.defn-name, super);
      else
	compiler-warning-location
	  (super-expr.source-location,
	   "%s superclass of %s is not obviously a constant.",
	   integer-to-english(index + 1, as: #"ordinal"),
	   defn.defn-name);
      end if;
      bogus? := #t;
    end method superclass-not-cclass-error;


  for (index from 0 below nsupers)
    let super-expr :: <constituent-parse>
      = super-exprs[index];
    let super :: false-or(<ct-value>)
      = ct-eval(super-expr, #f);
    if (instance?(super, <cclass>))
      check-class-for-violations(super, super-expr, index);
    else
      //
      // The superclass isn't a <class>.  So complain.
      superclass-not-cclass-error(super, super-expr, index);
    end if;
  end for;

  if (defn == dylan-defn(#"<object>"))
    unless (nsupers.zero?)
      error("<object> has superclasses?");
    end unless;
  else
    if (nsupers.zero?)
      compiler-error-location
	(defn, "%s has no superclasses.", defn.defn-name);
      bogus? := #t;
    elseif (closest-primary == #f & ~bogus?)
      error("<object> isn't being inherited or isn't primary?");
    end if;
  end if;

  unless (bogus?)
    //
    // Compute the slots and overrides.
    let slot-infos = map(compute-slot, defn.class-defn-slots);
    let override-infos = map(compute-override, defn.class-defn-overrides);
    //
    // Make and return the <cclass>.
    make-defined-cclass(defn, supers, slot-infos, override-infos);
  end unless;
end function compute-cclass;


// make-defined-cclass -- internal.
//
// Return a <defined-cclass> for `defn'.
//
define inline function make-defined-cclass
    (defn :: <real-class-definition>,
     supers :: <simple-object-vector>,
     slot-infos :: <simple-object-vector>,
     override-infos :: <simple-object-vector>)
 => (cclass :: <defined-cclass>);
  make(<defined-cclass>,
       loading: #f,
       name: defn.defn-name,
       defn: defn,
       direct-superclasses: as(<list>, supers),
       not-functional:
	 // Do we proclude functional subclasses?
	 if (defn.class-defn-functional?)
	   #f;
	 elseif (defn.class-defn-abstract?)
	   ~supers.empty?
	     & (any?(not-functional?, supers)
		  | any?(inhibits-functional-classes?, slot-infos));
	 else
	   #t;
	 end,
       functional: defn.class-defn-functional?,
       sealed: defn.class-defn-sealed?,
       primary: defn.class-defn-primary?,
       abstract: defn.class-defn-abstract?,
       slots: slot-infos,
       overrides: override-infos);
end function make-defined-cclass;


// compute-slot  -- internal.
//
define inline function compute-slot
    (slot :: <slot-defn>)
 => info :: <slot-info>;
  //
  // Note: we don't pass in anything for the type, init-value, or
  // init-function, because we need to compile-time-eval those, which we
  // can't do until tlf-finalization time.
  let info
    = if (slot.slot-defn-sizer-defn)
	make-slot-info-for-sizer-slot(slot);
      else
	make-slot-info-for-standard-slot(slot);
      end;
  slot.slot-defn-info := info;
  info;
end function compute-slot;


// make-slot-info-for-sizer-slot -- internal.
//
define inline function make-slot-info-for-sizer-slot
    (slot :: <slot-defn>)
 => (info :: <slot-info>);
  let getter-name = slot.slot-defn-getter-name;
  make(<vector-slot-info>,
       getter: find-variable(getter-name, create: #t),
       read-only: slot.slot-defn-setter-name == #f,
       init-value: slot.slot-defn-init-value & #t,
       init-function: slot.slot-defn-init-function & #t,
       init-keyword: slot.slot-defn-init-keyword,
       init-keyword-required:
	 slot.slot-defn-init-keyword-required?,
       size-slot: slot.slot-defn-sizer-defn.slot-defn-info);
end function make-slot-info-for-sizer-slot;


// make-slot-info-for-standard-slot -- internal.
//
define inline function make-slot-info-for-standard-slot
    (slot :: <slot-defn>)
 => (info :: <slot-info>);
  let getter-name = slot.slot-defn-getter-name;
  make(<slot-info>,
       allocation: slot.slot-defn-allocation,
       getter: find-variable(getter-name, create: #t),
       read-only: slot.slot-defn-setter-name == #f,
       init-value: slot.slot-defn-init-value & #t,
       init-function: slot.slot-defn-init-function & #t,
       init-keyword: slot.slot-defn-init-keyword,
       init-keyword-required:
	 slot.slot-defn-init-keyword-required?);
end function make-slot-info-for-standard-slot;
  
// compute-override -- internal.
//
define inline function compute-override
    (override :: <override-defn>) => info :: <override-info>;
  let getter-name = override.override-defn-getter-name;
  //
  // Note: we don't pass in anything for the init-value or init-function,
  // because we need to compile-time-eval those, which we can't do until
  // tlf-finalization time.
  let info = make(<override-info>,
		  getter: find-variable(getter-name, create: #t),
		  init-value: override.override-defn-init-value & #t,
		  init-function: override.override-defn-init-function & #t);
  override.override-defn-info := info;
  info;
end function compute-override;


// inhibits-functionsl-classes? -- internal GF.
//
define generic inhibits-functional-classes?
    (slot :: <slot-info>) => res :: <boolean>;


// inhibits-functional-classes? {<slot-info>}
//    -- method on internal GF.
//
define method inhibits-functional-classes?
    (slot :: <slot-info>) => res :: <boolean>;
  #f;
end method inhibits-functional-classes?;


// inhibits-functional-classes? {<instance-slot-info>}
//    -- method on internal GF.
//
define method inhibits-functional-classes?
    (slot :: <instance-slot-info>) => res :: <boolean>;
  #t;
end method inhibits-functional-classes?;

// Top level form finalization.
// ===========================

// finalize-top-level-form {<define-class-tlf>}
//    -- method on imported GF.
//
define method finalize-top-level-form (tlf :: <define-class-tlf>) => ();
  let defn :: <definition> = tlf.tlf-defn;
  //
  // Compute the cclass if it hasn't been computed yet.
  let cclass :: false-or(<cclass>)
    = compute-tlf-cclass-if-necessary(defn);
  let class-type = cclass | make(<unknown-ctype>);

  // Finalize the slots.
  for (slot in defn.class-defn-slots)
    finalize-slot(slot, cclass, class-type, tlf);
  end for;

  // Finalize the overrides.
  for (override in defn.class-defn-overrides)
    finalize-tlf-override(override, tlf);
  end for;
end method finalize-top-level-form;


// compute--tlfcclass-if-necessary -- internal.
//
// Compute `defn''s cclass if it is not yet computed, otherwise return
// whatever was previously computed.
//
define inline function compute-tlf-cclass-if-necessary
    (defn :: <definition>)
 => cclass :: false-or(<cclass>);
  if (defn.class-defn-cclass == #"not-computed-yet")
    defn.class-defn-cclass := compute-cclass(defn);
  else
    defn.class-defn-cclass;
  end;
end function compute-tlf-cclass-if-necessary;


// finalize-tlf-override  -- internal.
//
// Finalize `override'.
//
define inline function finalize-tlf-override
    (override :: <override-defn>,
     tlf :: <define-class-tlf>)
 => ();
  // Fill in the <override-info> with the init value.
  let info = override.override-defn-info;
  if (info)
    if (override.override-defn-init-function)
      let (ctv, change-to-init-value?)
	= maybe-define-init-function(override.override-defn-init-function, 
				     override.override-defn-getter-name,
				     tlf);
      if (ctv)
	if (change-to-init-value?)
	  info.override-init-function := #f;
	  info.override-init-value := ctv;
	else
	  info.override-init-function := ctv;
	end if;
      end if;
    elseif (override.override-defn-init-value)
      let init-val = ct-eval(override.override-defn-init-value, #f);
      if (init-val)
	info.override-init-value := init-val;
      end if;
    end if;
  end if;
end function finalize-tlf-override;


// finalize-slot
//
// Finalize `slot'.
//
// (Inlined because it has only one call site).
//
define inline function finalize-slot
    (slot :: <slot-defn>, cclass :: false-or(<cclass>),
     class-type :: <ctype>, tlf :: <define-class-tlf>)
    => ();
  //
  // Compute the type of the slot.
  let slot-type :: <ctype> = compute-slot-type(slot);

  let specializers :: <list>
    = if (slot.slot-defn-sizer-defn)
	list(class-type, specifier-type(#"<integer>"));
      else
	list(class-type);
      end;

  // Fill in the <slot-info> with the type, init value, and init-function
  fill-in-slot-info(slot, slot-type, tlf);
  
  // Define the accessor methods.
  define-slot-accessors(slot, slot-type, cclass, tlf, specializers);
end function finalize-slot;


// compute-slot-type  -- internal.
//
define inline function compute-slot-type
    (slot :: <slot-defn>)
 => slot-type :: <ctype>;
  if (slot.slot-defn-type)
    let type = ct-eval(slot.slot-defn-type, #f);
    if (instance?(type, <ctype>))
      type;
    else
      make(<unknown-ctype>);
    end;
  else
    object-ctype();
  end;
end function compute-slot-type;


// fill-in-slot-info  -- internal.
//
define inline function fill-in-slot-info
    (slot :: <slot-defn>, slot-type :: <ctype>,
     tlf :: <define-class-tlf>)
 => ();
  let info = slot.slot-defn-info;
  if (info)
    info.slot-type := slot-type;
    if (slot.slot-defn-init-function)
      let (ctv, change-to-init-value?)
	= maybe-define-init-function(slot.slot-defn-init-function,
				     slot.slot-defn-getter-name,
				     tlf);
      if (ctv)
	if (change-to-init-value?)
	  info.slot-init-function := #f;
	  info.slot-init-value := ctv;
	else
	  info.slot-init-function := ctv;
	end if;
      end if;
    elseif (slot.slot-defn-init-value)
      let init-val = ct-eval(slot.slot-defn-init-value, #f);
      if (init-val)
	info.slot-init-value := init-val;
      end if;
    end if;
  end if;
end function fill-in-slot-info;


// define-slot-accessors  -- internal.
//
define inline function define-slot-accessors
    (slot :: <slot-defn>, slot-type :: <ctype>,
     cclass :: false-or(<cclass>), tlf :: <define-class-tlf>,
     specializers :: <list>)
 => ();    
  local
    //
    // set-slot-defn-getter  -- internal.
    //
    method set-slot-defn-getter
	(library :: <library>, hairy? :: <boolean>)
     => ();
      slot.slot-defn-getter
	:= make(<getter-method-definition>,
		base-name: slot.slot-defn-getter-name,
		library: library,
		signature: make(<signature>,
				specializers: specializers,
				returns: slot-type),
		hairy: hairy?,
		slot: slot.slot-defn-info);
    end method set-slot-defn-getter,
    //
    // add-slot-defn-getter-to-gf
    //
    method add-slot-defn-getter-to-gf () => ();            
      let gf :: false-or(<generic-definition>)
	= slot.slot-defn-getter.method-defn-of;
      if (gf)
	ct-add-method(gf, slot.slot-defn-getter);
      end;
    end method add-slot-defn-getter-to-gf,
    //
    // add-seal-if-necessary
    //
    method add-seal-if-necessary(library :: <library>) => ();
      let gf :: false-or(<generic-definition>)
	= slot.slot-defn-getter.method-defn-of;
      if (slot.slot-defn-sealed?)
	if (gf)
	  add-seal(gf, library, specializers, tlf);
	else
	  compiler-error
	    ("%s doesn't name a generic function, so can't be sealed.",
	     slot.slot-defn-getter-name);
	end if;
      end if;
    end method add-seal-if-necessary,
    //
    // set-slot-defn-setter
    //
    method set-slot-defn-setter
	(library :: <library>, hairy? :: <boolean>)
     => ();
      slot.slot-defn-setter
	:= if (slot.slot-defn-setter-name)
	     let defn = make(<setter-method-definition>,
			     base-name: slot.slot-defn-setter-name,
			     library: library,
			     signature: make(<signature>,
					     specializers:
					       pair(slot-type, specializers),
					     returns: slot-type),
			     hairy: hairy?,
			     slot: slot.slot-defn-info);
	     let gf = defn.method-defn-of;
	     if (gf)
	       ct-add-method(gf, defn);
	     end;
	     if (slot.slot-defn-sealed?)
	       if (gf)
		 add-seal(gf, library,
			  pair(object-ctype(), specializers), tlf);
	       else
		 compiler-error
		   ("%s doesn't name a generic function, so can't be sealed.",
		    slot.slot-defn-setter-name);
	       end;
	     end;
	     defn;
	   else
	     #f;
	   end if;      
    end method set-slot-defn-setter;
  
  unless (slot.slot-defn-allocation == #"virtual")
    //
    // Extract the library from the class definition.
    let library :: <library> = tlf.tlf-defn.defn-library;
    //
    // Are the accessor methods hairy?
    let hairy? = ~cclass | instance?(slot-type, <unknown-ctype>);

    set-slot-defn-getter(library, hairy?);
    add-slot-defn-getter-to-gf();
    add-seal-if-necessary(library);
    set-slot-defn-setter(library, hairy?);
  end unless;
end function define-slot-accessors;


// maybe-define-init-function  -- internal.
//
define function maybe-define-init-function
    (expr :: <expression-parse>, getter-name :: <basic-name>,
     tlf :: <define-class-tlf>)
    => (ctv :: false-or(<ct-value>), change-to-init-value? :: <boolean>);
  let init-val :: false-or(<ct-value>) = ct-eval(expr, #f);
  if (init-val)
    return-init-val-or-error(init-val, expr);
  else
    let method-ref = expand-until-method-ref(expr);
    if (method-ref)
      maybe-define-init-function-from-method-ref
	(expr, getter-name, tlf, method-ref);
    else
      values(#f, #f);
    end if;
  end if;
end function maybe-define-init-function;


// return-init-val-or-error  -- internal.
//
// Return `init-val' and #f is `init-val' is a compile-time function,
// otherwise report an error and return (#f, #f).
//
define inline function return-init-val-or-error
    (init-fun :: <ct-value>, expr :: <expression-parse>)
 => (init-function :: false-or(<ct-value>),
     change-to-init-value? :: <false>);
  if (cinstance?(init-fun, function-ctype()))
    values(init-fun, #f);
  else
    compiler-error-location
      (expr, "Invalid init-function: %s.", init-fun);
    values(#f, #f);
  end if;
end function return-init-val-or-error;


// maybe-define-init-function-from-method-ref  -- internal.
//
define inline function maybe-define-init-function-from-method-ref
    (expr :: <expression-parse>, getter-name :: <basic-name>,
     tlf :: <define-class-tlf>, method-ref :: <method-ref-parse>)
 => (ctv :: false-or(<ct-value>), change-to-init-value? :: <boolean>);
  let method-parse = method-ref.method-ref-method;
  let (signature, anything-non-constant?)
    = compute-signature(method-parse.method-parameters,
			method-parse.method-returns);
  if (anything-non-constant?)
    values(#f, #f);
  else
    let result-type = first(signature.returns.positional-types,
			    default: signature.returns.rest-value-type);
    let ctv = ct-eval(method-parse.method-body, #f);
    if (ctv & cinstance?(ctv, result-type))
      // Change it to an init-value.
      values(ctv, #t);
    else
      // Make a constant init-function definition.
      define-constant-init-function
	(getter-name, tlf, method-parse);
    end if;
  end if;
end function maybe-define-init-function-from-method-ref;


// define-constant-init-function  -- internal.
//
define inline function define-constant-init-function
    (getter-name :: <basic-name>, tlf :: <define-class-tlf>,
     method-parse :: <method-parse>)
 => (ctv :: false-or(<ct-value>), change-to-init-value? :: <false>);
      let result-param
	= (first(method-parse.method-returns.varlist-fixed,
		 default: method-parse.method-returns.varlist-rest)
	     | make(<parameter>,
		    name: make(<identifier-token>,
			       kind: $raw-ordinary-word-token,
			       symbol: #"result")));
      let new-method-parse
	= make(<method-parse>,
	       parameters: make(<parameter-list>),
	       returns: make(<variable-list>, fixed: vector(result-param)),
	       body: make(<funcall-parse>,
			  function: make(<method-ref-parse>,
					 method: method-parse),
			  arguments: #[]));
      let (new-signature, anything-non-constant?)
	= compute-signature(new-method-parse.method-parameters,
			    new-method-parse.method-returns);
      if (anything-non-constant?)
	error("%= shouldn't be able to have anything non-constant in it",
	      new-signature);
      end if;
      let name
	= make(<derived-name>, how: #"init-function", 
	       base: getter-name);
      let init-func-defn
	= make(<init-function-definition>, name: name,
	       library: tlf.tlf-defn.defn-library,
	       signature: new-signature,
	       method-parse: new-method-parse);
      add!(tlf.tlf-init-function-defns, init-func-defn);
      values(init-func-defn.ct-value, #f);
end function   define-constant-init-function;

// class-defn-mumble-function accessors.
// ====================================

// class-defn-deferred-evaluations-function {<real-class-definition>}
//    -- method on exported GF.
//
define method class-defn-defered-evaluations-function
    (defn :: <real-class-definition>) => res :: false-or(<ct-function>);
  if (defn.%class-defn-defered-evaluations-function == #"not-computed-yet")
    defn.%class-defn-defered-evaluations-function
      := if (compute-new-evaluations-function?(defn))
	   make(<ct-function>,
		name: make(<derived-name>, how: #"deferred-evaluation",
			   base: defn.defn-name),
		signature: make(<signature>, specializers: #(),
				returns: make-values-ctype(#(), #f)));
	 else
	   #f;
	 end;
  else
    defn.%class-defn-defered-evaluations-function;
  end;
end;


// compute-new-evaluations-function?  -- internal.
//
define inline function compute-new-evaluations-function?
    (defn :: <real-class-definition>)
 => (create-new-function? :: <boolean>);
  block (return)
    let cclass = ct-value(defn);
    unless (cclass)
      return(#f);
    end;
    // If any of our superclasses have a defered evaluations
    // function, we need one.
    for (super in cclass.direct-superclasses)
      if (super.class-defn.class-defn-defered-evaluations-function)
	return(#t);
      end;
    end;
    // If any of our slots require some defered evaluations,
    // then we need a defered evaluations function.
    for (slot-defn in defn.class-defn-slots)
      let info = slot-defn.slot-defn-info;
      if (instance?(info.slot-type, <unknown-ctype>)
	    | info.slot-init-value == #t
	    | info.slot-init-function == #t)
	return(#t);
      end;
    end;
    // Same for the overrides.
    for (override-defn in defn.class-defn-overrides)
      let info = override-defn.override-defn-info;
      if (info.override-init-value == #t
	    | info.override-init-function == #t)
	return(#t);
      end;
    end;
    // ### inherited each-subclass slots w/ non obvious init
    // values impose the existance of the defered-evaluations
    // function.
  end block;
end function compute-new-evaluations-function?;


// class-defn-maker-function {<real-class-definition>}
//    -- method on exported GF.
//
// Lazily compute the `%class-defn-maker-function' slot of `defn'.
//
define method class-defn-maker-function
    (defn :: <real-class-definition>)
 => res :: false-or(<ct-function>);
  if (defn.%class-defn-maker-function == #"not-computed-yet")
    defn.%class-defn-maker-function
      := compute-class-defn-maker-function(defn);
  else
    defn.%class-defn-maker-function;
  end if;
end method class-defn-maker-function;


// compute-class-defn-maker-function  -- internal.
//
define inline function compute-class-defn-maker-function
    (defn :: <real-class-definition>)
 => class-defn-maker-function :: false-or(<ct-function>);
  block (return)
    let cclass :: <cclass> = ct-value(defn);
    //
    // If the class is hairy or abstract, no maker.
    if (cclass == #f | cclass.abstract?)
      return(#f);
    end;

    let key-infos = make(<stretchy-vector>);
    for (slot in cclass.all-slot-infos)
      if (instance?(slot, <instance-slot-info>))
	prepare-slot-for-maker-or-return(slot, cclass,
					 key-infos, return)
      end if;
    end for;
    //
    // Okay, we can make a ctv for the maker function.  First,
    // compute some values we will need.
    let name = make(<derived-name>, how: #"maker", base: defn.defn-name);
    let sig = make(<signature>, specializers: #(),
		   keys: as(<list>, key-infos), all-keys: #t,
		   returns: make(<direct-instance-ctype>,
				 base-class: cclass));
    //
    // If this is the maker for an immediate representation class,
    // set up the maker so that it can be inlined.
    let instance-rep = pick-representation(cclass, #"speed");
    let maker-defn
      = if (instance?(instance-rep, <immediate-representation>))
	  make(<maker-function-definition>,
	       name: name,
	       source-location: defn.source-location,
	       library: defn.defn-library,
	       signature: sig,
	       inline-function: maker-inline-expansion,
	       class-defn: defn);
	end if;
    //
    // And make the ctv.
    make(<ct-function>, name: name, signature: sig,
	 definition: maker-defn);
  end block;
end function compute-class-defn-maker-function;


// prepare-slot-for-maker-or-return  -- internal.
//
define inline function prepare-slot-for-maker-or-return
    (slot :: <slot-info>, cclass :: <cclass>,
     key-infos :: <stretchy-vector>, return :: <function>)
 => ();
  if (instance?(slot.slot-type, <unknown-ctype>))
    //
    // Unknown slot type: no maker.
    return(#f);
  end;
  //
  // Find the active override.
  let override :: false-or(<override-info>)
    = find-active-override(slot, cclass);
  //
  // If there is an init-function, and it isn't a constant, give
  // up.
  // !!! We don't actually use this value!!!
  // Is this correct???
  let init-function :: type-union(<ct-value>, <boolean>)
    = find-init-function-or-return(slot, override, return);
  //
  // If there is an init-value, and it isn't a constant, give up.
  let init-value :: type-union(<ct-value>, <boolean>)
    = find-init-value-or-return(slot, override, return);
  //
  // If the slot is keyword initializable, make a key-info for it.
  make-keyword-info-for-slot(slot, key-infos,
			     override, init-value);
end function prepare-slot-for-maker-or-return;


// find-active-override -- internal.
//
define inline function find-active-override
    (slot :: <slot-info>, cclass :: <ct-value>)
 => override :: false-or(<override-info>);
  block (found)
    for (override in slot.slot-overrides)
      if (csubtype?(cclass, override.override-introduced-by))
	found(override);
      end;
    finally
      #f;
    end;
  end;
end function find-active-override;


// find-init-function-or-return  -- internal.
//
define inline function find-init-function-or-return
    (slot :: <slot-info>, override :: false-or(<override-info>),
     return :: <function>)
 => init-function :: type-union(<ct-value>, <boolean>);
  let init-function
    = if (override)
	override.override-init-function;
      else
	slot.slot-init-function;
      end if;
  if (init-function == #t)
    return(#f);
  end if;
  init-function;
end function find-init-function-or-return;


// find-init-value-or-return  -- internal.
//
define inline function find-init-value-or-return
    (slot :: <slot-info>, override :: false-or(<override-info>),
     return :: <function>)
 => init-value :: type-union(<ct-value>, <boolean>);
  let init-value
    = if (override)
	override.override-init-value;
      else
	slot.slot-init-value;
      end;
  if (init-value == #t)
    return(#f);
  end;
  init-value;
end function find-init-value-or-return;


// make-keyword-info-for-slot  -- internal.
//
define inline function make-keyword-info-for-slot
    (slot :: <slot-info>, key-infos :: <stretchy-vector>,
     override :: false-or(<override-info>),
     init-value :: type-union(<ct-value>, <boolean>))
 => ();
  let key = slot.slot-init-keyword;
  if (key)
    let type = slot.slot-type;
    let required? = ~override & slot.slot-init-keyword-required?;
    let default-bogus?
      = init-value & ~cinstance?(init-value, type);
    let key-info
      = make(<key-info>, key-name: key, type: type,
	     required: required? | default-bogus?,
	     default: init-value);
    add!(key-infos, key-info);
  end if;
end function make-keyword-info-for-slot;


// maker-inline-expansion
//
define method maker-inline-expansion
    (maker-defn :: <maker-function-definition>)
    => res :: <function-literal>;
  let class-defn = maker-defn.maker-func-defn-class-defn;
  let component = make(<fer-component>);
  let builder = make-builder(component);
  let region = build-maker-function-body(builder, class-defn);
  let leaf = make-function-literal(builder, #f, #"function", #"local",
				   maker-defn.function-defn-signature, region);
  optimize-component(component, simplify-only: #t);
  leaf;
end method maker-inline-expansion;

// Top level form conversion.
// =========================

// convert-top-level-form {<fer-builder>, <define-class-tlf>}
//    -- method on exported GF.
//
define method convert-top-level-form
    (tl-builder :: <fer-builder>, tlf :: <define-class-tlf>) => ();
  let defn = tlf.tlf-defn;
  let cclass = ct-value(defn);
  if (cclass == #f)
    // The class is sufficiently hairy that we can't do anything.
    // Build top-level init code to create the class at runtime.
    error("### Can't deal with hairy classes yet.");
  else
    // The construction of the class object and the initialization of
    // the class variable will be handled by the linker.  We just need
    // to build the defered-evaluations, key-defaulter, and maker
    // functions.

    let lexenv = make(<lexenv>, method-name: defn.defn-name);
    let policy = lexenv.lexenv-policy;
    let source = defn.source-location;

    fer-convert-init-function-defns(tl-builder, tlf, lexenv);

    let evals-builder = make-builder(tl-builder);

    begin
      local
	//
	// do-deferred-evaluation-for-super
	//
	method do-deferred-evaluation-for (super :: <cclass>) => ();
	  if (super.class-defn.class-defn-defered-evaluations-function)
	    build-assignment
	      (evals-builder, policy, source, #(),
	       make-unknown-call
		 (evals-builder,
		  ref-dylan-defn(evals-builder, policy, source,
				 #"maybe-do-defered-evaluations"),
		  #f,
		  list(make-literal-constant(evals-builder, super))));
	  end;
	end method do-deferred-evaluation-for,
	//
	//
	method calculate-type-and-type-var
	    (slot-defn, slot-info, slot-type, slot-name)
	 => (type, type-var);
	  if (instance?(slot-type, <unknown-ctype>))
	    let type-expr = slot-defn.slot-defn-type;
	    let var
	      = make-local-var(evals-builder,
			       symcat(slot-name, "-type"),
			       specifier-type(#"<type>"));
	    fer-convert(evals-builder, type-expr, lexenv,
			#"assignment", var);
	    build-assignment
	      (evals-builder, policy, source, #(),
	       make-unknown-call
		 (evals-builder,
		  ref-dylan-defn(evals-builder, policy, source,
				 #"slot-type-setter"),
		  #f,
		  list(var,
		       make-literal-constant(evals-builder, slot-info))));
	    values(object-ctype(), var);
	  else
	    values(slot-type, #f);
	  end;
	end method;
	
      // Do the defered evaluations for any of the superclasses that need it.
      for (super in cclass.direct-superclasses)
	do-deferred-evaluation-for(super);
      end for;

      for (slot-defn in defn.class-defn-slots,
	   index from 0)
	let slot-info = slot-defn.slot-defn-info;
	let getter = slot-info.slot-getter;
 	let slot-name = slot-info.slot-getter.variable-name;

	let slot-type = slot-info.slot-type;
	let (type, type-var)
	  = calculate-type-and-type-var
	      (slot-defn, slot-info, slot-type, slot-name);

	let allocation = slot-defn.slot-defn-allocation;

	let init-value = slot-info.slot-init-value;
	let init-function = slot-info.slot-init-function;
	if (init-value == #t)
	  let var = make-local-var(evals-builder,
				   symcat(slot-name, "-init-value"),
				   object-ctype());
	  fer-convert(evals-builder, slot-defn.slot-defn-init-value,
		      lexenv, #"assignment", var);
	  build-assignment
	    (evals-builder, policy, source, #(),
	     make-unknown-call
	       (evals-builder,
		ref-dylan-defn(evals-builder, policy, source,
			       #"slot-init-value-setter"),
		#f,
		list(var, make-literal-constant(evals-builder, slot-info))));
	elseif (init-function == #t)
	  let leaf = convert-init-function(evals-builder, slot-info.slot-getter,
					   slot-defn.slot-defn-init-function);
	  build-assignment
	    (evals-builder, policy, source, #(),
	     make-unknown-call
	       (evals-builder,
		ref-dylan-defn(evals-builder, policy, source,
			       #"slot-init-function-setter"),
		#f,
		list(leaf, make-literal-constant(evals-builder, slot-info))));
	end;
	
	unless (allocation == #"virtual")
	  if (type-var)
	    local
	      method build-call (name, #rest args)
		let temp = make-local-var(evals-builder, name, object-ctype());
		build-assignment
		  (evals-builder, policy, source, temp,
		   make-unknown-call
		     (evals-builder,
		      ref-dylan-defn(evals-builder, policy, source, name),
		      #f, as(<list>, args)));
		temp;
	      end,
	      method build-add-method (gf-name, method-defn, method-leaf)
		// We don't use method-defn-of, because that is #f if there
		// is a definition but it isn't a define generic.
		let gf-var = find-variable(gf-name);
		let gf-defn = gf-var & gf-var.variable-definition;
		if (gf-defn)
		  let gf-leaf = build-defn-ref(evals-builder, policy,
					       source, gf-defn);
		  build-assignment
		    (evals-builder, policy, source, #(),
		     make-unknown-call
		       (evals-builder,
			ref-dylan-defn(evals-builder, policy, source,
				       #"add-method"),
			#f,
			list(gf-leaf, method-leaf)));
		  build-defn-set(evals-builder, policy, source, method-defn,
				 method-leaf);
		else
		  compiler-fatal-error-location
		    (tlf,
		     "No definition for %s, and can't implicitly define it.",
		     gf-name.name-symbol);
		end;
	      end;

	    let results = build-call(#"list", type-var);
	    let cclass-leaf = make-literal-constant(evals-builder, cclass);
	    let false-leaf
	      = make-literal-constant(evals-builder, as(<ct-value>, #f));
	    begin
	      let getter
		= build-getter(evals-builder, #f, slot-defn, slot-info);
	      let getter-specializers = build-call(#"list", cclass-leaf);
	      let meth = build-call(#"%make-method", getter-specializers,
				    results, false-leaf, getter);
	      build-add-method(slot-defn.slot-defn-getter-name,
			       slot-defn.slot-defn-getter, meth);
	    end;
	    if (slot-defn.slot-defn-setter)
	      let setter
		= build-setter(evals-builder, #f, slot-defn, slot-info);
	      let setter-specializers = build-call(#"list", type-var,
						   cclass-leaf);
	      let meth = build-call(#"%make-method", setter-specializers,
				    results, false-leaf, setter);
	      build-add-method(slot-defn.slot-defn-setter-name,
			       slot-defn.slot-defn-setter, meth);
	    end;
	  else
	    begin
	      let getter = slot-defn.slot-defn-getter.ct-value;
	      let getter-standin = slot-accessor-standin(slot-info, #"getter");
	      if (getter-standin)
		getter.ct-accessor-standin := getter-standin;
	      else
		build-getter(tl-builder, getter, slot-defn, slot-info);
	      end if;
	    end;
	    if (slot-defn.slot-defn-setter)
	      let setter = slot-defn.slot-defn-setter.ct-value;
	      let setter-standin = slot-accessor-standin(slot-info, #"setter");
	      if (setter-standin)
		setter.ct-accessor-standin := setter-standin;
	      else
		build-setter(tl-builder, setter, slot-defn, slot-info);
	      end if;
	    end if;
	  end if;
	end unless;
      end for;

      for (override-defn in defn.class-defn-overrides,
	   index from 0)
	let override-info = override-defn.override-defn-info;
	let getter = override-info.override-getter;
	let slot-name = getter.variable-name;
	let init-value = override-info.override-init-value;
	let init-function = override-info.override-init-function;

	if (init-value == #t | init-function == #t)
	  let descriptor-leaf
	    = make-literal-constant(evals-builder, override-info);

	  if (init-value)
	    let var = make-local-var(evals-builder,
				     symcat(slot-name, "-override-init-value"),
				     object-ctype());
	    fer-convert(evals-builder, override-defn.override-defn-init-value,
			lexenv, #"assignment", var);
	    build-assignment
	      (evals-builder, policy, source, #(),
	       make-unknown-call
		 (evals-builder,
		  ref-dylan-defn(evals-builder, policy, source,
				 #"override-init-value-setter"),
		  #f,
		  list(var, descriptor-leaf)));
	  else
	    let leaf
	      = convert-init-function(evals-builder, getter,
				      override-defn
					.override-defn-init-function);
	    build-assignment
	      (evals-builder, policy, source, #(),
	       make-unknown-call
		 (evals-builder,
		  ref-dylan-defn(evals-builder, policy, source,
				 #"override-init-function-setter"),
		  #f,
		  list(leaf, descriptor-leaf)));
	  end if;
	end if;
      end for;
    end begin;

    unless (cclass.abstract?)
      //
      // Build the key-defaulter (if concrete)
      // ### Need to write this.

      //
      // Build the maker.
      let (maker-region, maker-signature)
	= build-maker-function-body(tl-builder, defn);
      
      // Fill in the maker function.
      let ctv = defn.class-defn-maker-function;
      if (ctv)
	make-function-literal(tl-builder, ctv, #"function", #"global",
			      maker-signature, maker-region);
      else
	// The maker function isn't a compile-time constant, so add code to
	// the defered evaluations to install it.
	let maker-leaf
	  = make-function-literal(tl-builder, #f, #"function", #"local",
				  maker-signature, maker-region);
	build-assignment
	  (evals-builder, policy, source, #(),
	   make-unknown-call
	     (evals-builder,
	      ref-dylan-defn(evals-builder, policy, source,
			     #"class-maker-setter"),
	      #f,
	      list(maker-leaf,
		   make-literal-constant(evals-builder, cclass))));
      end if;
    end unless;

    let ctv = defn.class-defn-defered-evaluations-function;
    if (ctv)
      let func-region = build-function-body(tl-builder, policy, source, #f,
					    ctv.ct-function-name,
					    #(), make-values-ctype(#(), #f),
					    #t);
      build-region(tl-builder, builder-result(evals-builder));
      
      // ### install the key-defaulter function here?

      // Return nothing.
      build-return(tl-builder, policy, source, func-region, #());
      end-body(tl-builder);
      make-function-literal(tl-builder, ctv, #"function", #"global",
			    ctv.ct-function-signature, func-region);
    else
      assert(instance?(builder-result(evals-builder), <empty-region>));
    end if;
  end if;
end method convert-top-level-form;


// fer-convert-init-function-defns  -- internal
//
// fer-convert all `init-function-defn's of `tlf'.
//
define inline function fer-convert-init-function-defns
    (tl-builder :: <fer-builder>, tlf :: <define-class-tlf>,
     lexenv :: <lexenv>)
 => ();
    for (init-func-defn in tlf.tlf-init-function-defns)
      let meth = init-func-defn.init-func-defn-method-parse;
      let name = init-func-defn.defn-name;
      fer-convert-method(tl-builder, meth, name, init-func-defn.ct-value,
			 #"global", lexenv, lexenv);
    end for;
end function fer-convert-init-function-defns;






// make-descriptors-leaf  -- internal.
//
// not used.
//
/*
define function make-descriptors-leaf
    (builder :: <fer-builder>, policy :: <policy>, source :: <source-location>,
     what :: <byte-string>, for-class :: <cclass>)
    => leaf :: <leaf>;
  let var = make-local-var(builder, symcat(what, "-descriptors"),
			   object-ctype());
  build-assignment
    (builder, policy, source, var,
     make-unknown-call
       (builder,
	ref-dylan-defn(builder, policy, source,
		       symcat("class-", what, "-descriptors")),
	#f,
	list(make-literal-constant(builder, for-class))));
  var;
end;
*/

// build-maker-function-body  -- internal.
//
define function build-maker-function-body
    (tl-builder :: <fer-builder>, defn :: <class-definition>)
    => (maker-region :: <fer-function-region>,
	signature :: <signature>);
  let key-infos = make(<stretchy-vector>);
  let maker-args = make(<stretchy-vector>);
  let setup-builder = make-builder(tl-builder);
  let maker-builder = make-builder(tl-builder);
  let init-builder = make-builder(tl-builder);
  let cclass :: <cclass> = defn.ct-value;
  let direct = make(<direct-instance-ctype>, base-class: cclass);
  let instance-leaf = make-local-var(init-builder, #"instance", direct);
  let representation = pick-representation(direct, #"speed");
  let immediate-rep?
    = instance?(representation, <immediate-representation>);
  let make-immediate-args = make(<stretchy-vector>);
  let data-word-leaf = #f;
  let size-leaf = #f;
  let vector-slot = cclass.vector-slot;
  let size-slot = vector-slot & vector-slot.slot-size-slot;

  let policy = $Default-Policy;
  let source = defn.source-location;

  for (slot in cclass.all-slot-infos, index from 0)
    let slot-name = slot.slot-getter & slot.slot-getter.variable-name;

    select (slot by instance?)
      <instance-slot-info> =>
	//
	// If there isn't a getter, this is a bound? slot.  Bound? slots
	// are initialized along with the regular slot.
	if (slot.slot-getter)
	  //
	  // Get ahold of the type.
	  let slot-type = slot.slot-type;
	  let (type, type-var)
	    = if (instance?(slot-type, <unknown-ctype>))
		let var = make-local-var(maker-builder,
					 symcat(slot-name, "-type"),
					 specifier-type(#"<type>"));
		build-assignment
		  (maker-builder, policy, source, var,
		   make-unknown-call
		     (maker-builder,
		      ref-dylan-defn(maker-builder, policy, source,
				     #"slot-type"),
		      #f,
		      list(make-literal-constant(maker-builder, slot))));
		values(object-ctype(), var);
	      else
		values(slot-type, #f);
	      end;
	  //
	  // Find the active override if there is one. 
	  let override
	    = block (return)
		for (override in slot.slot-overrides)
		  if (csubtype?(cclass, override.override-introduced-by))
		    return(override);
		  end;
		finally
		  #f;
		end;
	      end;
	  //
	  // Get the init-value or init-function, either from the
	  // active override or from the slot itself if there is no
	  // active override.
	  let (init-value, init-function)
	    = if (override)
		values(override.override-init-value,
		       override.override-init-function);
	      else
		values(slot.slot-init-value, slot.slot-init-function);
	      end;

	  local
	    method build-slot-init
		(slot :: false-or(<slot-info>), leaf :: <leaf>) => ();
	      if (slot)
		if (immediate-rep?)
		  add!(make-immediate-args, leaf);
		else
		  let posn
		    = get-direct-position(slot.slot-positions, cclass);
		  unless (posn)
		    error("Couldn't find the position for %s",
			  slot.slot-getter.variable-name);
		  end unless;
		  if (posn == #"data-word")
		    data-word-leaf := leaf;
		  else
		    let posn-leaf
		      = make-literal-constant(init-builder,
					      as(<ct-value>, posn));
		    if (instance?(slot, <vector-slot-info>))
		      // We need to build a loop to initialize every
		      // element.
		      let block-region
			= build-block-body(init-builder, policy, source);
		      let index
			= make-local-var(init-builder, #"index",
					 specifier-type(#"<integer>"));
		      build-assignment
			(init-builder, policy, source, index,
			 make-literal-constant
			   (init-builder, as(<ct-value>, 0)));
		      build-loop-body(init-builder, policy, source);
		      let more?
			= make-local-var(init-builder, #"more?",
					 specifier-type(#"<boolean>"));
		      build-assignment
			(init-builder, policy, source, more?,
			 make-unknown-call
			   (init-builder,
			    ref-dylan-defn(init-builder, policy, source,
					   #"<"),
			    #f,
			    list(index, size-leaf)));
		      build-if-body(init-builder, policy, source, more?);
		      build-assignment
			(init-builder, policy, source, #(),
			 make-operation
			   (init-builder, <heap-slot-set>,
			    list(leaf, instance-leaf, posn-leaf, index),
			    slot-info: slot));
		      build-assignment
			(init-builder, policy, source, index,
			 make-unknown-call
			   (init-builder,
			    ref-dylan-defn(init-builder, policy, source,
					   #"+"),
			    #f,
			    list(index,
				 make-literal-constant
				   (init-builder, as(<ct-value>, 1)))));
		      build-else(init-builder, policy, source);
		      build-exit
			(init-builder, policy, source, block-region);
		      end-body(init-builder);
		      end-body(init-builder);
		      end-body(init-builder);
		    else
		      build-assignment
			(init-builder, policy, source, #(),
			 make-operation
			   (init-builder, <heap-slot-set>,
			    list(leaf, instance-leaf, posn-leaf),
			    slot-info: slot));
		      if (slot == size-slot)
			size-leaf := leaf;
		      end if;
		    end if;
		  end if;
		end if;
	      end if;
	    end method build-slot-init,
	    method extract-init-value (init-value-var) => ();
	      if (init-value == #t)
		if (override)
		  build-assignment
		    (maker-builder, policy, source,
		     init-value-var,
		     make-unknown-call
		       (maker-builder,
			ref-dylan-defn(maker-builder, policy, source,
				       #"override-init-value"),
			#f,
			list(make-literal-constant(maker-builder, override))));
		else
		  build-assignment
		    (maker-builder, policy, source,
		     init-value-var,
		     make-unknown-call
		       (maker-builder,
			ref-dylan-defn(maker-builder, policy, source,
				       #"slot-init-value"),
			#f,
			list(make-literal-constant(maker-builder, slot))));
		end if;
	      elseif (init-value)
		build-assignment
		  (maker-builder, policy, source, init-value-var,
		   make-literal-constant(maker-builder, init-value));
	      else
		error("shouldn't have called extract-init-value "
			"when init-value is false");
	      end;

	      if (type-var)
		build-assignment
		  (maker-builder, policy, source, init-value-var,
		   make-check-type-operation
		     (maker-builder, policy, source,
		      init-value-var, type-var));
	      end;
	    end,
	    method call-init-function (init-value-var) => ();
	      if (init-function == #t)
		let init-function-var
		  = make-local-var(maker-builder,
				   symcat(slot-name, "-init-function"),
				   function-ctype());
		if (override)
		  build-assignment
		    (maker-builder, policy, source,
		     init-function-var,
		     make-unknown-call
		       (maker-builder,
			ref-dylan-defn(maker-builder, policy, source,
				       #"override-init-function"),
			#f,
			list(make-literal-constant(maker-builder, override))));
		else
		  build-assignment
		    (maker-builder, policy, source,
		     init-function-var,
		     make-unknown-call
		       (maker-builder,
			ref-dylan-defn(maker-builder, policy, source,
				       #"slot-init-function"),
			#f,
			list(make-literal-constant(maker-builder, slot))));
		end;
		build-assignment
		  (maker-builder, policy, source, init-value-var,
		   make-unknown-call(maker-builder, init-function-var,
				     #f, #()));
	      elseif (init-function)
		let init-func-leaf
		  = make-literal-constant(maker-builder, init-function);
		build-assignment
		  (maker-builder, policy, source, init-value-var,
		   make-unknown-call(maker-builder, init-func-leaf, #f,
				     #()));
	      else
		error("shouldn't have called call-init-function "
			"when init-function is false");
	      end;

	      if (type-var)
		build-assignment
		  (maker-builder, policy, source, init-value-var,
		   make-check-type-operation
		     (maker-builder, policy, source,
		      init-value-var, type-var));
	      end;
	    end;
	  
	  let key = slot.slot-init-keyword;
	  if (key)
	    let required? = ~override & slot.slot-init-keyword-required?;
	    let default = ~(init-value == #t) & init-value;
	    let default-bogus? = default & ~cinstance?(default, type);
	    let key-info = make(<key-info>, key-name: key, type: type,
				required: required? | default-bogus?,
				default: default);
	    let init-value-var
	      = make-local-var(maker-builder,
			       symcat(slot-name, "-init-value"),
			       type);
	    add!(key-infos, key-info);
	    if (default)
	      add!(maker-args, init-value-var);
	      build-slot-init(slot, init-value-var);
	      build-slot-init(slot.slot-initialized?-slot,
			      make-literal-constant(init-builder,
						    as(<ct-value>, #t)));
	    else
	      let arg = make-local-var(maker-builder, key, type);
	      add!(maker-args, arg);
	      let supplied?-arg
		= make-local-var(maker-builder,
				 symcat(key, "-supplied?"),
				 specifier-type(#"<boolean>"));
	      if (key-info.key-needs-supplied?-var)
		add!(maker-args, supplied?-arg);
	      else
		build-assignment
		  (maker-builder, policy, source, supplied?-arg,
		   make-operation(maker-builder, <primitive>, list(arg),
				  name: #"initialized?"));
	      end;
	      build-if-body(maker-builder, policy, source, supplied?-arg);
	      build-assignment(maker-builder, policy, source,
			       init-value-var, arg);
	      build-else(maker-builder, policy, source);
	      if (init-value)
		extract-init-value(init-value-var);
	      elseif (init-function)
		call-init-function(init-value-var);
	      elseif (slot.slot-init-keyword-required?)
		build-assignment
		  (maker-builder, policy, source, #(),
		   make-error-operation
		     (maker-builder, policy, source,
		      #"missing-required-init-keyword-error",
		      make-literal-constant
			(maker-builder, as(<ct-value>, key)),
		      make-literal-constant(maker-builder, cclass)));
	      else
		build-assignment(maker-builder, policy, source,
				 init-value-var,
				 make(<uninitialized-value>,
				      derived-type: type.ctype-extent));
	      end;
	      end-body(maker-builder);
	      build-slot-init(slot, init-value-var);
	      build-slot-init(slot.slot-initialized?-slot,
			      if (init-value | init-function)
				make-literal-constant(init-builder,
						      as(<ct-value>, #t));
			      else
				supplied?-arg;
			      end);
	    end;
	  else
	    if (init-value | init-function)
	      let init-value-var
		= make-local-var(maker-builder,
				 symcat(slot-name, "-init-value"),
				 type);
	      if (init-value)
		extract-init-value(init-value-var);
	      else
		call-init-function(init-value-var);
	      end;
	      build-slot-init(slot, init-value-var);
	      build-slot-init(slot.slot-initialized?-slot,
			      make-literal-constant(init-builder,
						    as(<ct-value>, #t)));
	    else
	      build-slot-init
		(slot, make(<uninitialized-value>,
			    derived-type: type.ctype-extent));
	      build-slot-init
		(slot.slot-initialized?-slot,
		 make-literal-constant(init-builder, as(<ct-value>, #f)));
	    end if;
	  end if;
	end if;
      <each-subclass-slot-info> =>
	// ### Add stuff to the derived-evaluations function to init the
	// slot.  If the slot is keyword-initializable, add stuff to the
	// maker to check for that keyword and change the each-subclass
	// slot.
	error("Can't deal with each-subclass slots yet.");
      <class-slot-info> =>
	// ### If the slot is keyword-initializable, add stuff to the maker
	// to check for that keyword and change the class slot.
	error("Can't deal with class slots yet.");
      <virtual-slot-info> =>
	// Don't need to do anything for virtual slots.
	#f;
    end select;
  end for;
  
  let name = make(<derived-name>, how: #"maker", base: defn.defn-name);
  let maker-region
    = build-function-body(tl-builder, policy, source, #f, name,
			  as(<list>, maker-args), cclass, #t);
  build-region(tl-builder, builder-result(setup-builder));
  build-region(tl-builder, builder-result(maker-builder));
  let bytes = cclass.instance-slots-layout.layout-length;
  let base-len
    = make-literal-constant(tl-builder, as(<ct-value>, bytes));
  let len-leaf
    = if (vector-slot)
	let fi = specifier-type(#"<integer>");
	let elsize
	  = vector-slot.slot-representation.representation-size;
	let extra
	  = if (elsize == 1)
	      size-leaf;
	    else
	      let var = make-local-var(tl-builder, #"extra", fi);
	      let elsize-leaf
		= make-literal-constant(tl-builder,
					as(<ct-value>, elsize));
	      build-assignment
		(tl-builder, policy, source, var,
		 make-unknown-call
		   (tl-builder,
		    ref-dylan-defn(tl-builder, policy, source, #"*"),
		    #f,
		    list(size-leaf, elsize-leaf)));
	      var;
	    end;
	let var = make-local-var(tl-builder, #"bytes", fi);
	build-assignment
	  (tl-builder, policy, source, var,
	   make-unknown-call
	     (tl-builder,
	      ref-dylan-defn(tl-builder, policy, source, #"+"),
	      #f,
	      list(base-len, extra)));
	var;
      else
	base-len;
      end;
  build-assignment
    (tl-builder, policy, source, instance-leaf,
     if (immediate-rep?)
       make-operation
	 (tl-builder, <primitive>, as(<list>, make-immediate-args),
	  name: #"make-immediate", derived-type: direct.ctype-extent);
     elseif (data-word-leaf)
       make-operation
	 (tl-builder, <primitive>,
	  list(make-literal-constant(tl-builder, cclass),
	       len-leaf, data-word-leaf),
	  name: #"allocate-with-data-word", derived-type: direct.ctype-extent);
     else
       make-operation
	 (tl-builder, <primitive>,
	  list(make-literal-constant(tl-builder, cclass), len-leaf),
	  name: #"allocate", derived-type: direct.ctype-extent);
     end if);
  build-region(tl-builder, builder-result(init-builder));
  build-return(tl-builder, policy, source, maker-region,
	       list(instance-leaf));
  end-body(tl-builder);
  values(maker-region,
	 make(<signature>, specializers: #(),
	      keys: as(<list>, key-infos),
	      all-keys: #t,
	      returns: direct));
end function build-maker-function-body;


// convert-init-function  -- internal.
//
define function convert-init-function
    (builder :: <fer-builder>, getter :: <variable>,
     init-function :: <expression-parse>)
    => res :: <leaf>;
  let slot-name = getter.variable-name;
  let fun-name = make(<derived-name>,
  		      base: make(<basic-name>, symbol: slot-name,
		      		 module: getter.variable-home),
		      how: #"init-function");
  let lexenv = make(<lexenv>, method-name: fun-name);
  let policy = lexenv.lexenv-policy;
  let source = make(<source-location>);
  let var = make-lexical-var(builder, symcat(slot-name, "-init-function"),
			     source, function-ctype());
  fer-convert(builder, init-function, lexenv, #"let", var);

  let func-region
    = build-function-body(builder, policy, source, #t,
    			  fun-name, #(),
			  object-ctype(), #f);
  let temp = make-local-var(builder, #"result", object-ctype());
  build-assignment(builder, policy, source, temp,
		   make-unknown-call(builder, var, #f, #()));
  build-return(builder, policy, source, func-region, temp);
  end-body(builder);
  make-function-literal(builder, #f, #"function", #"local",
			make(<signature>, specializers: #()),
			func-region);
end function convert-init-function;


// slot-accessor-standin  -- internal.
//
define function slot-accessor-standin
    (slot :: <instance-slot-info>, kind :: one-of(#"getter", #"setter"))
    => standin :: false-or(<ct-function>);
  if (instance?(slot, <vector-slot-info>))
    #f;
  elseif (find-slot-offset(slot, slot.slot-introduced-by))
    let rep = slot.slot-representation;
    let standin-name :: false-or(<symbol>)
      = if (rep == *general-rep*)
	  symcat("general-rep-", kind);
	elseif (rep == *heap-rep*)
	  symcat("heap-rep-", kind);
	else
	  #f;
	end if;
    if (standin-name)
      let defn = dylan-defn(standin-name);
      if (defn)
	defn.ct-value;
      else
	#f;
      end if;
    else
      #f;
    end if;
  end if;
end function slot-accessor-standin;


// might-be-in-data-word  -- internal.
//
define inline function might-be-in-data-word?
    (slot :: <slot-info>) => res :: <boolean>;
  //
  // For a slot to ever be in the data-word, it must be in the data-word of
  // the class that introduced it.
  slot.slot-introduced-by.data-word-slot == slot;
end function might-be-in-data-word?;


// build-getter  -- internal.
//
define function build-getter
    (builder :: <fer-builder>, ctv :: false-or(<ct-method>),
     defn :: <slot-defn>, slot :: <instance-slot-info>)
    => res :: <method-literal>;
  let getter-name
      = make(<derived-name>, how: #"getter",
     	     base: defn.slot-defn-getter.defn-name);
  let lexenv = make(<lexenv>, method-name: getter-name);
  let policy = lexenv.lexenv-policy;
  let source = make(<source-location>);
  let cclass = slot.slot-introduced-by;
  let instance = make-lexical-var(builder, #"object", source, cclass);
  let index = if (instance?(slot, <vector-slot-info>))
		make-lexical-var(builder, #"index", source,
				 specifier-type(#"<integer>"));
	      else
		#f;
	      end if;
  let type = slot.slot-type;
  let region = build-function-body
    (builder, policy, source, #f,
     getter-name,
     if (index)
       list(instance, index);
     else
       list(instance);
     end,
     type, #t);
  let result = make-local-var(builder, #"result", type);
  local
    method get (offset :: <leaf>, init?-offset :: false-or(<leaf>)) => ();
      if (init?-offset)
	let init?-slot = slot.slot-initialized?-slot;
	let temp = make-local-var(builder, #"initialized?",
				  specifier-type(#"<boolean>"));
	build-assignment
	  (builder, policy, source, temp,
	   make-operation
	     (builder, <heap-slot-ref>,
	      list(instance, init?-offset),
	      derived-type: init?-slot.slot-type.ctype-extent,
	      slot-info: init?-slot));
	build-if-body(builder, policy, source, temp);
	build-else(builder, policy, source);
	build-assignment
	  (builder, policy, source, #(),
	   make-error-operation
	     (builder, policy, source, #"uninitialized-slot-error",
	      make-literal-constant(builder, slot), instance));
	end-body(builder);
      end;
      let maybe-data-word? = slot.might-be-in-data-word?;
      if (maybe-data-word?)
	assert(~init?-offset);
	assert(~index);
	let temp = make-local-var(builder, #"data-word?",
				  specifier-type(#"<boolean>"));
	build-assignment
	  (builder, policy, source, temp,
	   make-unknown-call
	     (builder, ref-dylan-defn(builder, policy, source, #"=="), #f,
	      list(offset,
		   make-literal-constant
		     (builder, as(<ct-value>, #"data-word")))));
	build-if-body(builder, policy, source, temp);
	build-assignment
	  (builder, policy, source, result,
	   make-operation
	     (builder, <data-word-ref>, list(instance),
	      derived-type: slot.slot-type.ctype-extent, slot-info: slot));
	build-else(builder, policy, source);
      end if;
      build-assignment
	(builder, policy, source, result,
	 make-operation
	   (builder, <heap-slot-ref>,
	    if (index)
	      list(instance, offset, index);
	    else
	      list(instance, offset);
	    end,
	    derived-type: slot.slot-type.ctype-extent,
	    slot-info: slot));
      if (maybe-data-word?)
	end-body(builder);
      end if;
      unless (init?-offset | slot-guaranteed-initialized?(slot, cclass))
	let temp = make-local-var(builder, #"initialized?", object-ctype());
	build-assignment(builder, policy, source, temp,
			 make-operation(builder, <primitive>, list(result),
					name: #"initialized?"));
	build-if-body(builder, policy, source, temp);
	build-else(builder, policy, source);
	build-assignment
	  (builder, policy, source, #(),
	   make-error-operation
	     (builder, policy, source, #"uninitialized-slot-error",
	      make-literal-constant(builder, slot), instance));
	end-body(builder);
      end;
    end;
  build-slot-posn-dispatch(builder, slot, instance, get);
  build-return(builder, policy, source, region, result);
  end-body(builder);
  make-function-literal
    (builder, ctv, #"method", if (ctv) #"global" else #"local" end,
     make(<signature>,
	  specializers:
	    if (index)
	      list(cclass, specifier-type(#"<integer>"));
	    else
	      list(cclass);
	    end,
	  returns: type),
     region);
end function build-getter;


// build-setter
//
define function build-setter
    (builder :: <fer-builder>, ctv :: false-or(<ct-method>),
     defn :: <slot-defn>, slot :: <instance-slot-info>)
    => res :: <method-literal>;
  let setter-name
    = make(<derived-name>, how: #"setter",
     	   base: defn.slot-defn-setter.defn-name);
  let init?-slot = slot.slot-initialized?-slot;
  let lexenv = make(<lexenv>, method-name: setter-name);
  let policy = lexenv.lexenv-policy;
  let source = make(<source-location>);
  let type = slot.slot-type;
  let new = make-lexical-var(builder, #"new-value", source, type);
  let cclass = slot.slot-introduced-by;
  let instance = make-lexical-var(builder, #"object", source, cclass);
  let index = if (instance?(slot, <vector-slot-info>))
		let fi = specifier-type(#"<integer>");
		let index = make-lexical-var(builder, #"index", source, fi);
		index;
	      else
		#f;
	      end if;
  let region = build-function-body
    (builder, policy, source, #f,
     setter-name,
     if (index)
       list(new, instance, index);
     else
       list(new, instance);
     end,
     type, #t);
  let result = make-local-var(builder, #"result", type);
  local
    method set (offset :: <leaf>, init?-offset :: false-or(<leaf>)) => ();
      build-assignment(builder, policy, source, #(),
		       make-operation(builder, <heap-slot-set>,
				      if (index)
					list(new, instance, offset, index);
				      else
					list(new, instance, offset);
				      end if,
				      slot-info: slot));
      if (init?-offset)
	let init?-slot = slot.slot-initialized?-slot;
	let true-leaf = make-literal-constant(builder, make(<literal-true>));
	let init-op = make-operation
	  (builder, <heap-slot-set>, list(true-leaf, instance, init?-offset),
	   slot-info: init?-slot);
	build-assignment(builder, policy, source, #(), init-op);
      end;
    end;
  build-slot-posn-dispatch(builder, slot, instance, set);
  build-return(builder, policy, source, region, new);
  end-body(builder);
  make-function-literal
    (builder, ctv, #"method", if (ctv) #"global" else #"local" end,
     make(<signature>,
	  specializers:
	    if (index)
	      list(type, cclass, specifier-type(#"<integer>"));
	    else
	      list(type, cclass);
	    end,
	  returns: type),
     region);
end function build-setter;


// build-slot-posn-dispatch  -- internal.
//
define function build-slot-posn-dispatch
    (builder :: <fer-builder>, slot :: <instance-slot-info>,
     instance-leaf :: <leaf>, thunk :: <function>)
    => ();
  let cclass = slot.slot-introduced-by;
  if (cclass.sealed? | cclass.primary?)
    // We don't have to do a runtime slot-position lookup, so make us a static
    // slot accessor method.
    let new-thunk
      = method (offset :: <slot-position>,
		init?-offset :: false-or(<slot-position>))
	    => ();
	  thunk(make-literal-constant(builder, as(<ct-value>, offset)),
		init?-offset
		  & make-literal-constant(builder,
					  as(<ct-value>, init?-offset)));
	end method;
    let position = get-universal-position(slot.slot-positions);
    let init?-slot = slot.slot-initialized?-slot;
    let init?-position
      = (init?-slot & get-universal-position(init?-slot.slot-positions));
    if (position & (init?-slot == #f | init?-position))
      // The slot only ever shows up at one place.  So just use that one
      // place.
      new-thunk(position, init?-position);
    else
      // The slot shows up at multiple positions.  This had better only happen
      // when the class is sealed because we are only supposed to try making
      // a static posn-dispatch when the class is sealed or primary and if the
      // class were primary, then there should only be one possible position
      // for each slot.
      assert(cclass.sealed?);
      
      if (every?(disjoin(abstract?, unique-id), cclass.subclasses))
	// All the concrete subclasses have unique-id's, so we can compute a
	// direct mapping from instance.object-class.unique-id to offset.
	build-unique-id-slot-posn-dispatch
	  (builder, slot, instance-leaf, new-thunk);
      else
	// One or more concrete subclass doesn't have a unique-id so we have
	// to build an instance? tree.
	build-instance?-slot-posn-dispatch
	  (builder, slot, instance-leaf, new-thunk);
      end if;
    end if;
  else
    // Open non-primary class.
    build-runtime-slot-posn-dispatch(builder, slot, instance-leaf, thunk);
  end if;
end function build-slot-posn-dispatch;


// build-unique-id-slot-posn-dispatch  -- internal.
//
define function build-unique-id-slot-posn-dispatch
    (builder :: <fer-builder>, slot :: <instance-slot-info>,
     instance-leaf :: <leaf>, thunk :: <function>)
    => ();
  let policy = $Default-Policy;
  let source = make(<source-location>);
  let cclass = slot.slot-introduced-by;
  let positions = slot.slot-positions;
  let init?-positions
    = (slot.slot-initialized?-slot
	 & slot.slot-initialized?-slot.slot-positions);
  let ranges = #();
  let prev = #f;
  for (entry in sort!(map(method (subclass)
			    let id = subclass.unique-id;
			    vector(id, id,
				   get-direct-position(positions, subclass),
				   init?-positions
				     & get-direct-position(init?-positions,
							   subclass));
			  end,
			  find-direct-classes(cclass)),
		      test: method (entry1, entry2)
			      entry1[0] < entry2[0];
			    end))
    if (prev == #f)
      ranges := list(entry);
      prev := ranges;
    elseif (prev.head[2] == entry[2] & prev.head[3] == entry[3])
      prev.head[1] := entry[1];
    else
      let new = list(entry);
      prev.tail := new;
      prev := new;
    end;
  finally
    let ranges = as(<simple-object-vector>, ranges);
    let less-then = ref-dylan-defn(builder, policy, source, #"<");
    //
    // Extract the unique id for this argument.
    let class-temp = make-local-var(builder, #"class", object-ctype());
    let obj-class-leaf
      = ref-dylan-defn(builder, policy, source, #"%object-class");
    build-assignment(builder, policy, source, class-temp,
		     make-unknown-call(builder, obj-class-leaf, #f,
				       list(instance-leaf)));
    let id-temp = make-local-var(builder, #"id", object-ctype());
    let unique-id-leaf
      = ref-dylan-defn(builder, policy, source, #"unique-id");
    build-assignment(builder, policy, source, id-temp,
		     make-unknown-call(builder, unique-id-leaf, #f,
				       list(class-temp)));
    local
      method split-range (min, max)
	if (min == max)
	  let entry :: <simple-object-vector> = ranges[min];
	  thunk(entry[2], entry[3]);
	else
	  let half-way-point = ash(min + max, -1);
	  let cond-temp = make-local-var(builder, #"cond", object-ctype());
	  let ctv = as(<ct-value>, ranges[half-way-point][1] + 1);
	  let bound = make-literal-constant(builder, ctv);
	  build-assignment
	    (builder, policy, source, cond-temp,
	     make-unknown-call(builder, less-then, #f,
			       list(id-temp, bound)));
	  build-if-body(builder, policy, source, cond-temp);
	  split-range(min, half-way-point);
	  build-else(builder, policy, source);
	  split-range(half-way-point + 1, max);
	  end-body(builder);
	end;
      end;
    split-range(0, ranges.size - 1);
  end;
end function build-unique-id-slot-posn-dispatch;


// build-instance?-slot-posn-dispatch  -- internal.
//
define function build-instance?-slot-posn-dispatch
    (builder :: <fer-builder>, slot :: <instance-slot-info>,
     instance-leaf :: <leaf>, thunk :: <function>)
    => ();
  break();

  let policy = $Default-Policy;
  let source = make(<source-location>);
  let cclass = slot.slot-introduced-by;
  let positions = as(<list>, slot.slot-positions);
  let init?-positions
    = (slot.slot-initialized?-slot
	 & as(<list>, slot.slot-initialized?-slot.slot-positions));
  local
    method split (classes :: <list>, possible-splits :: <list>)
	=> ();
      let best-test = #f;
      let best-yes-classes = #f;
      let best-yes-count = #f;
      let best-no-classes = #f;
      let best-no-count = #f;
      let best-weight = 0;

      for (split :: <cclass> in possible-splits)
	let yes-classes = #();
	let no-classes = #();
	for (class in classes)
	  if (csubtype?(class, split))
	    yes-classes := pair(class, yes-classes);
	  else
	    no-classes := pair(class, no-classes);
	  end if;
	end for;
	let yes-count
	  = count-distinct-positions(yes-classes, positions, init?-positions);
	let no-count
	  = count-distinct-positions(no-classes, positions, init?-positions);
	let weight = yes-count * no-count;
	if (weight > best-weight)
	  best-test := split;
	  best-yes-classes := yes-classes;
	  best-yes-count := yes-count;
	  best-no-classes := no-classes;
	  best-no-count := no-count;
	  best-weight := weight;
	end if;
      end for;

      let cond-temp = make-local-var(builder, #"cond", object-ctype());
      let type-leaf = make-literal-constant(builder, best-test);
      let instance?-leaf
	= ref-dylan-defn(builder, policy, source, #"instance?");
      build-assignment
	(builder, policy, source, cond-temp,
	 make-unknown-call
	   (builder, instance?-leaf, #f,
	    list(instance-leaf, type-leaf)));
      build-if-body(builder, policy, source, cond-temp);

      if (best-yes-count == 1)
	let characteristic-class = best-yes-classes.first;
	thunk(lookup-position(characteristic-class, positions),
	      lookup-position(characteristic-class, init?-positions));
      else
	split(best-yes-classes,
	      restrict-splits(possible-splits, best-test, #t));
      end if;

      build-else(builder, policy, source);

      if (best-no-count == 1)
	let characteristic-class = best-no-classes.first;
	thunk(lookup-position(characteristic-class, positions),
	      lookup-position(characteristic-class, init?-positions));
      else
	split(best-no-classes,
	      restrict-splits(possible-splits, best-test, #f));
      end if;

      end-body(builder);
    end method split;

  let initial-splits = map(head, positions);
  if (init?-positions)
    for (entry in init?-positions)
      let split :: <cclass> = entry.head;
      unless (member?(split, initial-splits))
	initial-splits := pair(split, initial-splits);
      end unless;
    end for;
  end if;
  split(find-direct-classes(cclass),
	restrict-splits(initial-splits, cclass, #t));
end function build-instance?-slot-posn-dispatch;


// lookup-position  -- internal GF.
//
define generic lookup-position
    (class :: <cclass>, positions :: false-or(<list>))
 => position :: false-or(<integer>);

// lookup-position  {<list>}
//    -- method on internal GF.
//
define method lookup-position (class :: <cclass>, positions :: <list>)
    => res :: false-or(<integer>);
  block (return)
    for (entry in positions)
      if (csubtype?(class, entry.head))
	return(entry.tail);
      end if;
    end for;
    #f;
  end block;
end method lookup-position;


// lookup-position {<false>}
//    -- method on internal GF.
//
define method lookup-position (class :: <cclass>, positions :: <false>)
    => res :: false-or(<integer>);
  #f;
end method lookup-position;


// restrict-splits  -- internal.
//
define inline function restrict-splits
    (splits :: <list>, class :: <cclass>, if-yes? :: <boolean>)
    => res :: <list>;
  choose(method (split :: <cclass>) => res :: <boolean>;
	   split ~== class & csubtype?(split, class) == if-yes?;
	 end method,
	 splits);
end function restrict-splits;


// count-distinct-positions  -- internal.
//
define function count-distinct-positions
    (classes :: <list>, positions :: <list>,
     init?-positions :: false-or(<list>))
    => res :: <integer>;
  let entries = #();
  for (class in classes)
    let offset = lookup-position(class, positions);
    let init?-offset = lookup-position(class, init?-positions);
    block (next)
      for (entry :: <pair> in entries)
	if (entry.head == offset & entry.tail == init?-offset)
	  next();
	end if;
      end for;
      entries := pair(pair(offset, init?-offset), entries);
    end block;
  end for;
  entries.size;
end function count-distinct-positions;


// build-runtime-slot-posn-dispatch  -- internal.
//
define function build-runtime-slot-posn-dispatch
    (builder :: <fer-builder>, slot :: <instance-slot-info>,
     instance-leaf :: <leaf>, thunk :: <function>)
    => ();
  let policy = $Default-Policy;
  let source = make(<source-location>);

  let class-temp = make-local-var(builder, #"class", object-ctype());
  let obj-class-leaf
    = ref-dylan-defn(builder, policy, source, #"%object-class");
  build-assignment(builder, policy, source, class-temp,
		   make-unknown-call(builder, obj-class-leaf, #f,
				     list(instance-leaf)));

  local
    method make-offset-var
	(name :: <symbol>, slot :: false-or(<instance-slot-info>))
	=> var :: false-or(<abstract-variable>);
      if (slot)
	let var = make-local-var(builder, name,
				 if (slot.might-be-in-data-word?)
				   specifier-type
				     (#(union:, #"<integer>",
					#(singleton:, #"data-word")));
				 else
				   specifier-type(#"<integer>");
				 end if);
	build-assignment
	  (builder, policy, source, var,
	   make-unknown-call
	     (builder,
	      ref-dylan-defn(builder, policy, source, #"find-slot-offset"),
	      #f,
	      list(class-temp, make-literal-constant(builder, slot))));
	var;
      else
	#f;
      end if;
    end method make-offset-var;
  thunk(make-offset-var(#"offset", slot),
	make-offset-var(#"init?-offset", slot.slot-initialized?-slot));
end function build-runtime-slot-posn-dispatch;


// Dumping stuff.
// =============

// dump-od{<define-class-tlf>}
//    -- method on imported GF.
//
// We dump the a define-binding-tlf to establish the name of the
// <real-class-definition>.  Then we dump all the accessor method definitions
// to make sure they get re-instantiated.
//
define method dump-od (tlf :: <define-class-tlf>, state :: <dump-state>) => ();
  let defn = tlf.tlf-defn;
  dump-simple-object(#"define-binding-tlf", state, defn);
  for (slot in defn.class-defn-slots)
    let sealed? = slot.slot-defn-sealed?;
    let getter = slot.slot-defn-getter;
    if (getter.method-defn-of & name-inherited-or-exported?(getter.defn-name))
      dump-od(slot.slot-defn-getter, state);
      if (sealed? & getter.method-defn-of.defn-library ~== defn.defn-library)
	dump-simple-object(#"sealed-domain", state,
			   getter.method-defn-of,
			   defn.defn-library,
			   getter.function-defn-signature.specializers);
      end if;
    end;
    let setter = slot.slot-defn-setter;
    if (setter & setter.method-defn-of
	  & name-inherited-or-exported?(setter.defn-name))
      dump-od(setter, state);
      if (sealed? & setter.method-defn-of.defn-library ~== defn.defn-library)
	dump-simple-object
	  (#"sealed-domain", state, setter.method-defn-of, defn.defn-library,
	   // We don't use the setter specializers, because the first
	   // specializer will be the slot type, not <object>.
	   pair(object-ctype(), getter.function-defn-signature.specializers));
      end if;
    end if;
  end for;
end method dump-od;


// These functions act like getters/setters on the <real-class-definition>, but
// really get/set slots in the cclass.  They are used so that we can dump
// cclass objects without having to reference non-type things.

// class-defn-new-slot-infos  -- internal.
//
define inline function class-defn-new-slot-infos
    (defn :: <real-class-definition>)
 => res :: <simple-object-vector>;
  let class = defn.class-defn-cclass;
  class & class.new-slot-infos;
end function class-defn-new-slot-infos;

// class-defn-new-slot-infos-setter  -- internal.
//
define inline function class-defn-new-slot-infos-setter
    (vec :: false-or(<simple-object-vector>),
     defn :: <real-class-definition>)
 => ();
  if (vec)
    defn.class-defn-cclass.new-slot-infos := vec;
  end;
end function class-defn-new-slot-infos-setter;


// class-defn-all-slot-infos  -- internal.
//
define inline function class-defn-all-slot-infos
    (defn :: <real-class-definition>)
 => res :: <simple-object-vector>;
  let class = defn.class-defn-cclass;
  class & class.all-slot-infos;
end function class-defn-all-slot-infos;

// class-defn-all-slot-infos-setter  -- internal.
//
define inline function class-defn-all-slot-infos-setter
    (vec :: false-or(<simple-object-vector>),
     defn :: <real-class-definition>)
 => ();
  if (vec)
    defn.class-defn-cclass.all-slot-infos := vec;
  end;
end function class-defn-all-slot-infos-setter;

// class-defn-override-infos  -- internal.
//
define inline function class-defn-override-infos
    (defn :: <real-class-definition>) => res :: <simple-object-vector>;
  let class = defn.class-defn-cclass;
  class & class.override-infos;
end function class-defn-override-infos;

// class-defn-override-infos-setter -- internal.
//
define inline function class-defn-override-infos-setter
    (vec :: false-or(<simple-object-vector>), defn :: <real-class-definition>)
    => ();
  if (vec)
    defn.class-defn-cclass.override-infos := vec;
  end;
end function class-defn-override-infos-setter;

// class-defn-vector-slot  -- internal.
//
define inline function class-defn-vector-slot
    (defn :: <real-class-definition>) => res :: false-or(<vector-slot-info>);
  let class = defn.class-defn-cclass;
  class & class.vector-slot;
end function class-defn-vector-slot;

// class-defn-vector-slot-setter  -- internal.
//
define inline function class-defn-vector-slot-setter
    (info :: false-or(<vector-slot-info>), defn :: <real-class-definition>)
    => ();
  let class = defn.class-defn-cclass;
  if (class)
    class.vector-slot := info;
  end;
end function class-defn-vector-slot-setter;

// $class-definition-slots
//
define constant $class-definition-slots
  = concatenate($definition-slots,
		list(class-defn-cclass, class:, #f,
		     %class-defn-defered-evaluations-function, #f,
		       %class-defn-defered-evaluations-function-setter,
		     %class-defn-maker-function, #f,
		       %class-defn-maker-function-setter,
		     class-defn-new-slot-infos, #f,
		       class-defn-new-slot-infos-setter,
    /* ### -- currently recomputed, so we don't really need to dump them.
		     class-defn-all-slot-infos, #f,
		       class-defn-all-slot-infos-setter, */
		     class-defn-override-infos, #f,
		       class-defn-override-infos-setter
    /* ### -- currently recomputed, so we don't really need to dump them.
		     , class-defn-vector-slot, #f,
		       class-defn-vector-slot-setter */));


// class-definition
//
add-make-dumper(#"class-definition", *compiler-dispatcher*,
		<real-class-definition>, $class-definition-slots,
		load-external: #t,
		load-side-effect:
		  method (defn :: <real-class-definition>) => ();
		    let class = defn.class-defn-cclass;
		    if (class)
		      class.class-defn := defn;
		    end;
		  end);


// class-definition
//
add-make-dumper(#"class-definition", *compiler-dispatcher*,
		<local-class-definition>, $class-definition-slots,
		dumper-only: #t);


// init-function-definition
//
add-make-dumper(#"init-function-definition", *compiler-dispatcher*,
		<init-function-definition>,
		$abstract-method-definition-slots,
		load-external: #t);


// maker-function-definition
//
add-make-dumper
  (#"maker-function-definition", *compiler-dispatcher*,
   <maker-function-definition>,
   concatenate
     ($abstract-method-definition-slots,
      list(maker-func-defn-class-defn, class-defn:,
	     maker-func-defn-class-defn-setter)),
   load-external: #t);

// Seals for file compiler/convert/defclass.dylan
// ==============================================

// <define-class-parse> -- subclass of <definition-parse>
define sealed domain make(singleton(<define-class-parse>));
define sealed domain initialize(<define-class-parse>);
// <slot-parse> -- subclass of <abstract-slot-parse>
define sealed domain make(singleton(<slot-parse>));
// <inherited-slot-parse> -- subclass of <abstract-slot-parse>
define sealed domain make(singleton(<inherited-slot-parse>));
// <init-arg-parse> -- subclass of <abstract-slot-parse>
define sealed domain make(singleton(<init-arg-parse>));
// <real-class-definition> -- subclass of <class-definition>
define sealed domain make(singleton(<real-class-definition>));
define sealed domain initialize(<real-class-definition>);
// <local-class-definition> -- subclass of <real-class-definition>
define sealed domain make(singleton(<local-class-definition>));
// <slot-defn> -- subclass of <object>
define sealed domain make(singleton(<slot-defn>));
define sealed domain initialize(<slot-defn>);
// <override-defn> -- subclass of <object>
define sealed domain make(singleton(<override-defn>));
define sealed domain initialize(<override-defn>);
// <init-function-definition> -- subclass of <abstract-method-definition>
define sealed domain make(singleton(<init-function-definition>));
define sealed domain initialize(<init-function-definition>);