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

;;;Scratchpad for playing with, extending, testing style checkers.

(defspecialk testerx (&quote a &rest body)
  (print a)
  (compiler-let ((compiler:*trace-style-checkers* nil)
		 (compiler:*trace-optimizations* nil))
    (enter-block 'foo)))

(defun tester (a)
  (print a))

(defun (:property tester compiler:style-checker) (form)
  (unless (self-evaluating-p (second form))
    (compiler:warn 'invalid-arg :implausible "Argument to ~S, /"~S/", not a constant" (first form) (second form))))
			   
;new alist per defun/style-checker/form-name
;compiler:*just-once-for-style-checkers-per-inner-form* t
;compiler:*just-once-for-style-checkers-per-inner-form-alist* NIL

(defun foo ()
  (compiler-let ((compiler:*just-once-for-style-checkers-per-inner-form* t)
		 (compiler:*trace-style-checkers* t))
    (enter-block 'foo
      (tester 1)
      (let ((niceguy '(a b c))
	    (fucked '(this should not show up)))
	(case processor-type-code
	  ((1 2 3) (print-herald)))
	(select-processor
	  ((:cadr :lambda :explorer) (print-herald)))
	(select-processor
	  (:lambda (print-disk-label))
	  (:cadr ())
	  ((:explorer) (print-disk-label))
	  (:falcon (print '???)))
	(with-open-file (implode fucked)
	  (explode niceguy)
	  (with-stack-list (shit x  1 2 3)
	    (tester x)
	    (tester shit)
	    (append niceguy shit)
	    (with-stack-list* (append shit nil)
	      (append x nil)
	      (append shit nil)
	      (append fucked nil)
	      (print append))))))))

(defun xyz ()
  (select-processor
    3
    (:lambda (print-herald)))
  (implode '(a b c)))

(defun zoo (&optional x)
  (messagecase 
    x
    (:foo 'hi)
    (:boo 'bye))
  (print (typep x))
  (select-processor
    (:falcon (print x))))

(defun scroo (&optional x)
  (select-processor
    (:beastly (print x))))

(defun scrood ()
  (select-processor
    (:lambda (print-herald) (print-disk-label))
    (t (print 'you-lose))))

(defun oldways (x a b)
  (compiler:compiler-let ((compiler:*just-once-for-style-checkers-per-inner-form* nil))
    (typep 3)
    (make-list working-storage-area 10.)
    (append '(d) nil)
    (string-equal "abcd" x 0 3)
    (string-equal "abcd" x a b)
    (string-equal "abcd" x a)
    (string-equal "abcd")
    (zl:subst nil nil '(a b c d))))

(defun ml ()
  (compiler-let ((*just-once-for-style-checkers-per-inner-form* nil))
    (make-list working-storage-area 33)
    (make-list 10. :cdr-coded t)
    (make-list 10. ':cdr-coded 'hi)
    (make-list 13 :foozle 13 :cdr-coded t)
    (make-list 13. :foozle 3)))

(defun frown (x)
  (call #'print-herald nil standard-output :optional 3)
  (g-l-p x))

(defun okargs (x y)
  (prog1 1)
  (prog2 1)
  (+ 1)
  (* 1)
  (plus 1)
  (times 1)
  (quotient 1)
  (difference '(a b c))
  (nconc '(a b c))
  (make-list 10. :area working-storage-area :sick-thing t)
  (string-equal x y :start1 9 :start8 7)
  (setq)
  (-)
  (psetq)
  (cond)
  (-)
  (//)
  (cl://))

(defun formatwhoops ()
  (compiler:compiler-let ((compiler:*just-once-for-style-checkers-per-inner-form* nil))
    (format 3)
    (format "hi there")))

(defun weird ()
  (break 'hi 3))

(defun testcheck (form) (compiler:warn 'test :implausible "test check"))
(defun test ())
(putprop 'test 'testcheck 'compiler:style-checker)

(defun foo ()
  (compiler:compiler-let ((compiler:*just-once-for-style-checkers-per-inner-form* '(check-byte-spec))
			  (compiler:*trace-style-checkers* t))
    (test)
    (test)
    (test)))