From 49228426de9b0968e38c6b5fe1b32ca62e934a23 Mon Sep 17 00:00:00 2001
From: Stelian Ionescu <sionescu@common-lisp.net>
Date: Sat, 16 Aug 2008 20:21:09 +0200
Subject: [PATCH] Add DEFOBSOLETE to base package.

Signed-off-by: Stelian Ionescu <sionescu@common-lisp.net>
---
 base/defobsolete.lisp | 55 +++++++++++++++++++++++++++++++++++++++++++++++++++
 base/pkgdcl.lisp      | 13 ++++++++++--
 iolib.base.asd        |  3 ++-
 3 files changed, 68 insertions(+), 3 deletions(-)
 create mode 100644 base/defobsolete.lisp

diff --git a/base/defobsolete.lisp b/base/defobsolete.lisp
new file mode 100644
index 0000000..76ca9bb
--- /dev/null
+++ b/base/defobsolete.lisp
@@ -0,0 +1,55 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
+;;;
+;;; --- Declaring forms as obsolete.
+;;;
+
+(in-package :iolib.base)
+
+(define-condition deprecation-warning (style-warning)
+  ((function-name :initarg :function-name :reader deprecation-warning-function-name)
+   (type :initarg :type :reader deprecation-warning-type)
+   (reason :initarg :reason :reader deprecation-warning-reason))
+  (:report (lambda (condition stream)
+             (format stream "~A is an obsolete ~A~@[; ~A~]"
+                     (deprecation-warning-function-name condition)
+                     (deprecation-warning-type condition)
+                     (deprecation-warning-reason condition))))
+  (:documentation "Warning signaled at compile-time indicating that a certain function has been deprecated."))
+
+(defun setf-function-name-p (function-name)
+  (and (eq 'setf (first function-name))
+       (null (cddr function-name))))
+
+(defun function-name-p (function-name)
+  "Returns T if FUNCTION-NAME is a legal function name:
+a symbol or a list (CL:SETF symbol)."
+  (or (symbolp function-name)
+      (and (consp function-name)
+           (setf-function-name-p function-name))))
+
+(deftype function-name ()
+  "A legal function name: a symbol or a list (CL:SETF symbol)."
+  `(or symbol (and cons (satisfies setf-function-name-p))))
+
+(defun signal-obsolete (function-name reason type action)
+  (funcall (ecase action
+             (:warn #'warn)
+             (:error #'error))
+           'deprecation-warning :function-name function-name
+           :type type :reason reason))
+
+(defmacro defobsolete (function-name reason &key (type "function") (action :warn))
+  "Declare the function denoted by FUNCTION-NAME as obsolete. REASON must
+either be a string or the name of a function to be used as alternative.
+ACTION chooses the function used to signal the deprecation warning:
+if :WARN then CL:WARN will be used, if :ERROR then CL:ERROR."
+  (check-type function-name function-name "a legal function name")
+  (check-type reason (or function-name string) "a legal function name or a string")
+  (check-type type (or symbol string))
+  (check-type action (member :warn :error))
+  (when (function-name-p reason)
+    (setf reason (format nil "use ~A instead." reason)))
+  `(define-compiler-macro ,function-name (&whole whole &rest args)
+     (declare (ignore args))
+     (signal-obsolete ',function-name ,reason ',type ,action)
+     whole))
diff --git a/base/pkgdcl.lisp b/base/pkgdcl.lisp
index ac65d35..5da6980 100644
--- a/base/pkgdcl.lisp
+++ b/base/pkgdcl.lisp
@@ -9,8 +9,17 @@
   (:use #:common-lisp :alexandria)
   (:shadow #:defun #:defmethod
            #:defmacro #:define-compiler-macro)
-  (:export #:return* #:lambda* #:defun #:defmethod
-           #:defmacro #:define-compiler-macro))
+  (:export
+   ;; RETURN*
+   #:return* #:lambda* #:defun #:defmethod
+   #:defmacro #:define-compiler-macro
+   ;; DEFOBSOLETE
+   #:deprecation-warning
+   #:deprecation-warning-function-name
+   #:deprecation-warning-type
+   #:deprecation-warning-reason
+   #:function-name #:function-name-p
+   #:defobsolete))
 
 (flet ((gather-external-symbols (&rest packages)
          (let ((symbols (make-hash-table :test #'eq)))
diff --git a/iolib.base.asd b/iolib.base.asd
index b044b1e..7cb4027 100644
--- a/iolib.base.asd
+++ b/iolib.base.asd
@@ -10,4 +10,5 @@
   :pathname (merge-pathnames (make-pathname :directory '(:relative "base"))
                              *load-truename*)
   :components ((:file "pkgdcl")
-               (:file "return-star" :depends-on ("pkgdcl"))))
+               (:file "return-star" :depends-on ("pkgdcl"))
+               (:file "defobsolete" :depends-on ("pkgdcl" "return-star"))))
-- 
2.11.4.GIT