;;; -*- Mode:Common-Lisp; Package:Compiler; Base:10 -*- ;;; ;;; RESTRICTED RIGHTS LEGEND ;;; ;;;Use, duplication, or disclosure by the Government is subject to ;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in ;;;Technical Data and Computer Software clause at 52.227-7013. ;;; ;;; TEXAS INSTRUMENTS INCORPORATED. ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; MS 2151 ;;; ;;; Copyright (C) 1984-1989 Texas Instruments Incorporated. All rights reserved. ;;; Copyright (C) 1980 Massachusetts Institute of Technology ;;;; *-----------------------------------------------------------* ;;;; | -- TI Explorer Lisp Compiler -- | ;;;; | This file contains the pass 1 style checking functions. | ;;;; *-----------------------------------------------------------* ;;; Feb. 1984 - Version 98 from MIT via LMI. ;;; 08/06/84 DNG - From MIT patch 98.47, add MAKE-OBSOLETE of CATCH and THROW, ;;; add style checkers for APPEND and SUBST. ;;; 09/05/84 DNG - Assorted improvements. ;;; 4/30/85 DNG - Add optimizers for TIME and BREAK. ;;; 7/26/85 DNG - File QCOPT split into files P1OPT, P1STYLE, and MACLISP. ;;; 12/14/85 DNG - New function FUNCALL-STYLE. ;;; 12/16/85 DNG - Add obsolete warning for FSET-CAREFULLY. ;;; 1/20/86 DNG - Add check for nested DEFUNs. ;;; 1/21/86 DNG - Function WARN-OBSOLETE replaces OBSOLETE. ;;; 1/31/86 DNG - Add checking for obsolete special variable names. ;;; 2/25/86 DNG - Moved to file ZETALISP style checking for things that are ;;; obsolete even in Zetalisp mode. ;;; 3/25/86 DNG - Converted from Zetalisp to Common Lisp. ;;; 10/20/86 DNG - Moved variable *WARN-OF-SUPERSEDED-FUNCTIONS-P* to file P1DEFS. ;;; 11/14/86 DNG - Improved warning for \\; add warning for REMAINDER and REST1 .. REST4. ;;; 11/17/86 DNG - Warn about PROCLAIM with other than one arg. [SPR 2832] ;;; 12/08/86 DNG - Don't give superseded warning in same file where function is ;;; defined. Warn on UNWIND-PROTECT with only 1 arg. [SPR 2866] ;;; 1/21/87 DNG - Don't give SUPERSEDED warnings in Zetalisp mode. ;;; 2/05/87 DNG - Added TYPE-PREDICATE-STYLE and AND-OR-STYLE . ;;; 3/07/87 DNG - Update CHECK-FOR-OBSOLETE-VARIABLE for SPR 3817; add obsolete ;;; warnings for ART-FLOAT-TO-IEEE, IEEE-TO-ART-FLOAT, and GLOBALIZE. ;;;------------------ The following done after Explorer release 3.0 ------ ;;; 7/06/87 DNG - Deleted inappropriate warning on PKG-FIND-PACKAGE. [SPR 5896]. ;;; Fix error in AND-OR-STYLE [SPR 5080]. ;;;------------------ The following done after Explorer release 4.0 ------ ;;; 4/13/88 DNG - Fix TYPE-PREDICATE-STYLE for SPR 7747. ;;;------------------ The following done for Explorer release 6.0 ------ ;;; 3/17/89 DNG - Added check to ensure result of DELETE etc. is used. Add ;;; superseded warnings for PARSE-NUMBER, GET-LOCATIVE-POINTER-INTO-ARRAY, ;;; GET-LIST-POINTER-INTO-ARRAY, TYI, and TYIPEEK . ;;; 2/18/89 DNG - Had to back out check for SORT result used. ;;; 4/07/89 DNG - Warn about special variable ZLC:PACKAGE etc. rather than LISP:PACKAGE. ;;; 4/11/89 DNG - Warn on CLI:EVAL with more than one arg. Warn about ;;; variables INTERPRETER-ENVIRONMENT and INTERPRETER-FUNCTION-ENVIRONMENT. ;;; 4/12/89 JLM - Changed (putptop ... usage to (setf (get ... ;;; 4/27/89 DNG - Add superseded warnings for ZLC:PKG-KILL and ZLC:PKG-NAME . ;;; 5/08/89 DNG - Remove warnings about pixel array functions. [SPR 4675 and 5653] ;;;; ================================== ;;;; Obsolete function warnings ;;;; ================================== (DEFUN WARN-OBSOLETE (FORM) ;; 1/21/86 DNG - Re-designed and renamed from OBSOLETE. ;; 1/23/86 DNG - Distinct message when old and new names share the same definition. (WHEN (AND OBSOLETE-FUNCTION-WARNING-SWITCH (NOT RUN-IN-MACLISP-SWITCH)) (LET (( MESSAGE (GET (FIRST FORM) 'SUPERSEDED-BY) )) (COND ((NULL MESSAGE) (WARN 'OBSOLETE :OBSOLETE "~S is an obsolete function." (FIRST FORM) )) ((STRINGP MESSAGE) (WARN 'OBSOLETE :OBSOLETE "~S is an obsolete function; ~A." (FIRST FORM) MESSAGE)) ((AND (SYMBOLP MESSAGE) (FBOUNDP MESSAGE) (FBOUNDP (FIRST FORM)) (EQUAL (FUNCTION-NAME (SYMBOL-FUNCTION (FIRST FORM))) (FUNCTION-NAME (SYMBOL-FUNCTION MESSAGE)))) (WARN 'OBSOLETE :OBSOLETE "~S is an obsolete name for function ~S." (FIRST FORM) MESSAGE ) ) (T (WARN 'OBSOLETE :OBSOLETE "~S is an obsolete function; use ~S instead." (FIRST FORM) MESSAGE )) ) ) ) ) #+:IEEE-FLOATING-POINT (let () ; these were misc-ops in release 2; not supported in release 3. (MAKE-OBSOLETE SYS::IEEE-TO-ART-FLOAT "Explorer now uses IEEE floating point format so conversion is not needed") (MAKE-OBSOLETE SYS::ART-FLOAT-TO-IEEE "Explorer now uses IEEE floating point format so conversion is not needed") ) ;;;; ================================== ;;;; Zetalisp functions superseded in Common Lisp ;;;; ================================== ;;;; DEFINE SUPERSEDED FUNCTION WARNING FUNCTIONS (DEFUN SUPERSEDED (form) "This function issues compiler warnings about otherwise valid functions which have been superseded by new Common Lisp functions. Warnings are issued if in Common Lisp mode and *WARN-OF-SUPERSEDED-FUNCTIONS-P* is true. This function expects the function symbol [i.e., (first FORM)] to have a property named SUPERSEDED which is one of the following: * A symbol which names the replacement function. * A string which describes what to use instead. * A function which receives the form as its argument and optionally returns a string. This property is usually established by the MAKE-SUPERSEDED macro. If this property is not on the function name, then no warning is issued." ;; 10/07/86 DNG - Don't say "by Common Lisp" unless new symbol in LISP package. ;; 12/08/86 DNG - Don't give warning in same file where function is defined. ;; 1/21/87 DNG - Don't give warnings in Zetalisp mode. ;; 4/22/89 DNG - Don't give warnings in Scheme mode. (declare (values ignore)) (when (and COMPILING-COMMON-LISP (not (compiling-scheme-p)) *WARN-OF-SUPERSEDED-FUNCTIONS-P* OBSOLETE-FUNCTION-WARNING-SWITCH (not (and (get-opcodes (first form)) ; macro-instruction (or SI:FILE-IN-COLD-LOAD (eq *package* KERNEL-PACKAGE)))) ;; The following test is to enable files like "KERNEL;ARRAYS" and ;; "KERNEL;STRINGS" to use old functions internally. (not (and FDEFINE-FILE-PATHNAME (eq (si:get-source-file-name (first form) 'defun) FDEFINE-FILE-PATHNAME))) ) (let* (( function (first form) ) ( replacement (get function 'superseded) )) (cond ((symbolp replacement) (if (and (fboundp replacement) (fboundp function) (or (equal (function-name (symbol-function function)) (function-name (symbol-function replacement))) (let ((opcodes (get-opcodes function) )) (and opcodes (equal opcodes (get-opcodes replacement))) ) ) ) (warn 'SUPERSEDED :OBSOLETE "~S is an old Zetalisp name for the Common Lisp function ~S." function replacement ) (warn 'SUPERSEDED :OBSOLETE (if (eq (symbol-package replacement) si:pkg-lisp-package) "Function ~S has been superseded by Common Lisp; use ~S instead." "Function ~S is obsolete; use ~S instead.") function replacement ) ) ) ((stringp replacement) (warn 'SUPERSEDED :OBSOLETE "Function ~S has been superseded by Common Lisp;~% ~A." function replacement) ) ((functionp replacement) ;; then this message must be calculated based upon FORM (let (( line-2 (funcall replacement form) )) (when (stringp line-2) ;; then we did find something to print, so prepend first line and issue warning (warn 'SUPERSEDED :OBSOLETE "Function ~S (or at least this usage if it) ~ has been superseded by Common Lisp;~% ~A." function line-2))) ) ) ; end cond )) ;when NIL ) ;superseded (DEFMACRO MAKE-SUPERSEDED (function replacement) "Mark FUNCTION (which is not evaluated) as an otherwise valid function that has been superseded by a new Common Lisp function. When FUNCTION is later compiled, a compiler warning will be issued if *WARN-OF-SUPERSEDED-FUNCTIONS-P* is true at that time. All warning messages are prefixed with a line indicating that the specified function has been superseded in Common Lisp. See SUPERSEDED for the text. The second line is calculated from REPLACEMENT. If REPLACEMENT (which is evaluated at compile time) is a string, it is used as-is. If it is a symbol, its print name is inserted into phrase \"Use instead.\". If it is a list, then it is assumed to be a lambda expression which, when FUNCALLed at compile time with the offending form as an argument, will return a string to use as the second line of the warning. If it does not return a string, no warning is issued by SUPERSEDED. CAUTION: Replacements suggested by MAKE-SUPERSEDED should work in both Zetalisp and Common Lisp mode. Use MAKE-INCOMPATIBLE to suggest replacements which, once made, would prevent the code from running in Zetalisp mode." ;; 10/07/86 DNG - Don't need COMPILE-LAMBDA call anymore. #-Elroy ; temporary for release 2 compiler which won't compile putprop arguments. (if (and (consp replacement) (eq (first replacement) 'function) (consp (second replacement)) (eq target-processor compiler:host-processor)) (setf replacement (lisp:compile-lambda (second replacement) (concatenate 'string (string function) "-SUPERSEDED") )) ) ;; normalize function (when (quotep function) ;; then someone quoted this function symbol by mistake, so unquote it (setf function (second function)) ) (unless (eq function replacement) `(progn (add-style-checker ,function superseded) ;; (putprop ',function ; jlm 4/12/89 ;; ,(if (symbolp replacement) ;; (list 'quote replacement) ;; replacement) ;; 'superseded) (setf (get ',function 'superseded) ,(if (symbolp replacement) (list 'quote replacement) replacement)))) );make-superseded ;;;; SUPERSEDED FUNCTION DECLARATIONS ;; A (make-superseded global:aref "use AREF, or (CHAR-INT (CHAR ...)) if the array is a string") (make-superseded array-length ARRAY-TOTAL-SIZE) ; identical (make-superseded array-pop VECTOR-POP) ; identical (make-superseded array-push "Use VECTOR-PUSH and swap arguments") (make-superseded array-push-extend "Use VECTOR-PUSH-EXTEND and swap first 2 arguments") (make-superseded aset "Use (SETF (AREF ...) ...) instead") (make-superseded ass #'(lambda (form &aux (*print-pretty* t)) (format nil "Use ASSOC with :TEST ~S instead" (second form)))) (make-superseded global:assoc "use ASSOC with :TEST #'EQUAL") (make-superseded assq "use ASSOC with :TEST #'EQ") (make-superseded GLOBAL:ATAN2 CLI:ATAN) ; identical ;; B (make-superseded bit-test LOGTEST) ; identical ;; C (make-superseded *catch CATCH) ; identical (make-superseded char char<=) (make-superseded char char>=) (make-superseded char char/=) (make-superseded check-arg-type check-type) ; identical (make-superseded global:close #'(lambda (form) (if (CDDR form) (format nil "Use (CLOSE ~S :ABORT ~S)" (second form) (third form)) "Use CLOSE") ) ) (make-superseded clrhash-equal clrhash) ; identical (make-superseded copyalist COPY-ALIST) ; identical (make-superseded copylist COPY-LIST) ; identical (make-superseded copysymbol COPY-SYMBOL) ; identical (make-superseded copytree COPY-TREE) ; identical ;; D (add-style-checker DECLARE-FLAVOR-INSTANCE-VARIABLES obs-dec-flav) (defun obs-dec-flav (form) (when (and COMPILING-COMMON-LISP OBSOLETE-FUNCTION-WARNING-SWITCH ) (warn 'obs-dec-flav :obsolete "~A is obsolete; use (DEFUN ... (DECLARE (:SELF-FLAVOR ~S)) ...) instead." (first form) (first (second form))))) (make-superseded defconst "Use DEFPARAMETER instead or use DEFCONSTANT for true compile-time constants") (make-superseded defmacro-displace defmacro) (add-style-checker del superseded-delete) (add-style-checker del-if superseded-del-if) (add-style-checker del-if-not superseded-del-if) (add-style-checker delq superseded-delete) (add-style-checker global:delete superseded-delete) (defun superseded-delete ( form ) ;; 2/10/86 - Fixed for DEL and REM. (when (and COMPILING-COMMON-LISP OBSOLETE-FUNCTION-WARNING-SWITCH ) (let (( SI:WARNINGS-PRINLEVEL 2 ) ( SI:WARNINGS-PRINLENGTH 7 ) (*print-pretty* t) item list count test ) (if (member (first form) '(global:del global:rem)) (setq test (second form) item (third form) list (fourth form) count (fifth form)) (setq item (second form) list (third form) count (fourth form) test (if (member (first form) '(global:delete global:remove)) '#'equal '#'eq)) ) (warn 'superseded-delete :obsolete "The function ~S has been superseded by Common Lisp; replace ~S with ~S" (first form) form `(,(if (eql (char (symbol-name (first form)) 0) #\D) 'DELETE 'REMOVE) ,item (THE LIST ,list) :TEST ,test . ,(when count (list :COUNT count))) ) ) ) ) (defun superseded-del-if ( form ) ;; 2/04/86 - Leave it alone if it has more than 2 arguments. ;; 2/10/86 - Fix to not show :TEST argument on REMOVE-IF etc. ;; 4/24/86 - Allow use of FIND-POSITION-IN-LIST in kernel. (when (and COMPILING-COMMON-LISP OBSOLETE-FUNCTION-WARNING-SWITCH (null (NTHCDR 3 form))) (let (( SI:WARNINGS-PRINLEVEL 2 ) ( SI:WARNINGS-PRINLENGTH 5 ) ( *print-pretty* t ) ( new-function (cond ((eq (first form) 'del-if-not) 'delete-if-not) ((eq (first form) 'del-if) 'delete-if) ((member (first form) '(rem-if-not subset)) 'remove-if-not) ((member (first form) '(rem-if subset-not)) 'remove-if) ((eq *package* kernel-package) ; allow internal routines (return-from superseded-del-if nil)) (t 'position)) )) (warn 'superseded-delete :obsolete "The function ~S has been superseded by Common Lisp; replace ~S with ~S" (first form) form (if (eq new-function 'position) `(position ,(second form) (THE LIST ,(third form)) :TEST #',(if (eq (first form) 'find-position-in-list-equal) 'equal 'eq) ) `(,new-function ,(second form) (THE LIST ,(third form)) ))))) NIL) (make-superseded deletef delete-file) ;(make-superseded do-forever LOOP) (make-superseded do-named "use DO inside a BLOCK") (make-superseded do*-named "use DO* inside a BLOCK") ;; E (make-superseded global:elt cli:elt) ;; F (add-style-checker find-position-in-list superseded-del-if) (add-style-checker find-position-in-list-equal superseded-del-if) ;(make-superseded fillarray fill) (make-superseded fixp INTEGERP) (make-superseded global:format "use FORMAT, but watch out for ~E, ~F, ~G, and ~X which have different meanings") (make-superseded fsymeval SYMBOL-FUNCTION) ;; G (make-superseded get-pname SYMBOL-NAME) (make-superseded gethash-equal gethash) ; identical (make-superseded GET-LOCATIVE-POINTER-INTO-ARRAY LOCF) (make-superseded GET-LIST-POINTER-INTO-ARRAY G-L-P) (make-obsolete GLOBALIZE EXPORT) ;; I (make-superseded global:intersection #'(lambda (form) (unless (NTHCDR 3 form) "use INTERSECTION with :TEST #'EQ"))) (make-superseded intern-soft find-symbol) ;; L (make-superseded lexpr-funcall APPLY) ; identical (make-superseded global:listp CONSP) (make-superseded local-declare "Use LOCALLY with the DECLAREs in front of the body") ;; M (make-superseded global:make-hash-table #'(lambda (form) (let ((options (REST form))) (if (or (member :TEST options) (member :COMPARE-FUNCTION options) (member :HASH-FUNCTION options)) "use MAKE-HASH-TABLE with the same options" "Use MAKE-HASH-TABLE with :TEST #'EQ")))) (make-superseded global:make-equal-hash-table "Use MAKE-HASH-TABLE with :TEST #'EQUAL") ;; (make-superseded MAKE-PIXEL-ARRAY make-array) ; removed 5/8/89 for SPR 4675 and 5653. (make-superseded make-syn-stream make-synonym-stream) (make-superseded global:map MAPL) (make-superseded maphash-equal maphash) (make-superseded mem #'(lambda (form &aux (*print-pretty* t)) (format nil "Use MEMBER with :TEST ~S instead" (second form)))) (make-superseded global:member "Use MEMBER with :TEST #'EQUAL") (make-superseded memq "Use MEMBER with :TEST #'EQ") (make-superseded multiple-value MULTIPLE-VALUE-SETQ) ; identical ;; N (make-superseded ncons "use (LIST #) or (CONS # NIL) depending on whether CDR-coding is desired") (make-superseded ncons-in-area "use (CONS-IN-AREA x NIL area)") ;(make-superseded neq "Use (NOT (EQ ...)) instead") (make-superseded global:nintersection #'(lambda (form) (unless (NTHCDR 3 form) "use NINTERSECTION with :TEST #'EQ"))) (make-obsolete cli:nlistp "use (NOT (LISTP #))") (make-superseded global:nunion #'(lambda (form) (unless (NTHCDR 3 form) "use NUNION with :TEST #'EQ"))) ;; P (make-superseded package-declare "use MAKE-PACKAGE or IN-PACKAGE") (make-superseded PARSE-NUMBER PARSE-INTEGER) (make-superseded ZLC:pkg-kill kill-package) (make-superseded ZLC:pkg-name package-name) ;; The next two removed 5/8/89 for SPR 4675 and 5653. ;;(make-superseded PIXEL-ARRAY-HEIGHT "use (ARRAY-DIMENSION array 0)") ;;(make-superseded PIXEL-ARRAY-WIDTH "use (ARRAY-DIMENSION array 1)") (make-superseded plist SYMBOL-PLIST) ; identical (make-superseded probef probe-file) ; identical (make-superseded puthash-equal puthash) ; identical (make-superseded PUT-ON-ALTERNATING-LIST "use SETF on GETF") ;; Q (COMMENT (make-superseded quotient "use / for floating result of floating arguments, otherwise use TRUNCATE for any integer result") ) (make-superseded QC-FILE LISP:compile-file) ;; R (make-superseded rass #'(lambda (form &aux (*print-pretty* t)) (format nil "Use RASSOC with :TEST ~S instead" (second form)))) (make-superseded global:rassoc "use RASSOC with :TEST #'EQUAL") (make-superseded rassq "use RASSOC with :TEST #'EQ") (make-superseded READLINE read-line) (make-superseded remainder cli:rem) (add-style-checker global:rem superseded-delete) (add-style-checker rem-if superseded-del-if) (add-style-checker rem-if-not superseded-del-if) (add-style-checker remq superseded-delete) (add-style-checker global:remove superseded-delete) (make-superseded remob unintern) ; (make-superseded remainder "use \\ in Zetalisp mode or REM in Common Lisp mode") (make-superseded remhash-equal remhash) ; identical (make-superseded rest1 rest) (make-superseded rest2 cddr) (make-superseded rest3 "use (NTHCDR 3 #)") (make-superseded rest4 "use (NTHCDR 4 #)") (make-superseded return-list "use (RETURN (VALUES-LIST #))") ;; S (make-superseded selectq CASE) ; identical (make-superseded special "use (PROCLAIM '(SPECIAL ...))") (make-superseded string-length "use LENGTH, provided the argument is known to already be a string") (make-superseded string-nreverse nreverse) (make-superseded string-reverse reverse) (make-superseded string-reverse-search "see SEARCH and use :FROM-END") (make-superseded string-reverse-search-char "see POSITION and use :FROM-END") (make-superseded string-reverse-search-not-char "see POSITION and use :FROM-END and :TEST-NOT") (make-superseded string-search "see SEARCH") (make-superseded string-search-char "see POSITION") (make-superseded string-search-not-char "see POSITION and use :TEST-NOT") (make-superseded string string/=) (make-superseded string string<=) (make-superseded string string>=) (make-superseded subrp "use (TYPEP # '(OR COMPILED-FUNCTION MICROCODE-FUNCTION))") (add-style-checker subset superseded-del-if) (add-style-checker subset-not superseded-del-if) (make-superseded global:subst "use (NSUBST new old (COPY-TREE tree) :TEST #'EQUAL)") (make-superseded substring subseq) (make-superseded swapf rotatef) ; identical (make-superseded swaphash-equal swaphash) (make-superseded symeval SYMBOL-VALUE) ;; T (make-superseded global:terpri #'(lambda (form) (declare (ignore form)) (if p1value "Use (NOT (TERPRI)) instead" "use TERPRI when the returned value doesn't matter"))) (make-superseded *throw THROW) ; identical (make-superseded TYI READ-CHAR) (make-superseded TYIPEEK PEEK-CHAR) (make-superseded tyo write-char) (make-superseded typep #'(lambda (form) (if (= 2 (length form)) "Use TYPE-OF instead when there is only one argument" (let ((type (third form))) (if (or (keywordp type) (and (quotep type) (keywordp (second type)))) (format nil "Use (TYPEP # '~A) instead of (TYPEP # ~S)" (eval type) type) ))))) ;; U (make-superseded global:union #'(lambda (form) (unless (NTHCDR 3 form) "use UNION with :TEST #'EQ"))) (make-superseded unspecial "use (PROCLAIM '(UNSPECIAL ...))") ;; V (make-superseded viewf view-file) ;identical ;; Signs & Symbols (make-superseded  >=) (make-superseded  <=) (make-superseded  /=) (make-superseded ^ EXPT) (make-superseded %div cli:/) (make-superseded \\\\ gcd) (add-style-checker \\ obsolete-in-cl) (defprop \\ remainder superseded-by) (DEFUN obsolete-in-cl (form) ;; 11/14/86 - Original. (when (and COMPILING-COMMON-LISP #-compiler:debug *WARN-OF-SUPERSEDED-FUNCTIONS-P*) (warn-obsolete form))) ;;;; ================================== ;;;; Style checkers ;;;; ================================== (COMMENT ;;; These are commented out because the style checker doesn't really manage ;;; to operate only on the user's typed-in code, and ;;; calls to these with one or zero args are generated by optimizers and macros. (ADD-STYLE-CHECKER OR NEED-TWO-ARGS) (ADD-STYLE-CHECKER AND NEED-TWO-ARGS) (ADD-STYLE-CHECKER COND NEED-AN-ARG) (ADD-STYLE-CHECKER PROGN NEED-TWO-ARGS) (ADD-STYLE-CHECKER PROG1 NEED-TWO-ARGS) ; ref SPR 813 ) (ADD-STYLE-CHECKER PROG2 NEED-TWO-ARGS) (ADD-STYLE-CHECKER + NEED-TWO-ARGS) (ADD-STYLE-CHECKER * NEED-TWO-ARGS) (ADD-STYLE-CHECKER NCONC NEED-TWO-ARGS) (ADD-STYLE-CHECKER CATCH NEED-TWO-ARGS) ; added 10/14/86 (ADD-STYLE-CHECKER UNWIND-PROTECT NEED-TWO-ARGS) ; added 12/8/86 for SPR 2866 (DEFUN NEED-TWO-ARGS (FORM) (WHEN (NULL (CDDR FORM)) (WARN 'WRONG-NUMBER-OF-ARGUMENTS :IMPLAUSIBLE "~S used with fewer than two arguments" (CAR FORM)))) (ADD-STYLE-CHECKER SETQ NEED-AN-ARG) (ADD-STYLE-CHECKER PSETQ NEED-AN-ARG) (ADD-STYLE-CHECKER PROCLAIM NEED-AN-ARG) (DEFUN NEED-AN-ARG (FORM) (UNLESS (CDR FORM) (WARN 'WRONG-NUMBER-OF-ARGUMENTS :IMPLAUSIBLE "~S used with no arguments" (CAR FORM)))) (ADD-STYLE-CHECKER PROCLAIM JUST-ONE-ARG) (DEFUN JUST-ONE-ARG (FORM) ; 11/17/86 - Original for SPR 2832. (WHEN (AND (CDDR FORM) (OR COMPILING-COMMON-LISP *WARN-OF-SUPERSEDED-FUNCTIONS-P*)) (WARN 'WRONG-NUMBER-OF-ARGUMENTS :IMPLAUSIBLE "~S used with more than one argument" (CAR FORM)))) (ADD-STYLE-CHECKER GLOBAL:FORMAT FORMAT-STYLE) (ADD-STYLE-CHECKER CLI:FORMAT FORMAT-STYLE) (DEFUN FORMAT-STYLE (FORM) (NEED-TWO-ARGS FORM) (WHEN (STRINGP (SECOND FORM)) (WARN 'BAD-ARGUMENT :IMPLAUSIBLE "FORMAT is used with ~S as its first argument, which should be a stream, T or NIL." (CADR FORM)))) ;; 10/17/86 DNG - moved BOUNDP and VALUE-CELL-LOCATION checks to ZETALISP file. (ADD-STYLE-CHECKER FUNCALL FUNCALL-STYLE) (ADD-STYLE-CHECKER LEXPR-FUNCALL FUNCALL-STYLE) (ADD-STYLE-CHECKER APPLY FUNCALL-STYLE) (DEFUN FUNCALL-STYLE ( FORM ) ;; 12/14/85 DNG - Original version. (LET (( FA (SECOND FORM) )) (WHEN (AND (CONSP FA) (MEMBER (FIRST FA) '(QUOTE FUNCTION) :TEST #'EQ) ) (LET (( FN (SECOND FA) )) (WHEN (AND (SYMBOLP FN) (FBOUNDP FN) (EQ (CAR-SAFE (SYMBOL-FUNCTION FN)) 'MACRO) ) (WARN 'FUNCALL-STYLE :PROBABLE-ERROR "Attempting to ~A the macro ~S" (FIRST FORM) FN) ))))) (ADD-STYLE-CHECKER DEFUN IMBEDDED-DEFUN) (ADD-STYLE-CHECKER DEFSUBST IMBEDDED-DEFUN) (ADD-STYLE-CHECKER DEFMACRO IMBEDDED-DEFUN) (DEFUN IMBEDDED-DEFUN ( FORM ) ;; 1/20/86 DNG - Original. ;; 8/01/86 DNG - Don't give warning in top-level dummy function. (UNLESS (TOP-LEVEL-DUMMY-FUNCTION-P *CURRENT-COMPILAND*) (WARN 'DEFUN :IMPLAUSIBLE "(~A ~A ...) is imbedded within another function; either there is a right parenthesis missing or you should be using ~A instead." (FIRST FORM) (SECOND FORM) (IF (EQ (FIRST FORM) 'DEFUN) 'FLET 'MACROLET) ))) (ADD-STYLE-CHECKER DEFVAR IMBEDDED-DEFVAR) (ADD-STYLE-CHECKER DEFCONST IMBEDDED-DEFVAR) (ADD-STYLE-CHECKER DEFPARAMETER IMBEDDED-DEFVAR) (ADD-STYLE-CHECKER DEFCONSTANT IMBEDDED-DEFVAR) (ADD-STYLE-CHECKER DEFFLAVOR IMBEDDED-DEFVAR) (ADD-STYLE-CHECKER DEFMETHOD IMBEDDED-DEFVAR) (ADD-STYLE-CHECKER GLOBAL:DEFSTRUCT IMBEDDED-DEFVAR) (ADD-STYLE-CHECKER CLI:DEFSTRUCT IMBEDDED-DEFVAR) (DEFUN IMBEDDED-DEFVAR ( FORM ) ;; 1/21/86 DNG - Original. ;; 1/31/86 DNG - Limit print length to 3. ;; 7/30/86 DNG - Don't give warning in top-level dummy function. (UNLESS (TOP-LEVEL-DUMMY-FUNCTION-P *CURRENT-COMPILAND*) (LET (( SI:WARNINGS-PRINLENGTH 3)) (WARN 'DEFVAR :IMPLAUSIBLE "~A is imbedded within a function; there is probably a right parenthesis missing somewhere." FORM) ))) (DEFUN ENSURE-VALUE-USED (FORM) ;; Style checker for destructive functions that should be used for their returned value. ;; 11/30/87 DNG - Original for Scheme system. ;; 12/12/87 DNG ;; 3/28/88 DNG - Add check for SETF-EXPAND property. ;; 3/17/89 DNG - Included in Explorer release 6. ;; 3/18/89 DNG - SORT is OK unless the argument is a list. (UNLESS (OR P1VALUE ; value being used ;; The following test removed because EXPR-TYPE-P is not safe to use on ;; code that has not yet been processed by P1. #| (AND (MEMBER (CAR FORM) '(SORT STABLE-SORT)) (NOT (EXPR-TYPE-P (SECOND FORM) 'LIST))) |#) (LET ((ARG (IF (AND (CDDR FORM) #| (NOT (MEMBER (CAR FORM) '(SORT STABLE-SORT))) |# ) (THIRD FORM) (SECOND FORM)))) (IF (OR (SYMBOLP ARG) (AND (CONSP ARG) (SYMBOLP (FIRST ARG)) (GETL (FIRST ARG) '(SI:SETF-METHOD SI:LOCF-METHOD SI::SETF-EXPAND)))) (WARN 'ENSURE-VALUE-USED ':IMPLAUSIBLE "Not using the value returned by ~S; Should do: (~A ~S ~S)." (FIRST FORM) (IF (COMPILING-SCHEME-P) "SET!" 'SETF) ARG FORM) (WARN 'ENSURE-VALUE-USED ':IMPLAUSIBLE "Not using the value returned by ~S." FORM))))) (ADD-STYLE-CHECKER DELETE ENSURE-VALUE-USED) (ADD-STYLE-CHECKER DELQ ENSURE-VALUE-USED) ;;(ADD-STYLE-CHECKER SORT ENSURE-VALUE-USED) ;;(ADD-STYLE-CHECKER STABLE-SORT ENSURE-VALUE-USED) (ADD-STYLE-CHECKER NREVERSE ENSURE-VALUE-USED) (ADD-STYLE-CHECKER CLI:EVAL EVAL-STYLE) (DEFUN EVAL-STYLE (FORM) ; 4/11/89 DNG (WHEN (CDDR FORM) (WARN 'WRONG-NUMBER-OF-ARGUMENTS :IMPOSSIBLE "~S used with more than one argument. If you are trying to pass an environment, use ~S instead." (CAR FORM) 'EVALHOOK))) ;;;; ================================== ;;;; Obsolete variable warnings ;;;; ================================== (DEFUN CHECK-FOR-OBSOLETE-VARIABLE ( VARNAME ) ;; Check whether a symbol is an obsolete special variable name. ;; 1/31/86 - Original. ;; 2/06/86 - Allow NEW-NAME to be a form or string. ;; 3/07/87 - Give warning when variable is unbound even when not in C.L. mode. [SPR 3817] (WHEN (OR COMPILING-COMMON-LISP (NOT (BOUNDP VARNAME))) (LET (( NEW-NAME (GET VARNAME 'OBSOLETE-VARIABLE) )) (UNLESS (OR (NULL NEW-NAME) INHIBIT-STYLE-WARNINGS-SWITCH (NOT OBSOLETE-FUNCTION-WARNING-SWITCH) ) (WARN 'CHECK-FOR-OBSOLETE-VARIABLE :OBSOLETE (IF (SYMBOLP NEW-NAME) "~S is an obsolete name for special variable ~S." "~S is an obsolete special variable; use ~A instead.") VARNAME NEW-NAME ))))) (MAKE-VARIABLE-OBSOLETE BASE *PRINT-BASE*) (MAKE-VARIABLE-OBSOLETE IBASE *READ-BASE*) (MAKE-VARIABLE-OBSOLETE STANDARD-INPUT *STANDARD-INPUT*) (MAKE-VARIABLE-OBSOLETE STANDARD-OUTPUT *STANDARD-OUTPUT*) (MAKE-VARIABLE-OBSOLETE TERMINAL-IO *TERMINAL-IO*) (MAKE-VARIABLE-OBSOLETE ERROR-OUTPUT *ERROR-OUTPUT*) (MAKE-VARIABLE-OBSOLETE TRACE-OUTPUT *TRACE-OUTPUT*) (MAKE-VARIABLE-OBSOLETE DEBUG-IO *DEBUG-IO*) (MAKE-VARIABLE-OBSOLETE QUERY-IO *QUERY-IO*) (MAKE-VARIABLE-OBSOLETE PRINLEVEL *PRINT-LEVEL*) (MAKE-VARIABLE-OBSOLETE PRINLENGTH *PRINT-LENGTH*) (MAKE-VARIABLE-OBSOLETE APPLYHOOK *APPLYHOOK*) (MAKE-VARIABLE-OBSOLETE EVALHOOK *EVALHOOK*) (MAKE-VARIABLE-OBSOLETE READTABLE *READTABLE*) (MAKE-VARIABLE-OBSOLETE PACKAGE *PACKAGE*) ;; 4/7/89 DNG - Added the next four lines. (MAKE-VARIABLE-OBSOLETE ZLC:APPLYHOOK *APPLYHOOK*) (MAKE-VARIABLE-OBSOLETE ZLC:EVALHOOK *EVALHOOK*) (MAKE-VARIABLE-OBSOLETE ZLC:READTABLE *READTABLE*) (MAKE-VARIABLE-OBSOLETE ZLC:PACKAGE *PACKAGE*) (MAKE-VARIABLE-OBSOLETE SI:*ALL-PACKAGES* (LIST-ALL-PACKAGES)) (MAKE-VARIABLE-OBSOLETE ZLC:*ALL-PACKAGES* (LIST-ALL-PACKAGES)) ;; 4/11/89 DNG - Added the next 2. (MAKE-VARIABLE-OBSOLETE SI:INTERPRETER-ENVIRONMENT SI:*INTERPRETER-ENVIRONMENT*) (MAKE-VARIABLE-OBSOLETE SI:INTERPRETER-FUNCTION-ENVIRONMENT SI:*INTERPRETER-FUNCTION-ENVIRONMENT*) ;;;; ================================== ;;;; Type declaration warnings ;;;; ================================== (ADD-STYLE-CHECKER ARRAYP TYPE-PREDICATE-STYLE) (ADD-STYLE-CHECKER SYMBOLP TYPE-PREDICATE-STYLE) (ADD-STYLE-CHECKER ATOM TYPE-PREDICATE-STYLE) (ADD-STYLE-CHECKER SYMBOLP TYPE-PREDICATE-STYLE) (ADD-STYLE-CHECKER GLOBAL:LISTP TYPE-PREDICATE-STYLE) (ADD-STYLE-CHECKER LISTP TYPE-PREDICATE-STYLE) (ADD-STYLE-CHECKER COMMON-LISP-LISTP TYPE-PREDICATE-STYLE) (ADD-STYLE-CHECKER STRINGP TYPE-PREDICATE-STYLE) (ADD-STYLE-CHECKER VECTORP TYPE-PREDICATE-STYLE) (ADD-STYLE-CHECKER BIT-VECTOR-P TYPE-PREDICATE-STYLE) (ADD-STYLE-CHECKER LOCATIVEP TYPE-PREDICATE-STYLE) (ADD-STYLE-CHECKER GLOBAL:NLISTP TYPE-PREDICATE-STYLE) (ADD-STYLE-CHECKER NAMED-STRUCTURE-P TYPE-PREDICATE-STYLE) (ADD-STYLE-CHECKER NUMBERP TYPE-PREDICATE-STYLE) (ADD-STYLE-CHECKER FIXNUMP TYPE-PREDICATE-STYLE) (ADD-STYLE-CHECKER INTEGERP TYPE-PREDICATE-STYLE) (ADD-STYLE-CHECKER FIXP TYPE-PREDICATE-STYLE) (ADD-STYLE-CHECKER REALP TYPE-PREDICATE-STYLE) (ADD-STYLE-CHECKER FLOATP TYPE-PREDICATE-STYLE) (ADD-STYLE-CHECKER RATIONALP TYPE-PREDICATE-STYLE) (ADD-STYLE-CHECKER RATIOP TYPE-PREDICATE-STYLE) (ADD-STYLE-CHECKER CHARACTERP TYPE-PREDICATE-STYLE) (ADD-STYLE-CHECKER COMPLEXP TYPE-PREDICATE-STYLE) (ADD-STYLE-CHECKER SMALL-FLOATP TYPE-PREDICATE-STYLE) (ADD-STYLE-CHECKER #.(GET 'SHORT-FLOAT 'SI:TYPE-PREDICATE) TYPE-PREDICATE-STYLE) (ADD-STYLE-CHECKER #.(GET 'DOUBLE-FLOAT 'SI:TYPE-PREDICATE) TYPE-PREDICATE-STYLE) (ADD-STYLE-CHECKER #.(GET 'LONG-FLOAT 'SI:TYPE-PREDICATE) TYPE-PREDICATE-STYLE) (DEFUN TYPE-PREDICATE-STYLE (FORM) ;; Issue warning on a type predicate which is unnecessary according to the ;; type declaration for the variable being tested. This is not really wrong, ;; but it suggests that the type declaration may be incorrect. ;; ;; 1/26/87 DNG - Original. ;; 2/05/87 DNG - Use a different message when type inferred from DEFCONSTANT instead of type declaration. ;; 4/13/88 DNG - Fix type test for a reference to a special variable within a binding of it. [SPR 7747] (WHEN (AND (CDR FORM) (SYMBOLP (SECOND FORM))) (LET* ((VAR (LOOKUP-VAR (SECOND FORM) VARS)) (DECLARED-TYPE (IF (AND VAR (NOT (EQ (VAR-LAP-ADDRESS VAR) (SECOND FORM)))) (VAR-DATA-TYPE VAR) (TYPE-OF-EXPRESSION (SECOND FORM))))) (UNLESS (OR (EQ DECLARED-TYPE 'T) (NOT (SI:TYPE-SPECIFIER-P DECLARED-TYPE)) (> (OPT-COMPILATION-SPEED OPTIMIZE-SWITCH) (OPT-SAFETY OPTIMIZE-SWITCH))) (LET* ((TEST-TYPE (DOLIST (X (GET (FIRST FORM) 'POST-OPTIMIZERS)) (WHEN (AND (CONSP X) (EQ (FIRST X) 'FOLD-TYPE-PREDICATE)) (RETURN (SECOND X))))) (RESULT (COND ((NULL TEST-TYPE) (debug-assert test-type) (RETURN-FROM TYPE-PREDICATE-STYLE NIL)) ((OR (EQUAL DECLARED-TYPE TEST-TYPE) (SUBTYPEP DECLARED-TYPE TEST-TYPE)) ; test passes "true") ((SI:DISJOINT-TYPEP DECLARED-TYPE TEST-TYPE) ; test fails "false") (T (RETURN-FROM TYPE-PREDICATE-STYLE NIL)) ))) (WARN 'TYPE-PREDICATE-STYLE ':IMPLAUSIBLE (IF (CONSTANTP (SECOND FORM)) "~S is a ~S constant so the test ~S is assumed always ~A." "Variable ~S was declared ~S so the test ~S is assumed always ~A.") (SECOND FORM) DECLARED-TYPE FORM RESULT))) )) NIL) (ADD-STYLE-CHECKER AND AND-OR-STYLE) (ADD-STYLE-CHECKER OR AND-OR-STYLE) (ADD-STYLE-CHECKER XOR AND-OR-STYLE) (ADD-STYLE-CHECKER COND AND-OR-STYLE) (ADD-STYLE-CHECKER WHEN AND-OR-STYLE) (ADD-STYLE-CHECKER UNLESS AND-OR-STYLE) (ADD-STYLE-CHECKER IF AND-OR-STYLE) (ADD-STYLE-CHECKER NOT AND-OR-STYLE) (ADD-STYLE-CHECKER NULL AND-OR-STYLE) (DEFUN AND-OR-STYLE (FORM) ;; 1/26/87 DNG - Original. ;; 2/05/87 DNG - Use a different message when type inferred from DEFCONSTANT instead of type declaration. ;; 2/06/87 DNG - Warn on AND and OR only when P1VALUE is D-INDS. ;; 7/06/87 DNG - Fix to avoid entering the error handler on an ill-formed COND. [SPR 5080] ;; 4/26/89 DNG - Don't pass NIL to TYPE-OF-EXPRESSION. (LET ((FIRST-ARG-ONLY (NOT (MEMBER (FIRST FORM) '(AND OR COND XOR) :TEST #'EQ)))) (UNLESS (OR FIRST-ARG-ONLY (EQ (FIRST FORM) 'COND) (EQ P1VALUE 'D-INDS)) (RETURN-FROM AND-OR-STYLE)) (DOLIST (ARG (CDR FORM)) (BLOCK CHECK-ARG (WHEN (EQ (FIRST FORM) 'COND) (IF (CONSP ARG) (SETQ ARG (FIRST ARG)) ;; Not legal, but P1COND will give a warning; don't trap here. (RETURN-FROM CHECK-ARG))) (WHEN (AND (SYMBOLP ARG) (NOT (NULL ARG))) (LET* ((VAR (LOOKUP-VAR ARG VARS)) (DECLARED-TYPE (IF VAR (VAR-DATA-TYPE VAR) (TYPE-OF-EXPRESSION ARG)))) (UNLESS (OR (EQ DECLARED-TYPE 'T) (NOT (SI:TYPE-SPECIFIER-P DECLARED-TYPE)) (AND (> (OPT-COMPILATION-SPEED OPTIMIZE-SWITCH) (OPT-SAFETY OPTIMIZE-SWITCH)) (RETURN-FROM AND-OR-STYLE)) (NOT (SI:DISJOINT-TYPEP DECLARED-TYPE 'NULL))) (LET (( SI:WARNINGS-PRINLEVEL 2 )) (WARN 'AND-OR-STYLE ':IMPLAUSIBLE (IF (CONSTANTP ARG) "~S is a ~S constant so in ~S it is assumed never NIL." "Variable ~S was declared ~S so in ~S it is assumed never NIL.") ARG DECLARED-TYPE FORM))) ))) (WHEN FIRST-ARG-ONLY (RETURN)) )) NIL)