#lang racket
(require "overload-by-recursive-functions.rkt")
(overload-existing-procedure length vector-length (vector?))
;(overload-existing-procedure length string-length (string?))
;
;(length #(1 2 3 4))
;(length '(1 2 3))
;(length "abcde")
in the required module i have:
(define-syntax overload-existing-procedure
(syntax-rules ()
((_ orig-funct funct (pred-arg1 ...))
(begin
(display "overload-existing-procedure :") (newline)
(define orig-funct (create-overloaded-procedure orig-funct funct (list pred-arg1 ...)))))))
this fails:
Welcome to DrRacket, version 8.9 [cs].
Language: racket, with debugging; memory limit: 8192 MB.
overload-existing-procedure :
. . length: undefined;
cannot reference an identifier before its definition
so i modify the module definition:
(define-syntax overload-existing-procedure
(syntax-rules ()
((_ orig-funct funct (pred-arg1 ...))
(begin
(display "overload-existing-procedure :") (newline)
(require (rename-in racket/base (orig-funct
backup-orig-funct)))
(define orig-funct (create-overloaded-procedure backup-orig-funct funct (list pred-arg1 ...)))))))
and it works
but only for one time, if i uncomment the second call it fails,which is normal:
#lang racket
(require "overload-by-recursive-functions.rkt")
(overload-existing-procedure length vector-length (vector?))
(overload-existing-procedure length string-length (string?))
;
;(length #(1 2 3 4))
;(length '(1 2 3))
;(length "abcde")
test.rkt:7:29: module: identifier already defined
at: length
in: (define-values (length) (create-overloaded-procedure backup-orig-funct string-length (list string?)))
#(181 6)
the solution would be to generate identifier for backup-orig-funct at each call of overload-existing-procedure
but i can not find a solution ( in Guile it works without modifications on the first code)
note that it is workin in toplevel but not in module and i do not want to force a toplevel behavior for that
i provides the full module code of overload-by-recursive-functions.rkt if someone want to use it for solving the problem:
#lang racket
;; overload
;; Damien Mattei
;; This file is part of Scheme+
;; Copyright 2021-2023 Damien MATTEI
;; 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 3 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, see <https://www.gnu.org/licenses/>.
;; Racket examples are in logic-syracuse code
;; Warning: overload is now a module to prevent infinite recursion in case someone overload a scheme procedure used in the implementation of any of the procedures provided by overload.scm (example: length !)
(provide define-overload-procedure
overload-procedure
define-overload-existing-procedure
overload-existing-procedure
define-overload-operator
overload-operator
define-overload-existing-operator
overload-existing-operator
define-overload-n-arity-operator
overload-n-arity-operator
define-overload-existing-n-arity-operator
overload-existing-n-arity-operator
increment-identifier-index
$ovrld-square-brackets-lst$
overload-square-brackets
;;find-getter-and-setter-for-overloaded-square-brackets
find-getter-for-overloaded-square-brackets
find-setter-for-overloaded-square-brackets
)
(require srfi/69) ;; Basic hash tables
;;(define $ovrld-ht$ (make-hash-table)) ;; for procedure and operators
(define $ovrld-square-brackets-lst$ '()) ;; for square brackets
(define identifier-index 0)
(define (increment-identifier-index)
(set! identifier-index (+ 1 identifier-index)))
;; dummy procedure , for compatibility with other API
(define-syntax define-overload-existing-procedure
(syntax-rules ()
((_ proc) '())))
;; (begin
;; (define qproc (quote proc))
;; (hash-table-set! $ovrld-meta$ qproc (list 'procedure 'existing))))))
(define-syntax define-overload-procedure
(syntax-rules ()
((_ proc)
(begin
(define qproc (quote proc))
(define (proc . args-lst) (error 'overload "failed because procedure can not be applied to arguments list. procedure , arguments list = " qproc args-lst))
;;(display "define-overload-procedure : proc =") (display proc) (newline)
;(hash-table-set! $ovrld-meta$ qproc (list 'procedure))
))))
(define-syntax define-overload-existing-operator
(syntax-rules ()
((_ proc) '()))) ;; do nothing
(define-syntax define-overload-existing-n-arity-operator
(syntax-rules ()
((_ proc) '())))
(define-syntax define-overload-operator
(syntax-rules ()
((_ proc)
(begin
(define qproc (quote proc))
(define (proc . args-lst) (error 'overload "failed because operator can not be applied to arguments list. operator , arguments list = " qproc args-lst))
(display "define-overload-operator : proc =") (display proc) (newline)
))))
(define-syntax define-overload-n-arity-operator
(syntax-rules ()
((_ proc)
(begin
(define qproc (quote proc))
(define (proc . args-lst) (error 'overload "failed because operator can not be applied to arguments list. operator , arguments list = " qproc args-lst))
(display "define-overload-operator : proc =") (display proc) (newline)
))))
;; Welcome to DrRacket, version 8.9 [cs].
;; Language: racket, with debugging; memory limit: 8192 MB.
;; > (define-overload-existing-procedure length)
;; '()
;; > (overload-existing-procedure length string-length (string?))
;; create-overloaded-procedure : pred-list = (#<procedure:string?>)
;; funct: #<procedure:string-length>
;; orig-funct: #<procedure:length>
;; old-funct: #<procedure:length>
;; new-funct: #<procedure:new-funct>
;; > (overload-existing-procedure length vector-length (vector?))
;; create-overloaded-procedure : pred-list = (#<procedure:vector?>)
;; funct: #<procedure:vector-length>
;; orig-funct: #<procedure:new-funct>
;; old-funct: #<procedure:new-funct>
;; new-funct: #<procedure:new-funct>
;; > (length "abcde")
;; 5
;; overload
(define-syntax overload-existing-procedure
(syntax-rules ()
((_ orig-funct funct (pred-arg1 ...))
(begin
(display "overload-existing-procedure :") (newline)
;;(define identifier-backup-orig-funct (string->symbol (string-append "backup-orig-funct" (number->string identifier-index))))
;;(increment-identifier-index)
(require (rename-in racket/base (orig-funct
backup-orig-funct)))
;;(define-namespace-anchor ankh-ovrld)
;;(define bsns-ovrld (namespace-anchor->namespace ankh-ovrld))
;;(current-namespace bsns-ovrld)
;;(define backup-orig-funct (eval identifier-backup-orig-funct (current-namespace)))
;(define orig-funct (create-overloaded-procedure orig-funct funct (list pred-arg1 ...)))))))
(define orig-funct (create-overloaded-procedure backup-orig-funct funct (list pred-arg1 ...)))))))
(define-syntax overload-procedure
(syntax-rules ()
((_ orig-funct funct (pred-arg1 ...))
(overload-existing-procedure orig-funct funct (pred-arg1 ...)))))
(define-syntax overload-existing-operator
(syntax-rules ()
((_ orig-funct funct (pred-arg1 ...))
;(begin
(define orig-funct (create-overloaded-existing-operator orig-funct funct (list pred-arg1 ...)))
;(display"Updating operators...") (newline)
;(update-operators)))))
)))
(define-syntax overload-operator
(syntax-rules ()
((_ orig-funct funct (pred-arg1 ...))
(overload-existing-operator orig-funct funct (pred-arg1 ...)))))
;; note: same as existing as we create it in first stage (declare/define)
(define-syntax overload-existing-n-arity-operator
(syntax-rules ()
((_ orig-funct funct (pred-arg1 ...))
(define orig-funct (create-overloaded-existing-n-arity-operator orig-funct funct (list pred-arg1 ...))))))
(define-syntax overload-n-arity-operator
(syntax-rules ()
((_ orig-funct funct (pred-arg1 ...))
(overload-existing-n-arity-operator orig-funct funct (pred-arg1 ...)))))
(define (check-arguments pred-list args)
(if (= (length pred-list) (length args))
(let ((pred-arg-list (map cons pred-list args)))
(andmap (λ (p) ((car p) (cdr p)))
;; replace andmap with every in Guile
;;(every (λ (p) ((car p) (cdr p)))
pred-arg-list))
#f))
;; args can be not the same number as predicates and their types must all match
(define (check-arguments-for-n-arity pred-list args)
(define type (car pred-list)) ;; i suppose all predicate are same
(define lbd-assign (lambda (arg) (cons type arg)))
(define pred-arg-list (map lbd-assign args))
(andmap (λ (p) ((car p) (cdr p)))
;; replace andmap with every in Guile
;;(every (λ (p) ((car p) (cdr p)))
pred-arg-list))
;; (define (add-list-list L1 L2) (map + L1 L2))
;; (define + (overload-proc + add-list-list (list list? list?)))
;; (+ '(1 2 3) '(4 5 6))
;; (define (add-pair p1 p2) (cons (+ (car p1) (car p2)) (+ (cdr p1) (cdr p2))))
;; (define + (overload-proc + add-pair (list pair? pair?)))
;; (+ (cons 1 2) (cons 3 4))
;; when a function that overload an operator has more than 2 args (f a1 a2 a3 ...) and only (f a1 a2) is defined
;; we do: (f a1 (f a2 a3 ...)) associativeness for operators like this.
;; + - * / ^ and other if any... we know,from overloading those operators are separate distinct case from simple functions.They are n-arity operators.
(define (create-overloaded-procedure orig-funct funct pred-list)
(display "create-overloaded-procedure")
(display " : pred-list = ") (display pred-list) (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)
;;(display "new-funct : args = ") (display args) (newline)
(if (check-arguments pred-list 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)
;; scheme@(guile-user)> (use-modules (overload))
;; ;;; note: source file /usr/local/share/guile/site/3.0/overload.scm
;; ;;; newer than compiled /Users/mattei/.cache/guile/ccache/3.0-LE-8-4.6/usr/local/share/guile/site/3.0/overload.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.scm
;; ;;; compiled /Users/mattei/.cache/guile/ccache/3.0-LE-8-4.6/usr/local/share/guile/site/3.0/overload.scm.go
;; scheme@(guile-user)> (define (add-vect-vect v1 v2) (map + v1 v2))
;; scheme@(guile-user)> (overload + add-vect-vect (list? list?) 'operator)
;; create-overloaded-operator : pred-list = (#<procedure list? (_)> #<procedure list? (_)>)
;; funct: #<procedure add-vect-vect (v1 v2)>
;; orig-funct: #<procedure + (#:optional _ _ . _)>
;; old-funct: #<procedure + (#:optional _ _ . _)>
;; new-funct: #<procedure new-funct args>
;; 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 : args = ((1 2 3) (4 5 6))
;; new funct :calling:#<procedure add-vect-vect (v1 v2)>
;; $1 = (5 7 9)
;; scheme@(guile-user)> (+ 2 3)
;; new-funct: #<procedure new-funct args>
;; new-funct : pred-list = (#<procedure list? (_)> #<procedure list? (_)>)
;; new-funct : args = (2 3)
;; new funct :calling:#<procedure + (#:optional _ _ . _)>
;; $2 = 5
;; 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? (_)>)
;; new-funct : args = ((1 2 3) (4 5 6) (7 8 9))
;; $3 = (12 15 18)
;; scheme@(guile-user)> {'(1 2 3) + '(4 5 6) + '(7 8 9)}
;; new-funct: new-funct = #<procedure new-funct args>
;; new-funct : pred-list = (#<procedure list? (_)> #<procedure list? (_)>)
;; new-funct : args = ((1 2 3) (4 5 6) (7 8 9))
;; new-funct : nb-args = 3
;; (12 15 18)
(define (create-overloaded-existing-operator orig-funct funct pred-list) ;; works for associative operators
(display "create-overloaded-existing-operator")
(display " : pred-list = ") (display pred-list) (newline)
(define old-funct orig-funct)
(define new-funct (lambda args ;; args is the list of arguments
;; (display "new-funct: new-funct = ") (display new-funct) (newline)
;; (display "new-funct : pred-list = ") (display pred-list) (newline)
;; (display "new-funct : args = ") (display args) (newline)
(define nb-args (length args))
;;(display "new-funct : nb-args = ") (display nb-args) (newline)
(cond ((check-arguments pred-list args) ;;(begin
;;(display "new funct :calling:") (display funct) (newline)
(apply funct args));;)
((> nb-args 2) (new-funct (car args)
(apply new-funct (cdr args)))) ;; op(a,b,...) = op(a,op(b,...))
(else
;;(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)
(define (create-overloaded-existing-n-arity-operator orig-funct funct pred-list) ;; works for associative operators
(newline)
(display "create-overloaded-existing-n-arity-operator")
(display " : pred-list = ") (display pred-list) (newline)
(display "orig-funct = ") (display orig-funct) (newline)
(display "funct = ") (display funct) (newline)
(define old-funct orig-funct)
(define new-funct (lambda args ;; args is the list of arguments
;; (newline)
;; (display "overloaded-existing-n-arity-operator") (newline)
;; (display "orig-funct = ") (display orig-funct) (newline)
;; (display "funct = ") (display funct) (newline)
;; (display "new-funct : new-funct = ") (display new-funct) (newline)
;; (display "new-funct : pred-list = ") (display pred-list) (newline)
;; (display "new-funct : args = ") (display args) (newline)
(define nb-args (length args))
;;(display "new-funct : nb-args = ") (display nb-args) (newline)
(if (check-arguments-for-n-arity pred-list args)
;;(begin
;;(display "new funct : calling:") (display funct) (newline)
(apply funct args);;)
;; ((> nb-args 2)
;; (begin
;; (display "new funct : calling:") (display new-funct) (newline)
;; (new-funct (car args) (apply new-funct (cdr args)))))
;; op(a,b,...) = op(a,op(b,...))
;;(else
;;(begin
;;(display "new funct : calling: ") (display old-funct) (newline)
(apply old-funct args))));;) ;; "recursively" call the older functions
(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)
(newline)
new-funct)
(define-syntax overload-square-brackets
(syntax-rules ()
((_ getter setter (pred-arg pred-arg1 ...)) ;; getter setter and list of predicate to check the arguments
(modify-$ovrld-square-brackets-lst$ (list (list pred-arg pred-arg1 ...)
(cons getter setter))))))
;; avoid: set!: cannot mutate module-required identifier in: $ovrld-square-brackets-lst$
(define (modify-$ovrld-square-brackets-lst$ arg)
(set! $ovrld-square-brackets-lst$ (cons arg $ovrld-square-brackets-lst$)))
;; example, return : '(#<procedure:vector-ref> . #<procedure:vector-set!>)
(define (find-getter-and-setter-for-overloaded-square-brackets args-lst)
(define (check-args-lst pred-list) ; check arguments list match predicates
(check-arguments pred-list args-lst))
(define (test-proc pred-proc-list) ; test the procedure if it matches with arguments
(if (check-args-lst (car pred-proc-list))
(car (cdr pred-proc-list))
#f))
(define proc-search-result (ormap test-proc $ovrld-square-brackets-lst$ )) ; search for a procedure matching arguments
(if proc-search-result
proc-search-result
(error '$bracket-apply$ "failed with those arguments list ~a" args-lst)))
;; > (find-getter-for-overloaded-square-brackets '(#(1 2 3) 1))
;; #<procedure:vector-ref>
(define (find-getter-for-overloaded-square-brackets args-lst)
(define (check-args-lst pred-list) ; check arguments list match predicates
(check-arguments pred-list args-lst))
(define (test-proc pred-proc-list) ; test the procedure if it matches with arguments
(if (check-args-lst (car pred-proc-list))
(car (cdr pred-proc-list))
#f))
(define proc-search-result (ormap test-proc $ovrld-square-brackets-lst$ )) ; search for a procedure matching arguments
(if proc-search-result
(car proc-search-result)
(error '$bracket-apply$ "no matching found in $ovrld-square-brackets-lst$ : failed with those arguments list ~a" args-lst)))
(define (find-setter-for-overloaded-square-brackets args-lst)
(define (check-args-lst pred-list) ; check arguments list match predicates
(check-arguments pred-list args-lst))
(define (test-proc pred-proc-list) ; test the procedure if it matches with arguments
(if (check-args-lst (car pred-proc-list))
(car (cdr pred-proc-list))
#f))
(define proc-search-result (ormap test-proc $ovrld-square-brackets-lst$ )) ; search for a procedure matching arguments
(if proc-search-result
(cdr proc-search-result)
(error '$bracket-apply$ "no matching found in $ovrld-square-brackets-lst$ : failed with those arguments list ~a" args-lst)))
;; this macro do the two overload steps in one for an existing procedure, (see the potential problem with infix precedence?)
(define-syntax overload-function
(syntax-rules ()
((_ (orig-funct (arg1 pred-arg1) ...) expr ...) (create-overloaded-procedure orig-funct
(lambda (arg1 ...) expr ...)
(pred-arg1 ...)))))
note that i have another completely rewritten that use hash tables and works but as this solution worked with Guile and is much pretty i tried to provide it as a dual solution for racket