;;;
;;; TALK-STRUCT:  Structures in Emacs.
;;;
;;; ----------------------------------------------------------------------
;;; This file is part of ILOG Talk.
;;; Inquiries to ILOG S.A.
;;;              9 rue de Verdun, BP 85,
;;;              94253 Gentilly Cedex, France.
;;;
;;; Copyright (c) 1993-1996 by ILOG
;;; $Header: /nfs/talk/work/talk/emacs/RCS/talk-struct.el,v 1.7 1996/01/12 20:14:50 v16admin Exp $
;;; ----------------------------------------------------------------------
;;;

(require 'backquote)
(require 'talk-loop)

;;; (tm:defstruct <class> <super>
;;;   ((<slot> [reader: <reader>]
;;;            [writer: <writer>]
;;;            [accessor: <accessor>] ; set-<accessor> to modify.
;;;            [default: <form>])
;;;    ...)
;;;    (generic: <gen-name> <args>)
;;;    ...
;;;    (method: <gen-name>)
;;;    ...)

;;; Automatically generated reader/writer is <class>-<slot> and
;;; set-<class>-<slot>.
;;; Automatically generated predicate is <class>p or <class>-p.
;;; Automatically generated constructor is the macro make-<class>
;;; which accepts (unevaluated) keywords corresponding to slot names
;;; plus a ':'.  If no key for a slot is given, the default: for that
;;; slot is used.

;;; (tm:defmethod <gen-name> ((<self> <class>) <arg2> ...)
;;;    form ...)
;;; Methods must be defined just after the class for which they are
;;; valid, before any subclasses to allow inheritance.


(defmacro tm:defstruct (name superclass slots &rest options)
  "Make a structure named NAME with readers, writers, predicate, and BOA
constructor."
  (let* ((full-name (tm:explode-elisp-symbol name))
	 (slotds (tm:collect-slot-names slots superclass))
	 (slot-names
	  (tm:loop ((slotd in: slotds))
		   (tm:collect (intern (car slotd)))))
	 (readers (tm:loop ((slot-name in: slotds))
			   (tm:collect (tm:make-reader full-name slot-name))))
	 (writers (tm:loop ((slot-name in: slotds))
			   (tm:collect (tm:make-writer full-name slot-name))))
	 (generics (tm:collect-generics name options))
	 (methods (tm:collect-methods name options))
	 (predicate (tm:make-predicate full-name))
	 (constructor (tm:make-constructor full-name slotds superclass)))
    (` (progn (,@ readers)
	      (,@ writers)
	      (,@ generics)
	      (, predicate)
	      (, constructor)
	      (tm:make-class (quote (, name))
			     (quote (, superclass))
			     (quote (, slotds))
			     (quote (, (tm:collect-generic-names options))))
	      (,@ methods)
	      (quote (, name))))))

(defmacro call-method (name class &rest args)
  (let ((gvect (tm:compute-gvect-var class))
	(gpos (symbol-value (tm:compute-gpos-var name))))
    (` (funcall (aref (, gvect) (, gpos)) (,@ args)))))

(defmacro tm:defmethod (gname lambda-list &rest body)
  ;; GNAME must be the name of the generic.
  ;; LAMBDA-LIST must be of the form ((self class) arg2 ...)
  ;; BODY is a list of forms.
  (let* ((spec-arg (car lambda-list))
	 (class (car (cdr spec-arg)))
	 (full-ll (cons (car spec-arg) (cdr lambda-list)))
	 (full-name (tm:explode-elisp-symbol gname))
	 (mname (tm:make-name (car full-name) (cdr full-name)
			      "-" (symbol-name class) "-method")))
    (` (defun (, mname) (, full-ll)
	 (,@ body)))))

(defun tm:collect-generics (name options)
  (tm:loop ((option in: options))
	   (let ((option-name (car option))
		 (option-val (cdr option)))
	     (if (eq option-name 'generic:)
		 (let ((gname (car option-val))
		       (args (car (cdr option-val))))
		   (tm:collect (tm:make-generic name gname args)))))))

(defun tm:collect-generic-names (options)
  (tm:loop ((option in: options))
	   (let ((option-name (car option))
		 (option-val (cdr option)))
	     (if (eq option-name 'generic:)
		 (tm:collect (car option-val))))))

(defun tm:collect-methods (name options)
  (tm:loop ((option in: options))
	   (let ((option-name (car option))
		 (option-val (cdr option)))
	     (if (eq option-name 'method:)
		 (let ((gname (car option-val)))
		   (tm:collect (tm:make-method name gname)))))))

(defun tm:make-reader (name slot)
  (let* ((slot-name (car slot))
	 (slot-position (car (cdr slot)))
	 (reader-name
	  (or (tm:getf 'reader: (cdr (cdr slot)))
	      (tm:getf 'accessor: (cdr (cdr slot)))
	      (tm:make-name (car name) (cdr name) "-" slot-name))))
     (list 'defun reader-name '(object)
	   (list 'aref 'object slot-position))))
	      
(defun tm:make-writer (name slot)
  (let* ((slot-name (car slot))
	 (slot-position (car (cdr slot)))
	 (writer-name
	  (or (tm:getf 'writer: (cdr (cdr slot)))
	      (let ((reader (tm:getf 'accessor: (cdr (cdr slot)))))
		(and reader
		     (let ((explode (tm:explode-elisp-symbol reader)))
		       (tm:make-name (or (car explode) (car name))
				     "set-" (cdr explode)))))
	      (tm:make-name (car name) "set-" (cdr name) "-" slot-name))))
    (list 'defun writer-name '(object new-value)
	  (list 'aset 'object slot-position 'new-value))))

(defun tm:make-generic (class-name gname args)
  (let ((gpos-var (tm:compute-gpos-var gname))
	(gvect-var (tm:compute-gvect-var class-name)))
    (` (defmacro (, gname) (, args)
	 (list 'let (list (list '_object_ (, (car args))))
	       (cons 'funcall
		     (list (list 'aref
				 (list 'aref '_object_ 1)
				 (, gpos-var))
			   '_object_
			   (,@ (cdr args)))))))))

(defun tm:make-method (class gname)
  (let* ((full-name (tm:explode-elisp-symbol gname))
	 (mname (tm:make-name (car full-name) (cdr full-name)
			      "-" (symbol-name class) "-method")))
    (` (progn (tm:add-method (quote (, class))
			     (quote (, gname))
			     (quote (, mname)))))))

(defun tm:make-predicate (name)
  (let* ((package (car name))
	 (class (cdr name))
	 (type (tm:make-name package class))
	 (pred-name (if (string-match "-" class)
			(tm:make-name package class "-p")
		      (tm:make-name package class "p"))))
    (list 'defun pred-name '(object)
	  (list 'and '(arrayp object)
		     '(> (length object) 0)
		     (list 'if (list 'eq '(tm:type-of object)
				     (list 'quote type))
			   'object
			   'nil)))))

(defvar *magic* (cons 1 1))

(defun tm:make-constructor (name slots super)
  (let* ((package (car name))
	 (class (cdr name))
	 (type (tm:make-name package class))
	 (cons-name (tm:make-name (car name) "make-" class)))
    (` (defmacro (, cons-name) (&rest plist)
	 (let* ((all-slots (tm:all-class-slots (quote (, type))))
		(values
		 (tm:loop
		  ((slotd in: all-slots))
		  (if (symbolp slotd) (setq slotd (list slotd)))
		  (let* ((key (intern (concat (car slotd) ":")))
			 (val (tm:getfd key plist *magic*)))
		    (tm:collect (if (eq val *magic*)
				    (tm:getf 'default: (cdr (cdr slotd)))
				  val))))))
	   (cons 'vector
		 (cons (quote (quote (, type)))
		       (cons (quote (, (tm:compute-gvect-var type)))
			     values))))))))

(defun tm:getfd (key plist default)
  (cond ((null plist) default)
	((eq key (car plist))
	 (car (cdr plist)))
	(t (tm:getfd key (cdr (cdr plist)) default))))

(defun tm:type-of (object)
  (aref object 0))

(defun tm:class-of (object)
  (tm:find-class (aref object 0)))

(defun tm:methods-of (object)
  (aref object 1))

;;; Managing class objects

(defun tm:make-class (name super slots generics)
  "Make and install a class named NAME, subclass of SUPER, with slots SLOTS"
  (let* ((superc (if super (tm:find-class super) ()))
	 (all-gens (tm:initialize-generics name superc generics)))
    (put name 'tm:class
	 (vector 'tm:class name super slots all-gens))))

(defun tm:initialize-generics (name super generics)
  "Each class has a vtbl of gf methods; this fn initializes it."
  (let* ((super-gens (if super (tm:class-generics super) ()))
	 (super-gens-len (length super-gens))
	 (gvect-var (tm:compute-gvect-var name))
	 (super-gvect
	  (if super
	      (symbol-value (tm:compute-gvect-var (tm:class-name super)))
	    []))
	 (gvect (make-vector (+ (length generics) super-gens-len) ())))
    (tm:loop ((index from: 0 to: (- super-gens-len 1)))
	     (aset gvect index (aref super-gvect index)))
    (tm:loop ((gen in: generics)
	      (pos from: super-gens-len))
	     (set (tm:compute-gpos-var gen) pos))
    (set gvect-var gvect)
    (append super-gens generics)))

(defun tm:add-method (class gname mname)
  (aset (symbol-value (tm:compute-gvect-var class))
	(symbol-value (tm:compute-gpos-var gname))
	mname))


(defun tm:find-class (name)
  "Return the class object for NAME"
  (get name 'tm:class))

(defun tm:class-name (class) (aref class 1))
(defun tm:class-super (class) (aref class 2))
(defun tm:class-slots (class) (aref class 3))
(defun tm:class-generics (class) (aref class 4))

(defun tm:all-class-slots (name)
  "Return all the slots for the class NAME, even superclass slots."
  (if name
      (let ((class (tm:find-class name)))
	(if (null class)
	    (error "tm:all-class-slots:  Class %s not found" name))
	(append (tm:all-class-slots (tm:class-super class))
		(tm:class-slots class)))
    ()))


;;; Auxiliary

(defun tm:explode-elisp-symbol (symbol)
  "If SYMBOL has the form <prefix>:<name>, return a pair (<prefix> . <name>),
otherwise a pair (() . <name>). Both <prefix> and <name> are strings."
  (let ((string (symbol-name symbol)))
    (if (null (string-match "\\([a-z]*\\):\\(.*\\)$" string))
        (cons () string)
      (cons (substring string (match-beginning 1) (match-end 1))
            (substring string (match-beginning 2) (match-end 2))))))

(defun tm:make-name (prefix &rest strings)
  "Return a symbol made of the concatenation of STRINGS. If PREFIX is not
(), it prefixes the new symbol."
  (intern
   (if prefix
       (apply 'concat prefix ":" strings)
     (apply 'concat strings))))

(defun tm:collect-slot-names (slots superclass)
  (let ((super-slots (tm:all-class-slots superclass)))
    (tm:loop ((index from: (+ 2 (length super-slots)))
	      (next in: slots))
	     (let ((slot-name (if (consp next) (car next) next))
		   (init-list (if (consp next) (cdr next) ())))
	       (if (memq slot-name super-slots)
		   ()
		 (tm:collect (cons (symbol-name slot-name)
				   (cons index init-list))))))))

(defun tm:verify-list (l)
  (cond ((symbolp l) t)
	((null l) t)
	((consp l)
	 (and (tm:verify-list (car l))
	      (tm:verify-list (cdr l))))
	(t ())))

(defun tm:compute-gpos-var (gname)
  (tm:make-name "internal" (symbol-name gname) "-position"))

(defun tm:compute-gvect-var (class-name)
  (tm:make-name "internal" (symbol-name class-name) "-gen-vect"))

(provide 'talk-struct)
