;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; LUSH Lisp Universal Shell
;;;   Copyright (C) 2002 Leon Bottou, Yann Le Cun, AT&T Corp, NECI.
;;; Includes parts of TL3:
;;;   Copyright (C) 1987-1999 Leon Bottou and Neuristique.
;;; Includes selected parts of SN3.2:
;;;   Copyright (C) 1991-2001 AT&T Corp.
;;;
;;; 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 of the License, 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 this program; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; $Id: overload.lsh,v 1.5 2003/03/06 04:44:58 leonb Exp $
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



#? *** Overloading compiled functions
;; Bla bla.




#? (typematch (<dh1>...<dhn>) <...args...>)
;; Apply the first of the DH functions <dh1>...<dhn>
;; whose prototype matches the type of the 
;; arguments <...args...>

(dm typematch(fn dhlist . args)
  (list typematch.sub (list 'quote dhlist) . args) )


#? (overload <overloadname> <...dhfunctionnames...>)
;; Define <overloadname> as an overloaded function
;; and adds <dhfunctioname> as one of its alternatives.

(dm overload(overload overloadname . dhfuncnames)
  (let ((alternatives (getp overloadname 'overload)))
    (each ((dhfuncname (reverse dhfuncnames)))
      (when (not (member dhfuncname alternatives))
        (setq alternatives (cons dhfuncname alternatives)) ) )
    (putp overloadname 'overload alternatives) )
  (list 'setq `:,overloadname
        (mlambda(overloadname . args)
          (list 'typematch (getp overloadname 'overload) . args) ) ) )


;; This function converts type descriptors
;; returned by function dhinfo-t into type declarations.
;; Why so many representations?
(de typematch.typedecl(desc)
  (while (and (consp desc) (= (car desc) 'ptr))
    (setq desc (cadr desc)) )
  (selectq (car desc)
    ;; Simple types
    (gptr '(-gptr-))
    (bool '(-bool-))
    (ubyte '(-ubyte- ))
    (byte '(-byte- ))
    (short '(-short- ))
    (int '(-int- ))
    (flt '(-flt- ))
    (real '(-real-))
    (str '(-str- ))
    (list (cons '-list- (mapcar typematch.typedecl (cdr desc))))
    (obj (list '-obj- (list (nth 1 desc))))
    (idx 
     (let* ((ndim (nth 2 desc))
            (base (nth 3 desc)) )
       (when (<> (car base) 'srg)
         (error 'typematch "Illegal type descriptor" desc) )
       (list (named (sprintf "-idx%d-" ndim))
             (typematch.typedecl (nth 2 base)) ) ) )
    (t
     (error 'typematch "Unsupported type descriptor" desc) ) ) )

;; This is the workhose of interpreted typematched calls
(de typematch.sub(dhlist . args)
  (let ((found ())
        (nargs (length args)))
    (while (not found)
      (when (not (consp dhlist))
        (error 'typematch "No type match for these arguments" ()) )
      (let* ((name (car dhlist))
             (func (eval `:,name))
             (info ()) )
        (setq dhlist (cdr dhlist))
        (when (is-of-class func |DH|)
          (setq info (dhinfo-t func)) )
        (when (not info)
          (error 'typematch "Not a compiled DH function" name) )
        (setq info (mapcar typematch.typedecl (cadr info)))
        (when (= (length info) nargs)
          (let ((okay t))
            (each ((d info)
                   (a args))
              (when okay
                (let ((p (getp (eval `:,(car d)) 'type-syntax)))
                  (setq p (p 'typematch d))
                  (when (not (p a))
                    (setq okay ()) ) ) ) )
            (when okay
              (setq found func) ) ) ) ) )
    (apply found args) ) )

;; dhm-p
(dhm-p typematch(source)
  (if (and (consp source) (consp (cdr source)))
      (cons (car source) (cons (cadr source) (dhc-pp-all (cddr source))))
    source ) )

;; compare types (ugly)
(de typematch.typecheck(ot1 ot2)
  (setq ot1 (==> ot1 copy))
  (setq ot2 (==> ot2 copy))
  (let ((dhc-unif-error-flag t)
        (dhc-unif-error (lambda args (setq dhc-unif-error-flag ()))) )
    (dhc-unify-types ot1 ot2)
    dhc-unif-error-flag ) )

;; dhm-t
(dhm-t typematch(source)
  (let* ((fs (cadr source))
         (as (cddr source)) 
         (ftypes ())
         (anodes ()) 
         (found-name ()) )
    ;; Check
    (each ((f fs))
      (when (not (symbolp f))
        (dhc-error "A list of function names was expected" fs) ) )
    (setq fnodes (all ((f fs)) (dhc-parse-expr-t f)) )
    (setq anodes (all ((a as)) (dhc-parse-expr-t a)) )
    ;; Search function
    (while (not found-name)
      (when (not (consp fs))
        (dhc-error "No type match for these arguments") )
      (let* ((f (car fs))
             (fnode (car fnodes))
             (ftype :fnode:type)
             (ptypes (dhu-extra ftype)) )
        (setq fs (cdr fs))
        (setq fnodes (cdr fnodes))
        (when (= (length ptypes) (length anodes))
          (let ((okay t))
            (each ((ptype ptypes)
                   (anode anodes))
              (when (and okay (not (typematch.typecheck ptype :anode:type)))
                (setq okay ()) ) ) 
            (when okay
              (setq found-name f) ) ) ) ) )
    ;; Select
    (dhc-parse-replacement-source-t 
     source (cons found-name (cddr source))) ) )






;;; Some tests


(when ()

  (libload "idx-float")
  (libload "idx-double")
  
  (overload idx-dotc idx-d3dotc idx-d2dotc idx-d1dotc)
  (overload idx-dotc idx-f3dotc)
  (overload idx-dotc idx-f2dotc)
  (overload idx-dotc idx-f1dotc)
  
  (de aa(a c b) ((-flt-) c) ((-idx1- (-flt-)) a b)
      (idx-dotc a c b) )
  (de ab(a c b) ((-flt-) c) ((-idx2- (-flt-)) a b)
      (idx-dotc a c b) )
  (de ac(a c b) ((-flt-) c) ((-idx3- (-flt-)) a b)
      (idx-dotc a c b) )
  (de ba(a c b) ((-real-) c) ((-idx1- (-real-)) a b)
      (idx-dotc a c b) )
  (de bb(a c b) ((-real-) c) ((-idx2- (-real-)) a b)
      (idx-dotc a c b) )
  (de bc(a c b) ((-real-) c) ((-idx3- (-real-)) a b)
      (idx-dotc a c b) )

  (dhc-make "test" aa ab ac ba bb bc)

)

