From 95e5dbf26d2ef80d48528cefee045797ba379829 Mon Sep 17 00:00:00 2001
From: Juan Jose Garcia Ripoll <jjgarcia@jjgr-2.local>
Date: Wed, 24 Feb 2010 10:55:04 +0100
Subject: [PATCH] Location annotations now use DSPECs

---
 src/c/symbols_list.h  |  3 +++
 src/c/symbols_list2.h |  3 +++
 src/lsp/helpfile.lsp  | 44 +++++++++++++++++++++++++++++++------------
 3 files changed, 38 insertions(+), 12 deletions(-)

diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h
index 1b51b6ccc..4c7b5f4b9 100755
--- a/src/c/symbols_list.h
+++ b/src/c/symbols_list.h
@@ -1874,6 +1874,9 @@ cl_symbols[] = {
 {EXT_ "GET-ANNOTATION", EXT_ORDINARY, NULL, -1, Cnil},
 {EXT_ "REMOVE-ANNOTATION", EXT_ORDINARY, NULL, -1, Cnil},
 {EXT_ "FUNCTION-LAMBDA-LIST", EXT_ORDINARY, NULL, -1, Cnil},
+{EXT_ "DEFAULT-ANNOTATION-LOGIC", EXT_ORDINARY, NULL, -1, Cnil},
+{EXT_ "OPTIONAL-ANNOTATION", EXT_ORDINARY, NULL, -1, Cnil},
+{EXT_ "LOCATION", EXT_ORDINARY, NULL, -1, Cnil},
 
 /* Tag for end of list */
 {NULL, CL_ORDINARY, NULL, -1, OBJNULL}};
diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h
index b386e4b83..a70d5e0c6 100755
--- a/src/c/symbols_list2.h
+++ b/src/c/symbols_list2.h
@@ -1874,6 +1874,9 @@ cl_symbols[] = {
 {EXT_ "GET-ANNOTATION",NULL},
 {EXT_ "REMOVE-ANNOTATION",NULL},
 {EXT_ "FUNCTION-LAMBDA-LIST",NULL},
+{EXT_ "DEFAULT-ANNOTATION-LOGIC",NULL},
+{EXT_ "OPTIONAL-ANNOTATION",NULL},
+{EXT_ "LOCATION",NULL},
 
 /* Tag for end of list */
 {NULL,NULL}};
diff --git a/src/lsp/helpfile.lsp b/src/lsp/helpfile.lsp
index 049205536..55e09de58 100644
--- a/src/lsp/helpfile.lsp
+++ b/src/lsp/helpfile.lsp
@@ -151,7 +151,7 @@ Sets up a new hash table for storing documentation strings."
             (si::hash-set object dict record)
             (remhash object dict))))))
 
-(defun get-annotation (object key sub-key)
+(defun get-annotation (object key &optional (sub-key :all))
   (let ((output '()))
     (dolist (dict *documentation-pool* output)
       (let ((record (if (hash-table-p dict)
@@ -224,18 +224,38 @@ strings."
 	(t
 	 (error "~S is an unknown documentation type" type))))
 
+(defun make-dspec (definition)
+  (when (consp definition)
+    (let* ((kind (first definition))
+           (name (second definition))
+           (extra '()))
+      (when (eq kind 'defmethod)
+        (let ((list (third definition)))
+          (setq extra (if (symbolp list)
+                          (cons list (fourth definition))
+                          list))))
+      (list* kind name extra))))
+
+;; (EXT:OPTIONAL-ANNOTATION arguments for EXT:ANNOTATE)
+(si::fset 'ext:optional-annotation
+          #'(ext:lambda-block ext:optional-annotation (whole env)
+               #+ecl-min
+               `(ext:annotate ,@(rest whole)))
+          t)
+
+(defun default-annotation-logic (source-location definition output-form
+                                 &optional (dspec (make-dspec definition)))
+  (let* ((kind (first definition))
+         (name (second definition)))
+    `(progn
+       (ext:optional-annotation ',name 'location ',dspec ',source-location)
+       ,(when (member kind '(defun defmacro defgeneric))
+          `(ext:optional-annotation ',name :lambda-list nil ',(third definition)))
+       ,output-form)))
+
 #+ecl-min
 (when (null *documentation-pool*) (new-documentation-pool 1024))
-
 #+ecl-min
-(setq ext::*register-with-pde-hook*
-      #'(lambda (source-location definition output-form)
-          (let* ((kind (first definition))
-                 (name (second definition)))
-            ;(print (list name kind source-location))
-            (when (not (member kind '(defmethod)))
-              (annotate name 'location kind source-location))
-            (when (member kind '(defun defmacro defgeneric))
-              (annotate name :lambda-list nil (third definition))))
-          output-form))
+(setq ext::*register-with-pde-hook* 'default-annotation-logic)
+