;;; -*- Mode:LISP; Package:COMPILER; Base:10; Readtable:CL -*-

;;;The style police:

(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
		   ((eq barg 'byte) 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))))

;;;How to turn on checker for one function:

(defmacro make-byte-spec-checker (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))
       (putprop ',sym 'check-byte-spec 'compiler:style-checker)
       (putprop ',sym ,argpos 'check-byte-spec-arg))))

;;;Now turn on checkers selectively:

(check-byte-specs ldb)
(check-byte-specs dpb 1)

;;;Test code:

(check-byte-specs fsksks)

(defun tester-ok (ppss wrd)
  (ldb ppss wrd)
  (ldb (byte 1 0) #o77)
  (dpb 0. ppss wrd)
  (dpb #o77 (byte 1 0) wrd))

(defstruct (bword (:type :array-leader))
  ((word)
   (byte-1 (byte 8 0.))
   (byte-2 (byte 8 8.))
   (byte-3 (byte 8 16.))
   (byte-4 (byte 8 24.))))

(untrace)

(let ((*trace-output* #'ignore))
  (untrace)
  (trace byte-expand check-byte-spec
	 si:defstruct-parse-items si:defstruct-parse-one-field
	 si:defstruct-define-ref-macros si:defstruct-expand-ref-macro
	 compiler-macroexpand-1 macroexpand-1 invoke-style-checker compiler-optimize))

(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

;;;Need a way to handle clause-matcher like DISPATCH:  
;  (dispatch ppss wrd
;    (0 (print 'ok))
;    (((byte 1 0)) (print 0))
;    (((byte 1 1)) (print 1))
;    (((byte 1 2)) (print 2))
;    (((byte 1 3)) (print 3))
;    (((byte 1 4)) (print 4))
;    (((byte 1 5)) (print 5))
;    (((byte 1 6)) (print 6))
;    (((byte 1 7)) (print 7))
;    (otherwise (print '???))))