
(in-package :pcl)

(defvar *defun-list* nil)
(defvar *defmethod-list* nil)
(defvar *defmacro-list* nil)
(defvar *defgeneric-list* nil)

(defun list-functions (&optional print-p)
  (let ((eof '(eof))
	(*package* *package*))
    (setq *defun-list* nil
	  *defmethod-list* nil
	  *defmacro-list* nil)
    (labels ((process-form (form)
	       (when (consp form)
		 (case (car form)
		   ((in-package export import shadow shadowing-import) (eval form))
		   #+lcl3.0 (lcl:handler-bind (eval form))
		   (let (when print-p (print form)))
		   (defun (push (list (cadr form) (caddr form))
				*defun-list*))
		   (defmethod (push (list (cadr form) (caddr form)) 
				    *defmethod-list*))
		   (defmacro (push (list (cadr form) (caddr form)) 
				   *defmacro-list*))
		   (defgeneric (push (list (cadr form) (caddr form)) 
				     *defgeneric-list*))
		   (eval-when (mapc #'process-form (cddr form)))
		   (progn (mapc #'process-form (cdr form)))
		   ((defvar defparameter defconstant proclaim 
		     defsetf defstruct deftype define-compiler-macro))
		   ((define-walker-template defopcode defoperand 
		     define-method-combination define-constructor-code-type 
		     defclass))
		   (t (when print-p (print form)))))))
      (dolist (file (system-source-files 'pcl))
	(with-open-file (in file :direction :input)
	  (loop (let ((form (read in nil eof)))
		  (when (eq form eof) (return nil))
		  (process-form form))))))
    (values (length *defun-list*)
	    (length *defmethod-list*)
	    (length *defmacro-list*)
	    (length *defgeneric-list*))))

(defun list-all-gfs (&key all-p (show-methods-p t) san-p (name "generic-functions"))
  (let ((keys nil) (opt nil)
	(gf-vector (make-array 10 :initial-element nil))
	(readers nil) (writers nil) (cv nil)
	(*package* *the-pcl-package*)
	(*print-pretty* nil)
	(s-a-n (find-package "SLOT-ACCESSOR-NAME"))
	(lisp-sans (mapcar #'slot-reader-symbol '(function type))))
    ;; This one has no predefined methods.
    (defgeneric update-dependent (metaobject dependent &rest initargs))
    (map-all-generic-functions 
     #'(lambda (gf)
	 (when (or all-p
		   (let ((name (generic-function-name gf)))
		     (when (consp name) (setq name (cadr name)))
		     (and (not (find #\: (symbol-name name)))
			  (or (eq (symbol-package name) *the-pcl-package*)
			      (and san-p
				   (memq name lisp-sans)
				   (and (eq (symbol-package name) s-a-n)
					(string= "PCL " (symbol-name name)
						 :end2 4)))))))
	   (let ((ll (generic-function-lambda-list gf)))
	     (multiple-value-bind (nrequired noptional 
					     keysp restp allow-other-keys-p keywords)
		 (analyze-lambda-list ll)
	       (cond ((use-constant-value-dfun-p gf t)
		      (push gf cv))
		     ((or keysp restp allow-other-keys-p keywords)
		      (push gf keys))
		     ((plusp noptional)
		      (push gf opt))
		     ((and (= nrequired 1)
			   (let ((m (generic-function-methods gf)))
			     (and m
				  (every #'standard-reader-method-p m))))
		      (push gf readers))
		     ((and (= nrequired 2)
			   (let ((m (generic-function-methods gf)))
			     (and m
				  (every #'standard-writer-method-p m))))
		      (push gf writers))
		     (t
		      (push gf (aref gf-vector nrequired)))))))))
    (with-open-file (out (let* ((system (get-system 'pcl))
				(*system-directory* (funcall (car system))))
			   (make-pathname :defaults
					  (truename (make-source-pathname "defsys"))
					  :name name))
			 :direction :output)
      (format out ";;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*-~2%")
      (format out "(in-package :pcl)~%")
      (flet ((print-gf-list (list)
	       (setq list
		     (sort (mapcar #'generic-function-name list)
			   #'(lambda (sym1 sym2)
			       (let* ((s1 (if (consp sym1) (cadr sym1) sym1))
				      (s2 (if (consp sym2) (cadr sym2) sym2))
				      (p1 (symbol-package s1))
				      (p2 (symbol-package s2)))
				 (if (eq p1 p2)
				     (string< (symbol-name s1) (symbol-name s2))
				     (string< (package-name p1) (package-name p2)))))))
	       (dolist (sym list)
		 (let* ((*print-case* :downcase)
			(gf (gdefinition sym))
			(lambda-list (generic-function-lambda-list gf)))
		   (format out "~&~S~%" `(defgeneric ,sym ,lambda-list))
		   (when show-methods-p
		     (dolist (m (generic-function-methods gf))
		       (let* ((q (method-qualifiers m))
			      (qs (if (null q) 
				      ""
				      (format nil "~{~S~^ ~}" q)))
			      (s (unparse-specializers m)))
			 (format out "~&;  ~7A ~S~%" qs s)))
		     (terpri out))))))
	(when cv
	  (format out "~%;;; class predicates~%")
	  (print-gf-list cv))
	(when readers
	  (format out "~%;;; readers~%")
	  (print-gf-list readers))
	(when writers
	  (format out "~%;;; writers~%")
	  (print-gf-list writers))
	(dotimes (i 10)
	  (when (aref gf-vector i)
	    (format out "~%;;; ~D argument~:P ~%" i)
	    (print-gf-list (aref gf-vector i))))
	(format out "~%;;; optional arguments  ~%")
	(print-gf-list opt)
	(format out "~%;;; keyword arguments  ~%")
	(print-gf-list keys))
      (terpri out))))
