extra/lint/lint.factor

   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 ;
   6 IN: lint
   7
   8 SYMBOL: def-hash
   9 SYMBOL: def-hash-keys
  10
  11 : set-hash-vector ( val key hash -- )
  12     2dup at -rot >r >r ?push r> r> set-at ;
  13
  14 : add-word-def ( word quot -- )
  15     dup callable? [
  16         def-hash get-global set-hash-vector
  17     ] [
  18         2drop
  19     ] if ;
  20
  21 : more-defs
  22     {
  23         { [ swap >r swap r> ] -rot }
  24         { [ swap swapd ] -rot }
  25         { [ >r swap r> swap ] rot }
  26         { [ swapd swap ] rot }
  27         { [ dup swap ] over }
  28         { [ dup -rot ] tuck }
  29         { [ >r swap r> ] swapd }
  30         { [ nip nip ] 2nip }
  31         { [ drop drop ] 2drop }
  32         { [ drop drop drop ] 3drop }
  33         { [ 0 = ] zero? }
  34         { [ pop drop ] pop* }
  35         { [ [ ] if ] when }
  36     } [ first2 swap add-word-def ] each ;
  37
  38 : accessor-words ( -- seq )
  39 {
  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
  48 } ;
  49
  50 : trivial-defs
  51     {
  52         [ get ] [ t ] [ { } ] [ . ] [ drop f ]
  53         [ drop ] [ f ] [ first ] [ second ] [ third ] [ fourth ]
  54         [ ">" write-html ] [ <unimplemented-typeflag> throw ]
  55         [ "/>" write-html ]
  56     } ;
  57
  58 H{ } clone def-hash set-global
  59 all-words [ dup word-def add-word-def ] each
  60 more-defs
  61
  62 ! Remove empty word defs
  63 def-hash get-global [
  64     drop empty? not
  65 ] assoc-subset
  66
  67 ! Remove constants [ 1 ]
  68 [
  69     drop dup length 1 = swap first number? and not
  70 ] assoc-subset
  71
  72 ! Remove set-alien-cell, etc.
  73 [
  74     drop [ accessor-words swap seq-diff ] keep [ length ] bi@ =
  75 ] assoc-subset
  76
  77 ! Remove trivial defs
  78 [
  79     drop trivial-defs member? not
  80 ] assoc-subset
  81
  82 ! Remove n m shift defs
  83 [
  84     drop dup length 3 = [
  85         dup first2 [ number? ] both?
  86         swap third \ shift = and not
  87     ] [ drop t ] if
  88 ] assoc-subset
  89
  90 ! Remove [ n slot ]
  91 [
  92     drop dup length 2 = [
  93         first2 \ slot = swap number? and not
  94     ] [ drop t ] if
  95 ] assoc-subset def-hash set-global
  96
  97 : find-duplicates
  98     def-hash get-global [
  99         nip length 1 >
 100     ] assoc-subset ;
 101
 102 def-hash get-global keys def-hash-keys set-global
 103
 104 GENERIC: lint ( obj -- seq )
 105
 106 M: object lint ( obj -- seq )
 107     drop f ;
 108
 109 : subseq/member? ( subseq/member seq -- ? )
 110     { [ 2dup start ] [ 2dup member? ] } || 2nip ;
 111
 112 M: callable lint ( quot -- seq )
 113     def-hash-keys get [
 114         swap subseq/member?
 115     ] with subset ;
 116
 117 M: word lint ( word -- seq )
 118     word-def dup callable? [ lint ] [ drop f ] if ;
 119
 120 : word-path. ( word -- )
 121     [ word-vocabulary ":" ] keep unparse 3append write nl ;
 122
 123 : (lint.) ( pair -- )
 124     first2 >r word-path. r> [
 125         bl bl bl bl
 126         dup .
 127         "-----------------------------------" print
 128         def-hash get at [ bl bl bl bl word-path. ] each
 129         nl
 130     ] each nl nl ;
 131
 132 : lint. ( alist -- )
 133     [ (lint.) ] each ;
 134
 135
 136 GENERIC: run-lint ( obj -- obj )
 137
 138 : (trim-self)
 139     def-hash get-global at* [
 140         dupd remove empty? not
 141     ] [
 142         drop f
 143     ] if ;
 144
 145 : trim-self ( seq -- newseq )
 146     [ [ (trim-self) ] subset ] assoc-map ;
 147
 148 : filter-symbols ( alist -- alist )
 149     [
 150         nip first dup def-hash get at
 151         [ first ] bi@ literalize = not
 152     ] assoc-subset ;
 153
 154 M: sequence run-lint ( seq -- seq )
 155     [
 156         global [ dup . flush ] bind
 157         dup lint
 158     ] { } map>assoc
 159     trim-self
 160     [ second empty? not ] subset
 161     filter-symbols ;
 162
 163 M: word run-lint ( word -- seq )
 164     1array run-lint ;
 165
 166 : lint-all ( -- seq )
 167     all-words run-lint dup lint. ;
 168
 169 : lint-vocab ( vocab -- seq )
 170     words run-lint dup lint. ;
 171
 172 : lint-word ( word -- seq )
 173     1array run-lint dup lint. ;