extra/descriptive/descriptive.factor

   1 USING: words kernel sequences locals locals.parser\r
   2 locals.definitions 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 [ [ narray ] dip 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 effect -- )\r
  23     [ drop "descriptive-definition" set-word-prop ]\r
  24     [ [ dupd [descriptive] ] dip define-declared ]\r
  25     3bi ;\r
  26 \r
  27 SYNTAX: DESCRIPTIVE: (:) define-descriptive ;\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 SYNTAX: DESCRIPTIVE:: (::) define-descriptive ;\r
  38 \r
  39 INTERSECTION: descriptive-lambda descriptive lambda-word ;\r
  40 \r
  41 M: descriptive-lambda definer drop \ DESCRIPTIVE:: \ ; ;\r
  42 \r
  43 M: descriptive-lambda definition\r
  44     "lambda" word-prop body>> ;\r