1 ! Copyright (C) 2007 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: alien alien.accessors arrays assocs combinators.lib io kernel
4 macros math namespaces prettyprint quotations sequences
5 vectors vocabs words html.elements slots.private tar ;
11 : set-hash-vector ( val key hash -- )
12 2dup at -rot >r >r ?push r> r> set-at ;
14 : add-word-def ( word quot -- )
16 def-hash get-global set-hash-vector
23 { [ swap >r swap r> ] -rot }
24 { [ swap swapd ] -rot }
25 { [ >r swap r> swap ] rot }
26 { [ swapd swap ] rot }
29 { [ >r swap r> ] swapd }
31 { [ drop drop ] 2drop }
32 { [ drop drop drop ] 3drop }
36 } [ first2 swap add-word-def ] each ;
38 : accessor-words ( -- seq )
40 alien-signed-1 alien-signed-2 alien-signed-4 alien-signed-8
41 alien-unsigned-1 alien-unsigned-2 alien-unsigned-4 alien-unsigned-8
42 <displaced-alien> alien-unsigned-cell set-alien-signed-cell
43 set-alien-unsigned-1 set-alien-signed-1 set-alien-unsigned-2
44 set-alien-signed-2 set-alien-unsigned-4 set-alien-signed-4
45 set-alien-unsigned-8 set-alien-signed-8
46 alien-cell alien-signed-cell set-alien-cell set-alien-unsigned-cell
47 set-alien-float alien-float
52 [ get ] [ t ] [ { } ] [ . ] [ drop f ]
53 [ drop ] [ f ] [ first ] [ second ] [ third ] [ fourth ]
54 [ ">" write-html ] [ <unimplemented-typeflag> throw ]
58 H{ } clone def-hash set-global
59 all-words [ dup word-def add-word-def ] each
62 ! Remove empty word defs
67 ! Remove constants [ 1 ]
69 drop dup length 1 = swap first number? and not
72 ! Remove set-alien-cell, etc.
74 drop [ accessor-words swap seq-diff ] keep [ length ] bi@ =
79 drop trivial-defs member? not
82 ! Remove n m shift defs
85 dup first2 [ number? ] both?
86 swap third \ shift = and not
93 first2 \ slot = swap number? and not
95 ] assoc-subset def-hash set-global
102 def-hash get-global keys def-hash-keys set-global
104 GENERIC: lint ( obj -- seq )
106 M: object lint ( obj -- seq )
109 : subseq/member? ( subseq/member seq -- ? )
110 { [ 2dup start ] [ 2dup member? ] } || 2nip ;
112 M: callable lint ( quot -- seq )
117 M: word lint ( word -- seq )
118 word-def dup callable? [ lint ] [ drop f ] if ;
120 : word-path. ( word -- )
121 [ word-vocabulary ":" ] keep unparse 3append write nl ;
123 : (lint.) ( pair -- )
124 first2 >r word-path. r> [
127 "-----------------------------------" print
128 def-hash get at [ bl bl bl bl word-path. ] each
136 GENERIC: run-lint ( obj -- obj )
139 def-hash get-global at* [
140 dupd remove empty? not
145 : trim-self ( seq -- newseq )
146 [ [ (trim-self) ] subset ] assoc-map ;
148 : filter-symbols ( alist -- alist )
150 nip first dup def-hash get at
151 [ first ] bi@ literalize = not
154 M: sequence run-lint ( seq -- seq )
156 global [ dup . flush ] bind
160 [ second empty? not ] subset
163 M: word run-lint ( word -- seq )
166 : lint-all ( -- seq )
167 all-words run-lint dup lint. ;
169 : lint-vocab ( vocab -- seq )
170 words run-lint dup lint. ;
172 : lint-word ( word -- seq )
173 1array run-lint dup lint. ;