Module:   dfmc-definitions
Synopsis: The domain definition processor.
Author:   Keith Playford
Copyright:    Original Code is Copyright (c) 1995-2004 Functional Objects, Inc.
              All rights reserved.
License:      Functional Objects Library Public License Version 1.0
Dual-license: GNU Lesser General Public License
Warranty:     Distributed WITHOUT WARRANTY OF ANY KIND

//// Domain definitions.

// Domain definition objects.

define dood-class <domain-definition> (<modifying-form>)
  lazy constant slot form-domain-type-expressions :: <sequence>,
    required-init-keyword: domain-type-expressions:;
end dood-class;

define leaf packed-slots form-properties (<domain-definition>, <modifying-form>)
  boolean slot form-sealed? = #t,    // vs. open
    init-keyword: sealed?:;  
  boolean slot form-sideways? = #f, // vs. upwards (maybe!)
    init-keyword: sideways?:;  
end packed-slots;

define inline method domain-definition? (object) => (well? :: <boolean>)
  instance?(object, <domain-definition>)
end method;

define method form-define-word
    (form :: <domain-definition>) => (word :: <symbol>)
  #"domain"
end method;

define generic form-domain-type-expressions
    (form :: <domain-definition>) => (types :: <sequence>);

// Conversion to a definition object.

define &definition domain-definer
  { define ?mods:* domain ?:name (?domain-types:*) }
    => do-define-domain(form, mods, name, domain-types);
end &definition;

define function do-define-domain
    (form, mods, name, domain-types) => (forms)
  let (options, adjectives) = parse-domain-adjectives(name, mods);
  let domain-types = parse-domain-types(domain-types);
  let tlf 
    = apply(make, <domain-definition>, 
            source-location:         fragment-source-location(form),
            variable-name:           name,
            adjectives:              adjectives,
            domain-type-expressions: as(<vector>, domain-types),
            options);
  list(tlf)
end function;

define function parse-domain-types (types-form)
  macro-case (types-form)
    { ?types:* } 
      => types;
  types:
    { }
      => #();
    { ?:expression, ... }
      => pair(expression, ...);
  end macro-case
end function;

//// Domain adjective parsing.

// In fact "define domain" only accepts "sealed", so it would be simple to
// handle it in the main converter. It's only done this way to give error
// reports consistent with those generated by other forms that accept
// adjectives. And in case the syntax gets extended somehow one day.

define property <domain-sealed-property> => sealed?: = #t
  value sealed = #t;
end property;

define property <domain-sideways-property> => sideways?: = #f
  value sideways = #t;
  // The following becomes #f when the compiler is being compiled as a
  // single component.
  value compiler-sideways = #t; 
end property;

define constant domain-adjectives
  = list(<domain-sealed-property>, <domain-sideways-property>);

define function parse-domain-adjectives (name, adjectives-form) => (initargs)
  parse-property-adjectives
    (domain-adjectives, adjectives-form, name)
end function;

//// Definition protocol.


define serious-program-warning <domain-not-on-generic-function>
  slot condition-definition,
    required-init-keyword: definition:;
  format-string 
    "This domain extends the definition %= which does not define a "
    "generic function - ignoring.";
  format-arguments definition;
end serious-program-warning;

define serious-program-warning <domain-on-undefined-variable>
  slot condition-variable,
    required-init-keyword: variable:;
  format-string
    "This domain attempts to extend the definition of an undefined variable "
    "%s from another library - ignoring.";
  format-arguments variable;
end serious-program-warning;

define method add-local-definition
    (definitions :: <definitions>, definition :: <domain-definition>) 
 => (new-definitions :: <definitions>)
  add-in-order(definitions, definition, test: defined-before?)
end method;


// define method install-top-level-form-bindings
//     (form :: <domain-definition>) => ()
//   add-modifying-definition(form-variable-name(form), form);
// end method;


define method install-top-level-form-bindings
    (form :: <domain-definition>) => ()
  let name = form-variable-name(form);
  let binding = lookup-binding(name);
  let def = binding-definition(binding, default: #f);
  if (~def & binding-imported-into-library?(binding))
    note(<domain-on-undefined-variable>,
	 source-location: form-source-location(form),
	 variable: binding);
    ignore-modifying-definition(name, form);
  elseif (def & ~instance?(def, <generic-definition>))
    note(<domain-not-on-generic-function>,
	 source-location: form-source-location(form),
	 definition:      def);
    ignore-modifying-definition(name, form);
  else
    add-modifying-definition(name, form);
  end;
end method;


define method uninstall-top-level-form-bindings
    (form :: <domain-definition>) => ()
  remove-modifying-definition(form-variable-name(form), form);
end method;

// eof