;;; liece-handler.el --- function overloading facilities
;; Copyright (C) 1998-2000 Daiki Ueno

;; Author: Daiki Ueno <ueno@unixuser.org>
;; Created: 1999-06-05

;; This file is part of Liece.

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.	 See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.


;;; Commentary:
;; 

;;; Code:

(eval-when-compile (require 'cl))

(eval-when-compile (require 'liece-inlines))

(eval-when-compile (require 'liece-clfns))

(defmacro liece-handler-make-obarray (backend)
  `(defvar ,(intern (format "liece-handler-%s-obarray" backend))
     (make-vector 107 0)))

(defmacro liece-handler-obarray (backend)
  `(symbol-value (intern-soft (format "liece-handler-%s-obarray" ,backend))))

(defun liece-handler-override-function-definition (name backend args function)
  (let ((ref (symbol-name (liece-gensym))))
    (if (symbolp name)
	(setq name (symbol-name name)))
    (put (intern name (liece-handler-obarray backend)) 'unifiers
	 (nconc (get (intern name (liece-handler-obarray backend)) 'unifiers)
		(list `(,(intern ref (liece-handler-obarray backend))
			,@args))))
    (fset (intern ref (liece-handler-obarray backend)) function)))

(defun liece-handler-unify-argument-list-function (args unifiers)
  (let ((index 0)
	(unfs (copy-alist unifiers))
	(len (length args))
	type)
    (setq unfs
	  (remove-if (lambda (unf) (/= (length (cdr unf)) len)) unfs))
    (dolist (arg args)
      (if (listp arg)
	  (setq unfs (remove-if-not
		      (lambda (unf)
			(let ((spec (nth index (cdr unf))))
			  (or (not (listp spec))
			      (eq (car spec) (car arg)))))
		      unfs)))
      (incf index))
    (if (caar unfs)
	(symbol-function (caar unfs)))))

(defmacro liece-handler-define-backend (type &optional parents)
  `(liece-handler-make-obarray ,type))

(defun liece-handler-find-function (name args backend)
  (let* ((fsym (intern-soft name (liece-handler-obarray backend)))
	 (unifiers (if fsym (get fsym 'unifiers))))
    (liece-handler-unify-argument-list-function args unifiers)))

(defun liece-handler-define-function (name specs function)
  (let ((args (butlast specs))
	(backend (car (last specs))))
    (liece-handler-override-function-definition name backend args function)))

(provide 'liece-handler)

;;; liece-handler.el ends here