;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 126.86
;;; Reason:
;;;  I took a pass over all the style-checkers in QCOPT - lots of the most important
;;;  functions - and fixed up warnings to 1) unify the way problems are displayed,
;;;  and 2) improve warning content.
;;;  
;;;  Enthusiasts note: also implemented a way to style-check a function call against
;;;  the published, "human readable" argument list, when it differs; e.g,
;;;  STRING-SEARCH, which supports two different calling sequences, and only gets
;;;  checked at compile time for &REST ARGS, not keywords.  The existing style check
;;;  mechanism for doing that was lame, and the general fix was useful elsewhere.
;;; Written 15-Sep-88 19:09:33 by keith (Keith Corbett) at site Gigamos Cambridge
;;; while running on Breaking Glass from band 3
;;; with Experimental System 126.84, Experimental ZWEI 126.10, Experimental ZMail 74.1, Experimental Local-File 76.0, Experimental File-Server 25.0, Experimental Unix-Interface 14.0, Experimental Tape 25.1, Experimental Lambda-Diag 18.0, microcode 1762, SDU Boot Tape 3.14, SDU ROM 103, Lambda/Falcon Development System.



; From modified file DJ: L.SYS; QCOPT.LISP#181 at 15-Sep-88 19:10:06
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCOPT  "


(defun unimplemented (form)
  (warn 'unimplemented ':implementation-limit
	"~S is not implemented in Zetalisp"
	(car form)))

))

; From modified file DJ: L.SYS; QCOPT.LISP#181 at 15-Sep-88 19:10:12
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCOPT  "


(defun need-two-args (form)
  (when (null (cddr form))
    (warn 'wrong-number-of-arguments :implausible
	  "~S called with fewer than two arguments" (car form))))

;;;Functions defined with (DECLARE(ARGLIST)) could be called with
;;;incorrect syntax; we may use the human-readable ARGLIST to check:

))

; From modified file DJ: L.SYS; QCOPT.LISP#181 at 15-Sep-88 19:10:16
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCOPT  "


(defun check-arglist-with-arglist (form &optional (sym (first form)))
  (declare (arglist form &optional sym))
  (check-number-of-args form `(lambda ,(arglist sym nil))))

;;; fascistic style checking to persecute mucklisp code

))

; From modified file DJ: L.SYS; QCOPT.LISP#181 at 15-Sep-88 19:10:23
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCOPT  "

(defun (:property append style-checker) (form)
  (need-two-args form)
  (when (and (= (length form) 3)
	     (si:member-equal (third form) '(nil 'nil)))
     (warn 'obsolete :obsolete
	   "(~S ... NIL) is an obsolete way to copy lists; use (~S ~S) instead"
	   'append 'copy-list (cadr form))))

))

; From modified file DJ: L.SYS; QCOPT.LISP#181 at 15-Sep-88 19:10:25
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCOPT  "


(defun (:property zl:subst style-checker) (form)
  (when (and (= (length form) 4)
	     (si:member-equal (cadr form) '(nil 'nil))
	     (si:member-equal (caddr form) '(nil 'nil)))
    (warn 'obsolete :obsolete
	  "(~S NIL NIL ...) is an obsolete way to copy trees; use (~S ~S) instead"
	  'subst 'copy-tree (cadddr form))))

))

; From modified file DJ: L.SYS; QCOPT.LISP#181 at 15-Sep-88 19:10:47
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCOPT  "


(defun need-an-arg (form)
  (or (cdr form)
      (warn 'wrong-number-of-arguments ':implausible
	    "~S called with no arguments" (car form))))

))

; From modified file DJ: L.SYS; QCOPT.LISP#181 at 15-Sep-88 19:10:53
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCOPT  "


(defun (:property format style-checker) (form)
   (need-two-args form)
   ;;>> It would be -kind- of nice to parse the format string for syntactic illegality...
   (if (typep (cadr form) '(or string number array))
       (warn 'bad-argument ':implausible
	     "~S ~called with ~S as its first argument,~&~
 which should be ~S, ~S, a stream, or a string with fill-pointer~"
	     'format (cadr form) t nil)))

;>> "(locf (symbol-value '*foo*))" seems a reasonable thing to me.
;(defrewrite value-cell-location-quoted-lossage value-cell-location (form)
;  ;(not-maclisp form)
;  (if (neq (car-safe (cadr form)) 'quote)
;      form
;    (warn 'value-cell-location ':obsolete
;	  "~S of quoted variable ~S is obsolete; use ~S"
;	  'value-cell-location (cadr (cadr form)) 'variable-location)
;    `(variable-location ,(cadr (cadr form)))))

;(defun (boundp style-checker) (form)
;  (and (consp (cadr form))
;       (eq (caadr form) 'quote)
;       (not (specialp (cadadr form)))
;       (warn 'boundp ':obsolete
;	     "BOUNDP of a quoted nonspecial variable is obsolete; use VARIABLE-BOUNDP")))

;;;; Style-checkers for things that don't work in Maclisp.

;;; These symbols don't exist in Maclisp, though they could, but they are likely losers.
;(defprop zl:listp not-maclisp style-checker)
;(defprop zl:nlistp not-maclisp style-checker)
;(defprop nsymbolp not-maclisp style-checker)

;;; these functions can't be added to maclisp by a user.
;(defprop intern-local not-maclisp style-checker)
;(defprop intern-soft not-maclisp style-checker)
;(defprop intern-local-soft not-maclisp style-checker)
;(defprop make-array not-maclisp style-checker)
;(defprop g-l-p not-maclisp style-checker)
;(defprop array-leader not-maclisp style-checker)
;(defprop store-array-leader not-maclisp style-checker)
;(defprop multiple-value not-maclisp style-checker)
;(defprop multiple-value-list not-maclisp style-checker)
;(defprop do-named not-maclisp style-checker)
;(defprop return-from not-maclisp style-checker)
;(defprop return-list not-maclisp style-checker)
;(defprop bind not-maclisp style-checker)
;(defprop %bind not-maclisp style-checker)
;(defprop compiler-let not-maclisp style-checker)
;(defprop local-declare not-maclisp style-checker)
;(defprop cons-in-area not-maclisp style-checker)
;(defprop list-in-area not-maclisp style-checker)
;(defprop ncons-in-area not-maclisp style-checker)
;(defprop variable-location not-maclisp style-checker)
;(defprop variable-boundp not-maclisp style-checker)
;(defprop car-location not-maclisp style-checker)
;(defprop property-cell-location not-maclisp style-checker)
;(defprop function-cell-location not-maclisp style-checker)
;(defprop fset not-maclisp style-checker)
;(defprop fboundp not-maclisp style-checker)
;(defprop fsymeval not-maclisp style-checker)
;(defprop closure not-maclisp style-checker)

;(defun not-maclisp (form)
;  (and run-in-maclisp-switch
;       (warn 'not-in-maclisp ':maclisp
;	     "~S is not implemented in Maclisp." (car form))))

))

; From modified file DJ: L.SYS; QCOPT.LISP#181 at 15-Sep-88 19:39:36
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCOPT  "


(defun (:property make-list style-checker) (form)
  (if (= (length form) 3)
      (warn 'obsolete :obsolete
	"~S ~called with obsolete calling sequence: ~S~&~
		Use (~S ~S~{ ~S~}) instead.~"
	'make-list form 'make-list (third form)
	(if (si:member-equal (second form) '(nil 'nil)) () `(:area ,(second form))))
    (check-arglist-with-arglist form 'make-list)))

(defun (:property typep style-checker) (form)
  (if (= (length form) 2)
      (warn 'obsolete :obsolete
	    "~S ~called with one argument; this format is obsolete.~&~
                  Either call ~S with two arguments or call ~S.~"
            'typep 'typep 'type-of)))

(defun (:property string-equal style-checker) (form)
  ;; Old style: (string-equal s1 s2 &optional start1 start2 end1 end2)
  ;; New style: (string-equal s1 s2 &key start1 end1 start2 end2)
  ;; Arglist seen by compiler: (string-equal string1 string2 &rest args)
  (let ((length (- (length form) 3))
        keys)
    (tagbody
        (cond (( length 0)
               (go done))
              ((> length 4)
               (go &key))
          ((cl:some (lambda (x)
                      (or (keywordp x)
                          (and (eq (car-safe x) 'quote) (keywordp (cadr x)))))
                    (setq keys (cdddr form)))
           (go &key))
          ((or (numberp (car keys))
               (numberp (caddr keys)))
           (go obsolete))
          ((or (self-evaluating-p (car keys))
               (and (cddr keys)
                    (self-evaluating-p (caddr keys))))
           (go &key))
          ((oddp length)
           (go obsolete))
          (t
           ;; cannot tell
           ;;  (either (string-equal s1 s2 foo bar) or (string-equal s1 s2 foo bar baz zap))
           ;; since foo and baz may be keywords when the function is called.
           (go maybe-obsolete)))
     obsolete
        (warn 'obsolete :obsolete
              ;; the ~{~S~} stuff is to avoid *print-length* screws
              ;;  in si::record-and-print-warning
              "~S ~called in an obsolete fashion, with optional (non-keyword) arguments.~@
                    Instead of: ~S~@
                    Use:        (~{~S~^ ~})~"
              'string-equal form
              `(string-equal ,(cadr form) ,(caddr form)
                             ,@(loop for x in keys
                                     for y in '(:start1 :start2 :end1 :end2)
                                  collect y collect x)))
        (go done)
     maybe-obsolete
        (warn 'foo :warning
              "~S ~called in what may be an obsolete fashion: ~S -~@
                If ~:[~S is a keyword~*~;~S and ~S are keywords~] ~
                  when ~S is called, then this form is correct,~%  ~
                  and agrees with ~:*~S's new arglist:~%  (~{~A~^ ~})~@
                If not, use (~{~S~^ ~}) instead.~"
              'string-equal form
              (cddr keys) (car keys) (caddr keys)
              'string-equal '(string1 string2 &key start1 end1 start2 end2)
              `(string-equal ,(cadr form) ,(caddr form)
                             ,@(loop for x in keys
                                     for y in '(:start1 :start2 :end1 :end2)
                                  collect y collect x)))
        (go done)
     &key
        (check-arglist-with-arglist form 'string-equal)
        (go done)
     done
        )))

))

; From modified file DJ: L.SYS; QCOPT.LISP#181 at 15-Sep-88 19:50:32
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCOPT  "


(defun (:property append style-checker) (form)
  (need-two-args form)
  (when (and (= (length form) 3)
	     (si:member-equal (third form) '(nil 'nil)))
     (warn 'obsolete :obsolete
	   "(~S ... NIL) ~is an obsolete way to copy lists.~@
                    Instead of: (~{~S~^ ~})~@
                    Use:        (~S ~S)~"
	   'append form
	   'copy-list (cadr form))))

))

; From modified file DJ: L.SYS; QCOPT.LISP#181 at 15-Sep-88 19:50:33
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCOPT  "


(defun (:property zl:subst style-checker) (form)
  (when (and (= (length form) 4)
	     (si:member-equal (cadr form) '(nil 'nil))
	     (si:member-equal (caddr form) '(nil 'nil)))
    (warn 'obsolete :obsolete
	  "(~S NIL NIL ...) ~is an obsolete way to copy trees.~@
                    Instead of: (~{~S~^ ~})~@
                    Use:        (~S ~S)~"
	  'subst form
	  'copy-tree (cadddr form))))

))

; From modified file DJ: L.SYS; QCOPT.LISP#181 at 15-Sep-88 19:50:34
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCOPT  "


(defun (:property make-list style-checker) (form)
  (if (= (length form) 3)
      (warn 'obsolete :obsolete
	"~S ~called with obsolete calling sequence: ~S~&~
		Use (~S ~S~{ ~S~}) instead.~"
	'make-list form 'make-list (third form)
	(if (si:member-equal (second form) '(nil 'nil)) () `(:area ,(second form))))
    (check-arglist-with-arglist form 'make-list)))

))

; From modified file DJ: L.SYS; QCOPT.LISP#181 at 15-Sep-88 19:50:38
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCOPT  "


(defun (:property typep style-checker) (form)
  (if (= (length form) 2)
      (warn 'obsolete :obsolete
	    "~S ~called with one argument; this format is obsolete.~&~
                  Either call ~S with two arguments or call ~S.~"
            'typep 'typep 'type-of)))

))

; From modified file DJ: L.SYS; QCOPT.LISP#181 at 15-Sep-88 19:50:40
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCOPT  "


(defun (:property string-equal style-checker) (form)
  ;; Old style: (string-equal s1 s2 &optional start1 start2 end1 end2)
  ;; New style: (string-equal s1 s2 &key start1 end1 start2 end2)
  ;; Arglist seen by compiler: (string-equal string1 string2 &rest args)
  (let ((length (- (length form) 3))
        keys)
    (tagbody
        (cond (( length 0)
               (go done))
              ((> length 4)
               (go &key))
          ((cl:some (lambda (x)
                      (or (keywordp x)
                          (and (eq (car-safe x) 'quote) (keywordp (cadr x)))))
                    (setq keys (cdddr form)))
           (go &key))
          ((or (numberp (car keys))
               (numberp (caddr keys)))
           (go obsolete))
          ((or (self-evaluating-p (car keys))
               (and (cddr keys)
                    (self-evaluating-p (caddr keys))))
           (go &key))
          ((oddp length)
           (go obsolete))
          (t
           ;; cannot tell
           ;;  (either (string-equal s1 s2 foo bar) or (string-equal s1 s2 foo bar baz zap))
           ;; since foo and baz may be keywords when the function is called.
           (go maybe-obsolete)))
     obsolete
        (warn 'obsolete :obsolete
              ;; the ~{~S~} stuff is to avoid *print-length* screws
              ;;  in si::record-and-print-warning
              "~S ~called in an obsolete fashion, with optional (non-keyword) arguments.~@
                    Instead of: (~{~S~^ ~})~@
                    Use:        (~{~S~^ ~})~"
              'string-equal form
              `(string-equal ,(cadr form) ,(caddr form)
                             ,@(loop for x in keys
                                     for y in '(:start1 :start2 :end1 :end2)
                                  collect y collect x)))
        (go done)
     maybe-obsolete
        (warn 'foo :warning
              "~S ~called in what may be an obsolete fashion: ~S -~@
                If ~:[~S is a keyword~*~;~S and ~S are keywords~] ~
                  when ~S is called, then this form is correct,~%  ~
                  and agrees with ~:*~S's new arglist:~%  (~{~A~^ ~})~@
                If not, use (~{~S~^ ~}) instead.~"
              'string-equal form
              (cddr keys) (car keys) (caddr keys)
              'string-equal '(string1 string2 &key start1 end1 start2 end2)
              `(string-equal ,(cadr form) ,(caddr form)
                             ,@(loop for x in keys
                                     for y in '(:start1 :start2 :end1 :end2)
                                  collect y collect x)))
        (go done)
     &key
        (check-arglist-with-arglist form 'string-equal)
        (go done)
     done
        )))

))