diff options
Diffstat (limited to 'lint.scm')
| -rw-r--r-- | lint.scm | 1164 |
1 files changed, 647 insertions, 517 deletions
@@ -20,7 +20,7 @@ (define *report-doc-strings* #f) ; old-style (CL) doc strings (define *report-func-as-arg-arity-mismatch* #f) ; as it says... (slow, and this error almost never happens) (define *report-constant-expressions-in-do* #f) ; kinda dumb -(define *report-bad-variable-names* '(l ll O ~)) ; bad names -- a list to check such as: +(define *report-bad-variable-names* '(l ll .. O ~)) ; bad names -- a list to check such as: ;;; '(l ll .. ~ data datum new item info temp tmp temporary val vals value foo bar baz aux dummy O var res retval result count str) (define *report-built-in-functions-used-as-variables* #f) ; string and length are the most common cases (define *report-forward-functions* #f) ; functions used before being defined @@ -99,7 +99,7 @@ defined? denominator dilambda? do dynamic-wind eof-object? eq? equal? eqv? even? exact->inexact exact? exp expt float? float-vector float-vector-ref float-vector? floor for-each funclet - gcd gensym gensym? ; why was gensym omitted earlier? + gcd gensym gensym? hash-table hash-table* hash-table-entries hash-table-ref hash-table? help hook-functions if imag-part inexact->exact inexact? infinite? inlet input-port? int-vector int-vector-ref int-vector? iterator-at-end? iterator-sequence integer->char @@ -171,6 +171,7 @@ catch throw error procedure-documentation procedure-signature help procedure-source funclet procedure-setter arity aritable? not eq? eqv? equal? morally-equal? gc s7-version emergency-exit exit dilambda make-hook hook-functions stacktrace tree-leaves tree-memq object->let + getenv directory? file-exists? #_{list} #_{apply_values} #_{append} unquote)) ht)) @@ -321,7 +322,7 @@ (hash-table-set! h d #t)) '(define define* define-constant lambda lambda* curlet require load eval eval-string define-macro define-macro* define-bacro define-bacro* define-expansion - definstrument defanimal define-envelope + definstrument define-animal define-envelope define-values define-module define-method define-syntax define-public define-inlinable define-integrable define^)) h)) @@ -396,10 +397,14 @@ (set! str1 (truncated-list->string f1)) (set! len1 (length str1))) (when (> len2 target-line-length) - (set! ((funclet lint-pretty-print) '*pretty-print-left-margin*) pp-left-margin) - (set! ((funclet lint-pretty-print) '*pretty-print-length*) (- 114 pp-left-margin)) - (set! str2 (lint-pp f2)) - (set! len2 (length str2))) + (let ((old-len2 len2)) + (set! ((funclet lint-pretty-print) '*pretty-print-left-margin*) pp-left-margin) + (set! ((funclet lint-pretty-print) '*pretty-print-length*) (- 114 pp-left-margin)) + (set! str2 (lint-pp f2)) + (set! len2 (length str2)) + (when (> len2 (* 10 old-len2)) ; this is aimed at some pathological s7test cases -- never hit otherwise I think + (set! str2 (truncated-list->string f2)) + (set! len2 (length str2))))) (format #f (if (< (+ len1 len2) target-line-length) (values "~A -> ~A" str1 str2) (values "~%~NC~A ->~%~NC~A" pp-left-margin #\space str1 pp-left-margin #\space str2)))))) @@ -714,8 +719,8 @@ (define (tree-equal-member sym tree) (and (pair? tree) (or (equal? (car tree) sym) - (tree-member sym (car tree)) - (tree-member sym (cdr tree))))) + (tree-equal-member sym (car tree)) + (tree-equal-member sym (cdr tree))))) (define (tree-unquoted-member sym tree) (and (unquoted-pair? tree) @@ -1175,7 +1180,8 @@ (when (and (len=1? body) (pair? (car body)) (case (caar body) ; change body to use if - ((if) #t) ; only 1 hit for 2 reversal branches + ((if) + #t) ; only 1 hit for 2 reversal branches, say 20 hits for 2 ifs + repeated return vals (collapsible) -- see tmp ((when) (set! body `((if ,(cadar body) ,@(if (null? (cdddar body)) @@ -1310,11 +1316,11 @@ (len=3? (cdr tree)) (not (tree-memq res-name (cadr tree))) (tree-memq res-name (cddr tree))) - `(if ,(cadr tree) - ,(if (eq? (caddr tree) res-name) + (list 'if (cadr tree) + (if (eq? (caddr tree) res-name) '(values) (subst (caddr tree))) - ,(if (eq? (cadddr tree) res-name) + (if (eq? (cadddr tree) res-name) '(values) (subst (cadddr tree))))) @@ -1379,6 +1385,7 @@ (set! for-each-case (rewrite-map #t name iter sequence (copy (unbegin (cadr cdrf))) initial-value))))) + (let ((iters ())) ;; recursion -> for-each (when (and (null? (cddr nf)) @@ -1408,7 +1415,7 @@ (unbegin (copy (cadr nf) (make-list (- (length (cadr nf)) 1)))) initial-value))))))) - ;; any number of args here, still if-based as above + ;; any number of args here, still if-based as above ;; ;; recursion->do ;; (n ((a b) (c d)) (if .1. (begin .2. (n (+ a 1) (cdr c))) .3.)) -> (do ((a b (+ a 1)) (c d (cdr c))) ((not .1.) .3.) .2.) @@ -1431,7 +1438,7 @@ (set! result do-body) (set! do-body old-res))) - (when (< (tree-leaves result) 30) + (when (< (tree-leaves result) 50) (let ((call (if (eq? (car do-body) name) do-body (and (eq? (car do-body) 'begin) @@ -1518,13 +1525,13 @@ (set! default-value (cadddr value)))) (unless (eq? default-value :unset) (let ((new-arglist (if (symbol? arglist) - (if default-value - `((,(car var1) ,default-value)) - (list (car var1))) + (list (if default-value + (list (car var1) default-value) + (car var1))) (append (copy arglist (make-list (abs (length arglist)))) - (if default-value ; #f is default - `((,(car var1) ,default-value)) - (list (car var1)))))) + (list (if default-value ; #f is default + (list (car var1) default-value) + (car var1)))))) (new-body (if (null? (cdadr body)) ; 0 other vars '... (list (if (or (eq? (car body) 'let) @@ -1615,6 +1622,7 @@ ((rational? c) 'rational?) ((real? c) 'real?) ((number? c) 'number?) + ((byte-vector? c) 'byte-vector?) ((string? c) 'string?) ((null? c) 'null?) ((char? c) 'char?) @@ -1622,10 +1630,9 @@ ((keyword? c) (cond ((assq c markers) => cdr) (else 'keyword?))) - ((vector? c) 'vector?) ((float-vector? c) 'float-vector?) ((int-vector? c) 'int-vector?) - ((byte-vector? c) 'byte-vector?) + ((vector? c) 'vector?) ((let? c) 'let?) ((hash-table? c) 'hash-table?) ((input-port? c) 'input-port?) @@ -1985,13 +1992,7 @@ (or (string=? "compute" (substring sname 0 7)) ; compute-* is as bad as get-* (string=? "calculate" (substring sname 0 9))))) ; perhaps one exception: computed-goto* (lint-format "surely there's a better name for this variable than ~A" caller vname) -#| - (if (let ((p (char-position #\@ sname))) ; this happens 3 times (in a test suite)! - (and (integer? p) - (string->number (substring sname 0 p)) - (string->number (substring sname (+ p 1))))) - (lint-format "s7 does not implement scheme's polar notation: ~A" caller vname)) -|# + ;; polar notation (see tmp) gets 3 hits (in a test suite)! )))))) @@ -3029,7 +3030,10 @@ (and (null? (cdddr p)) (equal? (caddr p) last))) (cddr form)) - (set! form `(,op (,(car form) ,@(map cadr (cdr form))) ,last))))))))) + (set! form (list op + (cons (car form) + (map cadr (cdr form))) + last))))))))) ;; (or (and A B) (and A C)) -> (and A (or B C)) ;; (or (and A B) (and C B)) -> (and (or A C) B) ;; (and (or A B) (or A C)) -> (or A (and B C)) @@ -3095,7 +3099,7 @@ ((begin) (let* ((len1 (- (length val) 1)) (new-last (simplify-boolean (list 'not (list-ref val len1)) () () env))) - `(,@(copy val (make-list len1)) ,new-last))))) + (append (copy val (make-list len1)) (list new-last)))))) ((not (equal? val arg)) (list 'not val)) @@ -3348,105 +3352,107 @@ (vals ()) (start #f)) - (define (constant-arg p) - (if (code-constant? (cadr p)) - (set! vals (cons (cadr p) vals)) - (and (code-constant? (caddr p)) - (set! vals (cons (caddr p) vals))))) - - (define (upgrade-eqf) - (set! eqfnc (case eqfnc - ((string=? string-ci=? = equal?) 'equal?) - ((#f eq?) 'eq?) - (else 'eqv?)))) - - (define (collect-vals p) - ;; = can't share: (equal? 1 1.0) -> #f, so (or (not x) (= x 1)) can't be simplified - ;; except via member+morally-equal? but that brings in float-epsilon and NaN differences. - ;; We could add both: 1 1.0 as in cond? - ;; - ;; another problem: using memx below means the returned value of the expression - ;; may not match the original (#t -> '(...)), so perhaps we should add a one-time - ;; warning about this, and wrap it in (pair? (mem...)) as an example. - ;; - ;; and another thing... the original might be broken: (eq? x #(1)) where equal? - ;; is more sensible, but that also changes the behavior of the expression: - ;; (memq x '(#(1))) may be #f (or #t!) when (member x '(#(1))) is '(#(1)). - ;; - ;; I think I'll try to turn out a more-or-less working expression, but warn about it. - - (case (car p) - ((string=? equal?) - (set! eqfnc (if (or (not eqfnc) - (eq? eqfnc (car p))) - (car p) - 'equal?)) - (and (= (length p) 3) - (constant-arg p))) - - ((char=?) - (if (memq eqfnc '(#f char=?)) - (set! eqfnc 'char=?) - (if (not (eq? eqfnc 'equal?)) - (set! eqfnc 'eqv?))) - (and (= (length p) 3) - (constant-arg p))) - - ((eq? eqv?) - (let ((leqf (car (->eqf (->lint-type ((if (code-constant? (cadr p)) cadr caddr) p)))))) - (cond ((not eqfnc) - (set! eqfnc leqf)) - - ((or (memq leqf '(#t equal?)) - (not (eq? eqfnc leqf))) - (set! eqfnc 'equal?)) - - ((memq eqfnc '(#f eq?)) - (set! eqfnc leqf)))) - (and (= (length p) 3) - (constant-arg p))) - - ((char-ci=? string-ci=? =) - (and (or (not eqfnc) - (eq? eqfnc (car p))) - (set! eqfnc (car p)) - (= (length p) 3) - (constant-arg p))) + (define collect-vals + (let () + (define (constant-arg p) + (if (code-constant? (cadr p)) + (set! vals (cons (cadr p) vals)) + (and (code-constant? (caddr p)) + (set! vals (cons (caddr p) vals))))) - ((eof-object?) - (upgrade-eqf) - (set! vals (cons #<eof> vals))) + (define (upgrade-eqf) + (set! eqfnc (case eqfnc + ((string=? string-ci=? = equal?) 'equal?) + ((#f eq?) 'eq?) + (else 'eqv?)))) - ((not) - (upgrade-eqf) - (set! vals (cons #f vals))) - - ((boolean?) - (upgrade-eqf) - (set! vals (cons #f (cons #t vals)))) - - ((zero?) - (if (memq eqfnc '(#f eq?)) (set! eqfnc 'eqv?)) - (set! vals (cons 0 (cons 0.0 vals)))) - - ((null?) - (upgrade-eqf) - (set! vals (cons () vals))) - - ((memq memv member) - (cond ((eq? (car p) 'member) - (set! eqfnc 'equal?)) - - ((eq? (car p) 'memv) - (set! eqfnc (if (eq? eqfnc 'string=?) 'equal? 'eqv?))) - - ((not eqfnc) - (set! eqfnc 'eq?))) - (and (= (length p) 3) - (quoted-pair? (caddr p)) - (set! vals (append (cadr (caddr p)) vals)))) - - (else #f))) + (lambda (p) + ;; = can't share: (equal? 1 1.0) -> #f, so (or (not x) (= x 1)) can't be simplified + ;; except via member+morally-equal? but that brings in float-epsilon and NaN differences. + ;; We could add both: 1 1.0 as in cond? + ;; + ;; another problem: using memx below means the returned value of the expression + ;; may not match the original (#t -> '(...)), so perhaps we should add a one-time + ;; warning about this, and wrap it in (pair? (mem...)) as an example. + ;; + ;; and another thing... the original might be broken: (eq? x #(1)) where equal? + ;; is more sensible, but that also changes the behavior of the expression: + ;; (memq x '(#(1))) may be #f (or #t!) when (member x '(#(1))) is '(#(1)). + ;; + ;; I think I'll try to turn out a more-or-less working expression, but warn about it. + + (case (car p) + ((string=? equal?) + (set! eqfnc (if (or (not eqfnc) + (eq? eqfnc (car p))) + (car p) + 'equal?)) + (and (= (length p) 3) + (constant-arg p))) + + ((char=?) + (if (memq eqfnc '(#f char=?)) + (set! eqfnc 'char=?) + (if (not (eq? eqfnc 'equal?)) + (set! eqfnc 'eqv?))) + (and (= (length p) 3) + (constant-arg p))) + + ((eq? eqv?) + (let ((leqf (car (->eqf (->lint-type ((if (code-constant? (cadr p)) cadr caddr) p)))))) + (cond ((not eqfnc) + (set! eqfnc leqf)) + + ((or (memq leqf '(#t equal?)) + (not (eq? eqfnc leqf))) + (set! eqfnc 'equal?)) + + ((memq eqfnc '(#f eq?)) + (set! eqfnc leqf)))) + (and (= (length p) 3) + (constant-arg p))) + + ((char-ci=? string-ci=? =) + (and (or (not eqfnc) + (eq? eqfnc (car p))) + (set! eqfnc (car p)) + (= (length p) 3) + (constant-arg p))) + + ((eof-object?) + (upgrade-eqf) + (set! vals (cons #<eof> vals))) + + ((not) + (upgrade-eqf) + (set! vals (cons #f vals))) + + ((boolean?) + (upgrade-eqf) + (set! vals (cons #f (cons #t vals)))) + + ((zero?) + (if (memq eqfnc '(#f eq?)) (set! eqfnc 'eqv?)) + (set! vals (cons 0 (cons 0.0 vals)))) + + ((null?) + (upgrade-eqf) + (set! vals (cons () vals))) + + ((memq memv member) + (cond ((eq? (car p) 'member) + (set! eqfnc 'equal?)) + + ((eq? (car p) 'memv) + (set! eqfnc (if (eq? eqfnc 'string=?) 'equal? 'eqv?))) + + ((not eqfnc) + (set! eqfnc 'eq?))) + (and (= (length p) 3) + (quoted-pair? (caddr p)) + (set! vals (append (cadr (caddr p)) vals)))) + + (else #f))))) (do ((fp (cdr form) (cdr fp))) ((not (pair? fp))) @@ -3751,12 +3757,14 @@ (equal? (cadr arg1) (cadr arg2))) (if (and (rational? (caddr arg1)) (rational? (caddr arg2))) - (return `(,(car arg1) - ,(cadr arg1) - ,((if (memq (car arg1) '(< <=)) min max) (caddr arg1) (caddr arg2))))) - (return `(,(car arg1) - ,(cadr arg1) - (,(if (memq (car arg1) '(< <=)) 'min 'max) ,(caddr arg1) ,(caddr arg2))))) + (return (list (car arg1) + (cadr arg1) + ((if (memq (car arg1) '(< <=)) min max) (caddr arg1) (caddr arg2))))) + (return (list (car arg1) + (cadr arg1) + (list (if (memq (car arg1) '(< <=)) 'min 'max) + (caddr arg1) + (caddr arg2))))) (when (and (or (equal? (caddr arg1) (cadr arg2)) ; (and (op x y) (op y z)) (equal? (cadr arg1) (caddr arg2)) ; (and (op x y) (op z x)) @@ -3844,7 +3852,7 @@ (when (and (member (cadr arg1) arg2) (memq (car arg2) '(string=? char=? eq? eqv? equal?)) - (null? (cdddr arg2)) + (len=2? (cdr arg2)) (hash-table-ref bools (car arg1)) (or (and (code-constant? (cadr arg2)) (compatible? (car arg1) (->lint-type (cadr arg2)))) @@ -4115,7 +4123,7 @@ (and (len>1? val) ; and redundant tests (hash-table-ref booleans (car val)) (any? (lambda (p) - (and (pair? p) + (and (len>1? p) (subsumes? (car val) (car p)) (equal? (cadr val) (cadr p)))) new-form))))) @@ -4142,16 +4150,19 @@ (fix:<= . <=) (fx<= . <=) (flo:<= . <=) (fl<= . <=) (fix:>= . >=) (fx>= . >=) (flo:>= . >=) (fl>= . >=) (fxlogand . logand) (fxlogior . logior) (fxlogxor . logxor) (fxlognot . lognot) + (fxand . logand) (fxior . logior) (fxxor . logxor) (fxnot . lognot) (fix:quotient . quotient) (fix:min . min) (fix:max . max) (fxquotient . quotient) + (flmax . max) (flmin . min) (flo:abs . abs) (flabs . abs) (flo:sin . sin) (flsin . sin) (flo:cos . cos) (flcos . cos) (flo:tan . tan) (fltan . tan) + (flo:asin . asin) (flasin . asin) + (flo:acos . acos) (flacos . acos) (flo:atan . atan) (flatan . atan) (flo:sqrt . sqrt) (flsqrt . sqrt) - (flo:exp . exp) (flexp . exp) + (flo:exp . exp) (flexp . exp) (flexpt . expt) (flo:log . log) (fllog . log)))) - (lambda (tree) (cond ((assq tree dumb-ops) => cdr) ((or (not (pair? tree)) @@ -4396,7 +4407,7 @@ (pair? (cddr arg1)) (pair? (cddr arg2)) (equal? (cddr arg1) (cddr arg2))) - `(/ (+ ,(cadr arg1) ,(cadr arg2)) ,@(cddr arg1))) + (cons '/ (cons (list '+ (cadr arg1) (cadr arg2)) (cddr arg1)))) (else (cons '+ val))))) (else @@ -4509,18 +4520,16 @@ (eq? op2 'exp)) (list 'exp (list '+ (cadr arg1) (cadr arg2)))) - ((and (eq? op1 'sqrt) ; (* (sqrt x) (sqrt y)) -> (sqrt (* x y)) - (eq? op2 'sqrt)) - (list 'sqrt (list '* (cadr arg1) (cadr arg2)))) + ;; (* (sqrt x) (sqrt y)) -> (sqrt (* x y)) if x and y not both negative? ((not (and (eq? op1 'expt) (eq? op2 'expt))) (cons '* val)) ((equal? (cadr arg1) (cadr arg2)) ; (* (expt x y) (expt x z)) -> (expt x (+ y z)) - `(expt ,(cadr arg1) (+ ,(caddr arg1) ,(caddr arg2)))) + (list 'expt (cadr arg1) (list '+ (caddr arg1) (caddr arg2)))) ((equal? (caddr arg1) (caddr arg2)) ; (* (expt x y) (expt z y)) -> (expt (* x z) y) - `(expt (* ,(cadr arg1) ,(cadr arg2)) ,(caddr arg1))) + (list 'expt (list '* (cadr arg1) (cadr arg2)) (caddr arg1))) (else (cons '* val))))) @@ -4543,7 +4552,7 @@ 0) ((memv -1 val) - `(- (* ,@(remove -1 val)))) ; (* -1 x y) -> (- (* x y)) + (list '- (cons '* (remove -1 val)))) ; (* -1 x y) -> (- (* x y)) ((let search ((args val)) ; (* x (if y 0 z) w) -> (if y 0 (* x z w)) (and (pair? args) @@ -4589,7 +4598,7 @@ (if (null? div) (cons '* (reverse mul)) `(/ (* ,@(reverse mul)) ,@(reverse div)))))) - (if (equal? expr form) + (if (morally-equal? expr form) ; possible NaN form (simplify-numerics expr env))))) @@ -4663,8 +4672,8 @@ (let ((true (caddr arg2)) (false (cadddr arg2))) `(if ,(cadr arg2) - ,(if (eqv? true 0) arg1 `(- ,arg1 ,true)) - ,(if (eqv? true 0) `(- ,arg1 ,false) arg1)))) + ,(if (eqv? true 0) arg1 (list '- arg1 true)) + ,(if (eqv? true 0) (list '- arg1 false) arg1)))) (else (cons '- args))))) (else @@ -5027,14 +5036,16 @@ ((memq (caar args) '(* + / -)) ; maybe extend this list `(,(car form) (,(caar args) ,@(map (lambda (p) - (if (and (pair? p) + (if (and (len=2? p) (memq (car p) '(inexact->exact exact))) (cadr p) p)) (cdar args))))) ((and (eq? (caar args) 'random) (eq? (car form) 'floor) + (null? (cddar args)) (float? (cadar args)) + (not (nan? (cadar args))) ; (floor (random nan.0))! (= (floor (cadar args)) (cadar args))) (list 'random (floor (cadar args)))) @@ -5069,6 +5080,8 @@ ((and (eq? (caar args) '-) ; (abs (- x)) -> (abs x) (len=1? (cdar args))) (list (car form) (cadar args))) + + ;; make-polar as arg never happens (else (cons (car form) args)))) (hash-table-set! h 'abs numabs) @@ -5262,7 +5275,7 @@ (integer-result? (caar args)) (and (eq? (caar args) 'random) (pair? (cdar args)) - (rational? (cadar args)))))) + (rational? (cadar args)))))) ; perhaps (exact (random 10.0)) -> (random 10)?? (car args)) ((number? (car args)) (catch #t (lambda () (inexact->exact (car args))) (lambda any (cons (car form) args)))) @@ -5991,7 +6004,7 @@ (and (every? code-constant? elements) elements) (and (every? (lambda (e) - (and (pair? e) + (and (len=2? e) (eq? (car e) 'quote))) elements) (map caadr elements)))))) @@ -7293,7 +7306,7 @@ ;; not string->number -- no point in copying a number and it's caught below (when (pair? (cdr form)) - (if (code-constant? (cadr form)) + (if (every? code-constant? (cdr form)) (let ((seq (checked-eval form))) (if (not (eq? seq :checked-eval-error)) ; (symbol->string 'abs) -> "abs" (lint-format "perhaps ~A -> ~A~A" caller @@ -8034,7 +8047,7 @@ ((string-append) ; (apply string-append (map ...)) (if (eq? (car cdr-args) 'symbol->string) (lint-format "perhaps ~A" caller ; (apply string-append (map symbol->string ...)) - (lists->string form `(format #f "~{~A~}" ,(cadr cdr-args)))) + (lists->string form (list 'format #f "~{~A~}" (cadr cdr-args)))) (if (simple-lambda? (car cdr-args)) (let ((body (caddar cdr-args))) (if (and (len=3? body) @@ -8105,7 +8118,8 @@ (= (car ary) (cdr ary)) ; else () as last, so can't suggest (car last) (= (cdr ary) (- len 2))) (lint-format "perhaps ~A" caller - (lists->string form `(,@(copy (cdr form) (make-list (- len 2))) (car ,(list-ref form (- len 1)))))))))))) + (lists->string form (append (copy (cdr form) (make-list (- len 2))) + (list (list 'car (list-ref form (- len 1))))))))))))) (hash-special 'apply sp-apply)) @@ -8126,7 +8140,7 @@ (lint-format "format with one argument takes a string: ~A" caller (truncated-list->string form))) ((and (string? (cadr form)) ; (format "str") -> str - (eq? head 'format) ; not snd-display + (eq? head 'format) ; not snd-display, error, etc (not (char-position #\~ (cadr form)))) (lint-format "perhaps ~A" caller (lists->string form (cadr form))))) env) @@ -8237,15 +8251,14 @@ (lint-format "perhaps ~A" caller ; (format #f "~S" x) -> (object->string x) (lists->string form (cons 'object->string (cons (cadddr form) - (if (string=? (caddr form) "~A") '(#f) ())))))))) + (if (string=? (caddr form) "~A") '(#f) ()))))))) + (if (and (eq? (cadr form) 't) ; (format t " ") + (not (var-member 't env))) + (lint-format "'t in ~A should probably be #t" caller (truncated-list->string form)))) (if (any? all-caps-warning (cdr form)) (lint-format "There's no need to shout: ~A" caller (truncated-list->string form))) - (if (and (eq? (cadr form) 't) ; (format t " ") - (not (var-member 't env))) - (lint-format "'t in ~A should probably be #t" caller (truncated-list->string form))) - (if (not (string? control-string)) (if (not (proper-list? args)) (lint-format "~S looks suspicious" caller form)) @@ -8261,7 +8274,8 @@ (if (> ndirs nargs) "too few" "too many") (truncated-list->string form))) - ((and (not (cadr form)) ; (format #f "123") + ((and (eq? head 'format) + (not (cadr form)) ; (format #f "123") (zero? ndirs) (not (char-position #\~ control-string))) (lint-format "~A could be ~S, (format is a no-op here)" caller (truncated-list->string form) (caddr form))) @@ -8276,22 +8290,22 @@ (case (car a) ((number->string) (if (null? (cddr a)) ; (format #f "~A" (number->string x)) - (lint-format "format arg ~A could be ~A" caller a (cadr a)) + (lint-format "~A arg ~A could be ~A" caller head a (cadr a)) (if (and (pair? (cddr a)) (integer? (caddr a)) (memv (caddr a) '(2 8 10 16))) (if (= (caddr a) 10) - (lint-format "format arg ~A could be ~A" caller a (cadr a)) - (lint-format "format arg ~A could use the format directive ~~~A and change the argument to ~A" caller a + (lint-format "~A arg ~A could be ~A" caller head a (cadr a)) + (lint-format "~A arg ~A could use the format directive ~~~A and change the argument to ~A" caller head a (case (caddr a) ((2) "B") ((8) "O") (else "X")) (cadr a)))))) ((symbol->string list->string object->string vector->string) ; (format #f "~A" (symbol->string 'x)) - (lint-format "format arg ~A could be ~A" caller a (cadr a))) + (lint-format "~A arg ~A could be ~A" caller head a (cadr a))) ((make-string) ; (format #f "~A" (make-string len c)) (if (pair? (cddr a)) - (lint-format "format arg ~A could use the format directive ~~NC and change the argument to ... ~A ~A ..." caller a + (lint-format "~A arg ~A could use the format directive ~~NC and change the argument to ... ~A ~A ..." caller head a (cadr a) (if (char? (caddr a)) (format #f "~W" (caddr a)) (caddr a))))) ((apply) @@ -8300,17 +8314,29 @@ (lint-format "use ~~{...~~} rather than ~A: ~A" caller (cadr a) a))) ((string-append) ; (format #f "~A" (string-append x y)) - (lint-format "format appends strings, so ~A seems wasteful" caller a))))) + (if (eq? head 'format) + (lint-format "format appends strings, so ~A seems wasteful" caller a)))))) args))))) (hash-special 'format sp-format)) - ;; ---------------- error ---------------- + ;; ---------------- error/throw ---------------- (let () (define (sp-error caller head form env) - (if (any? all-caps-warning (cdr form)) - (lint-format "There's no need to shout: ~A" caller (truncated-list->string form)))) - (hash-special 'error sp-error)) - + (when (pair? (cdr form)) + (let* ((tag (cadr form)) + (eq (eqf tag env))) + (if (string? tag) + (lint-format "~A's first argument should be a catchable tag, not ~S" caller head tag) + (if (not (member eq '((eq? eq?) (#t #t)))) + (lint-format "~A tag ~S is unreliable (catch uses eq? to match tags)" caller 'error tag))) + (if (and (pair? (cddr form)) + (string? (caddr form)) + (proper-list? (cdddr form))) + ((hash-table-ref special-case-functions 'format) caller head form env))))) + + (hash-special 'error sp-error) + (hash-special 'throw sp-error)) + ;; ---------------- sort! ---------------- (let () (define (sp-sort caller head form env) @@ -8362,10 +8388,11 @@ (null? (cdddr str))) (lint-format "perhaps ~A" caller (lists->string form - (if (and (integer? (caddr form)) - (integer? (caddr str))) - (list 'substring (cadr str) (+ (caddr str) (caddr form))) - (list 'substring (cadr str) (list '+ (caddr str) (caddr form))))))) + (list 'substring (cadr str) + (if (and (integer? (caddr form)) + (integer? (caddr str))) + (+ (caddr str) (caddr form)) + (list '+ (caddr str) (caddr form))))))) ;; end indices are complicated -- since this rarely happens, not worth the trouble (if (eqv? (caddr form) 0) ; (substring x 0) -> (copy x) @@ -8465,10 +8492,11 @@ (eq? (caadr form) 'list-tail)) (lint-format "perhaps ~A" caller ; (list-tail (list-tail x 1) 2) -> (list-tail x 3) (lists->string form - (if (and (integer? (caddr form)) - (integer? (caddr (cadr form)))) - (list 'list-tail (cadadr form) (+ (caddr (cadr form)) (caddr form))) - (list 'list-tail (cadadr form) (list '+ (caddr (cadr form)) (caddr form)))))))))) + (list 'list-tail (cadadr form) + (if (and (integer? (caddr form)) + (integer? (caddr (cadr form)))) + (+ (caddr (cadr form)) (caddr form)) + (list '+ (caddr (cadr form)) (caddr form)))))))))) (hash-special 'list-tail sp-list-tail)) ;; ---------------- eq? ---------------- @@ -8572,7 +8600,7 @@ ;; (equal? a (list b)) and equivalents happens a lot, but is the extra consing worse than ;; (and (pair? a) (equal? (car a) b) (null? (cdr a))) -- code readability seems more important here - + (cond ((or (eq? (car eq1) 'equal?) (eq? (car eq2) 'equal?)) (if (eq? head 'equal?) @@ -8587,10 +8615,10 @@ (if (eq? head 'eqv?) (if specific-op ; (eqv? (integer->char x) #\null) (lint-format "~A could be ~A in ~S" caller head specific-op form)) - (lint-format "~A ~A be eqv?~A in ~S" caller head - (if (eq? head 'eq?) "should" "could") - (if specific-op (format #f " or ~A" specific-op) "") - form))) + (lint-format "~A ~A be eqv?~A in ~S" caller head + (if (eq? head 'eq?) "should" "could") + (if specific-op (format #f " or ~A" specific-op) "") + form))) ((not (or (eq? (car eq1) 'eq?) (eq? (car eq2) 'eq?)))) @@ -8610,6 +8638,17 @@ form)))))) (hash-special 'eqv? sp-eqv?) (hash-special 'equal? sp-eqv?)) + + (let () + (define (sp-morally-equal caller head form env) + (if (and (= (length form) 3) + (code-constant? (cadr form)) + (code-constant? (caddr form))) + (lint-format "perhaps ~A" caller + (lists->string form + (apply morally-equal? (cdr form)))))) + (hash-special 'morally-equal? sp-morally-equal)) + ;; ---------------- map for-each ---------------- (let () @@ -8656,7 +8695,7 @@ (cddr form)))) (if (eq? head 'for-each) (cons (cadr form) args) - `(list (,(cadr form) ,@args)))))))) + (list 'list (cons (cadr form) args)))))))) ;; 2 happens a lot, but introduces evaluation order quibbles ;; we used to check for values if list arg -- got 4 hits! @@ -9307,21 +9346,12 @@ (lambda (caller head form env) (if (len=2? form) (let ((arg (cadr form))) - (if (and (pair? arg) + (if (and (len>1? arg) (eq? (car arg) 'quote) (symbol? (cadr arg)) ; (*s7* 'vector-print-length) (not (hash-table-ref s7-fields (cadr arg)))) (lint-format "unknown *s7* field: ~A" caller arg))))))) - ;; ---------------- throw ---------------- - (hash-special 'throw - (lambda (caller head form env) - (if (pair? (cdr form)) - (let* ((tag (cadr form)) - (eq (eqf tag env))) - (if (not (member eq '((eq? eq?) (#t #t)))) - (lint-format "~A tag ~S is unreliable (catch uses eq? to match tags)" caller 'throw tag)))))) - ;; ---------------- make-hash-table ---------------- (hash-special 'make-hash-table (lambda (caller head form env) @@ -9408,7 +9438,7 @@ (lists->string form ; (cons* (symbol->string v) " | " (w)) -> (cons (symbol->string v) (cons " | " (w))) (if (any-null? (cadddr form)) (list 'list (cadr form) (caddr form)) - `(cons ,(cadr form) (cons ,@(cddr form)))))))))) + (list 'cons (cadr form) (cons 'cons (cddr form)))))))))) (hash-special 'cons* sp-cons*)) ;; ---------------- the-environment etc ---------------- @@ -9900,7 +9930,8 @@ ((do) (if (len>1? (cdr arg)) (let ((end+res (caddr arg))) - (check-arg (if (len>1? end+res) + (check-arg (if (and (pair? end+res) + (> (length end+res) 1)) (list-ref end+res (- (length end+res) 1)) ()))))) @@ -9908,7 +9939,8 @@ (if (len>1? (cdr arg)) (for-each (lambda (clause) - (if (and (len>1? clause) + (if (and (pair? clause) + (> (length clause) 1) (not (eq? (cadr clause) '=>))) (check-arg (list-ref clause (- (length clause) 1))))) (cddr arg)))) @@ -10458,10 +10490,9 @@ (when (> (length hist) 2) ; an experiment -- if all refs are by list-ref (in effect) suggest a vector (let ((init (var-initial-value local-var))) ;; (format *stderr* "hist: ~A~%init: ~A~%outer: ~A~%" hist init outer-form) - (when (pair? init) - - ;; list->vector - (if (and (or (memq (car init) '(list make-list string->list vector->list)) + (when (and (pair? init) + ;; list->vector + (or (memq (car init) '(list make-list string->list vector->list)) (and (eq? (car init) 'quote) (pair? (cdr init)) (pair? (cadr init)))) @@ -10473,10 +10504,10 @@ (memq (car p) '(list-ref list-set! length reverse map for-each list->vector list->string list? pair? null? quote))))) hist)) - (lint-format "~A could be a vector, rather than a list" caller vname)) + (lint-format "~A could be a vector, rather than a list" caller vname)))) ;; string->byte-vector got no hits (see tmp) ;; vector->int|float-vector is mostly test stuff - ))) + ;; there are only a few a-lists>20 in len ;; -------- (let ((first (car hist))) ; all but the initial binding have to match this @@ -10524,7 +10555,7 @@ (+ lint-left-margin 4) #\space ;; "probably" here because the accesses could have hidden protective assumptions ;; i.e. full accessor is not valid at point of let binding - `(,vname (,new-op ,@(tree-subst (var-initial-value local-var) vname (cdr first)))) + (list vname (cons new-op (tree-subst (var-initial-value local-var) vname (cdr first)))) (truncated-list->string outer-form)))))))))))) ;; translate to dilambda fixing arg if necessary and mention generic set! @@ -10739,7 +10770,7 @@ vname (truncated-list->string (var-initial-value local-var)) (var-definer local-var)))) ;; not ref'd or set - (if (not (memq vname '(documentation signature iterator? defanimal))) + (if (not (memq vname '(documentation signature iterator? define-animal))) (let ((val (if (pair? (var-history local-var)) (car (var-history local-var)) (var-initial-value local-var))) (def (var-definer local-var))) (let-temporarily ((line-number (if (eq? caller top-level:) -1 line-number))) @@ -11063,7 +11094,7 @@ (and (pair? new-unused) (set! unused new-unused))))) (cddr p)))) - (lint-format "~A parameter ~A is a function whose parameter~P ~{~A~^, ~} ~A never used~%" caller + (lint-format "~A parameter ~A is a function whose parameter~P ~{~A~^, ~} ~A never used" caller vname (car p) (length unused) (map (lambda (p) (+ p 1)) (reverse unused)) @@ -11442,7 +11473,7 @@ ;; (... (define f14 (lambda (x y) (if (positive? x) (+ x y) y))) (+ (f11 1 2) (f14 1 2))) -> ;; (... (let ((f14 (lambda (x y) (if (positive? x) (+ x y) y)))) (+ (f11 1 2) (f14 1 2)))) (lint-format "the scope of ~A could be reduced: ~A" caller name - (truncated-lists->string `(... ,expr ,use-expr ,@end-dots) + (truncated-lists->string (cons '... (cons expr (cons use-expr end-dots))) `(... (,letx ((,name ,(caddr expr))) ,use-expr) ,@end-dots))))) @@ -11451,7 +11482,7 @@ ;; (... (set! x (+ x y)) ...) (lint-format "use set! to redefine ~A: ~A" caller name (lists->string (cons '... (cons use-expr end-dots)) - `(... (set! ,name ,(caddr use-expr)) ,@end-dots)))) + (cons '... (cons (list 'set! name (caddr use-expr)) end-dots))))) ((pair? (cadr use-expr)) (if (symbol? (caadr use-expr)) (let-temporarily ((target-line-length 120)) @@ -11877,7 +11908,7 @@ (lint-format "assuming ~A is not a macro, perhaps ~A" caller func-name (lists->string (list '... (car start-repeats) '...) - `(for-each ,func (vector ,@(reverse args))))))))))))) + (list 'for-each func (cons 'vector (reverse args))))))))))))) (set! repeats 0) (set! repeat-arg 0) (set! start-repeats fs))) @@ -12641,16 +12672,18 @@ (let ((cc1 (simplify-boolean (list 'not (car c1)) () () env))) (lint-format "perhaps ~A" caller (lists->string form - (if (null? (cddr c2)) - (list 'and cc1 (cadr c2)) - `(and ,cc1 (begin ,@(cdr c2)))))))) + (list 'and cc1 + (if (null? (cddr c2)) + (cadr c2) + (cons 'begin (cdr c2)))))))) (and (pair? (car c1)) ; (cond ((null? x) #t) (else y)) -> (or (null? x) y) (eq? (return-type (caar c1) env) 'boolean?) (lint-format "perhaps ~A" caller (lists->string form - (if (null? (cddr c2)) - (list 'or (car c1) (cadr c2)) - (list 'or (car c1) (cons 'begin (cdr c2))))))))) + (list 'or (car c1) + (if (null? (cddr c2)) + (cadr c2) + (cons 'begin (cdr c2))))))))) (and (boolean? (cadr c2)) (null? (cddr c2)) (not (equal? (cadr c1) (cadr c2))) @@ -12710,7 +12743,7 @@ (if (equal? eqv-select (cadr p)) (values (caddr p) (other-case (caddr p))) (values (cadr p) (other-case (cadr p))))) - (else (error "oops")))) + (else (error 'wrong-type-arg "oops")))) (cdr test)) exprs)))) @@ -12911,30 +12944,34 @@ (let ((inner-name (cadr inner)) (inner-args (caddr inner)) (inner-body (cdddr inner))) + (when (pair? inner-body) (do ((p outer-args (cdr p)) (a inner-args (cdr a))) ((or (null? p) (not (pair? a)) (not (pair? (car a))) + (pair? (caar a)) (and (not (eq? (car p) (caar a))) (tree-memq (car p) inner-body))) ;; args can be reversed, but rarely match as symbols (when (and (null? p) (or (null? a) (and (null? (cdr a)) + (pair? (cdar a)) (code-constant? (cadar a))))) - (let* ((args-match (do ((p outer-args (cdr p)) - (a inner-args (cdr a))) - ((or (null? p) - (not (eq? (car p) (caar a))) - (not (eq? (caar a) (cadar a)))) - (null? p)))) + (let* ((args-match (do ((p1 outer-args (cdr p1)) + (a1 inner-args (cdr a1))) + ((or (null? p1) + (null? (cdar a1)) + (not (eq? (car p1) (caar a1))) + (not (eq? (caar a1) (cadar a1)))) + (null? p1)))) (args-aligned (and (not args-match) - (do ((p outer-args (cdr p)) - (a inner-args (cdr a))) - ((or (null? p) - (not (eq? (car p) (cadar a)))) - (null? p)))))) + (do ((p1 outer-args (cdr p1)) + (a1 inner-args (cdr a1))) + ((or (null? p1) + (not (eq? (car p1) (cadar a1)))) + (null? p1)))))) (when (or args-match args-aligned) (let ((definer (if (null? a) 'define 'define*)) (extras (if (and (pair? a) @@ -12955,7 +12992,7 @@ (reverse result)) (set! result (cons (caar a) result)))) ,@extras) - ,@(tree-subst outer-name inner-name inner-body))))))))))))) + ,@(tree-subst outer-name inner-name inner-body)))))))))))))) (define (set!? form env) (and *report-any-!-as-setter* ; (inc! x) when inc! is unknown, assume it sets x @@ -12982,42 +13019,43 @@ (define (check-definee caller sym form env) - (cond ((keyword? sym) ; (define :x 1) - (lint-format "keywords are constants ~A" caller sym)) - - ((and (eq? sym 'pi) ; (define pi (atan 0 -1)) - (member (caddr form) '((atan 0 -1) - (acos -1) - (* 2 (acos 0)) - (* 4 (atan 1)) - (* 4 (atan 1 1))))) - (lint-format "~A is one of its many names, but pi is a predefined constant in s7" caller (caddr form))) - - ((constant? sym) ; (define most-positive-fixnum 432) - (lint-format "~A is a constant in s7: ~A" caller sym form)) - - ((eq? sym 'quote) - (lint-format "either a stray quote, or a real bad idea: ~A" caller (truncated-list->string form))) - - ((pair? sym) - (check-definee caller (car sym) form env)) - - ((let ((v (var-member sym env))) - (and (var? v) - (eq? (var-definer v) 'define-constant) - (len>2? form) - (not (equal? (caddr form) (var-initial-value v))) - v)) - => (lambda (v) - (let ((line (if (and (pair? (var-initial-value v)) - (positive? (pair-line-number (var-initial-value v)))) - (format #f "(line ~D): " (pair-line-number (var-initial-value v))) - ""))) - (lint-format "~A in ~A is already a constant, defined ~A~A" caller sym - (truncated-list->string form) - line - (truncated-list->string (var-initial-value v)))))))) - + (when (pair? (cddr form)) + (cond ((keyword? sym) ; (define :x 1) + (lint-format "keywords are constants ~A" caller sym)) + + ((and (eq? sym 'pi) ; (define pi (atan 0 -1)) + (member (caddr form) '((atan 0 -1) + (acos -1) + (* 2 (acos 0)) + (* 4 (atan 1)) + (* 4 (atan 1 1))))) + (lint-format "~A is one of its many names, but pi is a predefined constant in s7" caller (caddr form))) + + ((constant? sym) ; (define most-positive-fixnum 432) + (lint-format "~A is a constant in s7: ~A" caller sym form)) + + ((eq? sym 'quote) + (lint-format "either a stray quote, or a real bad idea: ~A" caller (truncated-list->string form))) + + ((pair? sym) + (check-definee caller (car sym) form env)) + + ((let ((v (var-member sym env))) + (and (var? v) + (eq? (var-definer v) 'define-constant) + (len>2? form) + (not (equal? (caddr form) (var-initial-value v))) + v)) + => (lambda (v) + (let ((line (if (and (pair? (var-initial-value v)) + (positive? (pair-line-number (var-initial-value v)))) + (format #f "(line ~D): " (pair-line-number (var-initial-value v))) + ""))) + (lint-format "~A in ~A is already a constant, defined ~A~A" caller sym + (truncated-list->string form) + line + (truncated-list->string (var-initial-value v))))))))) + (define binders (let ((h (make-hash-table))) (for-each (lambda (op) @@ -13417,7 +13455,7 @@ (hash-walker op define-walker)) '(define define* define-constant define-macro define-macro* define-bacro define-bacro* define-expansion - definstrument defanimal define-envelope ; for clm + definstrument define-animal define-envelope ; for clm define-public define*-public defmacro-public define-inlinable define-integrable define^))) ; these give more informative names in Guile and scmutils (MIT-scheme)) @@ -13566,7 +13604,13 @@ (begin (if (memq (car settee) '(vector-ref list-ref string-ref hash-table-ref)) ;; (set! (vector-ref v 0) 3) - (lint-format "~A as target of set!~A" caller (car settee) (truncated-list->string form))) + (lint-format "~A as target of set!~A" caller (car settee) (truncated-list->string form)) + (if (and (eq? (car settee) 'symbol-access) + (len>1? setval) + (eq? (car setval) 'lambda) + (list? (cadr setval)) + (not (= (length (cadr setval)) 2))) + (lint-format "symbol-access function should take 2 arguments: ~A" caller (truncated-list->string form)))) (lint-walk caller settee env) ; this counts as a reference since it's by reference so to speak ;; try type check (dilambda signatures) @@ -13614,6 +13658,7 @@ ((cond) ; (set! x (cond (z w) (else x))) -> (if z (set! x w)) -- this never happens (if (and (= (length setval) 3) + (pair? (caddr setval)) (memq (caaddr setval) '(#t else)) (null? (cddr (caddr setval))) (null? (cddadr setval))) @@ -13786,9 +13831,10 @@ ;; (if x (f y) (g y)) -> ((if x f g) y) ;; but f and g can't be or/and unless there are no expressions ;; I now like all of these -- originally found them odd: CL influence! - (if (equal? true-op test) - `((or ,test ,false-op) ,@true-rest) - `((if ,test ,true-op ,false-op) ,@true-rest))) + (cons (if (equal? true-op test) + (list 'or test false-op) + (list 'if test true-op false-op)) + true-rest)) ((and (eq? (caadr diff) #t) (not (cadadr diff))) @@ -13882,9 +13928,9 @@ ;; (if A (+ B B E C) (+ D D E C)) -> (+ (if A (+ B B) (+ D D)) E C) (lint-format "perhaps ~A" caller (lists->string form - `(,true-op - (if ,expr ,tp ,tq) - ,@(car headdiff))))))))))))))) + (cons true-op + (cons (list 'if expr tp tq) + (car headdiff)))))))))))))))) ;; (when (and (pair? true)...) ;; end tree-subst section @@ -13966,7 +14012,7 @@ (if (pair? (car false)) (list (list (caar false) '...)) (list (car false) '...))))))) - (lists->string form `(cond (,nexpr ,@nfalse) ,@true-rest))))) + (lists->string form (cons 'cond (cons (cons nexpr nfalse) true-rest)))))) ;; true-op = case happens a lot, but never in a way that (not expr)->false can be combined in the case @@ -14000,8 +14046,8 @@ (lists->string form (simplify-boolean (if (not false) - `(and ,expr (not ,true-test) ,true-false) - `(if (and ,expr (not ,true-test)) ,true-false ,false)) + (list 'and expr (list 'not true-test) true-false) + (list 'if (list 'and expr (list 'not true-test)) true-false false)) () () env))))) ;; (if a (if b d e) (if c d e)) -> (if (if a b c) d e)? reversed does not happen. @@ -14052,7 +14098,7 @@ (case false-op ((cond) ; (if a A (cond...)) -> (cond (a A) ...) (when (proper-list? false-rest) - (lint-format "perhaps ~A" caller (lists->string form `(cond (,expr ,true) ,@false-rest))))) + (lint-format "perhaps ~A" caller (lists->string form (cons 'cond (cons (list expr true) false-rest)))))) ((if) @@ -14153,7 +14199,7 @@ (if (pair? false) (let ((false-test (and (pair? false-rest) (car false-rest)))) (if (and (eq? false-op 'if) ; (if x 3 (if (not x) 4)) -> (if x 3 4) - (len>1? false-rest) + (> (or (length false-rest) 0) 1) ; proper-list and len>1? (not (side-effect? test env))) (if (or (equal? test false-test) (equal? expr false-test)) @@ -14192,7 +14238,7 @@ (member setval test)) ; that's all there's room for (let ((f (if (equal? settee (if (memq test-op '(< <=)) rel-arg1 rel-arg2)) 'max 'min))) (lint-format "perhaps ~A" caller - (lists->string form `(set! ,settee (,f ,@true-rest))))))))) + (lists->string form (list 'set! settee (cons f true-rest))))))))) ;; (if (<= (list-ref ind i) 32) (list-set! ind i 32)) -> (list-set! ind i (max (list-ref ind i) 32)) ((list-set! vector-set!) @@ -14212,7 +14258,7 @@ (if (memq test-op '(< <=)) 'max 'min))))) (if mx-op (lint-format "perhaps ~A" caller - (lists->string form `(,true-op ,settee ,index (,mx-op ,@(cdr test))))))))))))))) + (lists->string form (list true-op settee index (cons mx-op (cdr test))))))))))))))) (cond ((not (pair? true-rest))) ((not (eq? (car true) 'if)) ; (if test0 (if test1 expr)) -> (if (and test0 test1) expr) @@ -14248,6 +14294,7 @@ (let ((f (if (equal? (cadr test) (if (memq (car test) '(< <=)) true false)) 'min 'max))) (lint-format "perhaps ~A" caller (lists->string form (list f true false)))))) + ;; no hits for negative?/positive? and 0/0.0 here (cond ((eq? expr #t) ; (if #t #f) -> #f (lint-format "perhaps ~A" caller (lists->string form true))) @@ -14284,10 +14331,11 @@ ;; (if x y #t) -> (or (not x) y) (lint-format "perhaps ~A" caller (let ((nexpr (if false - (if (and (len>1? expr) - (eq? (car expr) 'not)) - (list 'or (cadr expr) true) - (list 'or (list 'not expr) true)) + (list 'or (if (and (len>1? expr) + (eq? (car expr) 'not)) + (cadr expr) + (list 'not expr)) + true) (list 'and expr true)))) (lists->string form (simplify-boolean nexpr () () env))))))) ((= len 4) @@ -14570,7 +14618,7 @@ (lists->string form (if (not (or (side-effect? expr env) (tree-set-member (map car sv) expr))) - `(let ,(reverse sv) (if ,expr ,ntv ,nfv)) + (list 'let (reverse sv) (list 'if expr ntv nfv)) (let ((uniq (find-unique-name form))) `(let ((,uniq ,expr)) (let ,(reverse sv) @@ -14594,7 +14642,7 @@ (eq? (car expr) 'not)) (cons 'unless (cons (cadr expr) (unbegin true))) (cons 'when (cons expr (unbegin true))))))) - + (if (symbol? expr) (set-ref expr caller form env) (lint-walk caller expr env)) @@ -14624,9 +14672,9 @@ (lint-format "perhaps ~A" caller (truncated-lists->string form - `(,(if (eq? head 'when) 'unless 'when) - ,(cadr test) - ,@(cddr form))))) + (cons (if (eq? head 'when) 'unless 'when) + (cons (cadr test) + (cddr form)))))) (if (never-false test) (lint-format "~A test is never false: ~A" caller head (truncated-list->string form)) (if (never-true test) ; (unless #f...) @@ -14679,10 +14727,10 @@ (cadr form)) #f) ,@(cdr body)))) - (when (or (and (memq (car body) '(when unless)) - (len>1? body)) - (and (eq? (car body) 'if) - (len=3? body))) + (when (case (car body) + ((when unless) (len>1? body)) + ((if) (len=3? body)) + (else #f)) (let ((new-test (let ((inner-test (if (eq? (car body) 'unless) (list 'not (cadr body)) (cadr body))) @@ -14797,7 +14845,7 @@ (cdr form)))) ;; (cond ((< x 1) (+ x 1)) ((< y 1) (+ x 3)) (else (+ x 2))) -> (+ x (cond ((< x 1) 1) ((< y 1) 3) (else 2))) (lint-format "perhaps ~A" caller - (lists->string form `(,@header (cond ,@middle) ,@trailer)))))))) + (lists->string form (append header (list (cons 'cond middle)) trailer)))))))) (partition-form (cdr form) (if else-error (- len 1) len))))) ;; not escaping else here because the trailing args might be evaluated first @@ -14814,20 +14862,20 @@ ;; (cond (X (f y z)) (Y (f y z)) (Z (f y z))) -> (if (or X Y Z) (f y z)) (lint-format "perhaps ~A" caller (lists->string form - `(if (or ,@(map car (cdr form))) - ,first-result))) + (list 'if (cons 'or (map car (cdr form))) first-result))) ;; here we need an else clause else (apply #<unspecified> args) (if (memq (car else-clause) '(#t else)) ;; (cond (X (f y z)) (else (g y z))) -> ((cond (X f) (else g)) y z) (lint-format "perhaps ~A" caller (lists->string form - `((cond ,@(map (lambda (c) - (list (car c) (caadr c))) - (cdr form))) - ,@(cdr first-result)))))))))))) + (cons (cons 'cond (map (lambda (c) + (list (car c) (caadr c))) + (cdr form))) + (cdr first-result)))))))))))) ;; ---------------- (let ((falses ()) - (trues ())) + (trues ()) + (prev-bool #f)) (for-each (lambda (clause) (set! ctr (+ ctr 1)) @@ -14835,7 +14883,8 @@ (begin (set! all-eqv #f) (set! has-combinations #f) - ;; ; (cond 1) + (set! prev-bool #f) + ;; (cond 1) (lint-format "cond clause ~A in ~A is not a pair?" caller clause (truncated-list->string form))) (begin @@ -14846,6 +14895,25 @@ (not (and (pair? (cdr clause)) (eq? (cadr clause) '=>))) ; case sends selector, but cond sends test result (cond-eqv? (car clause) eqv-select #t)))) + + ;; look for successive clause tests where the earlier includes the current (number? followed by integer? etc) + ;; slightly sloppy I guess -- the arg could be self-modifying! + (if (and (pair? clause) + (len>1? (car clause)) + (hash-table-ref bools (caar clause))) + (begin + (if (and prev-bool + (equal? (cadar prev-clause) (cadar clause)) ; args match + (subsumes? prev-bool (caar clause))) ; previous test already included this case + (lint-format "~A makes ~A pointless in ~A~A~%" caller + (car prev-clause) + (car clause) + (truncated-list->string form) + (if (eq? prev-bool 'list?) + (format #f "~%~NC(r5rs list? is proper-list? in s7)" (+ lint-left-margin 4) #\space) + ""))) + (set! prev-bool (caar clause))) + (set! prev-bool #f)) (if (and (pair? prev-clause) (not has-combinations) @@ -14919,7 +14987,7 @@ (else ,@(unbegin (cadddr first-sequel)))))))))) ((when unless) ;; (cond (a A) (else (when b B))) - (when (len>1? (cdr first-sequel)) + (when (> (length first-sequel) 2) (lint-format "else clause could be folded into the outer cond: ~A" caller (lists->string form (append (copy form (make-list ctr)) @@ -15090,7 +15158,7 @@ (cond ((equal? (simplify-boolean (car c1) () () env) (simplify-boolean (list 'not (car c2)) () () env)) (lint-format "perhaps ~A" caller ; (cond ((x) y) ((not (x)) z)) -> (cond ((x) y) (else z)) - (lists->string form `(cond ,c1 (else ,@(cdr c2)))))) + (lists->string form (list 'cond c1 (cons 'else (cdr c2)))))) ((and (pair? (cdr c2)) (not (pair? (cadr c2))) (not (memq (car c2) '(else #t))) @@ -15365,9 +15433,9 @@ (lint-format "perhaps ~A" caller (lists->string form (let ((not-reps - (simplify-boolean (if (null? (cdr reps)) - (list 'not (car reps)) - (list 'not (cons 'and reps))) + (simplify-boolean (list 'not (if (null? (cdr reps)) + (car reps) + (cons 'and reps))) () () env))) `(,@(copy form (make-list head-len)) (,not-reps @@ -15411,7 +15479,7 @@ (if (and (pair? (car clause)) (eq? (caar clause) 'not)) (cons 'unless (append (cdar clause) (cdr clause))) - (cons 'when (cons (car clause) (cdr clause)))))))))) + (cons 'when clause)))))))) (when has-else ; len > 1 here (let ((last-clause (list-ref form (- len 1)))) ; not the else branch! -- just before it. @@ -15534,10 +15602,10 @@ ((eq? (car a) #t) (if (not (car b)) nexpr - (simplify-boolean `(or ,nexpr ,(car b)) () () env))) + (simplify-boolean (list 'or nexpr (car b)) () () env))) ((car a) ; i.e a is not #f - `(if ,nexpr ,(car a) ,(car b))) + (list 'if nexpr (car a) (car b))) ((eq? (car b) #t) (simplify-boolean (list 'not nexpr) () () env)) @@ -15570,11 +15638,13 @@ ;; (cond ((and A B) c) (B d) (else e)) -> (cond (B (if A c d)) (else e)) (lint-format "perhaps ~A" caller (lists->string form - `(cond (,(car arg2) - (if ,((if (equal? (car arg2) (cadar arg1)) caddar cadar) arg1) - ,(cadr arg1) - ,(cadr arg2))) - ,@(cdddr form)))))) + (cons 'cond + (cons (list (car arg2) + (list 'if + ((if (equal? (car arg2) (cadar arg1)) caddar cadar) arg1) + (cadr arg1) + (cadr arg2))) + (cdddr form))))))) (if (and (len=1? last-clause) ; (cond ... ((or ...)) (else ...)) -> (cond ... (else (or ... ...))) (pair? (car last-clause)) @@ -15665,6 +15735,9 @@ (selector (cadr form)) (suggest made-suggestion)) + ;(let ((leaves (tree-leaves form)) (branches (length (cddr form)))) + ; (if (> leaves 100) (format *stderr* "case: ~A in ~A: ~A~%" leaves branches (/ (* 1.0 leaves) branches)))) + ;; ---------------- ;; if regular case + else -- just like cond above (let ((len (- (length form) 2))) ; number of clauses @@ -15750,7 +15823,7 @@ (middle (if (len=1? (car first-clause)) (list 'eqv? (cadr form) (caar first-clause)) `(memv ,(cadr form) ',(car first-clause))))) - (lists->string form `(,@header (if ,middle ,fmid ,emid) ,@trailer))))))) + (lists->string form (append header (cons (list 'if middle fmid emid) trailer)))))))) ;; len > 2 so use case in the revision (let ((middle (map (lambda (c) (if (and else-error @@ -15966,13 +16039,28 @@ ;; else-foldable as (((keys-from-test) true-branch) (else false-branch)) (set! else-foldable (if (pair? (cdddr expr)) - `(,(case-branch (cadr expr) selector (list (caddr expr))) - (else ,(cadddr expr))) + (list (case-branch (cadr expr) selector (list (caddr expr))) + (list 'else (cadddr expr))) (list (case-branch (cadr expr) selector (cddr expr)))))))))))))) (lint-walk-open-body caller (car form) exprs env)))) (cddr form)) + (let ((key-phrase + (let ((keylen (length all-keys))) + (cond ((< keylen 20)) + ((every? char? all-keys) + "vector (indexed by char->integer)") + ((every? (lambda (k) (and (integer? k) (<= 0 k 1000))) all-keys) + "vector") + ((> keylen 40) + "hash-table"))))) + (when (string? key-phrase) + (lint-format "perhaps use a ~A rather than a case statement:~%~NC~A" caller + key-phrase + (+ lint-left-margin 4) #\space + (truncated-list->string form)))) + (if (and has-else (pair? result) (not else-foldable)) @@ -16005,8 +16093,8 @@ (when (len>1? clause) ; ignore clauses that are messed up (let ((keys (car clause)) (exprs (cdr clause))) - (when (and (not (eq? keys 'else)) - (not (equal? exprs else-exprs))) + (unless (or (eq? keys 'else) + (equal? exprs else-exprs)) (let ((prev (member exprs new-keys-and-exprs (lambda (a b) (equal? a (cdr b)))))) (if prev (let* ((cur-clause (car prev)) @@ -16373,7 +16461,7 @@ ;; do -> for-each (when (len=1? step-vars) (let ((var (car step-vars))) - (when (and (len>1? (cdr var)) + (when (and (len>2? var) (len>1? (caddr var)) (len=1? (caddr form)) (pair? (caaddr form)) @@ -16660,16 +16748,17 @@ (lint-format "perhaps ~A" caller (lists->string form (if (eq? vname (cadadr p)) - (if (and (pair? (cddr p)) - (len>1? (caddr p)) - (memq (caaddr p) '(else #t t))) - (if (null? (cddr (caddr p))) - (list 'or vvalue (cadr (caddr p))) - (list 'or vvalue (cons 'begin (cdaddr p)))) - (list 'or vvalue - (cons 'cond (cddr p)))) - `(cond (,vvalue => ,(caadr (cadr p))) - ,@(cddr p)))))) + (list 'or vvalue + (if (and (pair? (cddr p)) + (len>1? (caddr p)) + (memq (caaddr p) '(else #t t))) + (if (null? (cddr (caddr p))) + (cadr (caddr p)) + (cons 'begin (cdaddr p))) + (cons 'cond (cddr p)))) + (cons 'cond + (cons (list vvalue '=> (caadr (cadr p))) + (cddr p))))))) (when (and (null? (cddr p)) ; (let ((x (+ y 1))) (abs x)) -> (abs (+ y 1)) (eq? vname (cadr p))) ; not tree-subst or trailing (pair) args: the let might be forcing evaluation order @@ -16702,13 +16791,15 @@ (len=2? if-false) (eq? vname (cadr if-false))) (let ((else-clause (if (eq? if-true vname) - `((else #f)) + (list (list 'else #f)) (if (and (pair? if-true) (tree-unquoted-member vname if-true)) :oops! ; if the let var appears in the else portion, we can't do anything with => - `((else ,if-true)))))) + (list (list 'else if-true)))))) (unless (eq? else-clause :oops!) - (lint-format "perhaps ~A" caller (lists->string form `(cond (,vvalue => ,(car if-false)) ,@else-clause)))))))) + (lint-format "perhaps ~A" caller + (lists->string form + (cons 'cond (cons (list vvalue '=> (car if-false)) else-clause))))))))) (let ((crf #f)) ;; all this stuff still misses (cond ((not x)...)) and (set! y (if x (cdr x)...)) i.e. need embedding in this case @@ -16718,14 +16809,24 @@ (equal? (cadr p) (list 'not vname))) (and (pair? vvalue) (memq (car vvalue) '(assoc assv assq member memv memq)) - (pair? (cadr p)) + (len>1? (cadr p)) ; (let ((x (memq z y))) (if (pair? x) (g x))) -> (cond ((memq z y) => g)) (or (eq? (caadr p) 'pair?) + (and (eq? (caadr p) 'list?) + (lint-format "in ~A, ~A can't be null so pair? might be better" caller p vname) + #t) (and (eq? (caadr p) 'null?) ;; (let ((x (assoc y z))) (if (null? x) (g x))) (lint-format "in ~A, ~A can't be null because ~A in ~A only returns #f or a pair" caller p vname (car vvalue) (truncated-list->string (car varlist))) #f)) - (eq? (cadadr p) vname))) + (eq? (cadadr p) vname)) + (and (memq (car vvalue) '(char-position string-position string->number length arity)) ; length|arity only in s7 + (or (eq? (cadr p) vname) + (and (len>1? (cadr p)) + (or (memq (caadr p) '(number? complex?)) + (and (not (eq? (car vvalue) 'string->number)) + (eq? (caadr p) 'integer?))) + (eq? (cadadr p) vname))))) (or (and (len=2? (caddr p)) ; one func arg (or (eq? vname (cadr (caddr p))) @@ -16751,11 +16852,11 @@ (null? (cdddr p)))) (let ((else-clause (if (pair? (cdddr p)) (if (eq? (cadddr p) vname) - `((else #f)) ; this stands in for the local var + (list (list 'else #f)) ; this stands in for the local var (if (and (pair? (cadddr p)) (tree-unquoted-member vname (cadddr p))) :oops! ; if the let var appears in the else portion, we can't do anything with => - `((else ,(cadddr p))))) + (list (list 'else (cadddr p))))) (case (car p) ((and) '((else #f))) ((or) '((else #t))) @@ -16763,7 +16864,9 @@ (unless (eq? else-clause :oops!) ;; (let ((x (assoc y z))) (if x (cdr x))) -> (cond ((assoc y z) => cdr)) (lint-format "perhaps ~A" caller - (lists->string form `(cond (,vvalue => ,(or crf (caaddr p))) ,@else-clause)))))))) + (lists->string form (cons 'cond + (cons (list vvalue '=> (or crf (caaddr p))) + else-clause))))))))) )) ; one var in varlist @@ -16807,57 +16910,66 @@ ((cond) ;; happens about a dozen times (let ((vars (map car (cadr form)))) - (if (tree-set-member vars (cdar body)) - (call-with-exit - (lambda (quit) - (let ((branch-let #f)) - (for-each (lambda (c) - (if (and (not branch-let) - (pair? c) - (side-effect? (car c) env)) - (quit)) - (when (and (pair? c) - (tree-set-member vars c)) - (if branch-let (quit)) - (set! branch-let c))) - (cdar body)) - (if (and branch-let + (when (tree-set-member vars (cdar body)) + (call-with-exit + (lambda (quit) + (let ((branch-let #f)) + (for-each (lambda (c) + (if (and (not branch-let) + (pair? c) + (side-effect? (car c) env)) + (quit)) + (when (and (pair? c) + (tree-set-member vars c)) + (if branch-let (quit)) + (set! branch-let c))) + (cdar body)) + (when (and branch-let (not (memq (car branch-let) vars)) (not (tree-set-member vars (car branch-let)))) - (lint-format "perhaps move the let into the '~A branch: ~A" caller - (truncated-list->string branch-let) - (lists->string form + (lint-format "perhaps move the let into the '~A branch: ~A" caller + (truncated-list->string branch-let) + (lists->string form + (if (eq? '=> (cadr branch-let)) + (if (eq? branch-let (cadar body)) + `(cond (,(car branch-let) => (let ,(cadr form) ,@(cddr branch-let))) ...) + `(cond ... (,(car branch-let) => (let ,(cadr form) ,@(cddr branch-let))) ...)) (if (eq? branch-let (cadar body)) `(cond (,(car branch-let) (let ,(cadr form) ,@(cdr branch-let))) ...) - `(cond ... (,(car branch-let) (let ,(cadr form) ,@(cdr branch-let))) ...))))))))))) + `(cond ... (,(car branch-let) (let ,(cadr form) ,@(cdr branch-let))) ...)))))))))))) ((case) (let ((vars (map car (cadr form))) (test (cadar body))) - (if (and (not (memq test vars)) - (not (tree-set-member vars test)) - (tree-set-member vars (cddar body))) - (call-with-exit - (lambda (quit) - (let ((branch-let #f)) - (for-each (lambda (c) - (when (and (pair? c) - (tree-set-member vars (cdr c))) - (if branch-let (quit)) - (set! branch-let c))) - (cddar body)) - (if (proper-list? branch-let) - (lint-format "perhaps move the let into the '~A branch: ~A" caller - (truncated-list->string branch-let) - (lists->string form + (when (and (not (memq test vars)) + (not (tree-set-member vars test)) + (tree-set-member vars (cddar body))) + (call-with-exit + (lambda (quit) + (let ((branch-let #f)) + (for-each (lambda (c) + (when (and (pair? c) + (tree-set-member vars (cdr c))) + (if branch-let (quit)) + (set! branch-let c))) + (cddar body)) + (when (proper-list? branch-let) + (lint-format "perhaps move the let into the '~A branch: ~A" caller + (truncated-list->string branch-let) + (lists->string form + (if (eq? '=> (cadr branch-let)) + (if (eq? branch-let (caddar body)) + `(case ,test (,(car branch-let) => (let ,(cadr form) ,@(cddr branch-let))) ...) + `(case ,test ... (,(car branch-let) => (let ,(cadr form) ,@(cddr branch-let))) ...)) (if (eq? branch-let (caddar body)) `(case ,test (,(car branch-let) (let ,(cadr form) ,@(cdr branch-let))) ...) - `(case ,test ... (,(car branch-let) (let ,(cadr form) ,@(cdr branch-let))) ...))))))))))) + `(case ,test ... (,(car branch-let) (let ,(cadr form) ,@(cdr branch-let))) ...)))))))))))) ((when unless) ; no hits -- maybe someday? (let ((test (cadar body)) (vars (map car (cadr form)))) (unless (or (memq test vars) (tree-set-member vars test) - (side-effect? test env)) + (side-effect? test env) + (not (proper-list? (cddar body)))) (lint-format "perhaps move the let inside the ~A: ~A" caller (caar body) (truncated-lists->string form `(,(caar body) ,test (let ,(cadr form) ,@(cddar body)))))))))) @@ -16868,9 +16980,10 @@ (when (and (= suggest made-suggestion) (not named-let) (< (length varlist) 8) + (every? pair? varlist) (not (memq (caar body) '(lambda lambda* define define* define-macro))) (not (and (eq? (caar body) 'set!) - (any? (lambda (v) (eq? (car v) (cadar body))) varlist))) + (any? (lambda (v) (and (eq? (car v) (cadar body)))) varlist))) (not (any-macro? (caar body) env)) (not (any? (lambda (p) (and (unquoted-pair? p) @@ -16902,14 +17015,12 @@ caller (lists->string form new-body)))) ) ; null cdr body etc - (when (and (pair? (cadr form)) ; (let ((x x)) (+ x 1)) -> (+ x 1), (let ((x x))...) does not copy x if x is a sequence - (= suggest made-suggestion) + (when (and (pair? (cadr form)) ; (let ((x x)) (+ x 1)) -> (+ x 1), (let ((x x))...) does not copy x if x is a sequence + (= suggest made-suggestion) ; used to check for returned lambda here, but that doesn't matter (every? (lambda (c) (and (len>1? c) ; the usual... (let binding might be messed up) (eq? (car c) (cadr c)))) - (cadr form)) - (not (and (pair? (caddr form)) - (memq (caaddr form) '(lambda lambda*))))) + (cadr form))) (let ((vs (map car (cadr form)))) (unless (any? (lambda (p) (and (pair? p) @@ -17022,17 +17133,18 @@ ;; the pattern (set! x y) ... (set! y x) happens a few times (say 5 to 10) (lint-format "perhaps use let-temporarily here: ~A" caller (lists->string form - (let ((new-let `(let-temporarily - ((,saved-name ,(if (pair? first-pos) - (caddar first-pos) - saved-name))) - ,@(map (lambda (expr) - (if (or (and (pair? first-pos) - (eq? expr (car first-pos))) - (eq? expr (car last-pos))) - (values) - expr)) - body)))) + (let ((new-let (cons 'let-temporarily + (cons (list (list saved-name + (if (pair? first-pos) + (caddar first-pos) + saved-name))) + (map (lambda (expr) + (if (or (and (pair? first-pos) + (eq? expr (car first-pos))) + (eq? expr (car last-pos))) + (values) + expr)) + body))))) (if (null? (cdr vars)) ; we know vars is a pair, want len=1 new-let (list 'let (map (lambda (v) @@ -17130,14 +17242,15 @@ setval (list 'let (map (lambda (v) (if (eq? (car v) settee) (values) v)) varlist) setval)) - `(let ,(map (lambda (v) - (if (eq? (car v) settee) ; (let ((x 0)) (set! x 1)...) -> (let ((x 1)) ...) - (list (car v) setval) ; replace initial with set! value - v)) - varlist) - ,@(if (null? (cddr body)) - (cdr body) - (list (cadr body) '...))))))) + (cons 'let + (cons (map (lambda (v) + (if (eq? (car v) settee) ; (let ((x 0)) (set! x 1)...) -> (let ((x 1)) ...) + (list (car v) setval) ; replace initial with set! value + v)) + varlist) + (if (null? (cddr body)) + (cdr body) + (list (cadr body) '...)))))))) ;; repetition for the moment (when (and (pair? varlist) (assq settee vars) ; settee is a local var @@ -17300,17 +17413,18 @@ varlist)) ;; (let ((xx 0)) (do ((x 1 (+ x 1)) (y x (- y 1))) ((= x 3) xx) (display y))) -> ;; (do ((xx 0) (x 1 (+ x 1)) (y x (- y 1))) ...) - (lint-format "perhaps ~A" caller - (lists->string form - (let ((do-form (cdar body))) - (if (null? (cdr body)) ; do is only expr in let - (list 'do (append varlist (car do-form)) - '...) - `(do ,(append varlist (car do-form)) - (,(and (pair? (cadr do-form)) (caadr do-form)) - ,@(if (side-effect? (cdadr do-form) env) (cdadr do-form) ()) - ,@(cdr body)) ; include rest of let as do return value - ...))))))))) + (let ((do-form (cdar body))) + (if (pair? do-form) + (lint-format "perhaps ~A" caller + (lists->string form + (if (null? (cdr body)) ; do is only expr in let + (list 'do (append varlist (car do-form)) + '...) + `(do ,(append varlist (car do-form)) + (,(and (pair? (cadr do-form)) (caadr do-form)) + ,@(if (side-effect? (cdadr do-form) env) (cdadr do-form) ()) + ,@(cdr body)) ; include rest of let as do return value + ...)))))))))) (when (and (> (length body) 3) ; setting this to 1 did not catch anything new (every? pair? varlist) @@ -17471,7 +17585,9 @@ ;; (let ((x 1) (y (f g 2))) (let loop ((a (+ x 1)) (b y)) (loop a b))) -> (let loop ((a (+ 1 1)) (b (f g 2))) (loop a b)) (lint-format "perhaps ~A" caller (lists->string form - `(let ,inner-vars ,new-args ,@named-body))))))) + (cons 'let + (cons inner-vars + (cons new-args named-body))))))))) ;; maybe more code than this is worth -- combine lets (when (and (memq (car inner) '(let let*)) @@ -17585,6 +17701,7 @@ (pair? body) (pair? (car body)) (eq? (caar body) 'do) + (len>2? (car body)) (< (tree-leaves (cdr body)) *max-cdr-len*)) (let ((inits (if (pair? (cadar body)) (map cadr (cadar body)) @@ -17969,7 +18086,9 @@ (lint-format "perhaps ~A" caller (case varlist-len ((1) (lists->string form - `(cond (,(cadr last-var) => ,(caaddr p)) ,@else-clause))) + (cons 'cond + (cons (list (cadr last-var) '=> (caaddr p)) + else-clause)))) ((2) (lists->string form `(let (,(car varlist)) (cond (,(cadr last-var) => ,(caaddr p)) ,@else-clause)))) @@ -18432,9 +18551,9 @@ ;; (call-with-input-file "file" (lambda (p) (read-char p))) -> (call-with-input-file "file" read-char) (lint-format "perhaps ~A" caller (lists->string form - (if (= len 2) - (list head (caar body)) - (list head (cadr form) (caar body))))) + (list head (if (= len 2) + (caar body) + (values (cadr form) (caar body)))))) (let ((cc (make-var :name port :initial-value (list (case head ((call-with-input-string) 'open-input-string) @@ -18585,12 +18704,12 @@ (lint-walk-body caller (caadr form) (cddr form) new-env)))))) (hash-walker 'let-syntax (lambda (caller form env) - (lint-walk-body caller 'define-method (cddr form) env) - env)) + (lint-walk-body caller 'define-method (cddr form) env) + env)) (hash-walker 'letrec-syntax (lambda (caller form env) - (lint-walk-body caller 'define-method (cddr form) env) - env)) + (lint-walk-body caller 'define-method (cddr form) env) + env)) ;; ---------------- case-lambda ---------------- (let () @@ -18627,9 +18746,9 @@ (lint-format "perhaps ~A" caller (lists->string form (if doc-string - `(let ((documentation ,doc-string)) - (lambda ,(caar body) ,@(cdar body))) - (cons 'lambda (cons (caar body) (cdar body))))))) + (list 'let (list (list 'documentation doc-string)) + (cons 'lambda (car body))) + (cons 'lambda (car body)))))) ((2) (when (let arglists-equal? ((args1 (caar body)) (args2 (caadr body))) @@ -18786,10 +18905,11 @@ (set! lvars (sort! lvars (lambda (a b) (< (caddr a) (caddr b))))) (if named-let - `(,(car tree) ,(cadr (assq (cadr tree) lvars)) + `(,(car tree) ,(cadr (assq (cadr tree) lvars)) ,(map (lambda (v) (list (cadr v) (cadddr v))) (cdr lvars)) ,@new-body) - `(,(car tree) ,(map (lambda (v) (list (cadr v) (cadddr v))) lvars) + `(,(car tree) + ,(map (lambda (v) (list (cadr v) (cadddr v))) lvars) ,@new-body))))) ((letrec letrec*) @@ -18810,9 +18930,9 @@ (for-each (lambda (local lv) (list-set! lv 3 (walker (cadr local) lvars))) locals lvars) - `(,(car tree) - ,(map (lambda (v) (list (cadr v) (cadddr v))) lvars) - ,@(walker body (append lvars vars))))) + (cons (car tree) + (cons (map (lambda (v) (list (cadr v) (cadddr v))) lvars) + (walker body (append lvars vars)))))) ((do) (if (not (and (len>1? (cdr tree)) @@ -18883,6 +19003,7 @@ ((lambda*) (if (not (and (pair? (cdr tree)) + (proper-list? (cddr tree)) (or (symbol? (cadr tree)) (proper-list? (cadr tree))))) (quit)) @@ -19178,7 +19299,8 @@ (format #f "(~A ... (~A ~A))" (car arg) head (truncated-list->string (list-ref body len))))))))) - (when (eq? (car arg) 'or) + (when (and (eq? (car arg) 'or) + (proper-list? arg)) (let ((else-clause (let ((last-clause (list-ref arg (- (length arg) 1)))) (if (and (pair? last-clause) (memq (car last-clause) '(error throw))) @@ -19231,7 +19353,7 @@ (lint-format "perhaps~A~%~NC~A ->~%~NC~A" caller disclaimer (+ lint-left-margin 4) #\space - (lint-pp `(,@header ,(one-call-and-dots (car p)) ,@trailer)) + (lint-pp (append header (cons (one-call-and-dots (car p)) trailer))) (+ lint-left-margin 4) #\space (if (and (memq (caar p) '(let let*)) (list? (cadar p)) @@ -19241,7 +19363,7 @@ (if (< (tree-leaves last) 12) (format #f "(~A ... ~A)" (caar p) - (lint-pp `(,@header ,last ,@trailer))) + (lint-pp (append header (cons last trailer)))) (lint-pp `(let ((_1_ ,(one-call-and-dots (car p)))) (,@header _1_ ,@trailer))))) (lint-pp `(let ((_1_ ,(one-call-and-dots (car p)))) @@ -19283,19 +19405,19 @@ (hash-table-ref no-side-effect-functions head) (not (memq head unsafe-makers))) (for-each (lambda (p) - (if (let constable? ((cp p)) - (and (len>1? cp) - (memq (car cp) '(list vector)) - (every? (lambda (inp) - (or (code-constant? inp) - (constable? inp))) - (cdr cp)))) - (let ((pval (eval/error caller p))) - (if (not (eq? pval :error)) - (lint-format "perhaps ~A -> ~A~A" caller - (truncated-list->string p) - (if (eq? (car p) 'list) "'" "") - (object->string pval)))))) + (when (let constable? ((cp p)) + (and (len>1? cp) + (memq (car cp) '(list vector)) + (every? (lambda (inp) + (or (code-constant? inp) + (constable? inp))) + (cdr cp)))) + (let ((pval (eval/error caller p))) + (if (not (eq? pval :error)) + (lint-format "perhaps ~A -> ~A~A" caller + (truncated-list->string p) + (if (eq? (car p) 'list) "'" "") + (object->string pval)))))) (cdr form))) (when (and (not (= line-number last-simplify-numeric-line-number)) @@ -19356,7 +19478,7 @@ (if (side-effect? test env) (format #f " (ignoring ~S's possible side-effects)" test) "") - (lists->string form `(,@header ,middle ,@q)))))))))))) + (lists->string form (append header (cons middle q))))))))))))) ((pair? head) (cond ((not (and (pair? (cdr head)) (memq (car head) '(lambda lambda*))))) @@ -19459,61 +19581,91 @@ (lint-format "perhaps ~A" caller ; `(,x) -> (list x) (lists->string form (list 'list (cadr form))))))) ((3) - (when (pair? (caddr form)) - (let ((arg1 (cadr form)) - (arg2 (caddr form))) - (if (not (or (and (pair? arg1) - (tree-set-member '(#_{apply_values} #_{list} #_{append} unquote) arg1)) - (tree-set-member '(#_{append} unquote) arg2) - (tree-set-member '(#_{list} #_{apply_values}) (cdr arg2)))) + (let ((arg1 (cadr form)) + (arg2 (caddr form))) + (if (not (or (and (pair? arg1) + (tree-set-member '(#_{apply_values} #_{append} unquote) arg1)) + (and (pair? arg2) + (or (tree-set-member '(#_{append} unquote) arg2) + (tree-set-member '(#_{list} #_{apply_values}) (cdr arg2)))))) (lint-format "perhaps ~A" caller ; `(f ,(map g x)) -> (list 'f (map g x)) (lists->string form ; `(f ,@(map g x)) -> (cons 'f (map g x)) - (case (car arg2) - ((#_{apply_values}) - (list 'cons arg1 (cadr arg2))) - ((#_{list}) - `(list ,arg1 (list ,@(cdr arg2)))) - (else - (list 'list arg1 arg2))))) - (if (and (eq? (car arg2) #_{apply_values}) - (not (qq-tree? (cadr arg2))) - (pair? arg1) ; `(,@x ,@y) -> (append x y) + (if (pair? arg2) + (case (car arg2) + ((#_{apply_values}) + (list 'cons (un_{list} arg1) (cadr arg2))) + ((#_{list}) + (list 'list (un_{list} arg1) (cons 'list (cdr arg2)))) + (else + (list 'list (un_{list} arg1) arg2))) + (list 'list (un_{list} arg1) arg2)))) + (if (and (len=2? arg1) (eq? (car arg1) #_{apply_values}) (not (qq-tree? (cadr arg1)))) - (lint-format "perhaps ~A" caller - (lists->string form - (list 'append - (un_{list} (cadr arg1)) - (un_{list} (cadr arg2)))))))))) - - ;; `(+ ,y ,@(map f x)) -> (cons '+ (cons y (map f x))) - ;; `(+ ,y ,@x ,@z etc) -> (cons '+ (cons y (append x z ...))) - ;; `(f ,@x ,@y etc) -> (cons 'f (append x y ...)) - ;; `(,@x ,@y etc) -> (append x y ...) - (else ; checked already that form is a proper-list, so the length here is > 3 + (if (and (len=2? arg2) + (not (qq-tree? (cadr arg2))) + (eq? (car arg2) #_{apply_values})) ; `(,@x ,@y) -> (append x y) + (lint-format "perhaps ~A" caller + (lists->string form + (list 'append + (un_{list} (cadr arg1)) + (un_{list} (cadr arg2))))) + (if (not (and (pair? arg2) + (tree-set-member '(#_{apply_values} #_{append} unquote) arg2))) + (lint-format "perhaps ~A" caller ; `(,@x ,y) -> (append x (list y)) + (lists->string form + (list 'append + (un_{list} (cadr arg1)) + (list 'list (un_{list} arg2))))))))))) + + (else ; checked already that form is a proper-list, so the length here is > 3 (define (safe-av? p) (and (pair? p) (eq? (car p) #_{apply_values}) (not (tree-set-member '(#_{apply_values} #_{list} #_{append} unquote) (cdr p))))) (let ((args (cdr form))) ; car is #_{list} - (when (every? safe-av? (cddr args)) - (if (safe-av? (cadr args)) - (if (safe-av? (car args)) - (lint-format "perhaps ~A" caller - (lists->string form - (cons 'append (map cadr args)))) - (if (not (tree-set-member '(#_{apply_values} #_{list} #_{append} unquote) (car args))) - (lint-format "perhaps ~A" caller - (lists->string form - `(cons ,(car args) (append ,@(map cadr (cdr args)))))))) - (if (not (or (tree-set-member '(#_{apply_values} #_{list} #_{append} unquote) (car args)) - (tree-set-member '(#_{apply_values} #_{list} #_{append} unquote) (cadr args)))) - (lint-format "perhaps ~A" caller - (lists->string form - (if (null? (cdddr args)) - `(cons ,(car args) (cons ,(cadr args) ,(cadr (caddr args)))) - `(cons ,(car args) (cons ,(cadr args) (append ,@(map cadr (cddr args))))))))))))))))) + (cond ((not (every? safe-av? (cddr args))) + (if (and (len=3? args) + (safe-av? (car args)) ; `(,@x ,@y ,z) -> (append x y (list z)) etc + (safe-av? (cadr args)) + (not (and (pair? (caddr args)) + (memq (caaddr args) '(#_{apply_values} #_{append} unquote))))) + (lint-format "perhaps ~A" caller + (lists->string form + (list 'append (cadar args) (cadadr args) + (list 'list (un_{list} (caddr args)))))))) + + ;; `(+ ,y ,@(map f x)) -> (cons '+ (cons y (map f x))) + ;; `(+ ,y ,@x ,@z etc) -> (cons '+ (cons y (append x z ...))) + ;; `(f ,@x ,@y etc) -> (cons 'f (append x y ...)) + ;; `(,@x ,@y etc) -> (append x y ...) + ((safe-av? (cadr args)) + (if (safe-av? (car args)) + (lint-format "perhaps ~A" caller + (lists->string form + (cons 'append (map cadr args)))) + (if (not (tree-set-member '(#_{apply_values} #_{append} unquote) (car args))) + (lint-format "perhaps ~A" caller + (lists->string form + `(cons ,(un_{list} (car args)) (append ,@(map cadr (cdr args))))))))) + + ((not (or (tree-set-member '(#_{apply_values} #_{append} unquote) (car args)) + (tree-set-member '(#_{apply_values} #_{append} unquote) (cadr args)))) + (lint-format "perhaps ~A" caller + (lists->string form + `(cons ,(un_{list} (car args)) + (cons ,(un_{list} (cadr args)) + ,(if (null? (cdddr args)) + (cadr (caddr args)) + (cons 'append (map cadr (cddr args))))))))) + ((and (len=3? args) + (safe-av? (car args)) ; `(,@x ,y ,@z) -> (append x (cons y z)) + (not (tree-set-member '(#_{apply_values} #_{append} unquote) (cadr args)))) + (lint-format "perhaps ~A" caller + (lists->string form + (list 'append (cadar args) + (list 'cons (un_{list} (cadr args)) (cadr (caddr args)))))))))))))) (let ((vars env)) (for-each (lambda (f) @@ -19844,7 +19996,7 @@ (cons #\! (lambda (str) (if (member str '("!optional" "!default" "!rest" "!key" "!aux" "!false" "!true" "!r6rs") string-ci=?) ; for MIT-scheme (string->keyword (substring str 1)) - (if (string=? str "!eof") ; Bigloo? + (if (string=? str "!eof") ; Bigloo? or Chicken? Guile writes it as #<eof> but can't read it (begin (format outport "~NC#!eof is probably #<eof> in s7~%" lint-left-margin #\space) #<eof>) @@ -20198,26 +20350,4 @@ #f)) |# -;;; list|vector->let? lst->ht if assoc -;;; case->vector|hash named-let->call/exit? -;;; it appears that case->vector is always a big win, case->hash less so, alist even less, but still a win -;;; the data should be in the closure, not spelled out -;;; make-list in recur or built-in? -;;; if x `() `() -- lint could embed the if here and elsewhere -;;; recur|do->assoc/member/*-position -- didn't I check this? -;;; -;;; 3472 3849 4619 12932 14923 16868 17303 18896 -;;; -;;; "(let () (define (func x) (if (close-input-port ) (caaddr /) (with-input-from-file 0(let (make-dilambda (lambda () 1) (lambda (a) a)) (set! i01+))))) 16868 -;;; "(let () (define (func x) (if (or . 1+0/0i ) (caaddr (caaadr /)))) (define (hi) (func (make-hook '(0 0 #f)))) 3472 -;;; "(let () (define (func x) (cond ((byte-vector-ref ) (iterator? 12.)) (else (unless .+2 '((x 1) y . 2) 1 - or case quote . __asdf__ ))))" 14923 -;;; "(let () (define (func x) (lambda* .(lcm . do ))) (define (hi) (func (string #\\a #\\null #\\b))) (hi))" 18896 -;;; "(let () (define (func x) (let . `(((x 1))) )) (define (hi) (func =>)) (hi))" 12923 -;;; "(let () (define (func x) (do . 1 )) (define (hi) (func (cons 1 2))) (hi))" (list 'do (append varlist (car do-form)) '...) 17303 -;;; -;;; repl complification -;;; (let ((line-len (- (+ end prompt-length 1) start))) (if (>= line-len last-col) (set! end (- (+ end line-len) last-col)))) -;;; (let ((line-len (- (+ end prompt-length 1) start))) (if (>= line-len last-col) (set! end (- (+ start last-col) prompt-length 1)))) - - -;;; 169 28349 696530 +;;; 174 28550 727902 |