Enter your search terms Submit search form
	Web pdp-10.trailing-edge.com

;;; Ett nytt f|rslag p} en defun-macro. Liksom den f|rra f|rst|r inte
;;; denna ev. inkapslingar n{r man definierar om funktioner.
;;; Dessutom tittar den p} den globala variabeln *redefine-warnings*
;;; (som kanske borde heta n}got annat) om den ska varna n{r man 
;;; f|rs|ker definiera om en funktion. Variabeln ska vara bunden till
;;; en lista som kan inneh}lla n}got eller n}gra av de keywords som
;;; funktionerna FIND-SYMBOL och INTERN returnerar som andra v{rde;
;;; :INTERNAL, :EXTERNAL och :INHERITED. Om en funktion t.ex. h|r hemma
;;; i ett annat paket och *redefine-warnings* {r (:inherited) ges
;;; felmeddelande. Om man forts{tter med OK definieras den om i alla
;;; fall.



(in-package 'lisp)
(export '(*redefine-warnings*))

(defvar *redefine-warnings* '(:inherited)
  "List of symbol types we are to warn the user for redefining,
  e.g. (:INHERITED :INTERNAL).")


;;; Separates documentation, declarations and forms in the same way
;;; as original defun. Could perhaps be more rigorous.
(defun split-body (body &optional doc dec)
  (cond ((endp body) (values doc (reverse dec) body))
	((and (not doc) (stringp (first body)) (not (endp (rest body))))
	 (split-body (rest body) (first body) dec))
	((and (listp (first body)) (eql 'declare (caar body)))
	 (split-body (rest body) doc (cons (first body) dec)))
	(t (values doc (reverse dec) body))))

#|
;; from Flavors I think
(defun extract-doc-and-declares (forms)
  (do ((forms forms (cdr forms))
       (docs nil (cons (car forms) docs)))
      ((or (endp forms)
	   (and (not (stringp (car forms)))
		(not (and (listp (car forms))
			  (eq (caar forms) 'declare)))))
       (values (nreverse docs) forms))))
|#

;;; Hack encapsulations
(defun basic-definition (symbol)
  (let ((sym (get symbol 'encapsulated-definition)))
    (if sym (basic-definition sym) symbol)))


;;; Must do this because of some weird inconsistencies in the packages or
;;; some magic with the special-forms.
(unexport 'defun)					; Hide the old one..
(unintern 'defun)					; ...excise it...


(defmacro defun (&rest args)
  (let ((name (first args))
	(arglist (second args))
	(body (cddr args)))
    (multiple-value-bind (documentation declarations forms)
			 (split-body body)
      (when documentation
	(setq documentation
	      `((setf (documentation ',name 'function)
		      ,documentation))))
      `(let ((fun #'(lambda ,arglist ,@declarations (block ,name ,@forms))))
	 (cond ((special-form-p ',name)
		(error "Trying to DEFUN a special form."))
	       ((fboundp ',name)			; Redefining.
		(multiple-value-bind (symbol where)
;	          (declare (ignore symbol))
				     (find-symbol ,(string name))
		  (when (member where *redefine-warnings*)
		    (cerror "Redefine it anyway."
			    "Trying to redefine ~S, ~
			    ~:[which is an ~(~a~) function in ~;~
			       which was ~(~a~) from ~]~
			    the ~a package."
			    ',name (eql where :inherited) (symbol-name where)
			    (package-name (symbol-package ',name))))
		  (fset (basic-definition ',name) fun)))
	       (t (fset ',name fun)))			; New definition.
	 (setf (documentation ',name 'source)
	       (and *file-being-loaded* (namestring *file-being-loaded*)))
	 ,@documentation
	 ',name))))					; Return the name.


(export 'defun)						; ...and export the
							; new one.