factor: trim using lists

[factor.git] / extra / descriptive / descriptive.factor

diff --git a/extra/descriptive/descriptive.factor b/extra/descriptive/descriptive.factor
old mode 100755 (executable)
new mode 100644 (file)
index b1fdf24..bb3b3dd
--- a/extra/descriptive/descriptive.factor
+++ b/extra/descriptive/descriptive.factor
@@ -1,45 +1,62 @@
-USING: words kernel sequences locals locals.parser\r
-locals.definitions accessors parser namespaces continuations\r
-summary definitions generalizations arrays ;\r
-IN: descriptive\r
-\r
-ERROR: descriptive-error args underlying word ;\r
-\r
-M: descriptive-error summary\r
-    word>> "The " swap name>> " word encountered an error."\r
-    3append ;\r
-\r
-<PRIVATE\r
-: rethrower ( word inputs -- quot )\r
-    [ length ] keep [ >r narray r> swap 2array flip ] 2curry\r
-    [ 2 ndip descriptive-error ] 2curry ;\r
-\r
-: [descriptive] ( word def -- newdef )\r
-    swap dup "declared-effect" word-prop in>> rethrower\r
-    [ recover ] 2curry ;\r
-PRIVATE>\r
-\r
-: define-descriptive ( word def -- )\r
-    [ "descriptive-definition" set-word-prop ]\r
-    [ dupd [descriptive] define ] 2bi ;\r
-\r
-: DESCRIPTIVE:\r
-    (:) define-descriptive ; parsing\r
-\r
-PREDICATE: descriptive < word\r
-    "descriptive-definition" word-prop ;\r
-\r
-M: descriptive definer drop \ DESCRIPTIVE: \ ; ;\r
-\r
-M: descriptive definition\r
-    "descriptive-definition" word-prop ;\r
-\r
-: DESCRIPTIVE::\r
-    (::) define-descriptive ; parsing\r
-\r
-INTERSECTION: descriptive-lambda descriptive lambda-word ;\r
-\r
-M: descriptive-lambda definer drop \ DESCRIPTIVE:: \ ; ;\r
-\r
-M: descriptive-lambda definition\r
-    "lambda" word-prop body>> ;\r
+! Copyright (c) 2008 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays continuations debugger definitions
+effects effects.parser generalizations io kernel
+locals.definitions locals.parser prettyprint sequences
+sequences.generalizations tools.annotations words ;
+IN: descriptive
+
+ERROR: descriptive-error args underlying word ;
+
+M: descriptive-error error.
+    "The word " write dup word>> pprint " encountered an error." print
+    "Arguments:" print
+    dup args>> stack.
+    "Error:" print
+    underlying>> error. ;
+
+<PRIVATE
+
+: rethrower ( word inputs -- quot )
+    [ length ] keep [ [ narray ] dip swap 2array flip ] 2curry
+    [ 2 ndip descriptive-error ] 2curry ;
+
+: [descriptive] ( word def effect -- newdef )
+    swapd in>> rethrower [ recover ] 2curry ;
+
+PRIVATE>
+
+: make-descriptive ( word -- )
+    dup [ ] [ def>> ] [ stack-effect ] tri [descriptive]
+    '[ drop _ ] annotate ;
+
+: define-descriptive ( word def effect -- )
+    [ drop "descriptive-definition" set-word-prop ]
+    [ [ [ dup ] 2dip [descriptive] ] keep define-declared ]
+    3bi ;
+
+SYNTAX: DESCRIPTIVE: (:) define-descriptive ;
+
+PREDICATE: descriptive < word
+    "descriptive-definition" word-prop >boolean ;
+
+M: descriptive definer drop \ DESCRIPTIVE: \ ; ;
+
+M: descriptive definition
+    "descriptive-definition" word-prop ;
+
+M: descriptive reset-word
+    [ call-next-method ]
+    [ "descriptive-definition" remove-word-prop ] bi ;
+
+SYNTAX: DESCRIPTIVE:: (::) define-descriptive ;
+
+PREDICATE: descriptive-lambda < descriptive lambda-word? ;
+
+M: descriptive-lambda definer drop \ DESCRIPTIVE:: \ ; ;
+
+M: descriptive-lambda definition
+    "lambda" word-prop body>> ;
+
+M: descriptive-lambda reset-word
+    [ call-next-method ] [ "lambda" remove-word-prop ] bi ;