[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 14/25: `match' refactor in goops.scm
From: |
Andy Wingo |
Subject: |
[Guile-commits] 14/25: `match' refactor in goops.scm |
Date: |
Mon, 19 Jan 2015 10:41:11 +0000 |
wingo pushed a commit to branch wip-goops-refactor
in repository guile.
commit c1083711a2fb5b033e8e3d406113ae809cb58a3b
Author: Andy Wingo <address@hidden>
Date: Fri Jan 16 10:19:47 2015 +0100
`match' refactor in goops.scm
* module/oop/goops.scm (compute-dispatch-procedure): Use `match'.
---
module/oop/goops.scm | 74 ++++++++++++++++++++++---------------------------
1 files changed, 33 insertions(+), 41 deletions(-)
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index 80bd115..70504eb 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -993,59 +993,51 @@ followed by its associated value. If @var{l} does not
hold a value for
(define (compute-dispatch-procedure gf cache)
(define (scan)
(let lp ((ls cache) (nreq -1) (nrest -1))
- (cond
- ((null? ls)
- (collate (make-vector (1+ nreq) '())
- (make-vector (1+ nrest) '())))
- ((vector-ref (car ls) 2) ; rest
- (lp (cdr ls) nreq (max nrest (vector-ref (car ls) 0))))
- (else ; req
- (lp (cdr ls) (max nreq (vector-ref (car ls) 0)) nrest)))))
+ (match ls
+ (()
+ (collate (make-vector (1+ nreq) '())
+ (make-vector (1+ nrest) '())))
+ ((#(len specs rest? cmethod) . ls)
+ (if rest?
+ (lp ls nreq (max nrest len))
+ (lp ls (max nreq len) nrest))))))
(define (collate req rest)
(let lp ((ls cache))
- (cond
- ((null? ls)
- (emit req rest))
- ((vector-ref (car ls) 2) ; rest
- (let ((n (vector-ref (car ls) 0)))
- (vector-set! rest n (cons (car ls) (vector-ref rest n)))
- (lp (cdr ls))))
- (else ; req
- (let ((n (vector-ref (car ls) 0)))
- (vector-set! req n (cons (car ls) (vector-ref req n)))
- (lp (cdr ls)))))))
+ (match ls
+ (() (emit req rest))
+ (((and entry #(len specs rest? cmethod)) . ls)
+ (if rest?
+ (vector-set! rest len (cons entry (vector-ref rest len)))
+ (vector-set! req len (cons entry (vector-ref req len))))
+ (lp ls)))))
(define (emit req rest)
(let ((gf-sym (gensym "g")))
(define (emit-rest n clauses free)
(if (< n (vector-length rest))
- (let ((methods (vector-ref rest n)))
- (cond
- ((null? methods)
- (emit-rest (1+ n) clauses free))
- ;; FIXME: hash dispatch
- (else
- (call-with-values
- (lambda ()
- (emit-linear-dispatch gf-sym n methods free #t))
- (lambda (clause free)
- (emit-rest (1+ n) (cons clause clauses) free))))))
+ (match (vector-ref rest n)
+ (() (emit-rest (1+ n) clauses free))
+ ;; FIXME: hash dispatch
+ (methods
+ (call-with-values
+ (lambda ()
+ (emit-linear-dispatch gf-sym n methods free #t))
+ (lambda (clause free)
+ (emit-rest (1+ n) (cons clause clauses) free)))))
(emit-req (1- (vector-length req)) clauses free)))
(define (emit-req n clauses free)
(if (< n 0)
(comp `(lambda ,(map cdr free)
(case-lambda ,@clauses))
(map car free))
- (let ((methods (vector-ref req n)))
- (cond
- ((null? methods)
- (emit-req (1- n) clauses free))
- ;; FIXME: hash dispatch
- (else
- (call-with-values
- (lambda ()
- (emit-linear-dispatch gf-sym n methods free #f))
- (lambda (clause free)
- (emit-req (1- n) (cons clause clauses) free))))))))
+ (match (vector-ref req n)
+ (() (emit-req (1- n) clauses free))
+ ;; FIXME: hash dispatch
+ (methods
+ (call-with-values
+ (lambda ()
+ (emit-linear-dispatch gf-sym n methods free #f))
+ (lambda (clause free)
+ (emit-req (1- n) (cons clause clauses) free)))))))
(emit-rest 0
(if (or (zero? (vector-length rest))
- [Guile-commits] 02/25: append-map rather than mapappend, (continued)
- [Guile-commits] 02/25: append-map rather than mapappend, Andy Wingo, 2015/01/19
- [Guile-commits] 03/25: GOOPS utils module cleanups, Andy Wingo, 2015/01/19
- [Guile-commits] 04/25: Fold (oop goops util) into (oop goops), Andy Wingo, 2015/01/19
- [Guile-commits] 05/25: Scheme GOOPS cleanups, Andy Wingo, 2015/01/19
- [Guile-commits] 07/25: scm_make cleanup, Andy Wingo, 2015/01/19
- [Guile-commits] 06/25: Add compute-cpl tests, Andy Wingo, 2015/01/19
- [Guile-commits] 09/25: Commenting in goops.scm, Andy Wingo, 2015/01/19
- [Guile-commits] 08/25: Narrative reordering in goops.scm, Andy Wingo, 2015/01/19
- [Guile-commits] 11/25: when and unless for one-armed ifs in goops.scm, Andy Wingo, 2015/01/19
- [Guile-commits] 13/25: Convert emit-linear-dispatch to use match, Andy Wingo, 2015/01/19
- [Guile-commits] 14/25: `match' refactor in goops.scm,
Andy Wingo <=
- [Guile-commits] 15/25: GOOPS class slot indices defined as inline values, Andy Wingo, 2015/01/19
- [Guile-commits] 10/25: More GOOPS comments, Andy Wingo, 2015/01/19
- [Guile-commits] 17/25: slot-ref, slot-set! et al bypass "using-class" variants, Andy Wingo, 2015/01/19
- [Guile-commits] 18/25: change-object-class refactor, Andy Wingo, 2015/01/19
- [Guile-commits] 19/25: GOOPS: Deprecate "using-class" procs like slot-ref-using-class, Andy Wingo, 2015/01/19
- [Guile-commits] 12/25: More GOOPS cleanups, Andy Wingo, 2015/01/19
- [Guile-commits] 20/25: The GOOPS "unbound" value is a unique pair, Andy Wingo, 2015/01/19
- [Guile-commits] 16/25: Manipulate GOOPS vtable flags from Scheme, for speed, Andy Wingo, 2015/01/19
- [Guile-commits] 21/25: Beginnings of <slot> slot definition class, Andy Wingo, 2015/01/19
- [Guile-commits] 23/25: Use a vtable bit to mark <slot> instances, Andy Wingo, 2015/01/19