<html><head><meta http-equiv="Content-Type" content="text/html charset=utf-8"></head><body style="word-wrap: break-word; -webkit-nbsp-mode: space; -webkit-line-break: after-white-space;"><div>Is this sort of like what you mean?:</div><div><br></div><div><div><font face="Courier New">(define dup (my-match-lambda*))</font></div><div><font face="Courier New"><br></font></div><div><font face="Courier New">(my-match-lambda-add-clause! dup [(list (? string? s)) (string-append s s)])</font></div><div><font face="Courier New">(my-match-lambda-add-clause! dup [(list (? integer? n)) (list n n)])</font></div><div><br></div><div><font face="Courier New">(check-equal? (dup "Hello") "HelloHello")</font></div><div><font face="Courier New">(check-equal? (dup 10) '(10 10))</font></div></div><div><br></div><div>Here’s the code:</div><div><br></div><div><div><font face="Courier New">#lang racket</font></div><div><font face="Courier New"><br></font></div><div><font face="Courier New">(provide my-match-lambda*</font></div><div><font face="Courier New"> (struct-out my-match-lambda-procedure)</font></div><div><font face="Courier New"> my-match-lambda-append</font></div><div><font face="Courier New"> my-match-lambda-add-clause!</font></div><div><font face="Courier New"> my-match-lambda-add-overriding-clause!</font></div><div><font face="Courier New"> (struct-out exn:fail:my-match-lambda:no-match)</font></div><div><font face="Courier New"> (struct-out exn:fail:my-match-lambda:no-match:next-clause)</font></div><div><font face="Courier New"> raise-my-match-lambda:no-match-error)</font></div><div><font face="Courier New"><br></font></div><div><font face="Courier New">(module+ test</font></div><div><font face="Courier New"> (require rackunit)</font></div><div><font face="Courier New"> </font></div><div><font face="Courier New"> (define dup (my-match-lambda*))</font></div><div><font face="Courier New"> </font></div><div><font face="Courier New"> (my-match-lambda-add-clause! dup [(list (? string? s)) (string-append s s)])</font></div><div><font face="Courier New"> (my-match-lambda-add-clause! dup [(list (? integer? n)) (list n n)])</font></div><div><font face="Courier New"> </font></div><div><font face="Courier New"> (check-equal? (dup "Hello") "HelloHello")</font></div><div><font face="Courier New"> (check-equal? (dup 10) '(10 10))</font></div><div><font face="Courier New"> </font></div><div><font face="Courier New"> )</font></div><div><font face="Courier New"><br></font></div><div><font face="Courier New">(define-syntax-rule (my-match-lambda* clause ...)</font></div><div><font face="Courier New"> (my-match-lambda-procedure</font></div><div><font face="Courier New"> (list (clause->proc clause) ...)))</font></div><div><font face="Courier New"><br></font></div><div><font face="Courier New">(define-syntax-rule (clause->proc clause)</font></div><div><font face="Courier New"> (match-lambda* clause [args (raise-my-match-lambda:no-match-error args)]))</font></div><div><font face="Courier New"><br></font></div><div><font face="Courier New">(struct my-match-lambda-procedure (procs)</font></div><div><font face="Courier New"> #:transparent #:mutable</font></div><div><font face="Courier New"> #:property prop:procedure</font></div><div><font face="Courier New"> (lambda (this . args)</font></div><div><font face="Courier New"> (let ([procs (my-match-lambda-procedure-procs this)])</font></div><div><font face="Courier New"> (define proc (apply my-match-lambda-append procs))</font></div><div><font face="Courier New"> (apply proc args))))</font></div><div><font face="Courier New"><br></font></div><div><font face="Courier New">(define within-my-match-lambda-append?</font></div><div><font face="Courier New"> (make-parameter #f))</font></div><div><font face="Courier New"><br></font></div><div><font face="Courier New">(define my-match-lambda-append</font></div><div><font face="Courier New"> (case-lambda</font></div><div><font face="Courier New"> [() (case-lambda)]</font></div><div><font face="Courier New"> [(f) f]</font></div><div><font face="Courier New"> [(f1 f2) (lambda args</font></div><div><font face="Courier New"> (with-handlers ([exn:fail:my-match-lambda:no-match:next-clause?</font></div><div><font face="Courier New"> (λ (e) (apply f2 args))])</font></div><div><font face="Courier New"> (parameterize ([within-my-match-lambda-append? #t])</font></div><div><font face="Courier New"> (apply f1 args))))]))</font></div><div><font face="Courier New"><br></font></div><div><font face="Courier New">(define-syntax-rule (my-match-lambda-add-clause! proc clause ...)</font></div><div><font face="Courier New"> (set-my-match-lambda-procedure-procs! proc</font></div><div><font face="Courier New"> (append (my-match-lambda-procedure-procs proc)</font></div><div><font face="Courier New"> (list (clause->proc clause) ...))))</font></div><div><font face="Courier New"><br></font></div><div><font face="Courier New">(define-syntax-rule (my-match-lambda-add-overriding-clause! proc clause ...)</font></div><div><font face="Courier New"> (set-my-match-lambda-procedure-procs! proc</font></div><div><font face="Courier New"> (append (list (clause->proc clause) ...)</font></div><div><font face="Courier New"> (my-match-lambda-procedure-procs proc))))</font></div><div><font face="Courier New"><br></font></div><div><font face="Courier New">(struct exn:fail:my-match-lambda:no-match exn:fail (args) #:transparent)</font></div><div><font face="Courier New">(struct exn:fail:my-match-lambda:no-match:next-clause exn:fail:my-match-lambda:no-match () #:transparent)</font></div><div><font face="Courier New"><br></font></div><div><font face="Courier New">(define (raise-my-match-lambda:no-match-error args)</font></div><div><font face="Courier New"> (define message</font></div><div><font face="Courier New"> (string-append</font></div><div><font face="Courier New"> "my-match-lambda: no clause matches" "\n"</font></div><div><font face="Courier New"> " args: "(~v args)""))</font></div><div><font face="Courier New"> (define error-exn</font></div><div><font face="Courier New"> (with-handlers ([exn:fail? identity])</font></div><div><font face="Courier New"> (error message)))</font></div><div><font face="Courier New"> (define exn</font></div><div><font face="Courier New"> (cond [(within-my-match-lambda-append?)</font></div><div><font face="Courier New"> (exn:fail:my-match-lambda:no-match:next-clause</font></div><div><font face="Courier New"> message (exn-continuation-marks error-exn) args)]</font></div><div><font face="Courier New"> [else</font></div><div><font face="Courier New"> (exn:fail:my-match-lambda:no-match</font></div><div><font face="Courier New"> message (exn-continuation-marks error-exn) args)]))</font></div><div><font face="Courier New"> (raise exn))</font></div></div><div><br></div><div><br></div><div>tnh</div><br><div><div>On Apr 3, 2014, at 5:43 AM, Roman Klochkov <<a href="mailto:kalimehtar@mail.ru">kalimehtar@mail.ru</a>> wrote:</div><br class="Apple-interchange-newline"><blockquote type="cite"><div><font face="courier new, monospace">Or even simpler <br><br>(define (dup a)<br> (cond</font></div><div><font face="courier new, monospace"> [(string? a) (string-append a a)]</font></div><div><font face="courier new, monospace"> [(integer? a) (list a a)])<br><br></font></div>:-)<br><br>I think, Alejandro wanted to add clauses in different places (generic in one module, added method in another, for example).<br><br><br>Thu, 3 Apr 2014 20:11:36 +1100 от Daniel Prager <<a href="mailto:daniel.a.prager@gmail.com">daniel.a.prager@gmail.com</a>>:<br><blockquote style="border-left-width: 1px; border-left-style: solid; border-left-color: rgb(8, 87, 166); margin: 10px; padding: 0px 0px 0px 10px;"><div id=""><div class="js-helper js-readmsg-msg"><div id="style_13965167960000000572_BODY"><div dir="ltr"><div>Here's an out-of-the-box option, using Racket's <a href="http://docs.racket-lang.org/reference/match.html#%28form._%28%28lib._racket%2Fmatch..rkt%29._define%2Fmatch%29%29" target="_blank">pattern matching</a> with the (? predicate) form:</div><div><br></div><div><font face="courier new, monospace">(define/match (dup a)</font></div><div><font face="courier new, monospace"> [((? string?)) (string-append a a)]</font></div><div><font face="courier new, monospace"> [((? integer?)) (list a a)])</font></div><div><br></div><div>Dan</div><div><div dir="ltr"></div></div></div></div><div>____________________<br> Racket Users list:<br> <a href="http://lists.racket-lang.org/users" target="_blank">http://lists.racket-lang.org/users</a><br><br></div></div></div></blockquote><br><br>-- <br>Roman Klochkov<br>____________________<br> Racket Users list:<br> <a href="http://lists.racket-lang.org/users">http://lists.racket-lang.org/users</a></blockquote></div></body></html>