overload a procedure

[Damien Mattei <damien.mattei@gmail.com>]

hello,

i try to make a macro to overload a procedure in scheme.

i already done it in Python in two ways:
-with decorator using a hash table that save the functions and the
parameters types:
https://github.com/damien-mattei/vision3D_python/blob/master/Overload_by_class.py
-with decorator and functions using recursive functions that check the
parameters at each level of recursion until it fall back to the good
parameters types or default to the built in procedure:
https://github.com/damien-mattei/vision3D_python/blob/master/Overload_by_function_recursive.py
i suppose it works, at least the Overload_by_class.py has been already used
intensively in :
https://github.com/damien-mattei/vision3D_python/blob/master/Matrix3x3.py

ok now i come to the scheme problem implementing the two solutions; in
scheme i can not use types so i use type predicates (number? verctor?
string? list?....)to identify the good function depending of the parameters
types find with the predicates.
i tried with macro and recursive function with this solution:

example of use::
(overload + add-vect-vect vector? vector?)

here is the code:

;; overload

;; (define-module (overload-recursive)
;;   #:use-module ((guile))
;;   #:export (overload))

;; alternate: comment above and (load "overload-recursive.scm")

;; (use-modules (overload-recursive))
;; (define (mult-num-vect k v) (map (λ (x) (* k x)) v))

;; (overload * mult-num-vect number? list?)

;;(* 3 '(1 2 3))

;; scheme@(guile-user)> (use-modules (overload-recursive))
;; scheme@(guile-user)> (define (add-list-list L1 L2) (map + L1 L2))
;; scheme@(guile-user)> (overload + add-list-list list? list?)
;; scheme@(guile-user)> (+ '(1 2 3) '(4 5 6))

;; (use-modules (srfi srfi-43)) ;; vector-map
;; (define (add-vect-vect V1 V2) (vector-map + V1 V2))
;; (overload + add-vect-vect vector? vector?)
;; (+ (vector 1 2 3) (vector 4 5 6))

;; exist in Racket but not Guile
(define andmap
  (lambda (function list1 . more-lists)
    (letrec ((some? (lambda (fct list)
     ;; returns #f if (function x) returns #t for
     ;; some x in the list
     (and (pair? list)
  (or (fct (car list))
      (some? fct (cdr list)))))))

      ;; variadic map implementation terminates
      ;; when any of the argument lists is empty.
      (let ((lists (cons list1 more-lists)))
(if (some? null? lists)
   #t
   (and (apply function (map car lists))
(apply andmap function (map cdr lists))))))))

;; scheme@(guile-user)> {3 * '(1 2 3)}
;; $3 = (3 6 9)

;; scheme@(guile-user)> (define (add-vect-vect v1 v2) (map + v1 v2))
;; scheme@(guile-user)> (add-vect-vect '(1 2 3) '(4 5 6))
;; $4 = (5 7 9)
;; scheme@(guile-user)> (overload + add-vect-vect list? list?)
;; scheme@(guile-user)> (+ '(1 2 3) '(4 5 6))
;; $5 = (5 7 9)
;; scheme@(guile-user)> (+ '(1 2 3) '(4 5 6) '(7 8 9))
;; $6 = (12 15 18)

;; scheme@(guile-user)> (+ '(1 2 3))
;; $7 = (1 2 3)

;; scheme@(guile-user)> (define (add-pair p1 p2) (cons (+ (car p1) (car
p2)) (+ (cdr p1) (cdr p2))))
;; scheme@(guile-user)> (overload + add-pair pair? pair?)
;; overload
;; scheme@(guile-user)> (+ (cons 1 2) (cons 3 4))
(define-syntax overload

  (syntax-rules ()


    ((_ orig-funct funct pred-arg1 ...)  (begin
 (display "overload") (newline)
 (define old-funct orig-funct)
     (define new-funct (lambda args ;; args is the list of arguments
     (display "new-funct: ") (display new-funct) (newline)
         (define pred-list (list pred-arg1 ...))
         (display "new-funct : pred-list = ") (display pred-list) (newline)
         (define pred-arg-list (map cons pred-list args))
         (display "new-funct : pred-arg-list = ") (display pred-arg-list)
(newline)

     (define chk-args (andmap (λ (p) ((car p) (cdr p)))
            pred-arg-list))
         (display "new-funct : chk-args = ") (display chk-args) (newline)
     (display "new-funct : args = ") (display args) (newline)
         (if chk-args
 (begin
   (display "new funct :calling:") (display funct) (newline)
   (apply funct args))
 (begin
   (display "new funct :calling:") (display old-funct) (newline)
   (apply old-funct args)))))
 (display "funct: ") (display funct) (newline)
 (display "orig-funct: ") (display orig-funct) (newline)
 (display "old-funct: ") (display old-funct) (newline)
 (display "new-funct: ") (display new-funct) (newline)

     ;;(set! orig-funct new-funct)
 (define orig-funct new-funct)
 ;;(display "after set!: orig-funct: ")
 (display "after re-define: orig-funct: ") (display orig-funct)
(newline)))))




     ;; ((_ orig-funct funct pred-arg1 ...)  (let* ((old-funct orig-funct)
     ;; (new-funct  (lambda args ;; args is the list of arguments
     ;;      (display "new-funct: ") (display new-funct) (newline)
     ;;      (define pred-list (list pred-arg1 ...))
     ;;      (display "new-funct : pred-list = ") (display pred-list)
(newline)
     ;;      (define pred-arg-list (map cons pred-list args))
     ;;      (display "new-funct : pred-arg-list = ") (display
pred-arg-list) (newline)

     ;;      (define chk-args (andmap (λ (p) ((car p) (cdr p)))
     ;;             pred-arg-list))
     ;;      (display "new-funct : chk-args = ") (display chk-args)
(newline)
     ;;      (display "new-funct : args = ") (display args) (newline)
     ;;      (if chk-args
     ;;  (begin
     ;;    (display "new funct :calling:") (display funct) (newline)
     ;;    (apply funct args))
     ;;  (begin
     ;;    (display "new funct :calling:") (display old-funct) (newline)
     ;;    (apply old-funct args))))))

     ;;   (display "funct: ") (display funct) (newline)
     ;;   (display "orig-funct: ") (display orig-funct) (newline)
     ;;   (display "old-funct: ") (display old-funct) (newline)
     ;;   (display "new-funct: ") (display new-funct) (newline)

     ;;   ;;(set! orig-funct new-funct)
     ;;   (define orig-funct new-funct)
     ;;   ;;(display "after set!: orig-funct: ")
     ;;   (display "after re-define: orig-funct: ") (display orig-funct)
(newline)
     ;;   ))))

unfortunately it fail to overload correctly:

scheme@(guile-user)> (use-modules (overload-recursive))
;;; note: source file /usr/local/share/guile/site/3.0/overload-recursive.scm
;;;       newer than compiled
/Users/mattei/.cache/guile/ccache/3.0-LE-8-4.6/usr/local/share/guile/site/3.0/overload-recursive.scm.go
;;; note: auto-compilation is enabled, set GUILE_AUTO_COMPILE=0
;;;       or pass the --no-auto-compile argument to disable.
;;; compiling /usr/local/share/guile/site/3.0/overload-recursive.scm
;;; compiled
/Users/mattei/.cache/guile/ccache/3.0-LE-8-4.6/usr/local/share/guile/site/3.0/overload-recursive.scm.go
scheme@(guile-user)> (define (add-list-list L1 L2) (map + L1 L2))
scheme@(guile-user)> (overload + add-list-list list? list?)
;;; <stdin>:3:10: warning: non-idempotent binding for `+'.  When first
loaded, value for `+` comes from imported binding, but later module-local
definition overrides it; any module reload would capture module-local
binding rather than import.
;;; <stdin>:3:10: warning: non-idempotent binding for `+'.  When first
loaded, value for `+` comes from imported binding, but later module-local
definition overrides it; any module reload would capture module-local
binding rather than import.
overload
funct: #<procedure add-list-list (L1 L2)>
orig-funct: #<procedure + (#:optional _ _ . _)>
old-funct: #<procedure + (#:optional _ _ . _)>
new-funct: #<procedure new-funct-3b4b7258f9d0b3 args>
after re-define: orig-funct: #<procedure new-funct-3b4b7258f9d0b3 args>
scheme@(guile-user)> (+ '(1 2 3) '(4 5 6))
new-funct: #<procedure new-funct-3b4b7258f9d0b3 args>
new-funct : pred-list = (#<procedure list? (_)> #<procedure list? (_)>)
new-funct : pred-arg-list = ((#<procedure list? (_)> 1 2 3) (#<procedure
list? (_)> 4 5 6))
new-funct : chk-args = #t
new-funct : args = ((1 2 3) (4 5 6))
new funct :calling:#<procedure add-list-list (L1 L2)>
$1 = (5 7 9)
scheme@(guile-user)> (use-modules (srfi srfi-43)) ;; vector-map
scheme@(guile-user)>  (define (add-vect-vect V1 V2) (vector-map + V1 V2))

scheme@(guile-user)>  (overload + add-vect-vect vector? vector?)
overload
funct: #<procedure add-vect-vect (V1 V2)>
orig-funct: #<procedure new-funct-3b4b7258f9d0b3 args>
old-funct: #<procedure new-funct-3b4b7258f9d0b3 args>
new-funct: #<procedure new-funct-3b4b7258f9d0b3 args>
after re-define: orig-funct: #<procedure new-funct-3b4b7258f9d0b3 args>
scheme@(guile-user)> (+ '(1 2 3) '(4 5 6))
new-funct: #<procedure new-funct-3b4b7258f9d0b3 args>
new-funct : pred-list = (#<procedure vector? (_)> #<procedure vector? (_)>)
new-funct : pred-arg-list = ((#<procedure vector? (_)> 1 2 3) (#<procedure
vector? (_)> 4 5 6))
new-funct : chk-args = #f
new-funct : args = ((1 2 3) (4 5 6))
new funct :calling:#<procedure new-funct-3b4b7258f9d0b3 args>
new-funct: #<procedure new-funct-3b4b7258f9d0b3 args>
new-funct : pred-list = (#<procedure list? (_)> #<procedure list? (_)>)
new-funct : pred-arg-list = ((#<procedure list? (_)> 1 2 3) (#<procedure
list? (_)> 4 5 6))
new-funct : chk-args = #t
new-funct : args = ((1 2 3) (4 5 6))
new funct :calling:#<procedure add-list-list (L1 L2)>
$2 = (5 7 9)
scheme@(guile-user)> (+ 3 4)
new-funct: #<procedure new-funct-3b4b7258f9d0b3 args>
new-funct : pred-list = (#<procedure vector? (_)> #<procedure vector? (_)>)
new-funct : pred-arg-list = ((#<procedure vector? (_)> . 3) (#<procedure
vector? (_)> . 4))
new-funct : chk-args = #f
new-funct : args = (3 4)
new funct :calling:#<procedure new-funct-3b4b7258f9d0b3 args>
new-funct: #<procedure new-funct-3b4b7258f9d0b3 args>
new-funct : pred-list = (#<procedure list? (_)> #<procedure list? (_)>)
new-funct : pred-arg-list = ((#<procedure list? (_)> . 3) (#<procedure
list? (_)> . 4))
new-funct : chk-args = #f
new-funct : args = (3 4)
new funct :calling:#<procedure new-funct-3b4b7258f9d0b3 args>
new-funct: #<procedure new-funct-3b4b7258f9d0b3 args>
new-funct : pred-list = (#<procedure list? (_)> #<procedure list? (_)>)
new-funct : pred-arg-list = ((#<procedure list? (_)> . 3) (#<procedure
list? (_)> . 4))
new-funct : chk-args = #f
new-funct : args = (3 4)

it run in an infinite recursive call.

the problem seems to come from macro and hygiene and the procedure :
#<procedure new-funct-3b4b7258f9d0b3 args>
that always have look the same at any level of overloading.
also this message:
warning: non-idempotent binding for `+'.  When first loaded, value for `+`
comes from imported binding, but later module-local definition overrides
it; any module reload would capture module-local binding rather than import.
can be bind to the problem.

It is an interesting but hard problem to solve and i'm searching some help.
Or if someone has an alternate solution to to an overloading macro that
would works like this:
(define (add-vect-vect V1 V2) (vector-map + V1 V2))
(overload + add-vect-vect vector? vector?)

best regards,
Damien