1 ! Copyright (C) 2007, 2008 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien alien.accessors arrays assocs
4 combinators.short-circuit fry hashtables html.elements io
5 kernel math namespaces prettyprint quotations sequences
6 sequences.deep sets slots.private vectors vocabs words
13 : set-hash-vector ( val key hash -- )
14 2dup at -rot [ ?push ] 2dip set-at ;
16 : more-defs ( hash -- )
18 { -rot [ swap >r swap r> ] }
19 { -rot [ swap swapd ] }
20 { rot [ >r swap r> swap ] }
21 { rot [ swapd swap ] }
24 { swapd [ >r swap r> ] }
26 { 2drop [ drop drop ] }
27 { 3drop [ drop drop drop ] }
31 { >boolean [ f = not ] }
32 } swap '[ first2 _ set-hash-vector ] each ;
34 : accessor-words ( -- seq )
36 alien-signed-1 alien-signed-2 alien-signed-4 alien-signed-8
37 alien-unsigned-1 alien-unsigned-2 alien-unsigned-4 alien-unsigned-8
38 <displaced-alien> alien-unsigned-cell set-alien-signed-cell
39 set-alien-unsigned-1 set-alien-signed-1 set-alien-unsigned-2
40 set-alien-signed-2 set-alien-unsigned-4 set-alien-signed-4
41 set-alien-unsigned-8 set-alien-signed-8
42 alien-cell alien-signed-cell set-alien-cell set-alien-unsigned-cell
43 set-alien-float alien-float
53 [ drop ] ! because of declare
56 [ first ] [ second ] [ third ] [ fourth ]
57 [ ">" write-html ] [ "/>" write-html ]
61 H{ } clone def-hash set-global
64 dup def>> dup callable?
65 [ def-hash get-global set-hash-vector ] [ drop ] if
68 ! ! Remove definitions
70 ! Remove empty word defs
71 def-hash get-global [ drop empty? not ] assoc-filter
73 ! Remove constants [ 1 ]
74 [ drop { [ length 1 = ] [ first number? ] } 1&& not ] assoc-filter
76 ! Remove words that are their own definition
77 [ [ [ def>> ] [ 1quotation ] bi = not ] filter ] assoc-map
79 ! Remove set-alien-cell, etc.
80 [ drop [ accessor-words diff ] keep [ length ] bi@ = ] assoc-filter
83 [ drop trivial-defs member? not ] assoc-filter
89 [ first \ tag = ] [ second number? ] [ third \ eq? = ]
95 [ [ wrapper? ] deep-contains? ]
96 [ [ hashtable? ] deep-contains? ]
100 ! Remove n m shift defs
102 drop dup length 3 = [
103 [ first2 [ number? ] both? ]
104 [ third \ shift = ] bi and not
111 [ first2 [ number? ] [ \ slot = ] bi* and not ] [ drop t ] if
117 [ def-hash set-global ] [ keys def-hash-keys set-global ] bi
119 : find-duplicates ( -- seq )
120 def-hash get-global [ nip length 1 > ] assoc-filter ;
122 GENERIC: lint ( obj -- seq )
124 M: object lint ( obj -- seq ) drop f ;
126 : subseq/member? ( subseq/member seq -- ? )
127 { [ start ] [ member? ] } 2|| ;
129 M: callable lint ( quot -- seq )
130 [ def-hash-keys get-global ] dip '[ _ subseq/member? ] filter ;
132 M: word lint ( word -- seq )
133 def>> dup callable? [ lint ] [ drop f ] if ;
135 : word-path. ( word -- )
136 [ vocabulary>> ] [ unparse ] bi ":" glue print ;
138 : 4bl ( -- ) bl bl bl bl ;
140 : (lint.) ( pair -- )
141 first2 [ word-path. ] dip [
142 [ 4bl . "-----------------------------------" print ]
143 [ def-hash get-global at [ 4bl word-path. ] each nl ] bi
146 : lint. ( alist -- ) [ (lint.) ] each ;
148 GENERIC: run-lint ( obj -- obj )
150 : (trim-self) ( val key -- obj ? )
151 def-hash get-global at*
152 [ dupd remove empty? not ] [ drop f ] if ;
154 : trim-self ( seq -- newseq )
155 [ [ (trim-self) ] filter ] assoc-map ;
157 : filter-symbols ( alist -- alist )
159 nip first dup def-hash get-global at
160 [ first ] bi@ literalize = not
163 M: sequence run-lint ( seq -- seq )
164 [ dup lint ] { } map>assoc trim-self
165 [ second empty? not ] filter filter-symbols ;
167 M: word run-lint ( word -- seq ) 1array run-lint ;
169 : lint-all ( -- seq ) all-words run-lint dup lint. ;
171 : lint-vocab ( vocab -- seq ) words run-lint dup lint. ;
173 : lint-word ( word -- seq ) 1array run-lint dup lint. ;