From 6b1e70042ed11ea018ad0da2a54ceb88efccb2c7 Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Tue, 23 Feb 2010 15:56:39 +0100 Subject: [PATCH] The documentation file can now store other annotations. --- src/CHANGELOG | 3 ++ src/lsp/evalmacros.lsp | 19 +++---- src/lsp/helpfile.lsp | 109 +++++++++++++++++++++++++++++++---------- 3 files changed, 93 insertions(+), 38 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index d8b9400bd..e02ce464a 100755 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -121,6 +121,9 @@ and important fixes to let ECL work better with Slime. contains references to the location of all C functions. This file can be used to locate functions from the core library in Slime, using M-. + - Documentation files now allow for annotation of arbitrary symbols, + based on a key and a sub-key which are both symbols. + ;;; Local Variables: *** ;;; mode:text *** ;;; fill-column:79 *** diff --git a/src/lsp/evalmacros.lsp b/src/lsp/evalmacros.lsp index 50c999633..095d50086 100644 --- a/src/lsp/evalmacros.lsp +++ b/src/lsp/evalmacros.lsp @@ -23,20 +23,17 @@ last FORM. If not, simply returns NIL." (multiple-value-setq (body doc-string) (remove-documentation body)) (let* ((function `#'(ext::lambda-block ,name ,vl ,@body)) (global-function `#'(ext::lambda-block ,name ,vl - (declare (si::c-global)) - ,@body))) + (declare (si::c-global)) + ,@body))) (when *dump-defun-definitions* (print function) (setq function `(si::bc-disassemble ,function))) - `(progn - (eval-when (:execute) - (si::fset ',name ,function)) - (eval-when (:load-toplevel) - ,(ext:register-with-pde whole `(si::fset ',name ,global-function))) - ,@(si::expand-set-documentation name 'function doc-string) - ',name))) + `(progn + ,(ext:register-with-pde whole `(si::fset ',name ,global-function)) + ,@(si::expand-set-documentation name 'function doc-string) + ',name))) -(defmacro defmacro (name vl &body body &aux doc-string) +(defmacro defmacro (&whole whole name vl &body body &aux doc-string) ;; Documentation in help.lsp (multiple-value-bind (function pprint doc-string) (sys::expand-defmacro name vl body) @@ -45,7 +42,7 @@ last FORM. If not, simply returns NIL." (print function) (setq function `(si::bc-disassemble ,function))) `(eval-when (:compile-toplevel :load-toplevel :execute) - (si::fset ',name ,function t ,pprint) + ,(ext:register-with-pde whole `(si::fset ',name ,function t ,pprint)) ,@(si::expand-set-documentation name 'function doc-string) ',name))) diff --git a/src/lsp/helpfile.lsp b/src/lsp/helpfile.lsp index a469f6c9a..761e41500 100644 --- a/src/lsp/helpfile.lsp +++ b/src/lsp/helpfile.lsp @@ -20,7 +20,7 @@ (let* ((*package* (find-package "CL")) (file (open path :direction :input))) (do ((end nil) - (h (make-hash-table :size 1024 :test #'eql))) + (h (make-hash-table :size 1024 :test #'equal))) (end h) (do ((c (read-char file nil))) ((or (not c) (eq c #\^_)) @@ -58,6 +58,8 @@ path))) (defun search-help-file (key path &aux (pos 0)) + (when (not (stringp key)) + (return-from search-help-file nil)) (labels ((bin-search (file start end &aux (delta 0) (middle 0) sym) (declare (fixnum start end delta middle)) (when (< start end) @@ -98,7 +100,7 @@ (setq *keep-documentation* t)) #-ecl-min (progn - (defvar *documentation-pool* (list (make-hash-table :test #'eq :size 128) + (defvar *documentation-pool* (list (make-hash-table :test #'equal :size 128) "SYS:help.doc")) (defvar *keep-documentation* t)) @@ -108,6 +110,64 @@ Sets up a new hash table for storing documentation strings." (push (make-hash-table :test #'eql :size size) *documentation-pool*)) +(defun record-cons (record key sub-key) + (let ((cons (cons key sub-key))) + (dolist (i record i) + (when (equalp (car i) cons) + (return i))))) + +(defun record-field (record key sub-key) + (cdr (record-cons record key sub-key))) + +(defun set-record-field (record key sub-key value) + (let ((field (record-cons record key sub-key))) + (if field + (rplacd field value) + (setq record (list* (cons (cons key sub-key) value) record))) + record)) + +(defun rem-record-field (record key sub-key) + (let ((x (record-cons record key sub-key))) + (if x + (let ((output '())) + (dolist (i record output) + (when (not (eq i x)) + (setq output (cons i output))))) + record))) + +(defun annotate (object key sub-key value) + (let ((dict (first *documentation-pool*))) + (when (hash-table-p dict) + (let ((record (set-record-field (gethash object dict) + key sub-key value))) + (si::hash-set object dict record))))) + +(defun remove-annotation (object key sub-key) + (let ((dict (first *documentation-pool*))) + (when (hash-table-p dict) + (let ((record (rem-record-field (gethash object dict) + key sub-key))) + (if record + (si::hash-set object dict record) + (remhash object dict)))))) + +(defun get-annotation (object key sub-key) + (let ((output '())) + (dolist (dict *documentation-pool* output) + (let ((record (if (hash-table-p dict) + (gethash object dict) + (if (stringp dict) + (search-help-file object dict) + nil)))) + (when record + (if (eq sub-key :all) + (dolist (i record) + (let ((key-sub-key (car i))) + (when (equal (car key-sub-key) key) + (push (cdr i) output)))) + (if (setq output (record-field record key sub-key)) + (return output)))))))) + (defun dump-documentation (file &optional (merge nil)) "Args: (filespec &optional (merge nil)) Saves the current hash table for documentation strings to the specificed file. @@ -118,35 +178,18 @@ the help file." (dump-help-file dict file merge) (rplaca *documentation-pool* file)))) -(defun get-documentation (object doc-type &aux output) - (dolist (dict *documentation-pool*) - (cond ((hash-table-p dict) - (when (and (setq output (gethash object dict)) - (setq output (getf output doc-type))) - (return-from get-documentation output))) - ((and (stringp dict) - (or (symbolp object) - (functionp object))) - (when (and (setq output (search-help-file - (if (functionp object) - (compiled-function-name object) - object) - dict)) - (setq output (getf output doc-type))) - (return-from get-documentation output)))))) +(defun get-documentation (object doc-type) + (when (functionp object) + (when (null (setq object (compiled-function-name object))) + (return-from get-documentation nil))) + (get-annotation object 'documentation doc-type)) (defun set-documentation (object doc-type string) (when (not (or (stringp string) (null string))) (error "~S is not a valid documentation string" string)) - (let ((dict (first *documentation-pool*))) - (when (hash-table-p dict) - (let ((plist (gethash object dict))) - (setq plist (if string - (put-f plist string doc-type) - (rem-f plist doc-type))) - (if plist - (si::hash-set object dict plist) - (remhash object dict))))) + (if string + (annotate object 'documentation doc-type string) + (remove-annotation object 'documentation doc-type)) string) (defun expand-set-documentation (symbol doc-type string) @@ -176,3 +219,15 @@ strings." #+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)) + (annotate name 'location kind source-location) + (when (member kind '(defun defmacro defgeneric)) + (annotate name 'arglist nil (third definition)))) + output-form)) +