-! Copyright (C) 2007, 2008 Doug Coleman.
+! Copyright (C) 2007, 2008, 2011 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.accessors arrays assocs
-combinators.short-circuit fry hashtables html.elements io
-kernel math namespaces prettyprint quotations sequences
-sequences.deep sets slots.private vectors vocabs words
-kernel.private ;
+USING: accessors arrays assocs assocs.extras classes
+classes.tuple.private combinators.short-circuit continuations io
+kernel kernel.private locals.backend make math math.private
+namespaces prettyprint quotations sequences sequences.deep
+shuffle slots.private splitting stack-checker vocabs words
+words.alias ;
IN: lint
-SYMBOL: def-hash
-SYMBOL: def-hash-keys
+<PRIVATE
-: set-hash-vector ( val key hash -- )
- 2dup at -rot [ ?push ] 2dip set-at ;
-
-: more-defs ( hash -- )
- {
+CONSTANT: manual-substitutions
+ H{
{ -rot [ swap [ swap ] dip ] }
{ -rot [ swap swapd ] }
{ rot [ [ swap ] dip swap ] }
{ rot [ swapd swap ] }
{ over [ dup swap ] }
- { tuck [ dup -rot ] }
{ swapd [ [ swap ] dip ] }
+ { 2swap [ -roll -roll ] }
{ 2nip [ nip nip ] }
+ { 3nip [ 2nip nip ] }
+ { 4nip [ 3nip nip ] }
{ 2drop [ drop drop ] }
{ 3drop [ drop drop drop ] }
{ pop* [ pop drop ] }
{ when [ [ ] if ] }
{ >boolean [ f = not ] }
- } swap '[ first2 _ set-hash-vector ] each ;
-
-: accessor-words ( -- seq )
-{
- alien-signed-1 alien-signed-2 alien-signed-4 alien-signed-8
- alien-unsigned-1 alien-unsigned-2 alien-unsigned-4 alien-unsigned-8
- <displaced-alien> alien-unsigned-cell set-alien-signed-cell
- set-alien-unsigned-1 set-alien-signed-1 set-alien-unsigned-2
- set-alien-signed-2 set-alien-unsigned-4 set-alien-signed-4
- set-alien-unsigned-8 set-alien-signed-8
- alien-cell alien-signed-cell set-alien-cell set-alien-unsigned-cell
- set-alien-float alien-float
-} ;
-
-: trivial-defs
- {
- [ drop ] [ 2array ]
- [ bitand ]
-
- [ . ]
- [ get ]
- [ t ] [ f ]
- [ { } ]
- [ drop f ]
- [ "cdecl" ]
- [ first ] [ second ] [ third ] [ fourth ]
- [ ">" write-html ] [ "/>" write-html ]
- } ;
-
-! ! Add definitions
-H{ } clone def-hash set-global
-
-all-words [
- dup def>> dup callable?
- [ def-hash get-global set-hash-vector ] [ drop ] if
-] each
-
-! ! Remove definitions
-
-! Remove empty word defs
-def-hash 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 set-alien-cell, etc.
-[ drop [ accessor-words diff ] keep [ length ] bi@ = ] assoc-filter
-
-! Remove trivial defs
-[ drop trivial-defs member? not ] assoc-filter
-
-! Remove numbers only defs
-[ drop [ number? ] all? not ] assoc-filter
-
-! Remove curry only defs
-[ drop [ \ curry = ] all? not ] assoc-filter
-
-! Remove tag defs
-[
- drop {
- [ length 3 = ]
- [ first \ tag = ] [ second number? ] [ third \ eq? = ]
- } 1&& not
-] assoc-filter
-
-[
- drop {
- [ [ wrapper? ] deep-any? ]
- [ [ hashtable? ] deep-any? ]
- } 1|| not
-] assoc-filter
-
-! Remove n m shift defs
-[
- drop dup length 3 = [
- [ first2 [ number? ] both? ]
- [ third \ shift = ] bi and not
- ] [ drop t ] if
-] assoc-filter
-
-! Remove [ n slot ]
-[
- drop dup length 2 =
- [ first2 [ number? ] [ \ slot = ] bi* and not ] [ drop t ] if
-] assoc-filter
+ }
+CONSTANT: trivial-defs
+ {
+ [ ">" write ] [ "/>" write ] [ " " write ]
+ [ 0 or + ]
+ [ dup length <iota> ]
+ [ 0 swap copy ]
+ [ dup length ]
+ [ 0 swap ]
+ [ 2dup = ] [ 2dup eq? ]
+ [ = not ] [ eq? not ]
+ [ boa throw ]
+ [ with each ] [ with map ]
+ [ curry filter ]
+ [ compose compose ]
+ [ empty? ] [ empty? not ]
+ [ dup empty? ] [ dup empty? not ]
+ [ 2dup both-fixnums? ]
+ [ [ drop ] prepose ]
+ [ 1 0 ? ]
+ }
+
+: lintable-word? ( word -- ? )
+ {
+ [ vocabulary>> "specialized-" head? ]
+ [ vocabulary>> "windows-messages" = ]
+ [ alias? ]
+ } 1|| not ;
-dup more-defs
+: lintable-words ( -- words )
+ all-words [ lintable-word? ] filter ;
-[ def-hash set-global ] [ keys def-hash-keys set-global ] bi
+: ignore-def? ( def -- ? )
+ {
+ ! Remove small defs
+ [ length 1 <= ]
+
+ ! Remove trivial defs
+ [ trivial-defs member? ]
+
+ ! Remove curry only defs
+ [ [ \ curry = ] all? ]
+
+ ! Remove words with locals
+ [ [ \ load-locals = ] any? ]
+
+ ! Remove stuff with wrappers
+ [ [ wrapper? ] any? ]
+
+ ! Remove trivial math
+ [ [ { [ number? ] [ { + - / * /i /f >integer } member? ] } 1|| ] all? ]
+
+ ! Remove more trival defs
+ [
+ {
+ [ length 2 = ]
+ [ first2 [ word? ] either? ]
+ [ first2 [ { dip dup over swap drop } member? ] either? ]
+ } 1&&
+ ]
+
+ ! Remove [ V{ } clone ] and related
+ [
+ {
+ [ length 2 = ]
+ [ first { [ sequence? ] [ assoc? ] } 1|| ]
+ [ second { clone clone-like like assoc-like make } member? ]
+ } 1&&
+ ]
+
+ ! Remove [ foo get ] and related
+ [
+ {
+ [ length 2 = ]
+ [ first word? ]
+ [ second { get get-global , % } member? ]
+ } 1&&
+ ]
+
+ ! Remove [ first second ] and related
+ [
+ {
+ [ length 2 = ]
+ [ first { first second third } member? ]
+ [ second { first second third } member? ]
+ } 1&&
+ ]
+
+ ! Remove [ [ trivial ] if ] and related
+ [
+ {
+ [ length 2 = ]
+ [ first { [ quotation? ] [ ignore-def? ] } 1&& ]
+ [ second { if if* unless unless* when when* curry } member? ]
+ } 1&&
+ ]
+
+ ! Remove [ n - ] and related
+ [
+ {
+ [ length 2 = ]
+ [ first { [ number? ] [ boolean? ] } 1|| ]
+ [ second { + - / * < <= = >= > shift bitand bitor bitxor eq? } member? ]
+ } 1&&
+ ]
+
+ ! Remove [ dup 0 > ] and related
+ [
+ {
+ [ length 3 = ]
+ [ first { dup over } member? ]
+ [ second number? ]
+ [ third { + - / * < <= = >= > } member? ]
+ } 1&&
+ ]
+
+ ! Remove [ drop f f ] and related
+ [
+ {
+ [ length 4 <= ]
+ [ first { drop 2drop 3drop nip 2nip 3nip 4nip } member? ]
+ [ rest-slice [ boolean? ] all? ]
+ } 1&&
+ ]
+
+ ! Remove [ length 1 = ] and related
+ [
+ {
+ [ length 3 = ]
+ [ first \ length = ]
+ [ second number? ]
+ [ third { + - / * < <= = >= > } member? ]
+ } 1&&
+ ]
+
+ ! Remove [ dup length 1 = ] and related
+ [
+ {
+ [ length 4 = ]
+ [ first { dup over } member? ]
+ [ second \ length = ]
+ [ third number? ]
+ [ fourth { + - / * < <= = >= > } member? ]
+ } 1&&
+ ]
+
+ ! Remove numbers/t/f only defs
+ [
+ [ { [ number? ] [ boolean? ] } 1|| ] all?
+ ]
+
+ ! Remove [ tag n eq? ]
+ [
+ {
+ [ length 3 = ]
+ [ first \ tag = ] [ second number? ] [ third \ eq? = ]
+ } 1&&
+ ]
+
+ ! Remove [ { foo } declare class-of ]
+ [
+ {
+ [ length 3 = ]
+ [ first { [ array? ] [ length 1 = ] } 1&& ]
+ [ second \ declare = ]
+ [ third \ class-of = ]
+ } 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? ] [ ignore-def? not ] } 1&& ] deep-filter ;
+
+: (load-definitions) ( word def hash -- )
+ [ all-callables ] dip push-at-each ;
+
+: load-definitions ( words -- hash )
+ H{ } clone [ '[ dup def>> _ (load-definitions) ] each ] keep ;
+
+SYMBOL: lint-definitions
+SYMBOL: lint-definitions-keys
+
+: reload-definitions ( -- )
+ ! Load lintable and non-ignored definitions
+ lintable-words load-definitions
+
+ ! Remove words that are their own definition
+ [ [ [ def>> ] [ 1quotation ] bi = ] reject ] assoc-map
+
+ ! Add manual definitions
+ manual-substitutions over '[ _ push-at ] assoc-each
+
+ ! Set globals to new values
+ [ lint-definitions set-global ]
+ [ keys lint-definitions-keys set-global ] bi ;
: find-duplicates ( -- seq )
- def-hash get-global [ nip length 1 > ] assoc-filter ;
+ lint-definitions get-global [ nip length 1 > ] assoc-filter ;
GENERIC: lint ( obj -- seq )
M: object lint ( obj -- seq ) drop f ;
-: subseq/member? ( subseq/member seq -- ? )
- { [ start ] [ member? ] } 2|| ;
-
M: callable lint ( quot -- seq )
- [ def-hash-keys get-global ] dip '[ _ subseq/member? ] filter ;
+ lint-definitions-keys get-global [ subseq-index? ] with filter ;
-M: word lint ( word -- seq )
- def>> dup callable? [ lint ] [ drop f ] if ;
+M: word lint ( word -- seq/f )
+ def>> [ callable? ] deep-filter [ lint ] map concat ;
: word-path. ( word -- )
- [ vocabulary>> ] [ unparse ] bi ":" glue print ;
+ [ vocabulary>> write ":" write ] [ . ] bi ;
: 4bl ( -- ) bl bl bl bl ;
: (lint.) ( pair -- )
first2 [ word-path. ] dip [
[ 4bl . "-----------------------------------" print ]
- [ def-hash get-global at [ 4bl word-path. ] each nl ] bi
- ] each nl nl ;
+ [ lint-definitions get-global at [ 4bl word-path. ] each nl ] bi
+ ] each nl ;
: lint. ( alist -- ) [ (lint.) ] each ;
GENERIC: run-lint ( obj -- obj )
: (trim-self) ( val key -- obj ? )
- def-hash get-global at*
+ lint-definitions get-global at*
[ dupd remove empty? not ] [ drop f ] if ;
: trim-self ( seq -- newseq )
: filter-symbols ( alist -- alist )
[
- nip first dup def-hash get-global at
+ nip first dup lint-definitions get-global at
[ first ] bi@ literalize = not
] assoc-filter ;
M: sequence run-lint ( seq -- seq )
- [ dup lint ] { } map>assoc trim-self
- [ second empty? not ] filter filter-symbols ;
+ [ lint ] zip-with trim-self
+ [ second empty? ] reject filter-symbols ;
M: word run-lint ( word -- seq ) 1array run-lint ;
-: lint-all ( -- seq ) all-words run-lint dup lint. ;
-
-: lint-vocab ( vocab -- seq ) words run-lint dup lint. ;
+PRIVATE>
-: lint-word ( word -- seq ) 1array run-lint dup lint. ;
+: find-swap/swap ( word -- ? )
+ def>> [ callable? ] deep-filter
+ [
+ {
+ [ [ \ swap = ] count 2 >= ]
+ [
+ { swap } split rest but-last
+ [ [ infer ] [ 2drop ( -- ) ] recover ( x -- x ) = ] any?
+ ]
+ } 1&&
+ ] any? ;
+
+: find-redundant-word-props ( -- seq )
+ all-words [
+ {
+ [ { [ foldable? ] [ flushable? ] } 1|| ]
+ [ inline? ]
+ } 1&&
+ ] filter ;
+
+: lint-all ( -- seq )
+ all-words run-lint dup lint. ;
+
+: lint-vocab ( vocab -- seq )
+ vocab-words run-lint dup lint. ;
+
+: lint-vocabs ( prefix -- seq )
+ [ loaded-vocab-names ] dip [ head? ] curry filter [ lint-vocab ] map ;
+
+: lint-word ( word -- seq )
+ 1array run-lint dup lint. ;
+
+reload-definitions
projects / factor.git / blobdiff