Work at SourceForge, help us to make it a better place! We have an immediate need for a Support Technician in our San Francisco or Denver office.

Close

[e90b2f]: src / lsp / helpfile.lsp Maximize Restore History

Download this file

helpfile.lsp    185 lines (162 with data), 6.7 kB

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SYSTEM -*-
;;;;
;;;; Copyright (c) 2001, Juan Jose Garcia-Ripoll.
;;;;
;;;; This program is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Library General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2 of the License, or (at your option) any later version.
;;;;
;;;; See file '../Copyright' for full details.
;;;;
(in-package "SYSTEM")
;;;;----------------------------------------------------------------------
;;;; Documentation system
;;;;
#+ecl-min
(progn
(*make-special '*documentation-pool*)
(setq *documentation-pool* nil)
(*make-special '*keep-documentation*)
(setq *keep-documentation* t))
#-ecl-min
(progn
(setq *documentation-pool* (list (make-hash-table :test #'equal :size 128)
"SYS:help.doc"))
(defparameter *keep-documentation* t))
(defun new-documentation-pool (&optional (size 1024))
"Args: (&optional hash-size)
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 &optional (sub-key :all))
(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 (cons (cdr key-sub-key) (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.
If MERGE is true, merges the contents of this table with the original values in
the help file."
(let ((dict (first *documentation-pool*)))
(when (hash-table-p dict)
(dump-help-file dict file merge)
(rplaca *documentation-pool* file))))
(defun get-documentation (object doc-type)
(when (functionp object)
(when (null (setq object (compiled-function-name object)))
(return-from get-documentation nil)))
(if (and object (listp object) (si::valid-function-name-p object))
(get-annotation (second object) 'setf-documentation doc-type)
(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 ((key 'documentation))
(when (and object (listp object) (si::valid-function-name-p object))
(setq object (second object) key 'setf-documentation))
(if string
(annotate object key doc-type string)
(remove-annotation object key doc-type)))
string)
(defun expand-set-documentation (symbol doc-type string)
(when (and *keep-documentation* string)
(when (not (stringp string))
(error "~S is not a valid documentation string" string))
`((set-documentation ',symbol ',doc-type ,string))))
#-clos
(defun documentation (object type)
"Args: (symbol doc-type)
Returns the DOC-TYPE doc-string of SYMBOL; NIL if none exists. Possible doc-
types are:
FUNCTION (special forms, macros, and functions)
VARIABLE (global variables)
TYPE (type specifiers)
STRUCTURE (structures)
SETF (SETF methods)
All built-in special forms, macros, functions, and variables have their doc-
strings."
(cond ((member type '(function type variable setf structure))
(when (not (symbolp object))
(error "~S is not a symbol." object))
(si::get-documentation object type))
(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)
(declare (ignore env #-ecl-min whole))
#+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* 'default-annotation-logic)