Revive the lint tool

db4
Doug Coleman 2011-10-14 01:39:07 -07:00
parent 0965d9be41
commit 6586b97128
4 changed files with 25 additions and 38 deletions

View File

@ -1,19 +1,18 @@
! Copyright (C) 2007, 2008 Doug Coleman. ! Copyright (C) 2007, 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.accessors arrays assocs USING: accessors alien arrays assocs combinators.short-circuit
combinators.short-circuit fry hashtables io fry hashtables io kernel math namespaces prettyprint quotations
kernel math namespaces prettyprint quotations sequences sequences sequences.deep shuffle slots.private vectors vocabs
sequences.deep sets slots.private vectors vocabs words words xml.data ;
kernel.private ;
IN: lint IN: lint
SYMBOL: def-hash SYMBOL: lint-definitions
SYMBOL: def-hash-keys SYMBOL: lint-definitions-keys
: set-hash-vector ( val key hash -- ) : set-hash-vector ( val key hash -- )
2dup at -rot [ ?push ] 2dip set-at ; 2dup at -rot [ ?push ] 2dip set-at ;
: more-defs ( hash -- ) : manual-substitutions ( hash -- )
{ {
{ -rot [ swap [ swap ] dip ] } { -rot [ swap [ swap ] dip ] }
{ -rot [ swap swapd ] } { -rot [ swap swapd ] }
@ -30,45 +29,32 @@ SYMBOL: def-hash-keys
{ >boolean [ f = not ] } { >boolean [ f = not ] }
} swap '[ first2 _ set-hash-vector ] each ; } swap '[ first2 _ set-hash-vector ] each ;
: accessor-words ( -- seq ) CONSTANT: trivial-defs
{
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 ( -- seq )
{ {
[ drop ] [ 2array ] [ drop ] [ 2array ]
[ bitand ] [ bitand ]
[ . ] [ . ]
[ get ] [ get ]
[ t ] [ f ] [ t ] [ f ]
[ { } ] [ { } ]
[ drop f ] [ drop f ] [ 2drop ] [ 2drop t ]
[ cdecl ] [ cdecl ]
[ first ] [ second ] [ third ] [ fourth ] [ first ] [ second ] [ third ] [ fourth ]
[ ">" write ] [ "/>" write ] [ ">" write ] [ "/>" write ]
} ; }
! ! Add definitions ! ! Add definitions
H{ } clone def-hash set-global H{ } clone lint-definitions set-global
all-words [ all-words [
dup def>> dup callable? dup def>> dup callable?
[ def-hash get-global set-hash-vector ] [ drop ] if [ lint-definitions get-global set-hash-vector ] [ drop ] if
] each ] each
! ! Remove definitions ! ! Remove definitions
! Remove empty word defs ! Remove empty word defs
def-hash get-global [ drop empty? not ] assoc-filter lint-definitions get-global [ drop empty? not ] assoc-filter
! Remove constants [ 1 ] ! Remove constants [ 1 ]
[ drop { [ length 1 = ] [ first number? ] } 1&& not ] assoc-filter [ drop { [ length 1 = ] [ first number? ] } 1&& not ] assoc-filter
@ -76,8 +62,10 @@ def-hash get-global [ drop empty? not ] assoc-filter
! Remove words that are their own definition ! Remove words that are their own definition
[ [ [ def>> ] [ 1quotation ] bi = not ] filter ] assoc-map [ [ [ def>> ] [ 1quotation ] bi = not ] filter ] assoc-map
! Remove set-alien-cell, etc. ! Remove specialized*
[ drop [ accessor-words diff ] keep [ length ] bi@ = ] assoc-filter [ nip [ vocabulary>> "specialized-" head? ] any? not ] assoc-filter
[ nip [ vocabulary>> "windows.messages" = ] any? not ] assoc-filter
! Remove trivial defs ! Remove trivial defs
[ drop trivial-defs member? not ] assoc-filter [ drop trivial-defs member? not ] assoc-filter
@ -117,13 +105,12 @@ def-hash get-global [ drop empty? not ] assoc-filter
[ first2 [ number? ] [ \ slot = ] bi* and not ] [ drop t ] if [ first2 [ number? ] [ \ slot = ] bi* and not ] [ drop t ] if
] assoc-filter ] assoc-filter
dup manual-substitutions
dup more-defs [ lint-definitions set-global ] [ keys lint-definitions-keys set-global ] bi
[ def-hash set-global ] [ keys def-hash-keys set-global ] bi
: find-duplicates ( -- seq ) : 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 ) GENERIC: lint ( obj -- seq )
@ -133,20 +120,20 @@ M: object lint ( obj -- seq ) drop f ;
{ [ start ] [ member? ] } 2|| ; { [ start ] [ member? ] } 2|| ;
M: callable lint ( quot -- seq ) M: callable lint ( quot -- seq )
[ def-hash-keys get-global ] dip '[ _ subseq/member? ] filter ; [ lint-definitions-keys get-global ] dip '[ _ subseq/member? ] filter ;
M: word lint ( word -- seq ) M: word lint ( word -- seq )
def>> dup callable? [ lint ] [ drop f ] if ; def>> dup callable? [ lint ] [ drop f ] if ;
: word-path. ( word -- ) : word-path. ( word -- )
[ vocabulary>> ] [ unparse ] bi ":" glue print ; [ vocabulary>> ] [ name>> ] bi ":" glue print ;
: 4bl ( -- ) bl bl bl bl ; : 4bl ( -- ) bl bl bl bl ;
: (lint.) ( pair -- ) : (lint.) ( pair -- )
first2 [ word-path. ] dip [ first2 [ word-path. ] dip [
[ 4bl . "-----------------------------------" print ] [ 4bl . "-----------------------------------" print ]
[ def-hash get-global at [ 4bl word-path. ] each nl ] bi [ lint-definitions get-global at [ 4bl word-path. ] each nl ] bi
] each nl nl ; ] each nl nl ;
: lint. ( alist -- ) [ (lint.) ] each ; : lint. ( alist -- ) [ (lint.) ] each ;
@ -154,7 +141,7 @@ M: word lint ( word -- seq )
GENERIC: run-lint ( obj -- obj ) GENERIC: run-lint ( obj -- obj )
: (trim-self) ( val key -- obj ? ) : (trim-self) ( val key -- obj ? )
def-hash get-global at* lint-definitions get-global at*
[ dupd remove empty? not ] [ drop f ] if ; [ dupd remove empty? not ] [ drop f ] if ;
: trim-self ( seq -- newseq ) : trim-self ( seq -- newseq )
@ -162,7 +149,7 @@ GENERIC: run-lint ( obj -- obj )
: filter-symbols ( alist -- alist ) : filter-symbols ( alist -- alist )
[ [
nip first dup def-hash get-global at nip first dup lint-definitions get-global at
[ first ] bi@ literalize = not [ first ] bi@ literalize = not
] assoc-filter ; ] assoc-filter ;

View File