;; Copyright 2004 Stephen J. Turnbull

;; This file is licensed under the GNU General Public License, version 2.

;; Implementation of synfl-defclass

;; We could use cl.el's defstruct, I suppose, but for a number of reasons
;; I think it's probably cleaner to use symbols to carry slot information
;; rather than lists or vectors.  This makes compiling a grammar somewhat
;; slower, but should not slow down the generated parser at all.

(defvar synfl-name-table (make-hash-table)
  "For internal use.

Table mapping names to objects.")

(defmacro synfl-defclass (cname doc &rest options)
  "Define a synfl class named CNAME with docstring DOC according to OPTIONS.

CNAME and OPTIONS are not evaluated, but DOC is evaluated.

CNAME must be a (non-keyword) symbol, which will be interned with type
`type'.  (The resulting object supports no useful queries in the
current implementation.)  DOC must be a string.  OPTIONS must be an
alist, each of whose elements takes one of the following forms:

  (force BOOLEAN)
  (slot SLOT-NAME . SLOT-OPTIONS)
  (constructor CTOR-NAME . DEFN)

The 'force option, if non-nil, converts redefinition of the class from
an error to a warning of level 'warning and type 'synfl-defclass.

A 'slot option defines a slot named SLOT-NAME (which must be a symbol).
The following slot names are reserved for the use of the implementation:
  type, name

#### slot options are currently unimplemented
SLOT-OPTIONS must be an alist, each of whose elements takes one of the
following forms:

  (optional BOOLEAN)

All slot options default to nil.
The 'optional slot option, if non-nil, means that the slot need not be
present in a valid object of class CNAME.

#### Explicit constructor definition is unimplemented.
A 'constructor option defines a constructor named CTOR-NAME (which must be
a symbol) with definition DEFN.  CTOR-NAME should be of the form
\"synfl-FOO-CNAME-BAR\" where at least one of FOO and BAR should be a verb
suggesting construction.  Either FOO or BAR may be omitted.  DEFN may be
nil (useful to disable implicitly defined constructors) or a list containing
a funcallable object.

The following constructors will be implicitly defined if not specified
explicitly:
  synfl-make-CNAME (object-name &rest slot-value-plist)
  synfl-copy-CNAME (object)
Constructors return a symbol converted to an object of type CNAME.
SLOT-VALUE-PLIST is a property list whose keys are slot names.

The following accessors and mutators will be defined:
  synfl-CNAME-SLOTNAME (object)
  synfl-CNAME-set-SLOTNAME (object value)

The following functions are defined on any object.  They return non-nil
iff the object is a member of a synfl class.

  synfl-class (object)
  synfl-name (object)

The following tests and predicates will be supported for any object:

  synfl-type-p (object class)
  synfl-check (object class)
  synfl-validate (object &optional class)

CLASS must be a synfl class.
`synfl-type-p' returns non-nil iff OBJECT is of class CLASS.
`synfl-check' has no useful return value, but signals an error if OBJECT is
not of class CLASS.
`synfl-validate' has no useful return value, but sets OBJECT's type to CLASS
if the slots present in OBJECT are compatible with class CLASS.  Otherwise
it signals `wrong-type-argument'.  If CLASS is nil, OBJECT is checked for
compatibility with its nominal class."

  ;; keep promise about evaluation
  (setq doc (eval doc))

  (let (forms force slot-names slot-descs)

    ;; do it --- note, we return (reverse forms)
    (push 'progn forms)

    ;; Error checking -- these must be executed first to prevent unwanted
    ;; side effects if the specification is erroneous.

    ;; check args
    ;; must be last things pushed to FORMS
    (push `(unless (stringp ',doc)
	     (error 'wrong-type-argument 'stringp ',doc))
	  forms)
    (push `(unless (symbolp ',cname)
	     (error 'wrong-type-argument 'symbolp ',cname))
	  forms)

    ;; check for redefinition of CNAME
    ;; must be the second-to-last thing pushed to forms
    (when (gethash cname synfl-class-table)
      (push (if force
		`(display-warning 'synfl-defclass
		   (format "Redefining %s" ,cname))
	      `(error 'setting-constant (format "Redefining %s" ,cname)))
	    forms))

    ;; make the class object
    (push `(synfl-make-object ',cname 'type) forms)

    ;; handle the options
    ;; these include defining slots and operations, as well as true options
    (mapc (lambda (option)
	    (cond ((eq (car option) 'force)
		   ;; handle force options
		   (setq force (cadr option)))

		  ((eq (car option) 'slot)
		   ;; define a slot
		   (let ((slot-name (cadr option)))
		     (push `(defsubst ,(intern (format "synfl-%s-%s"
						       cname slot-name))
			      (object)
			      (get object ',slot-name))
			   forms)
		     (push `(defsubst ,(intern (format "synfl-%s-set-%s"
						       cname slot-name))
			      (object value)
			      (put object ',slot-name value))
			   forms)
		     ;; do something with any slot-options
		     ;; collect slot names
		     (push `(push ',slot-name
				  (get (synfl-object ',cname) 'slots)))))

		  ((eq (car option) 'constructor)
		   ;; define a constructor
		   (push `(error 'unimplemented
				 "explicitly define constructor"
				 ,(cadr option))
			 forms))))
	  options)

    ;; implicit constructors
    ;; #### check for explicit definitions first!!
    (push `(defsubst ,(intern (format "synfl-make-%s" cname))
	     (name &optional slot-plist)
	     ,(apply #'concat
		     (append (list (format "Construct a %s" cname))
			     (when slot-names
			       (append (list " with slot(s)")
				       (mapcar (lambda (x)
						 (format " %s" x))
					       slot-names)))
			     (list ".\nSlot names are keys in SLOT-PLIST.")
			     (list (if doc (format "\n\n%s" doc) ""))))
	     (let ((this (gensym)))
	       (put this 'type ',cname)
	       (put this 'name name)
	       (puthash name this synfl-class-table)
	       (mapcar (lambda (slot)
			 (let ((key (car slot))
			       (value (cdr slot)))
			   (if (memq key ',slot-names)
			       (put this key value)
			     (error 'wrong-type-argument "not a slot" key)))
		       (plist-to-alist slot-plist))))
	     this)
	  forms)
    (push `(defsubst ,(intern (format "synfl-copy-%s" cname))
	     (object)
	     ,(concat (format "Construct a %s by copying OBJECT." cname)
		      (if doc (format "\n\n%s" doc) ""))
	     (let ((this (gensym)))
	       (put this 'type ',cname)
	       (put this 'name nil)
	       ,@(mapcar (lambda (slot)
			   `(put this ',slot (get object ',slot)))
			 slot-names))
	     this)
	  forms)

    (reverse forms)))

(defsubst synfl-type-p (object type)
  "Non-nil if OBJECT is of synfl type TYPE."
  (eq (get object 'type) type))

;; Maybe make TYPE optional?
(defun synfl-object (name type)
  "Return the synfl object corresponding to NAME with type TYPE, or nil.

NAME is a Lisp symbol, and TYPE is a synfl type or nil.

If TYPE is nil, get the unique object of that name.  Signals
`invalid-argument' if NAME is not unique when TYPE is nil.  See also
`synfl-intern'."
  (catch 'object
    (mapc (lambda (x) (when (synfl-type-p x type) (throw 'object x)))
	  (gethash name synfl-name-table))
    nil))

(defun synfl-make-object (name type)
  "Return an uninitialized object named NAME of type TYPE.

If such an object already exists, signal `invalid-argument'.  See also
`synfl-intern'."
  (error 'unimplemented))

(defun synfl-intern (name type)
  "Return the object named NAME of type TYPE.

NAME is a Lisp symbol and TYPE is a synfl type.

When the object exists, return the object.  Otherwise return an
uninitialized object named NAME of type TYPE.  See also
`synfl-make-object' and `synfl-object'."
  (or (synfl-object name type) (synfl-make-object name type)))

(defun synfl-clone (object)
  "Return a new object with properties identical to those of OBJECT.

Value, function definition, and so on are ignored."
  (let ((this (gensym)))
    (setplist this (copy-sequence (symbol-plist object)))
    this))

(defun synfl-class (object)
  "Return the synfl class of OBJECT, or nil if not a member of a synfl class.

Note: the name of an object is not (usually) a member of a synfl class.
Eg, objects may be implemented as gensyms.  This should not usually matter
as the UI/API implementation should automagically convert names to objects."
  (when (symbolp object)
    (get object 'class)))

(defun synfl-name (object)
  "Return the name of OBJECT, or nil if not a member of a synfl class.

Note: the name of an object is not (usually) a member of a synfl class.
Eg, objects may be implemented as gensyms.  This should not usually matter
as the UI/API implementation should automagically convert names to objects."
  (when (symbolp object)
    (get object 'name)))

;; convenience function for parser-generator application
(defun synfl-grammar (object)
  "Get the grammar of OBJECT, or nil if not a member of a synfl class.

Note: the name of an object is not (usually) a member of a synfl class.
Eg, objects may be implemented as gensyms.  This should not usually matter
as the UI/API implementation should automagically convert names to objects."
  (when (symbolp object)
    (get object 'grammar)))

