extra/descriptive/descriptive.factor

   1 USING: words kernel sequences locals\r
   2 locals.private accessors parser namespaces continuations\r
   3 summary definitions generalizations arrays ;\r
   4 IN: descriptive\r
   5 \r
   6 ERROR: descriptive-error args underlying word ;\r
   7 \r
   8 M: descriptive-error summary\r
   9     word>> "The " swap name>> " word encountered an error."\r
  10     3append ;\r
  11 \r
  12 <PRIVATE\r
  13 : rethrower ( word inputs -- quot )\r
  14     [ length ] keep [ >r narray r> swap 2array flip ] 2curry\r
  15     [ 2 ndip descriptive-error ] 2curry ;\r
  16 \r
  17 : [descriptive] ( word def -- newdef )\r
  18     swap dup "declared-effect" word-prop in>> rethrower\r
  19     [ recover ] 2curry ;\r
  20 PRIVATE>\r
  21 \r
  22 : define-descriptive ( word def -- )\r
  23     [ "descriptive-definition" set-word-prop ]\r
  24     [ dupd [descriptive] define ] 2bi ;\r
  25 \r
  26 : DESCRIPTIVE:\r
  27     (:) define-descriptive ; parsing\r
  28 \r
  29 PREDICATE: descriptive < word\r
  30     "descriptive-definition" word-prop ;\r
  31 \r
  32 M: descriptive definer drop \ DESCRIPTIVE: \ ; ;\r
  33 \r
  34 M: descriptive definition\r
  35     "descriptive-definition" word-prop ;\r
  36 \r
  37 : DESCRIPTIVE::\r
  38     (::) define-descriptive ; parsing\r
  39 \r
  40 INTERSECTION: descriptive-lambda descriptive lambda-word ;\r
  41 \r
  42 M: descriptive-lambda definer drop \ DESCRIPTIVE:: \ ; ;\r
  43 \r
  44 M: descriptive-lambda definition\r
  45     "lambda" word-prop body>> ;\r