lint.l (8649B)
1 # 31jul13abu 2 # (c) Software Lab. Alexander Burger 3 4 # *NoLint 5 6 (de noLint (X V) 7 (if V 8 (push1 '*NoLint (cons X V)) 9 (or (memq X *NoLint) (push '*NoLint X)) ) ) 10 11 (de global? (S) 12 (or 13 (memq S '(NIL ^ @ @@ @@@ This T)) 14 (member (char S) '(`(char '*) `(char '+))) ) ) 15 16 (de local? (S) 17 (or 18 (str? S) 19 (member (char S) '(`(char '*) `(char '_))) ) ) 20 21 (de dlsym? (S) 22 (and 23 (car (setq S (split (chop S) ':))) 24 (cadr S) 25 (low? (caar S)) ) ) 26 27 (de lint1 ("X") 28 (cond 29 ((atom "X") 30 (when (sym? "X") 31 (cond 32 ((memq "X" "*L") (setq "*Use" (delq "X" "*Use"))) 33 ((local? "X") (lint2 (val "X"))) 34 (T 35 (or 36 (getd "X") 37 (global? "X") 38 (member (cons "*X" "X") *NoLint) 39 (memq "X" "*Bnd") 40 (push '"*Bnd" "X") ) ) ) ) ) 41 ((num? (car "X"))) 42 (T 43 (casq (car "X") 44 ((: ::)) 45 (; (lint1 (cadr "X"))) 46 (quote 47 (let F (fun? (cdr "X")) 48 (if (or (and (pair F) (not (fin @))) (== '@ F)) 49 (use "*L" (lintFun (cdr "X"))) 50 (lint2 (cdr "X")) ) ) ) 51 ((de dm) 52 (let "*X" (cadr "X") 53 (lintFun (cddr "X")) ) ) 54 (recur 55 (let recurse (cdr "X") 56 (lintFun recurse) ) ) 57 (task 58 (lint1 (cadr "X")) 59 (let "Y" (cddr "X") 60 (use "*L" 61 (while (num? (car "Y")) 62 (pop '"Y") ) 63 (while (and (car "Y") (sym? @)) 64 (lintVar (pop '"Y")) 65 (pop '"Y") ) 66 (mapc lint1 "Y") ) ) ) 67 (let? 68 (use "*L" 69 (lintVar (cadr "X")) 70 (mapc lint1 (cddr "X")) ) ) 71 (let 72 (use "*L" 73 (if (atom (cadr "X")) 74 (lintVar (cadr "X")) 75 (for (L (cadr "X") L (cddr L)) 76 (lintDup (car L) 77 (extract '((X F) (and F X)) 78 (cddr L) 79 '(T NIL .) ) ) 80 (lintVar (car L)) 81 (lint1 (cadr L)) ) ) 82 (mapc lint1 (cddr "X")) ) ) 83 (use 84 (use "*L" 85 (if (atom (cadr "X")) 86 (lintVar (cadr "X")) 87 (mapc lintVar (cadr "X")) ) 88 (mapc lint1 (cddr "X")) ) ) 89 (for 90 (use "*L" 91 (let "Y" (cadr "X") 92 (cond 93 ((atom "Y") # (for X (1 2 ..) ..) 94 (lint1 (caddr "X")) 95 (lintVar "Y") 96 (lintLoop (cdddr "X")) ) 97 ((atom (cdr "Y")) # (for (I . X) (1 2 ..) ..) 98 (lintVar (car "Y")) 99 (lint1 (caddr "X")) 100 (lintVar (cdr "Y")) 101 (lintLoop (cdddr "X")) ) 102 ((atom (car "Y")) # (for (X (1 2 ..) ..) ..) 103 (lint1 (cadr "Y")) 104 (lintVar (car "Y")) 105 (mapc lint1 (cddr "Y")) 106 (lintLoop (cddr "X")) ) 107 (T # (for ((I . L) (1 2 ..) ..) ..) 108 (lintVar (caar "Y")) 109 (lint1 (cadr "Y")) 110 (lintVar (cdar "Y")) 111 (mapc lint1 (cddr "Y")) 112 (lintLoop (cddr "X")) ) ) ) ) ) 113 ((case casq state) 114 (lint1 (cadr "X")) 115 (for "X" (cddr "X") 116 (mapc lint1 (cdr "X")) ) ) 117 ((cond nond) 118 (for "X" (cdr "X") 119 (mapc lint1 "X") ) ) 120 (loop 121 (lintLoop (cdr "X")) ) 122 (do 123 (lint1 (cadr "X")) 124 (lintLoop (cddr "X")) ) 125 (=: 126 (lint1 (last (cddr "X"))) ) 127 ((dec inc pop push push1 queue fifo val idx accu) 128 (_lintq '(T)) ) 129 ((cut port) 130 (_lintq '(NIL T)) ) 131 (set 132 (_lintq '(T NIL .)) ) 133 (xchg 134 (_lintq '(T T .)) ) 135 (T 136 (cond 137 ((pair (car "X")) 138 (lint1 @) 139 (mapc lint2 (cdr "X")) ) 140 ((memq (car "X") "*L") 141 (setq "*Use" (delq (car "X") "*Use")) 142 (mapc lint2 (cdr "X")) ) 143 ((fun? (val (car "X"))) 144 (if (num? @) 145 (mapc lint1 (cdr "X")) 146 (when (local? (car "X")) 147 (lint2 (val (car "X"))) ) 148 (let "Y" (car (getd (pop '"X"))) 149 (while (and (pair "X") (pair "Y")) 150 (lint1 (pop '"X")) 151 (pop '"Y") ) 152 (if (or (== '@ "Y") (= "Prg" "Y") (= "*Prg" "Y")) 153 (mapc lint1 "X") 154 (lint2 "X") ) ) ) ) 155 (T 156 (or 157 (str? (car "X")) 158 (dlsym? (car "X")) 159 (== '@ (car "X")) 160 (memq (car "X") *NoLint) 161 (memq (car "X") "*Def") 162 (push '"*Def" (car "X")) ) 163 (mapc lint1 (cdr "X")) ) ) ) ) ) ) ) 164 165 (de lint2 (X Mark) 166 (cond 167 ((memq X Mark)) 168 ((atom X) 169 (and (memq X "*L") (setq "*Use" (delq X "*Use"))) ) 170 (T (lint2 (car X)) 171 (lint2 (cdr X) (cons X Mark)) ) ) ) 172 173 (de lintVar (X Flg) 174 (cond 175 ((or (not (sym? X)) (memq X '(NIL *DB *Solo ^ meth quote T))) 176 (push '"*Var" X) ) 177 ((not (global? X)) 178 (or 179 Flg 180 (member (cons "*X" X) *NoLint) 181 (memq X "*Use") 182 (push '"*Use" X) ) 183 (push '"*L" X) ) ) ) 184 185 (de lintDup (X Lst) 186 (and 187 (memq X Lst) 188 (not (member (cons "*X" X) *NoLint)) 189 (push '"*Dup" X) ) ) 190 191 (de lintLoop ("Lst") 192 (for "Y" "Lst" 193 (if (and (pair "Y") (or (=T (car "Y")) (not (car "Y")))) 194 (mapc lint1 (cdr "Y")) 195 (lint1 "Y") ) ) ) 196 197 (de _lintq (Lst) 198 (mapc 199 '((X Flg) 200 (lint1 (if Flg (strip X) X)) ) 201 (cdr "X") 202 Lst ) ) 203 204 (de lintFun ("Lst") 205 (let "A" (and (pair "Lst") (car "Lst")) 206 (while (pair "A") 207 (lintDup (car "A") (cdr "A")) 208 (lintVar (pop '"A") T) ) 209 (when "A" 210 (lintVar "A") ) 211 (mapc lint1 (cdr "Lst")) ) ) 212 213 (de lint ("X" "C") 214 (let ("*L" NIL "*Var" NIL "*Dup" NIL "*Def" NIL "*Bnd" NIL "*Use" NIL) 215 (when (pair "X") 216 (setq "C" (cdr "X") "X" (car "X")) ) 217 (cond 218 ("C" # Method 219 (let "*X" (cons "X" "C") 220 (lintFun (method "X" "C")) ) ) 221 ((pair (val "X")) # Function 222 (let "*X" "X" 223 (lintFun (val "X")) ) ) 224 ((info "X") # File name 225 (let "*X" "X" 226 (in "X" (while (read) (lint1 @))) ) ) 227 (T (quit "Can't lint" "X")) ) 228 (when (or "*Var" "*Dup" "*Def" "*Bnd" "*Use") 229 (make 230 # Bad variables 231 (and "*Var" (link (cons 'var "*Var"))) 232 # Duplicate parameters 233 (and "*Dup" (link (cons 'dup "*Dup"))) 234 # Undefined functions 235 (and "*Def" (link (cons 'def "*Def"))) 236 # Unbound variables 237 (and "*Bnd" (<> `(char '_) (char "X")) (link (cons 'bnd "*Bnd"))) 238 # Unused variables 239 (and "*Use" (link (cons 'use "*Use"))) ) ) ) ) 240 241 (de lintAll @ 242 (let *Dbg NIL 243 (make 244 (for "X" (all) 245 (cond 246 ((= `(char "+") (char "X")) 247 (for "Y" (val "X") 248 (and 249 (pair "Y") 250 (fun? (cdr "Y")) 251 (lint (car "Y") "X") 252 (link (cons (cons (car "Y") "X") @)) ) ) ) 253 ((and (not (global? "X")) (pair (getd "X")) (lint "X")) 254 (link (cons "X" @)) ) ) ) 255 (while (args) 256 (and (lint (next)) (link (cons (arg) @))) ) ) ) ) 257 258 # vi:et:ts=3:sw=3