[plt-scheme] Polymorphic Structure Types
On Tue, 22 Apr 2003, Eli Barzilay wrote:
> 1. Swindle did that for ages... (Sorry, but I couldn't resist, I know
> that you know...) And it is not as heavyweight as it seems.
I love Swindle. It's a great piece of software to have available in
Scheme and offers a lot. But I am having some problems with its
performance on small examples. I have a stupid little benchmark below -
but the Swindle code is more than ten times slower. Am I making some
obvious mistake?
Regards
Andre
(require (lib "pattern-dispatch.ss" "mzscheme"))
(require (lib "poly-records.ss" "mzscheme"))
(define-record point x y)
(define-record color r g b)
(define-record colored-point (point color) x y r g b tag)
(define a-point (make-point 50 70))
(define a-colored-point (make-colored-point 10 20 1 2 3 'a-tag))
(define (show ($ point x y)) (list x y))
(define (show ($ color r g b)) (list r g b))
(define (show ($ colored-point x y r g b tag)) (list x y r g b tag))
(show a-point)
(show a-colored-point)
(time (let loop ([i 100000])
(unless (= i 0)
(color? a-colored-point)
(point-x a-point)
(point-x a-colored-point)
(color-g a-colored-point)
(show a-point)
(show a-colored-point)
(loop (- i 1)))))
(require (lib "swindle.ss" "swindle"))
(-defclass-autoaccessors-naming- :slot)
(-defclass-auto-initargs- (:auto #t))
(defclass <point> () x y)
(defclass <color> () r g b)
(defclass <colored-point> (<point> <color>) tag)
(define a-point (make-point 50 70))
(define a-colored-point (make-colored-point 1 2 3 10 20 'a-tag))
(defmethod (show1 (p <point>)) (list (x p) (y p)))
(defmethod (show1 (c <color>)) (list (r c) (g c) (b c)))
(defmethod (show1 (cp <colored-point>)) (list (x cp) (y cp)
(r cp) (g cp)
(b cp) (tag cp)))
(show1 a-point)
(show1 a-colored-point)
(time (let loop ([i 100000])
(unless (= i 0)
(color? a-colored-point)
(x a-point)
(x a-colored-point)
(g a-colored-point)
(show1 a-point)
(show1 a-colored-point)
(loop (- i 1)))))
-------------- next part --------------
(module pattern-dispatch mzscheme
(provide (all-from-except mzscheme
lambda
case-lambda
define))
(provide (rename define* define)
(rename case-define* case-define)
(rename lambda* lambda)
(rename case-lambda* case-lambda))
(require-for-syntax (lib "list.ss"))
(require (lib "etc.ss")
(lib "match.ss"))
;; Execute body, catching all errors and returning `#f' if one occurred.
;; If no errors, return value of body.
;; Snippet copied from Eli Barzilay's code.
(define-syntax no-errors
(syntax-rules ()
[(_ <body>)
(with-handlers ((void (lambda (x) #f))) <body>)]))
(define-syntax-set (define* case-define* lambda* case-lambda*
case-define-pat case-lambda-pat)
;; define* expands to define in all the non-pattern cases.
(define define*/proc
(lambda (stx)
(syntax-case stx ()
[(_ (<f> . <arglist>) <expr> ...)
(andmap valid-symbol? (improper->proper (syntax-object->datum #'<arglist>)))
#'(define (<f> . <arglist>) <expr> ...)]
[(_ (<f> . <arglist>) <expr> ...)
#'(case-define-pat [(<f> . <arglist>) <expr> ...])]
[(_ <identifier> <expr> ...)
#'(define <identifier> <expr> ...)])))
(define case-define*/proc
(lambda (stx)
(syntax-case stx ()
[(_ [<expr> ...]) ;; Single declaration - handle as
#'(define* <expr> ...)] ;; above.
[(_ [(<f> . <arglist>) <expr> ...]
...)
#'(case-define-pat [(<f> . <arglist>) <expr> ...]
...)])))
(define case-define-pat/proc
(lambda (stx)
(syntax-case stx ()
[(_ [(<f> . <arglist>) <expr> ...] ...)
(with-syntax ([<name> (car (syntax-e #'(<f> ...)))])
(let ([last-pat (car (reverse (syntax-object->datum #'(<arglist> ...))))])
(if (andmap symbol? (improper->proper last-pat))
#'(define <name> (case-lambda* [<arglist> <expr> ...] ...))
(syntax-case #'(<arglist> ...) ()
[((<arg>) ...) ;; Avoid "apply" if single argument
#'(begin
(define <name> (if (no-errors (procedure? <name>))
(let ([next-method <name>])
(case-lambda* [<arglist> <expr> ...]
...
[(x) (next-method x)]))
(case-lambda* [(<arg>) <expr> ...] ...))))]
[_
#'(begin
(define <name> (if (no-errors (procedure? <name>))
(let ([next-method <name>])
(case-lambda* [<arglist> <expr> ...]
...
[x (apply next-method x)]))
(case-lambda* [<arglist> <expr> ...] ...))))]))))])))
;; lambda* expands to lambda in all the non-pattern cases.
(define lambda*/proc
(lambda (stx)
(syntax-case stx ()
[(_ <arglist> <expr> ...)
(if (andmap valid-symbol? (improper->proper (syntax-object->datum #'<arglist>)))
#'(lambda <arglist> <expr> ...)
#'(case-lambda-pat [<arglist> <expr> ...]))])))
;; case-lambda* expands to case-lambda in all the non-pattern cases.
(define case-lambda*/proc
(lambda (stx)
(syntax-case stx ()
[(_ [<arglist> <expr> ...] ...)
(if (andmap valid-symbol? (apply append
(map improper->proper
(syntax-object->datum #'(<arglist> ...)))))
#'(case-lambda [<arglist> <expr> ...] ...)
#'(case-lambda-pat [<arglist> <expr> ...] ...))])))
(define (case-lambda-pat/proc stx)
(syntax-case stx ()
[(_ [(<pat>) <expr> ...] ...) ;; Single argument handled separately
#'(match-lambda [<pat> <expr> ...] ...)] ;; (match-lambda more efficient)
[(_ [<arglist> <expr> ...] ...)
#'(match-lambda* [<arglist> <expr> ...] ...)]))
(define (improper->proper x)
(cond [(null? x) null]
[(not (pair? x)) (list x)]
[else (cons (car x)
(improper->proper (cdr x)))]))
(define (valid-symbol? x)
(and (symbol? x)
(not (eq? x '_))))
) ;; end syntax-set
) ;; end module
![[logo]](/logo.png){kind=logo}