core/classes/tuple/parser/parser.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors kernel sets namespaces sequences parser
   4 lexer combinators words classes.parser classes.tuple arrays ;
   5 IN: classes.tuple.parser
   6
   7 : slot-names ( slots -- seq )
   8     [ dup array? [ first ] when ] map ;
   9
  10 : shadowed-slots ( superclass slots -- shadowed )
  11     [ all-slots [ name>> ] map ] [ slot-names ] bi* intersect ;
  12
  13 : check-slot-shadowing ( class superclass slots -- )
  14     shadowed-slots [
  15         [
  16             "Definition of slot ``" %
  17             %
  18             "'' in class ``" %
  19             name>> %
  20             "'' shadows a superclass slot" %
  21         ] "" make note.
  22     ] with each ;
  23
  24 ERROR: duplicate-slot-names names ;
  25
  26 : check-duplicate-slots ( slots -- )
  27     slot-names duplicates
  28     dup empty? [ drop ] [ duplicate-slot-names ] if ;
  29
  30 ERROR: invalid-slot-name name ;
  31
  32 : parse-long-slot-name ( -- )
  33     [ scan , \ } parse-until % ] { } make ;
  34
  35 : parse-slot-name ( string/f -- ? )
  36     #! This isn't meant to enforce any kind of policy, just
  37     #! to check for mistakes of this form:
  38     #!
  39     #! TUPLE: blahblah foo bing
  40     #!
  41     #! : ...
  42     {
  43         { [ dup not ] [ unexpected-eof ] }
  44         { [ dup { ":" "(" "<" "\"" "!" } member? ] [ invalid-slot-name ] }
  45         { [ dup ";" = ] [ drop f ] }
  46         [ dup "{" = [ drop parse-long-slot-name ] when , t ]
  47     } cond ;
  48
  49 : parse-tuple-slots ( -- )
  50     scan parse-slot-name [ parse-tuple-slots ] when ;
  51
  52 : parse-tuple-definition ( -- class superclass slots )
  53     CREATE-CLASS
  54     scan {
  55         { ";" [ tuple f ] }
  56         { "<" [ scan-word [ parse-tuple-slots ] { } make ] }
  57         [ tuple swap [ parse-slot-name [ parse-tuple-slots ] when ] { } make ]
  58     } case
  59     dup check-duplicate-slots
  60     3dup check-slot-shadowing ;