From 54e4e8873a5460e1b9cc3d1716008b64494895b4 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 9 Feb 2009 00:25:33 -0600
Subject: [PATCH] delegate: add support for single-generic protocols, add
failing unit test for bug
---
basis/delegate/delegate-tests.factor | 26 +++++++++++++++++++++++++-
basis/delegate/delegate.factor | 9 +++++++--
2 files changed, 32 insertions(+), 3 deletions(-)
diff --git a/basis/delegate/delegate-tests.factor b/basis/delegate/delegate-tests.factor
index 2651a44f32..4b02407735 100644
--- a/basis/delegate/delegate-tests.factor
+++ b/basis/delegate/delegate-tests.factor
@@ -119,4 +119,28 @@ PROTOCOL: silly-protocol do-me ;
CONSULT: silly-protocol a-tuple drop f ; "> <string-reader> "delegate-test" parse-stream
] unit-test
-[ ] [ T{ a-tuple } do-me ] unit-test
\ No newline at end of file
+[ ] [ T{ a-tuple } do-me ] unit-test
+
+! A slot protocol issue
+DEFER: slot-protocol-test-3
+SLOT: y
+
+[ f ] [ \ y>> \ slot-protocol-test-3 method >boolean ] unit-test
+
+[ [ ] ] [
+ <" IN: delegate.tests
+USING: accessors delegate ;
+TUPLE: slot-protocol-test-3 x ;
+CONSULT: y>> slot-protocol-test-3 x>> ;">
+ <string-reader> "delegate-test-1" parse-stream
+] unit-test
+
+[ t ] [ \ y>> \ slot-protocol-test-3 method >boolean ] unit-test
+
+[ [ ] ] [
+ <" IN: delegate.tests
+TUPLE: slot-protocol-test-3 x y ;">
+ <string-reader> "delegate-test-1" parse-stream
+] unit-test
+
+[ t ] [ \ y>> \ slot-protocol-test-3 method >boolean ] unit-test
\ No newline at end of file
diff --git a/basis/delegate/delegate.factor b/basis/delegate/delegate.factor
index c88c99384f..37277685d5 100644
--- a/basis/delegate/delegate.factor
+++ b/basis/delegate/delegate.factor
@@ -1,8 +1,10 @@
! Copyright (C) 2007, 2008 Daniel Ehrenberg
+! Portions copyright (C) 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes.tuple definitions
-generalizations generic hashtables kernel lexer make math parser
-generic.parser sequences sets slots words words.symbol fry ;
+generalizations generic generic.standard hashtables kernel
+lexer make math parser generic.parser sequences sets slots
+words words.symbol fry ;
IN: delegate
: protocol-words ( protocol -- words )
@@ -13,6 +15,9 @@ IN: delegate
GENERIC: group-words ( group -- words )
+M: standard-generic group-words
+ dup "combination" word-prop #>> 2array 1array ;
+
M: tuple-class group-words
all-slots [
name>>