Re: overload a procedure

[Damien Mattei]

yes your are right, it works with GOOPS out of the box.
scheme@(guile-user)> (use-modules (oop goops) (srfi srfi-43))
scheme@(guile-user)> (define-method (+ (a <vector>) (b <vector>))
(vector-append a b))
scheme@(guile-user)> (+ #(1 2 3) #(4 5))
$3 = #(1 2 3 4 5)
scheme@(guile-user)> (+ #(1 2 3) #(4 5) #(2 5))
$4 = #(1 2 3 4 5 2 5)
scheme@(guile-user)> (define (add-list-list L1 L2) (map + L1 L2))
scheme@(guile-user)> <vector>
$5 = #<<class> <vector> 102b5a780>
scheme@(guile-user)> <list>
$6 = #<<class> <list> 102b5aa00>
scheme@(guile-user)> (define-method (+ (a <list>) (b <list>))
(add-list-list a b))
scheme@(guile-user)> (+ '(1 2 3) '(4 5 6))
$7 = (5 7 9)
scheme@(guile-user)> (+ '(1 2 3) '(4 5 6) '(7 8 9))
$8 = (12 15 18)
scheme@(guile-user)> (define-method (area (a <number>)) (* a a))
scheme@(guile-user)> (area 3)
$9 = 9
scheme@(guile-user)> (define-method (area (a <number>) (b <number>)) (* a
b))
scheme@(guile-user)> (area 3 4)
$10 = 12
scheme@(guile-user)> {'(1 2 3) + '(4 5 6)}
$11 = (5 7 9)

i wanted a more portable solution, i'm coming near a solution that works
with a procedure, not a macro:

(define (overload-proc orig-funct funct pred-list)

  (display "overload-proc") (newline)
  (define old-funct orig-funct)
  (define new-funct (lambda args ;; args is the list of arguments
     (display "new-funct: ") (display new-funct) (newline)
     (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)

  new-funct)

still a few things to fix like dealing with an arbitrary number of
parameters (what GOOPS do very well) and it will be good:

 scheme@(guile-user)> (load "overload-recursive.scm")
scheme@(guile-user)> (define (add-list-list L1 L2) (map + L1 L2))
scheme@(guile-user)> (define + (overload-proc + add-list-list (list list?
list?)))
overload-proc
funct: #<procedure add-list-list (L1 L2)>
orig-funct: #<procedure + (#:optional _ _ . _)>
old-funct: #<procedure + (#:optional _ _ . _)>
new-funct: #<procedure new-funct args>
scheme@(guile-user)> (+ 2 3)
new-funct: #<procedure new-funct args>
new-funct : pred-list = (#<procedure list? (_)> #<procedure list? (_)>)
new-funct : pred-arg-list = ((#<procedure list? (_)> . 2) (#<procedure
list? (_)> . 3))
new-funct : chk-args = #f
new-funct : args = (2 3)
new funct :calling:#<procedure + (#:optional _ _ . _)>
$1 = 5
scheme@(guile-user)> (+ '(1 2 3) '(4 5 6))
new-funct: #<procedure new-funct 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)> (+ '(1 2 3) '(4 5 6) '(7 8 9))
new-funct: #<procedure new-funct args>
new-funct : pred-list = (#<procedure list? (_)> #<procedure list? (_)>)
ice-9/boot-9.scm:1685:16: In procedure raise-exception:
In procedure map: List of wrong length: ((1 2 3) (4 5 6) (7 8 9))

Entering a new prompt.  Type `,bt' for a backtrace or `,q' to continue.
scheme@(guile-user) [1]> ,q
scheme@(guile-user)> (define (add-pair p1 p2) (cons (+ (car p1) (car p2))
(+ (cdr p1) (cdr p2))))
scheme@(guile-user)> (define + (overload-proc + add-pair (list pair?
pair?)))
overload-proc
funct: #<procedure add-pair (p1 p2)>
orig-funct: #<procedure new-funct args>
old-funct: #<procedure new-funct args>
new-funct: #<procedure new-funct args>
scheme@(guile-user)> (+ (cons 1 2) (cons 3 4))
new-funct: #<procedure new-funct args>
new-funct : pred-list = (#<procedure pair? (_)> #<procedure pair? (_)>)
new-funct : pred-arg-list = ((#<procedure pair? (_)> 1 . 2) (#<procedure
pair? (_)> 3 . 4))
new-funct : chk-args = #t
new-funct : args = ((1 . 2) (3 . 4))
new funct :calling:#<procedure add-pair (p1 p2)>
new-funct: #<procedure new-funct args>
new-funct : pred-list = (#<procedure pair? (_)> #<procedure pair? (_)>)
new-funct : pred-arg-list = ((#<procedure pair? (_)> . 1) (#<procedure
pair? (_)> . 3))
new-funct : chk-args = #f
new-funct : args = (1 3)
new funct :calling:#<procedure new-funct args>
new-funct: #<procedure new-funct args>
new-funct : pred-list = (#<procedure list? (_)> #<procedure list? (_)>)
new-funct : pred-arg-list = ((#<procedure list? (_)> . 1) (#<procedure
list? (_)> . 3))
new-funct : chk-args = #f
new-funct : args = (1 3)
new funct :calling:#<procedure + (#:optional _ _ . _)>
new-funct: #<procedure new-funct args>
new-funct : pred-list = (#<procedure pair? (_)> #<procedure pair? (_)>)
new-funct : pred-arg-list = ((#<procedure pair? (_)> . 2) (#<procedure
pair? (_)> . 4))
new-funct : chk-args = #f
new-funct : args = (2 4)
new funct :calling:#<procedure new-funct args>
new-funct: #<procedure new-funct args>
new-funct : pred-list = (#<procedure list? (_)> #<procedure list? (_)>)
new-funct : pred-arg-list = ((#<procedure list? (_)> . 2) (#<procedure
list? (_)> . 4))
new-funct : chk-args = #f
new-funct : args = (2 4)
new funct :calling:#<procedure + (#:optional _ _ . _)>
$3 = (4 . 6)
scheme@(guile-user)> (+ 3 4)
new-funct: #<procedure new-funct args>
new-funct : pred-list = (#<procedure pair? (_)> #<procedure pair? (_)>)
new-funct : pred-arg-list = ((#<procedure pair? (_)> . 3) (#<procedure
pair? (_)> . 4))
new-funct : chk-args = #f
new-funct : args = (3 4)
new funct :calling:#<procedure new-funct args>
new-funct: #<procedure new-funct 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 + (#:optional _ _ . _)>
$4 = 7
scheme@(guile-user)> (+ '(1 2 3) '(4 5 6))
new-funct: #<procedure new-funct args>
new-funct : pred-list = (#<procedure pair? (_)> #<procedure pair? (_)>)
new-funct : pred-arg-list = ((#<procedure pair? (_)> 1 2 3) (#<procedure
pair? (_)> 4 5 6))
new-funct : chk-args = #t
new-funct : args = ((1 2 3) (4 5 6))
new funct :calling:#<procedure add-pair (p1 p2)>
new-funct: #<procedure new-funct args>
new-funct : pred-list = (#<procedure pair? (_)> #<procedure pair? (_)>)
new-funct : pred-arg-list = ((#<procedure pair? (_)> . 1) (#<procedure
pair? (_)> . 4))
new-funct : chk-args = #f
new-funct : args = (1 4)
new funct :calling:#<procedure new-funct args>
new-funct: #<procedure new-funct args>
new-funct : pred-list = (#<procedure list? (_)> #<procedure list? (_)>)
new-funct : pred-arg-list = ((#<procedure list? (_)> . 1) (#<procedure
list? (_)> . 4))
new-funct : chk-args = #f
new-funct : args = (1 4)
new funct :calling:#<procedure + (#:optional _ _ . _)>
new-funct: #<procedure new-funct args>
new-funct : pred-list = (#<procedure pair? (_)> #<procedure pair? (_)>)
new-funct : pred-arg-list = ((#<procedure pair? (_)> 2 3) (#<procedure
pair? (_)> 5 6))
new-funct : chk-args = #t
new-funct : args = ((2 3) (5 6))
new funct :calling:#<procedure add-pair (p1 p2)>
new-funct: #<procedure new-funct args>
new-funct : pred-list = (#<procedure pair? (_)> #<procedure pair? (_)>)
new-funct : pred-arg-list = ((#<procedure pair? (_)> . 2) (#<procedure
pair? (_)> . 5))
new-funct : chk-args = #f
new-funct : args = (2 5)
new funct :calling:#<procedure new-funct args>
new-funct: #<procedure new-funct args>
new-funct : pred-list = (#<procedure list? (_)> #<procedure list? (_)>)
new-funct : pred-arg-list = ((#<procedure list? (_)> . 2) (#<procedure
list? (_)> . 5))
new-funct : chk-args = #f
new-funct : args = (2 5)
new funct :calling:#<procedure + (#:optional _ _ . _)>
new-funct: #<procedure new-funct args>
new-funct : pred-list = (#<procedure pair? (_)> #<procedure pair? (_)>)
new-funct : pred-arg-list = ((#<procedure pair? (_)> 3) (#<procedure pair?
(_)> 6))
new-funct : chk-args = #t
new-funct : args = ((3) (6))
new funct :calling:#<procedure add-pair (p1 p2)>
new-funct: #<procedure new-funct args>
new-funct : pred-list = (#<procedure pair? (_)> #<procedure pair? (_)>)
new-funct : pred-arg-list = ((#<procedure pair? (_)> . 3) (#<procedure
pair? (_)> . 6))
new-funct : chk-args = #f
new-funct : args = (3 6)
new funct :calling:#<procedure new-funct args>
new-funct: #<procedure new-funct args>
new-funct : pred-list = (#<procedure list? (_)> #<procedure list? (_)>)
new-funct : pred-arg-list = ((#<procedure list? (_)> . 3) (#<procedure
list? (_)> . 6))
new-funct : chk-args = #f
new-funct : args = (3 6)
new funct :calling:#<procedure + (#:optional _ _ . _)>
new-funct: #<procedure new-funct args>
new-funct : pred-list = (#<procedure pair? (_)> #<procedure pair? (_)>)
new-funct : pred-arg-list = ((#<procedure pair? (_)>) (#<procedure pair?
(_)>))
new-funct : chk-args = #f
new-funct : args = (() ())
new funct :calling:#<procedure new-funct args>
new-funct: #<procedure new-funct args>
new-funct : pred-list = (#<procedure list? (_)> #<procedure list? (_)>)
new-funct : pred-arg-list = ((#<procedure list? (_)>) (#<procedure list?
(_)>))
new-funct : chk-args = #t
new-funct : args = (() ())
new funct :calling:#<procedure add-list-list (L1 L2)>
$5 = (5 7 9)
sorry for the verbose output, it is still in developping...
regards,
damien

On Sun, Feb 19, 2023 at 6:52 PM Vivien Kraus <vivien@planete-kraus.eu>
wrote:

> Hi Damien,
>
> Le dimanche 19 février 2023 à 18:45 +0100, Damien Mattei a écrit :
> > 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?)
>
> Did you try GOOPS? It provides that kind of functionality.
>
> (use-modules (oop goops) (srfi srfi-43))
> (define-method (+ (a <vector>) (b <vector>)) (vector-append a b))
> (+ #(1 2 3) #(4 5))
>
> Vivien
>