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 inspector parser
   4 lexer combinators words classes.parser classes.tuple arrays ;
   5 IN: classes.tuple.parser
   6
   7 : shadowed-slots ( superclass slots -- shadowed )
   8     [ all-slots [ name>> ] map ]
   9     [ [ dup array? [ first ] when ] map ]
  10     bi* intersect ;
  11
  12 : check-slot-shadowing ( class superclass slots -- )
  13     shadowed-slots [
  14         [
  15             "Definition of slot ``" %
  16             %
  17             "'' in class ``" %
  18             name>> %
  19             "'' shadows a superclass slot" %
  20         ] "" make note.
  21     ] with each ;
  22
  23 ERROR: invalid-slot-name name ;
  24
  25 M: invalid-slot-name summary
  26     drop
  27     "Invalid slot name" ;
  28
  29 : parse-long-slot-name ( -- )
  30     [ scan , \ } parse-until % ] { } make ;
  31
  32 : parse-slot-name ( string/f -- ? )
  33     #! This isn't meant to enforce any kind of policy, just
  34     #! to check for mistakes of this form:
  35     #!
  36     #! TUPLE: blahblah foo bing
  37     #!
  38     #! : ...
  39     {
  40         { [ dup not ] [ unexpected-eof ] }
  41         { [ dup { ":" "(" "<" "\"" } member? ] [ invalid-slot-name ] }
  42         { [ dup ";" = ] [ drop f ] }
  43         [ dup "{" = [ drop parse-long-slot-name ] when , t ]
  44     } cond ;
  45
  46 : parse-tuple-slots ( -- )
  47     scan parse-slot-name [ parse-tuple-slots ] when ;
  48
  49 : parse-tuple-definition ( -- class superclass slots )
  50     CREATE-CLASS
  51     scan {
  52         { ";" [ tuple f ] }
  53         { "<" [ scan-word [ parse-tuple-slots ] { } make ] }
  54         [ tuple swap [ parse-slot-name [ parse-tuple-slots ] when ] { } make ]
  55     } case 3dup check-slot-shadowing ;