From 26cc5510497a5fd9a33e1cfe12f222449400964e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 1 Sep 2009 11:36:06 -0500 Subject: [PATCH] fix another tuple definition bug --- core/classes/tuple/parser/parser-tests.factor | 6 ++++++ core/classes/tuple/parser/parser.factor | 8 ++++---- 2 files changed, 10 insertions(+), 4 deletions(-) diff --git a/core/classes/tuple/parser/parser-tests.factor b/core/classes/tuple/parser/parser-tests.factor index 0121e217b9..2b9fd7b89b 100644 --- a/core/classes/tuple/parser/parser-tests.factor +++ b/core/classes/tuple/parser/parser-tests.factor @@ -147,3 +147,9 @@ TUPLE: bad-inheritance-tuple ; [ "IN: classes.tuple.parser.tests TUPLE: bad-inheritance-tuple < bad-inheritance-tuple ;" eval( -- ) ] [ error>> bad-inheritance? ] must-fail-with + +TUPLE: bad-inheritance-tuple2 ; +TUPLE: bad-inheritance-tuple3 < bad-inheritance-tuple2 ; +[ + "IN: classes.tuple.parser.tests TUPLE: bad-inheritance-tuple2 < bad-inheritance-tuple3 ;" eval( -- ) +] [ error>> bad-inheritance? ] must-fail-with diff --git a/core/classes/tuple/parser/parser.factor b/core/classes/tuple/parser/parser.factor index 61267a464f..0a57ad34f3 100644 --- a/core/classes/tuple/parser/parser.factor +++ b/core/classes/tuple/parser/parser.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel sets namespaces make sequences parser lexer combinators words classes.parser classes.tuple arrays -slots math assocs parser.notes ; +slots math assocs parser.notes classes.algebra ; IN: classes.tuple.parser : slot-names ( slots -- seq ) @@ -58,15 +58,15 @@ ERROR: invalid-slot-name name ; ERROR: bad-inheritance class superclass ; -: check-self-inheritance ( class1 class2 -- class1 class2 ) - 2dup = [ bad-inheritance ] when ; +: check-inheritance ( class1 class2 -- class1 class2 ) + 2dup swap class<= [ bad-inheritance ] when ; : parse-tuple-definition ( -- class superclass slots ) CREATE-CLASS scan 2dup = [ ] when { { ";" [ tuple f ] } { "<" [ - scan-word check-self-inheritance [ parse-tuple-slots ] { } make + scan-word check-inheritance [ parse-tuple-slots ] { } make ] } [ tuple swap [ parse-slot-name [ parse-tuple-slots ] when ] { } make ] } case