core/classes/builtin/builtin.factor

   1 ! Copyright (C) 2004, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors classes classes.algebra words kernel
   4 kernel.private namespaces sequences math math.private
   5 combinators assocs quotations ;
   6 IN: classes.builtin
   7
   8 SYMBOL: builtins
   9
  10 PREDICATE: builtin-class < class
  11     "metaclass" word-prop builtin-class eq? ;
  12
  13 : class>type ( class -- n ) "type" word-prop ; foldable
  14
  15 PREDICATE: lo-tag-class < builtin-class class>type 7 <= ;
  16
  17 PREDICATE: hi-tag-class < builtin-class class>type 7 > ;
  18
  19 : type>class ( n -- class ) builtins get-global nth ;
  20
  21 : bootstrap-type>class ( n -- class ) builtins get nth ;
  22
  23 M: hi-tag class hi-tag type>class ;
  24
  25 M: object class tag type>class ;
  26
  27 M: builtin-class rank-class drop 0 ;
  28
  29 GENERIC: define-builtin-predicate ( class -- )
  30
  31 M: lo-tag-class define-builtin-predicate
  32     dup class>type [ eq? ] curry [ tag ] prepend define-predicate ;
  33
  34 M: hi-tag-class define-builtin-predicate
  35     dup class>type [ eq? ] curry [ hi-tag ] prepend 1quotation
  36     [ dup tag 3 eq? ] [ [ drop f ] if ] surround
  37     define-predicate ;
  38
  39 M: lo-tag-class instance? [ tag ] [ class>type ] bi* eq? ;
  40
  41 M: hi-tag-class instance?
  42     over tag 3 eq? [ [ hi-tag ] [ class>type ] bi* eq? ] [ 2drop f ] if ;
  43
  44 M: builtin-class (flatten-class) dup set ;
  45
  46 M: builtin-class (classes-intersect?)
  47     {
  48         { [ 2dup eq? ] [ 2drop t ] }
  49         { [ over builtin-class? ] [ 2drop f ] }
  50         [ swap classes-intersect? ]
  51     } cond ;
  52
  53 M: anonymous-intersection (flatten-class)
  54     participants>> [ flatten-builtin-class ] map
  55     [
  56         builtins get sift [ (flatten-class) ] each
  57     ] [
  58         unclip [ assoc-intersect ] reduce [ swap set ] assoc-each
  59     ] if-empty ;
  60
  61 M: anonymous-complement (flatten-class)
  62     drop builtins get sift [ (flatten-class) ] each ;