[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 67/88: Convert emit-linear-dispatch to use match
From: |
Andy Wingo |
Subject: |
[Guile-commits] 67/88: Convert emit-linear-dispatch to use match |
Date: |
Fri, 23 Jan 2015 15:25:54 +0000 |
wingo pushed a commit to branch master
in repository guile.
commit d273b9c2675e3c425fe36d3c85231125063037a5
Author: Andy Wingo <address@hidden>
Date: Wed Jan 14 20:43:35 2015 +0100
Convert emit-linear-dispatch to use match
* module/oop/goops.scm (emit-linear-dispatch): Convert to use `match'.
---
module/oop/goops.scm | 65 +++++++++++++++++++++++++------------------------
1 files changed, 33 insertions(+), 32 deletions(-)
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index 26a8ac9..c0dd75b 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -952,44 +952,45 @@ followed by its associated value. If @var{l} does not
hold a value for
,(if rest?
`(cons* ,@args rest)
`(list ,@args)))))
- (cond
- ((null? methods)
+ (match methods
+ (()
(values `(,(if rest? `(,@args . rest) args)
(let ,(map (lambda (t a)
`(,t (class-of ,a)))
types args)
,exp))
free))
- (else
- ;; jeez
- (let preddy ((free free)
- (types types)
- (specs (vector-ref (car methods) 1))
- (checks '()))
- (if (null? types)
- (let ((m-sym (gensym "p")))
- (lp (cdr methods)
- (acons (vector-ref (car methods) 3)
- m-sym
- free)
- `(if (and . ,checks)
- ,(if rest?
- `(apply ,m-sym ,@args rest)
- `(,m-sym . ,args))
- ,exp)))
- (let ((var (assq-ref free (car specs))))
- (if var
- (preddy free
- (cdr types)
- (cdr specs)
- (cons `(eq? ,(car types) ,var)
- checks))
- (let ((var (gensym "c")))
- (preddy (acons (car specs) var free)
- (cdr types)
- (cdr specs)
- (cons `(eq? ,(car types) ,var)
- checks))))))))))))
+ ((#(_ specs _ cmethod) . methods)
+ (let build-dispatch ((free free)
+ (types types)
+ (specs specs)
+ (checks '()))
+ (match types
+ (()
+ (let ((m-sym (gensym "p")))
+ (lp methods
+ (acons cmethod m-sym free)
+ `(if (and . ,checks)
+ ,(if rest?
+ `(apply ,m-sym ,@args rest)
+ `(,m-sym . ,args))
+ ,exp))))
+ ((type . types)
+ (match specs
+ ((spec . specs)
+ (let ((var (assq-ref free spec)))
+ (if var
+ (build-dispatch free
+ types
+ specs
+ (cons `(eq? ,type ,var)
+ checks))
+ (let ((var (gensym "c")))
+ (build-dispatch (acons spec var free)
+ types
+ specs
+ (cons `(eq? ,type ,var)
+ checks)))))))))))))))
(define (compute-dispatch-procedure gf cache)
(define (scan)
- [Guile-commits] 57/88: append-map rather than mapappend, (continued)
- [Guile-commits] 57/88: append-map rather than mapappend, Andy Wingo, 2015/01/23
- [Guile-commits] 58/88: GOOPS utils module cleanups, Andy Wingo, 2015/01/23
- [Guile-commits] 55/88: Cosmetic goops refactors., Andy Wingo, 2015/01/23
- [Guile-commits] 53/88: goops.c no longer knows about <class> slot allocation, Andy Wingo, 2015/01/23
- [Guile-commits] 61/88: scm_make cleanup, Andy Wingo, 2015/01/23
- [Guile-commits] 64/88: More GOOPS comments, Andy Wingo, 2015/01/23
- [Guile-commits] 59/88: Fold (oop goops util) into (oop goops), Andy Wingo, 2015/01/23
- [Guile-commits] 51/88: Reimplement %allocate-instance in Scheme, Andy Wingo, 2015/01/23
- [Guile-commits] 62/88: Narrative reordering in goops.scm, Andy Wingo, 2015/01/23
- [Guile-commits] 66/88: More GOOPS cleanups, Andy Wingo, 2015/01/23
- [Guile-commits] 67/88: Convert emit-linear-dispatch to use match,
Andy Wingo <=
- [Guile-commits] 60/88: Add compute-cpl tests, Andy Wingo, 2015/01/23
- [Guile-commits] 72/88: change-object-class refactor, Andy Wingo, 2015/01/23
- [Guile-commits] 69/88: GOOPS class slot indices defined as inline values, Andy Wingo, 2015/01/23
- [Guile-commits] 71/88: slot-ref, slot-set! et al bypass "using-class" variants, Andy Wingo, 2015/01/23
- [Guile-commits] 70/88: Manipulate GOOPS vtable flags from Scheme, for speed, Andy Wingo, 2015/01/23
- [Guile-commits] 73/88: GOOPS: Deprecate "using-class" procs like slot-ref-using-class, Andy Wingo, 2015/01/23
- [Guile-commits] 65/88: when and unless for one-armed ifs in goops.scm, Andy Wingo, 2015/01/23
- [Guile-commits] 75/88: Beginnings of <slot> slot definition class, Andy Wingo, 2015/01/23
- [Guile-commits] 68/88: `match' refactor in goops.scm, Andy Wingo, 2015/01/23
- [Guile-commits] 78/88: Inline helpers into slot-ref, slot-set!, etc, Andy Wingo, 2015/01/23