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

#|

Suppose for some reason we have a group of functions each of which takes one
&REST argument; but such a function only wants to deal with up to 8 arguments.
Compiler style checking is a useful thing to do in this situation.

Now we have to do something like:

(defun takes-up-to-8-args (form &aux len)
  (unless (< (setq len (1- (length form))) 9)
    (compiler:warn 'too-many-args :implausible
      "~A expects up to 8 arguments, called with ~D"
      (car form)
      len)))

And then for each such function:

(defprop foo 'takes-up-to-8-args 'compiler:style-checker)

This code implements a more convenient syntax, with the additional advantage
that there is a single, unique interface.  

This extension also helps to enforce an important requirement for all style
checkers to return the proper values.  The compiler style checker mechanism
(CSM) also depends on each style checker function to return either NIL, meaning
no warning was issued (no style violation occurred), or, as the second value,
the symbol 'compiler:warn, which is passed back through several layers of
FUNCALL to INVOKE-STYLE-CHECKER.  (The first value is usually, but not
dependably, the list used to record the warning; fortunately this is not
currently used by anybody.)

Proposed syntax:


(defcompiler-style-checker (name-or-functions &rest clauses))
			   
			   
|#

(defmacro defcompiler-style-checker (name-and-functions special-case
				     args-list vars-list
				     &rest clauses
				     &aux defname)
  (declare (zwei:indentation 1 1 2 1))
  `(progn
     ,special-case
     (defun
	    ,(setq defname
		   (etypecase name-and-functions
		     (symbol name-and-functions)
		     (cons (car name-and-functions))))
	    ,args-list
       (let ,vars-list
	    (or ,@(loop for clause in clauses
			;;Add check (cadr clause)
			collect `(if ,(car clause)
				     (warn ',(cadr clause)  ,@(cddr clause))))))
       ,@(unless (atom name-and-functions)
	   (loop for name in (cdr name-and-functions)
		 collect `(putprop ',name ',defname 'style-checker))))))

(defcompiler-style-checker takes-up-to-8-args ()
  (form)
  (len)
  ((unless (< (setq len (1- (length form))) 9))
   (too-many-args :implausible
		  "~A expects up to 8 arguments, called with ~D"
		  (car form)
		  len)))