core/classes/predicate/predicate.factor

   1 ! Copyright (C) 2004, 2010 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: classes classes.algebra classes.algebra.private
   4 classes.private kernel words ;
   5 IN: classes.predicate
   6
   7 PREDICATE: predicate-class < class
   8     "metaclass" word-prop predicate-class eq? ;
   9
  10 <PRIVATE
  11
  12 GENERIC: predicate-quot ( class -- quot )
  13
  14 M: predicate-class predicate-quot
  15     [ superclass-of predicate-def ]
  16     [ "predicate-definition" word-prop ] bi
  17     '[ dup @ _ [ drop f ] if ] ;
  18
  19 PRIVATE>
  20
  21 : define-predicate-class ( class superclass definition -- )
  22     [ drop f f predicate-class define-class ]
  23     [ nip "predicate-definition" set-word-prop ]
  24     [
  25         2drop
  26         [ dup predicate-quot define-predicate ]
  27         [ update-classes ]
  28         bi
  29     ] 3tri ;
  30
  31 M: predicate-class reset-class
  32     [ call-next-method ] [ "predicate-definition" remove-word-prop ] bi ;
  33
  34 M: predicate-class rank-class drop 2 ;
  35
  36 M: predicate-class instance?
  37     2dup superclass-of instance? [
  38         "predicate-definition" word-prop call( object -- ? )
  39     ] [ 2drop f ] if ;
  40
  41 M: predicate-class (flatten-class)
  42     superclass-of (flatten-class) ;
  43
  44 M: predicate-class (classes-intersect?)
  45     superclass-of classes-intersect? ;