core/slots/deprecated/deprecated.factor

   1 ! Copyright (C) 2005, 2008 Slava Pestov.\r
   2 ! See http://factorcode.org/license.txt for BSD license.\r
   3 USING: accessors arrays kernel kernel.private math namespaces\r
   4 sequences strings words effects generic generic.standard\r
   5 classes slots.private combinators slots ;\r
   6 IN: slots.deprecated\r
   7 \r
   8 : reader-effect ( class spec -- effect )\r
   9     >r ?word-name 1array r> slot-spec-name 1array <effect> ;\r
  10 \r
  11 PREDICATE: slot-reader < word "reading" word-prop >boolean ;\r
  12 \r
  13 : set-reader-props ( class spec -- )\r
  14     2dup reader-effect\r
  15     over slot-spec-reader\r
  16     swap "declared-effect" set-word-prop\r
  17     slot-spec-reader swap "reading" set-word-prop ;\r
  18 \r
  19 : define-reader ( class spec -- )\r
  20     dup slot-spec-reader [\r
  21         [ set-reader-props ] 2keep\r
  22         dup slot-spec-offset\r
  23         over slot-spec-reader\r
  24         rot slot-spec-class reader-quot\r
  25         define-slot-word\r
  26     ] [\r
  27         2drop\r
  28     ] if ;\r
  29 \r
  30 : writer-effect ( class spec -- effect )\r
  31     slot-spec-name swap ?word-name 2array 0 <effect> ;\r
  32 \r
  33 PREDICATE: slot-writer < word "writing" word-prop >boolean ;\r
  34 \r
  35 : set-writer-props ( class spec -- )\r
  36     2dup writer-effect\r
  37     over slot-spec-writer\r
  38     swap "declared-effect" set-word-prop\r
  39     slot-spec-writer swap "writing" set-word-prop ;\r
  40 \r
  41 : define-writer ( class spec -- )\r
  42     dup slot-spec-writer [\r
  43         [ set-writer-props ] 2keep\r
  44         dup slot-spec-offset\r
  45         swap slot-spec-writer\r
  46         [ set-slot ]\r
  47         define-slot-word\r
  48     ] [\r
  49         2drop\r
  50     ] if ;\r
  51 \r
  52 : define-slot ( class spec -- )\r
  53     2dup define-reader define-writer ;\r
  54 \r
  55 : define-slots ( class specs -- )\r
  56     [ define-slot ] with each ;\r
  57 \r
  58 : reader-word ( class name vocab -- word )\r
  59     >r >r "-" r> 3append r> create ;\r
  60 \r
  61 : writer-word ( class name vocab -- word )\r
  62     >r [ swap "set-" % % "-" % % ] "" make r> create ;\r
  63 \r
  64 : (simple-slot-word) ( class name -- class name vocab )\r
  65     over vocabulary>> >r >r name>> r> r> ;\r
  66 \r
  67 : simple-reader-word ( class name -- word )\r
  68     (simple-slot-word) reader-word ;\r
  69 \r
  70 : simple-writer-word ( class name -- word )\r
  71     (simple-slot-word) writer-word ;\r
  72 \r
  73 : deprecated-slots ( class slot-specs -- slot-specs' )\r
  74     [\r
  75         2dup name>> simple-reader-word >>reader\r
  76         2dup name>> simple-writer-word >>writer\r
  77     ] map nip ;\r