/core/classes/union/union.factor

http://github.com/abeaumont/factor · Factor · 79 lines · 55 code · 22 blank · 2 comment · 5 complexity · 90dc76ceef9d90149b4cb51afd6c800d MD5 · raw file

  1. ! Copyright (C) 2004, 2011 Slava Pestov.
  2. ! See http://factorcode.org/license.txt for BSD license.
  3. USING: accessors assocs classes classes.algebra
  4. classes.algebra.private classes.builtin classes.private
  5. combinators definitions kernel kernel.private math math.private
  6. quotations sequences words ;
  7. IN: classes.union
  8. PREDICATE: union-class < class
  9. "metaclass" word-prop union-class eq? ;
  10. <PRIVATE
  11. GENERIC: union-of-builtins? ( class -- ? )
  12. M: builtin-class union-of-builtins? drop t ;
  13. M: union-class union-of-builtins?
  14. members [ union-of-builtins? ] all? ;
  15. M: class union-of-builtins?
  16. drop f ;
  17. : fast-union-mask ( class -- n )
  18. [ 0 ] dip flatten-class
  19. [ drop class>type 2^ bitor ] assoc-each ;
  20. : empty-union-predicate-quot ( class -- quot )
  21. drop [ drop f ] ;
  22. : fast-union-predicate-quot ( class -- quot )
  23. fast-union-mask 1quotation
  24. [ tag 1 swap fixnum-shift-fast ]
  25. [ fixnum-bitand 0 eq? not ]
  26. surround ;
  27. : slow-union-predicate-quot ( class -- quot )
  28. members [ predicate-def ] map unclip swap
  29. [ [ dup ] prepend [ drop t ] ] { } map>assoc alist>quot ;
  30. : union-predicate-quot ( class -- quot )
  31. {
  32. { [ dup members empty? ] [ empty-union-predicate-quot ] }
  33. { [ dup union-of-builtins? ] [ fast-union-predicate-quot ] }
  34. [ slow-union-predicate-quot ]
  35. } cond ;
  36. : define-union-predicate ( class -- )
  37. dup union-predicate-quot define-predicate ;
  38. M: union-class update-class define-union-predicate ;
  39. : (define-union-class) ( class members -- )
  40. f swap f union-class make-class-props (define-class) ;
  41. PRIVATE>
  42. : define-union-class ( class members -- )
  43. [ (define-union-class) ]
  44. [ drop changed-conditionally ]
  45. [ drop update-classes ]
  46. 2tri ;
  47. M: union-class rank-class drop 7 ;
  48. M: union-class instance?
  49. "members" word-prop [ instance? ] with any? ;
  50. M: anonymous-union instance?
  51. members>> [ instance? ] with any? ;
  52. M: anonymous-union class-name
  53. members>> [ class-name ] map " " join ;
  54. M: union-class normalize-class
  55. members <anonymous-union> normalize-class ;
  56. M: union-class (flatten-class)
  57. members <anonymous-union> (flatten-class) ;