;;; -*- Mode:LISP; Package:SYSTEM-INTERNALS; Readtable:CL; Base:10 -*-

(defvar *csfn-debug* nil)

(defmacro freal (&rest args)
  `(unless *csfn-debug* (format t ,@args)))

(defmacro debug (&rest args)
  `(when *csfn-debug* (format t ,@args)))

(defun new-source-file-name (sym old new)
  (let ((source (copy-tree (get sym :source-file-name))))
    (etypecase source
      (null (setq source new))
      (pathname
       (if (eq source old)
	   (setq source new)
	 (setq source (ncons (list 'defun new source)))))
      (cons
       (let ((paths (cdr (assoc 'defun source))))
	 (if (null paths)
	     (setq source (cons (list 'defun new) source))
	   (setf (cdr (assoc 'defun source))
		 (progn (setq paths (remove old paths))
			(pushnew new paths)))))))
    source))

(defun csfn (old new &optional *csfn-debug*)
  (setq old (merge-pathnames old (pathname "sys:sys;*.lisp#>")))
  (setq new (merge-pathnames new old))
  (let ((old2 (send old :new-pathname :type :unspecific :version :unspecific))
	(new2 (send new :new-pathname :type :unspecific :version :unspecific)))
    (with-open-file (in new)
      (do ((form (read in nil :eof) (read in nil :eof)))
	  ((eq form :eof))
	(let ((sym (second form)))
	  (when (symbolp sym)
	    (format t "~2&")
	    (debug "~A was ~S~&  is " sym (get sym :source-file-name))
	    (freal  "(setf (get '~A :source-file-name) " sym)
	    (freal "~&    '")
	    (format t "~S" (new-source-file-name sym old2 new2))
	    (freal "\)")))))))

;;;(si:csfn "eval" "special-forms")