lint: cleanup, deep compare, print clickable words.

diff --git a/extra/lint/lint-tests.factor b/extra/lint/lint-tests.factor
index 09c74b82d0e349c06eb7498c8d78a4838d54e27b..dd3e2053d376f8c408267a4e9ad6914b000b1ea2 100644 (file)
--- a/extra/lint/lint-tests.factor
+++ b/extra/lint/lint-tests.factor
@@ -1,4 +1,4 @@
-USING: io lint kernel math tools.test ;
+USING: io lint kernel math sequences tools.test ;
 IN: lint.tests
 
 ! Don't write code like this
@@ -6,6 +6,10 @@ IN: lint.tests
 
 [ { { lint1 { [ [ ] if ] } } } ] [ \ lint1 lint-word ] unit-test
 
-: lint3 ( a b -- b a b ) dup -rot ; ! tuck
+: lint2 ( a b -- b a b ) dup -rot ; ! tuck
 
-[ { { lint3 { [ dup -rot ] } } } ] [ \ lint3 lint-word ] unit-test
+[ { { lint2 { [ dup -rot ] } } } ] [ \ lint2 lint-word ] unit-test
+
+: lint3 ( seq -- seq ) [ 0 swap nth 1 + ] map ;
+
+[ { { lint3 { [ 0 swap nth ] } } } ] [ \ lint3 lint-word ] unit-test

diff --git a/extra/lint/lint.factor b/extra/lint/lint.factor
index 85d2e9b639ef48ee4bbb5a89d4211a3f263f0112..b370f41cbca70d1b5062d44e158d469629a1b528 100644 (file)
--- a/extra/lint/lint.factor
+++ b/extra/lint/lint.factor
@@ -1,19 +1,16 @@
 ! Copyright (C) 2007, 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien arrays assocs combinators.short-circuit
-fry hashtables io kernel math namespaces prettyprint quotations
+USING: accessors alien arrays assocs classes.tuple.private
+combinators.short-circuit fry hashtables io kernel
+locals.backend make math namespaces prettyprint quotations
 sequences sequences.deep shuffle slots.private vectors vocabs
 words xml.data words.alias ;
 IN: lint
 
-SYMBOL: lint-definitions
-SYMBOL: lint-definitions-keys
-
-: set-hash-vector ( val key hash -- )
-    2dup at -rot [ ?push ] 2dip set-at ;
+<PRIVATE
 
-: manual-substitutions ( hash -- )
-    {
+CONSTANT: manual-substitutions
+    H{
         { -rot [ swap [ swap ] dip ] }
         { -rot [ swap swapd ] }
         { rot [ [ swap ] dip swap ] }
@@ -27,91 +24,107 @@ SYMBOL: lint-definitions-keys
         { pop* [ pop drop ] }
         { when [ [ ] if ] }
         { >boolean [ f = not ] }
-    } swap '[ first2 _ set-hash-vector ] each ;
+    }
 
 CONSTANT: trivial-defs
     {
-        [ drop ] [ 2drop ] [ 2array ]
-        [ bitand ]
-        [ . ]
-        [ new ]
-        [ get ]
-        [ "" ]
-        [ t ] [ f ]
-        [ { } ]
-        [ drop t ] [ drop f ] [ 2drop t ] [ 2drop f ]
-        [ cdecl ]
-        [ first ] [ second ] [ third ] [ fourth ]
+        [ drop t ] [ drop f ]
+        [ 2drop t ] [ 2drop f ]
+        [ 3drop t ] [ 3drop f ]
         [ ">" write ] [ "/>" write ]
+        [ length 1 - ] [ length 1 = ] [ length 1 > ]
+        [ drop f f ] [ 2drop f f ]
+        [ drop f f f ]
+        [ nip f f ]
+        [ 0 or + ]
+        [ dup 0 > ] [ dup 0 <= ]
+        [ dup length iota ]
+        [ 0 swap copy ]
+        [ dup 1 + ]
     }
 
-! ! Add definitions
-H{ } clone lint-definitions set-global
-
-all-words [
-    dup def>> dup callable?
-    [ lint-definitions get-global set-hash-vector ] [ drop ] if
-] each
-
-! ! Remove definitions
-
-! Remove empty word defs
-lint-definitions get-global [ drop empty? not ] assoc-filter
-
-! Remove constants [ 1 ]
-[ drop { [ length 1 = ] [ first number? ] } 1&& not ] assoc-filter
-
-! Remove words that are their own definition
-[ [ [ def>> ] [ 1quotation ] bi = not ] filter ] assoc-map
-
-! Remove specialized*
- [ nip [ vocabulary>> "specialized-" head? ] any? not ] assoc-filter
-
- [ nip [ vocabulary>> "windows.messages" = ] any? not ] assoc-filter
-
- [ nip [ alias? ] any? not ] assoc-filter
-
-! Remove trivial defs
-[ drop trivial-defs member? not ] assoc-filter
-
-! Remove numbers only defs
-[ drop [ number? ] all? not ] assoc-filter
+: lintable-word? ( word -- ? )
+    {
+        [ vocabulary>> "specialized-" head? ]
+        [ vocabulary>> "windows-messages" = ]
+        [ alias? ]
+    } 1|| not ;
 
-! Remove curry only defs
-[ drop [ \ curry = ] all? not ] assoc-filter
+: lintable-words ( -- words )
+    all-words [ lintable-word? ] filter ;
 
-! Remove tag defs
-[
-    drop {
-            [ length 3 = ]
-            [ first \ tag = ] [ second number? ] [ third \ eq? = ]
-    } 1&& not
-] assoc-filter
+: ignore-def? ( def -- ? )
+    {
+        ! Remove small defs
+        [ length 2 <= ]
+
+        ! Remove trivial defs
+        [ trivial-defs member? ]
+
+        ! Remove curry only defs
+        [ [ \ curry = ] all? ]
+
+        ! Remove words with locals
+        [ [ \ load-locals = ] any? ]
+
+        ! Remove numbers/t/f only defs
+        [
+            [ { [ number? ] [ t? ] [ f eq? ] } 1|| ] all?
+        ]
+
+        ! Remove tag defs
+        [
+            {
+                [ length 3 = ]
+                [ first \ tag = ] [ second number? ] [ third \ eq? = ]
+            } 1&&
+        ]
+
+        ! Remove [ m n shift ]
+        [
+            {
+                [ length 3 = ]
+                [ first2 [ number? ] both? ] [ third \ shift = ]
+            } 1&&
+        ]
+
+        ! Remove [ layout-of n slot ]
+        [
+            {
+                [ length 3 = ]
+                [ first \ layout-of = ]
+                [ second number? ]
+                [ third \ slot = ]
+            } 1&&
+        ]
+    } 1|| ;
+
+: all-callables ( def -- seq )
+    [ callable? ] deep-filter ;
+
+: (load-definitions) ( word def hash -- )
+    [ all-callables ] dip '[ _ push-at ] with each ;
+
+: load-definitions ( words -- hash )
+    H{ } clone [ '[ dup def>> _ (load-definitions) ] each ] keep ;
 
-[
-    drop {
-        [ [ wrapper? ] deep-any? ]
-        [ [ hashtable? ] deep-any? ]
-    } 1|| not
-] assoc-filter
+SYMBOL: lint-definitions
+SYMBOL: lint-definitions-keys
 
-! Remove n m shift defs
-[
-    drop dup length 3 = [
-        [ first2 [ number? ] both? ]
-        [ third \ shift = ] bi and not
-    ] [ drop t ] if
-] assoc-filter 
+: reload-definitions ( -- )
+    ! Load lintable and non-ignored definitions
+    lintable-words load-definitions
+    [ drop ignore-def? not ] assoc-filter
 
-! Remove [ n slot ]
-[
-    drop dup length 2 =
-    [ first2 [ number? ] [ \ slot = ] bi* and not ] [ drop t ] if
-] assoc-filter
+    ! Remove words that are their own definition
+    [ [ [ def>> ] [ 1quotation ] bi = not ] filter ] assoc-map
 
-dup manual-substitutions
+    ! Add manual definitions
+    manual-substitutions over '[ _ push-at ] assoc-each
 
-[ lint-definitions set-global ] [ keys lint-definitions-keys set-global ] bi
+    ! Set globals to new values
+    [ lint-definitions set-global ]
+    [ keys lint-definitions-keys set-global ] bi ;
 
 : find-duplicates ( -- seq )
     lint-definitions get-global [ nip length 1 > ] assoc-filter ;
@@ -120,17 +133,14 @@ GENERIC: lint ( obj -- seq )
 
 M: object lint ( obj -- seq ) drop f ;
 
-: subseq/member? ( subseq/member seq -- ? )
-    { [ start ] [ member? ] } 2|| ;
-
 M: callable lint ( quot -- seq )
-    [ lint-definitions-keys get-global ] dip '[ _ subseq/member? ] filter ;
+    [ lint-definitions-keys get-global ] dip '[ _ subseq? ] filter ;
 
-M: word lint ( word -- seq )
-    def>> dup callable? [ lint ] [ drop f ] if ;
+M: word lint ( word -- seq/f )
+    def>> all-callables [ lint ] map concat ;
 
 : word-path. ( word -- )
-    [ vocabulary>> ] [ name>> ] bi ":" glue print ;
+    [ vocabulary>> write ":" write ] [ . ] bi ;
 
 : 4bl ( -- ) bl bl bl bl ;
 
@@ -138,7 +148,7 @@ M: word lint ( word -- seq )
     first2 [ word-path. ] dip [
         [ 4bl .  "-----------------------------------" print ]
         [ lint-definitions get-global at [ 4bl word-path. ] each nl ] bi
-    ] each nl nl ;
+    ] each nl ;
 
 : lint. ( alist -- ) [ (lint.) ] each ;
 
@@ -163,11 +173,18 @@ M: sequence run-lint ( seq -- seq )
 
 M: word run-lint ( word -- seq ) 1array run-lint ;
 
-: lint-all ( -- seq ) all-words run-lint dup lint. ;
+PRIVATE>
 
-: lint-vocab ( vocab -- seq ) words run-lint dup lint. ;
+: lint-all ( -- seq )
+    all-words run-lint dup lint. ;
+
+: lint-vocab ( vocab -- seq )
+    words run-lint dup lint. ;
 
 : lint-vocabs ( prefix -- seq )
     [ vocabs ] dip [ head? ] curry filter [ lint-vocab ] map ;
 
-: lint-word ( word -- seq ) 1array run-lint dup lint. ;
+: lint-word ( word -- seq )
+    1array run-lint dup lint. ;
+
+reload-definitions