From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: Damien Mattei Newsgroups: gmane.lisp.guile.user Subject: overload a procedure Date: Sun, 19 Feb 2023 18:45:39 +0100 Message-ID: Mime-Version: 1.0 Content-Type: text/plain; charset="UTF-8" Content-Transfer-Encoding: quoted-printable Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="28763"; mail-complaints-to="usenet@ciao.gmane.io" To: guile-user Original-X-From: guile-user-bounces+guile-user=m.gmane-mx.org@gnu.org Sun Feb 19 18:46:44 2023 Return-path: Envelope-to: guile-user@m.gmane-mx.org Original-Received: from lists.gnu.org ([209.51.188.17]) by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1pTnls-0007L4-KS for guile-user@m.gmane-mx.org; Sun, 19 Feb 2023 18:46:44 +0100 Original-Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1pTnlD-00085j-7d; Sun, 19 Feb 2023 12:46:03 -0500 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1pTnl6-000811-Ie for guile-user@gnu.org; Sun, 19 Feb 2023 12:46:00 -0500 Original-Received: from mail-ed1-x534.google.com ([2a00:1450:4864:20::534]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1pTnl3-0006KN-5f for guile-user@gnu.org; Sun, 19 Feb 2023 12:45:55 -0500 Original-Received: by mail-ed1-x534.google.com with SMTP id ek25so3437122edb.7 for ; Sun, 19 Feb 2023 09:45:52 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20210112; h=to:subject:message-id:date:from:mime-version:from:to:cc:subject :date:message-id:reply-to; bh=fho01Sotwac6WRmjJb1I6oIwJ8pi6AVmiTHheMGMp9U=; b=l6tAwfn0ogAN2xN7AOpOl/e20i7AhGVclFoE2Aq0Av/Xamu152E7n7f13DZkMdesnZ D6cm0JY4v0rXHTQ+RW84rrbZ7voEVVXBEdr7PAiCMbcJ/HVySPSbkEBF/cefwN9jxjbR TyUKRo2eOH9NTFTkXzEWeHzDloj+90aPggdaTcEmKTe3+8EzA9VC/3Quz26M8hAEYci6 9nZCKXHJM3PeIMUbUk/yBD8qQYLBnMl0mskOG3UDYe8EiX4suXYNm5KfnLddSuGsX7p4 zOMYLDUQBlOwCOATPF2j+A6hfMLsA0Po64HEYmGFuJKFLLkJXIyO52QCj+Lh6OHzQ/ar V3Zw== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=to:subject:message-id:date:from:mime-version:x-gm-message-state :from:to:cc:subject:date:message-id:reply-to; bh=fho01Sotwac6WRmjJb1I6oIwJ8pi6AVmiTHheMGMp9U=; b=ssSpLz/5VOHSriXsbRUReue6V91paBVoSp2bJX0nK1bPi1g+7tA2b5JkjqPdw2LqtX ATvuepr62xTI1wxWww+YbIgR2Grql4z+lby0jhxpkFPMvI+Tl+kxzWPxIPtwvecexOL4 sc+zANxUW8HcLy/s6xunr1HPs+jf76A34HUxexIuVN+GMTY4tCwZM/JUHSwa0fOCPNxV +Kv1v3JL6RGGoXYWH9UF73ZAdIBemCVhyHGly3sxw3Mx7ZNozZ6I3MkBXBsLW4C/Xese ndfNjCECPr9EzuGTAX6tyoR0Tlo4+yIlDX8HfGTp7NjbcP6mtGzLTBxQP1WVq8nV0wrp ABXA== X-Gm-Message-State: AO0yUKVZgFuaeCtu6qPrXYv5BY11Wj+f6qTre0Qkdtol31yYb6GtE7qk GAZqMtlV/caWJr5JoJV7r5wc27K9As4IzG5YlmcDrZTREBE= X-Google-Smtp-Source: AK7set8NbG0OM9hwg18USWYgchBFKp0aL7iTWHmVVCSs6kusgkKYiVc98wYlRR1HrGlvdFqhC/mPYOo3oWU6Ud+WZCw= X-Received: by 2002:a17:906:d9dc:b0:887:2895:d26e with SMTP id qk28-20020a170906d9dc00b008872895d26emr3221848ejb.4.1676828750735; Sun, 19 Feb 2023 09:45:50 -0800 (PST) Received-SPF: pass client-ip=2a00:1450:4864:20::534; envelope-from=damien.mattei@gmail.com; helo=mail-ed1-x534.google.com X-Spam_score_int: -20 X-Spam_score: -2.1 X-Spam_bar: -- X-Spam_report: (-2.1 / 5.0 requ) BAYES_00=-1.9, DKIM_SIGNED=0.1, DKIM_VALID=-0.1, DKIM_VALID_AU=-0.1, DKIM_VALID_EF=-0.1, FREEMAIL_FROM=0.001, HTML_MESSAGE=0.001, RCVD_IN_DNSWL_NONE=-0.0001, SPF_HELO_NONE=0.001, SPF_PASS=-0.001 autolearn=ham autolearn_force=no X-Spam_action: no action X-Content-Filtered-By: Mailman/MimeDel 2.1.29 X-BeenThere: guile-user@gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: General Guile related discussions List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-user-bounces+guile-user=m.gmane-mx.org@gnu.org Original-Sender: guile-user-bounces+guile-user=m.gmane-mx.org@gnu.org Xref: news.gmane.io gmane.lisp.guile.user:18918 Archived-At: 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_cl= ass.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_fu= nction_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 (=CE=BB (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 =3D (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 =3D (5 7 9) ;; scheme@(guile-user)> (overload + add-vect-vect list? list?) ;; scheme@(guile-user)> (+ '(1 2 3) '(4 5 6)) ;; $5 =3D (5 7 9) ;; scheme@(guile-user)> (+ '(1 2 3) '(4 5 6) '(7 8 9)) ;; $6 =3D (12 15 18) ;; scheme@(guile-user)> (+ '(1 2 3)) ;; $7 =3D (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 =3D ") (display pred-list) (newlin= e) (define pred-arg-list (map cons pred-list args)) (display "new-funct : pred-arg-list =3D ") (display pred-arg-list) (newline) (define chk-args (andmap (=CE=BB (p) ((car p) (cdr p))) pred-arg-list)) (display "new-funct : chk-args =3D ") (display chk-args) (newline) (display "new-funct : args =3D ") (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 =3D ") (display pred-list) (newline) ;; (define pred-arg-list (map cons pred-list args)) ;; (display "new-funct : pred-arg-list =3D ") (display pred-arg-list) (newline) ;; (define chk-args (andmap (=CE=BB (p) ((car p) (cdr p))) ;; pred-arg-list)) ;; (display "new-funct : chk-args =3D ") (display chk-args) (newline) ;; (display "new-funct : args =3D ") (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.sc= m ;;; 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=3D0 ;;; 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?) ;;; :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. ;;; :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: # orig-funct: # old-funct: # new-funct: # after re-define: orig-funct: # scheme@(guile-user)> (+ '(1 2 3) '(4 5 6)) new-funct: # new-funct : pred-list =3D (# #) new-funct : pred-arg-list =3D ((# 1 2 3) (# 4 5 6)) new-funct : chk-args =3D #t new-funct : args =3D ((1 2 3) (4 5 6)) new funct :calling:# $1 =3D (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: # orig-funct: # old-funct: # new-funct: # after re-define: orig-funct: # scheme@(guile-user)> (+ '(1 2 3) '(4 5 6)) new-funct: # new-funct : pred-list =3D (# #) new-funct : pred-arg-list =3D ((# 1 2 3) (# 4 5 6)) new-funct : chk-args =3D #f new-funct : args =3D ((1 2 3) (4 5 6)) new funct :calling:# new-funct: # new-funct : pred-list =3D (# #) new-funct : pred-arg-list =3D ((# 1 2 3) (# 4 5 6)) new-funct : chk-args =3D #t new-funct : args =3D ((1 2 3) (4 5 6)) new funct :calling:# $2 =3D (5 7 9) scheme@(guile-user)> (+ 3 4) new-funct: # new-funct : pred-list =3D (# #) new-funct : pred-arg-list =3D ((# . 3) (# . 4)) new-funct : chk-args =3D #f new-funct : args =3D (3 4) new funct :calling:# new-funct: # new-funct : pred-list =3D (# #) new-funct : pred-arg-list =3D ((# . 3) (# . 4)) new-funct : chk-args =3D #f new-funct : args =3D (3 4) new funct :calling:# new-funct: # new-funct : pred-list =3D (# #) new-funct : pred-arg-list =3D ((# . 3) (# . 4)) new-funct : chk-args =3D #f new-funct : args =3D (3 4) it run in an infinite recursive call. the problem seems to come from macro and hygiene and the procedure : # 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