;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 126.89
;;; Reason:
;;;  Implement style checker on system functions that expect byte specifier arguments.
;;;  Try to warn about obviously non-portable arguments; the typical situation we want
;;;  to flush out is calling, e.g., LDB with a numeric constant.  Here is an example
;;;  of a function that calls LDB and DPB several ways that are non-portable:
;;;  
;;;    (defun tester-ng (ppss wrd)
;;;      (compiler-let ((compiler:*just-once-for-style-checkers-per-inner-form* nil))
;;;        (ldb #(1 2 3) wrd)
;;;        (ldb nil wrd)
;;;        (ldb t wrd)
;;;        (ldb :keyword wrd)
;;;        (ldb (* ppss 3) wrd)
;;;        (dpb #b1010 261. wrd)
;;;        (dpb #o17 (max 3 5) 77.)
;;;        (ldb (times ppss 3) wrd)))
;;;    
;;;    << While compiling TESTER-NG >>
;;;     LDB called with an invalid BYTE specifier "#(1 2 3)"; this is not portable
;;;     LDB called with a null BYTE specifier; this is not portable
;;;     LDB called with T as a BYTE specifier; this is not portable
;;;     LDB called with the keyword :KEYWORD as a BYTE specifier; this is not portable
;;;     LDB called with a call to * as a BYTE specifier; this may not be portable
;;;     DPB called with the numeric constant 261 as a BYTE specifier; this is not portable
;;;     DPB called with a call to MAX as a BYTE specifier; this may not be portable
;;;     LDB called with a call to TIMES as a BYTE specifier; this may not be portable
;;;  
;;;  Any function, such as BYTE, that is known to return a portable byte
;;;  specifier will not generate a warning if it has a non-NIL
;;;  COMPILER:LEGAL-BYTE-SPECIFIER property.  If anybody has such a need
;;;  frequently, this could be modified to look at a function-internal
;;;  declaration.
;;; Written 23-Sep-88 19:41:11 by keith (Keith Corbett) at site Gigamos Cambridge
;;; while running on Breaking Glass from band 1
;;; with Experimental System 126.88, 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, Experimental ZWEI 126.11, microcode 1762, SDU Boot Tape 3.14, SDU ROM 103.



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


;;;BYTE SPEC callers

(defun check-byte-spec (form &aux flag)
  (let* ((fcn (car form))
	 (argpos (or (get fcn 'check-byte-spec-arg) 0))
	 (barg (nth (1+ argpos) form))
	 (definitely-not-portable t))
    (when
      (setq flag
	    ;;Return to FLAG the warning, if any
	    (macrolet ((middle (prefix)
			       (format nil "~A ~~S as a BYTE specifier" prefix))
		       (at-end (prefix)
			       (format nil "~A BYTE specifier /"~~S/"" prefix))
		       (simple (prefix)
			       (format nil "~A BYTE specifier~~*" prefix)))
	      (typecase barg
		(keyword (middle "the keyword"))	;Keywords will never be right
		((member t nil)				; T, NIL other selv-evaling vars
		 (if barg (simple "T as a")
		   (simple "a null")))
		(symbol nil)				;Variables? We can't be sure.
		(list					;"Random" function calls are not portable.
		 (setq barg (car barg))
		 (cond
		   ((get barg 'legal-byte-specifier) nil)	;The ideal: calls to BYTE
		   (t (setq definitely-not-portable nil)	;Can't be sure
		      (middle "a call to"))))
		(number (middle "the numeric constant"))	;Numbers
		(t (at-end "an invalid")))))
      (warn 'invalid-byte-spec :not-portable
	"~S called with ~A; this ~:[may not be~;is not~] portable"
	fcn
	(format nil flag barg)
	definitely-not-portable))))

;;;Put the LEGAL-BYTE-SPECIFIER property on things like BYTE that return
;;;portable, legally formatted byte specifiers -- i.e., they don't do any
;;;processor-specific arithmetic.
(defprop byte t legal-byte-specifier)

(defmacro check-byte-spec-arg (sym &optional (argpos 0))
  (check-type sym symbol)
  (check-type argpos (integer 0))
  `(eval-when (eval compile load)
     (progn
       (unless (fboundp ',sym)
	 (warn 'function-not-valid :implausible
	   "Establishing byte-spec checker for undefined function ~S" ',sym))
       (let ((prev-check (get ',sym 'style-checker)))
	 (and prev-check (neq prev-check 'check-byte-spec)
	      (warn 'redefining-style-checker :probable-error
		"Redefining style check on ~S from ~S to ~S"
		',sym prev-check 'check-byte-spec)))
       (putprop ',sym 'check-byte-spec 'style-checker)
       (putprop ',sym ,argpos 'check-byte-spec-arg))))

(check-byte-spec-arg byte-position)
(check-byte-spec-arg byte-size)
(check-byte-spec-arg dpb 1)
(check-byte-spec-arg ldb)
(check-byte-spec-arg ldb-test)
(check-byte-spec-arg mask-field)
(check-byte-spec-arg deposit-field 1)
(check-byte-spec-arg %logldb)
(check-byte-spec-arg %logdpb 1)
(check-byte-spec-arg %p-ldb)
(check-byte-spec-arg %p-ldb-offset)
(check-byte-spec-arg %p-mask-field)
(check-byte-spec-arg %p-mask-field-offset)
(check-byte-spec-arg %p-dpb 1)
(check-byte-spec-arg %p-dpb-offset 1)
(check-byte-spec-arg %p-deposit-field 1)
(check-byte-spec-arg %p-deposit-field-offset 1)

))