source: trunk/cocoa-ide-contrib/foy/cl-documentation-cm/cl-documentation.lisp @ 14985

Last change on this file since 14985 was 14985, checked in by gfoy, 9 years ago

Updates for ccl 1.7

File size: 25.6 KB
Line 
1;;;-*-Mode: LISP; Package: CL-DOCUMENTATION -*-
2
3;;; ----------------------------------------------------------------------------
4;;;
5;;;      cl-documentation.lisp
6;;;
7;;;      copyright (c) 2009 Glen Foy
8;;;      (Permission is granted to Clozure Associates to distribute this file.)
9;;;
10;;;      This code is moronically simple, but surprisingly useful.
11;;;      It adds a documentation tool for CL functions to the Context-Menu mechanism.
12;;;      Right-Click displays a list of submenus.  The submenus are functional groups.
13;;;      Popping the submenu displays entries for all CL functions belonging to that
14;;;      functional group.  Selecting a function open a documentation dialog.
15;;;
16;;;      See the NOTE: below about selecting the Help Menu or the Context-Menu.
17;;;
18;;;      This software is offered "as is", without warranty of any kind.
19;;;
20;;;      Mod History, most recent first:
21;;;      9/2/9   Added a second menu, providing an alphabetical index.
22;;;      8/31/9  version 0.1b1
23;;;              First cut.
24;;;
25;;; ----------------------------------------------------------------------------
26
27(defPackage "CL-DOCUMENTATION" (:nicknames "CLDOC") (:use :cl :ccl))
28(in-package "CL-DOCUMENTATION")
29
30(require :context-menu-cm)
31(cmenu:check-hyperspec-availability "CL-Documentation-CM")
32
33;;; NOTE:
34;;; If you want this utility in the context menu, uncomment the pushnew.
35;;; If you want it under the Help Menu, leave as is.
36;;; (pushnew :install-cl-doc-as-context-menu *features*)
37
38(defParameter *cl-documentation-menu* nil "The cl-documentation-menu instance.")
39(defParameter *cl-alphabetical-menu* nil "The cl-alphabetical-menu instance.")
40
41
42;;; ----------------------------------------------------------------------------
43;;;
44(defClass CL-DOCUMENTATION-MENU (ns:ns-menu) 
45  ((tool-menu :initform nil :accessor tool-menu)
46   (sub-title :initform "functional groups" :reader sub-title)
47   (doc-path :initform (merge-pathnames ";ReadMe.rtf" cl-user::*cl-documentation-directory*) :reader doc-path)
48   (text-view :initform nil :accessor text-view))
49  (:documentation "A menu containing CL functions sorted into functional groups.")
50  (:metaclass ns:+ns-object))
51
52(objc:defmethod (#/clDocumentationAction: :void) ((m cl-documentation-menu) (sender :id))
53  (display-cl-doc (item-symbol sender) (text-view m)))
54
55(objc:defmethod (#/update :void) ((m cl-documentation-menu))
56  (when (tool-menu m)
57    (cmenu:update-tool-menu m (tool-menu m) :sub-title (sub-title m)))
58  (call-next-method))
59
60#+install-cl-doc-as-context-menu
61(defMethod initialize-instance :after ((m cl-documentation-menu) &key)
62  (setf (tool-menu m) (cmenu:add-default-tool-menu m :doc-file (doc-path m))))
63
64(defun display-cl-doc (symbol text-view)
65  "Display the documentation for SYMBOL."
66  ;; If Hemlock-Commands is loaded, this will be
67  ;; redefined there to use the documentation dialog.
68  (gui::lookup-hyperspec-symbol symbol text-view))
69
70(setq *cl-documentation-menu* (make-instance 'cl-documentation-menu))
71
72;;; ----------------------------------------------------------------------------
73;;;
74(defClass CL-CATEGORY-MENU-ITEM (ns:ns-menu-item) 
75  ((symbol :initform nil :accessor item-symbol))
76  (:documentation "Support for the documentation menu.")
77  (:metaclass ns:+ns-object))
78
79(defun populate-submenu (menu symbol-list)
80  "Create and add menu-items for each functional group in SYMBOL-LIST."
81  (dolist (sym symbol-list)
82    (let ((menu-item (make-instance 'cl-category-menu-item))
83          (attributed-string (#/initWithString:attributes:
84                              (#/alloc ns:ns-attributed-string) 
85                              (ccl::%make-nsstring (string-downcase (string sym)))
86                              cmenu:*hemlock-menu-dictionary*)))
87      (#/setAttributedTitle: menu-item attributed-string)
88      (#/setAction: menu-item (ccl::@selector "clDocumentationAction:"))
89      (#/setTarget: menu-item  *cl-documentation-menu*)
90      (setf (item-symbol menu-item) sym)
91      (#/addItem: menu menu-item))))
92
93(defun make-submenu-item (title symbol-list)
94  "Create a menu-item with a submenu and populate the submenu based on SYMBOL-LIST."
95  (let ((menu-item (make-instance ns:ns-menu-item))
96        (attributed-string (#/initWithString:attributes:
97                            (#/alloc ns:ns-attributed-string) 
98                            (ccl::%make-nsstring title)
99                            cmenu:*hemlock-menu-dictionary*))
100        (submenu (make-instance ns:ns-menu)))
101    (#/setAttributedTitle: menu-item attributed-string)
102    (#/setSubmenu: menu-item submenu)
103    (populate-submenu submenu symbol-list)
104    menu-item))
105
106;;; ----------------------------------------------------------------------------
107;;;
108(defParameter *evaluation-and-compilation-symbol-list*
109  (list 'compile 'compiler-macro-function 'constantp 'declaim 'declare 'define-compiler-macro 
110        'define-symbol-macro 'defmacro 'eval 'eval-when 'lambda 'load-time-value 'locally 
111        'macroexpand 'macroexpand-1 'macro-function 'proclaim 'special-operator-p 'symbol-macrolet
112        'the 'quote))
113
114(defParameter *evaluation-and-compilation*
115  (make-submenu-item "evaluation and compilation" *evaluation-and-compilation-symbol-list*))
116
117;;; ----------------------------------------------------------------------------
118;;;
119(defParameter *types-and-classes-symbol-list*
120  (list 'coerce 'deftype 'subtypep 'type-error-datum 'type-error-expected-type 'type-of 'typep))
121
122(defParameter *types-and-classes*
123  (make-submenu-item "types and classes" *types-and-classes-symbol-list*))
124
125;;; ----------------------------------------------------------------------------
126;;;
127(defParameter *control-and-data-flow-symbol-list*
128  (list 'and 'apply 'block 'case 'catch 'ccase 'compiled-function-p 'complement 'cond 
129        'constantly 'ctypecase 'defconstant 'define-modify-macro 'define-setf-expander 
130        'defparameter 'defsetf 'defun 'defvar 'destructuring-bind 'ecase 'eq 'eql 'equal 'equalp 
131        'etypecase 'every 'fboundp 'fdefinition 'flet 'fmakunbound 'funcall 'function 
132        'function-lambda-expression 'functionp 'labels 'get-setf-expansion 'go 'identity 'if 
133        'let 'let* 'macrolet 'multiple-value-bind 'multiple-value-call 'multiple-value-list 
134        'multiple-value-prog1 'multiple-value-setq 'not 'notany 'notevery 'nth-value 'or 'prog 
135        'prog* 'prog1 'prog2 'progn 'progv 'psetf 'psetq 'return 'return-from 'rotatef 'setf 
136        'setq 'shiftf 'some 'tagbody 'throw 'typecase 'unless 'unwind-protect 'values 
137        'values-list 'when))
138
139(defParameter *control-and-data-flow*
140  (make-submenu-item "control and data flow" *control-and-data-flow-symbol-list*))
141
142;;; ----------------------------------------------------------------------------
143;;;
144(defParameter *iteration-symbol-list*
145  (list 'do 'do* 'dolist 'dotimes 'loop))
146
147(defParameter *iteration*
148  (make-submenu-item "iteration" *iteration-symbol-list*))
149
150;;; ----------------------------------------------------------------------------
151;;;
152(defParameter *objects-symbol-list*
153  (list 'add-method 'allocate-instance 'call-method 'call-next-method 'change-class 'class-name 
154        'class-of 'compute-applicable-methods 'defclass 'defgeneric 'define-method-combination 
155        'defmethod 'ensure-generic-function 'find-class 'find-method 'function-keywords 
156        'initialize-instance 'make-instance 'make-instances-obsolete 'make-load-form 
157        'make-load-form-saving-slots 'method-qualifiers 'next-method-p 'no-applicable-method 
158        'no-next-method 'reinitialize-instance 'remove-method 'shared-initialize 'slot-boundp 
159        'slot-exists-p 'slot-makunbound 'slot-missing 'slot-unbound 'slot-value 'with-accessors 
160        'with-slots 'unbound-slot-instance 'update-instance-for-different-class 
161        'update-instance-for-redefined-class))
162
163(defParameter *objects*
164  (make-submenu-item "objects" *objects-symbol-list*))
165
166;;; ----------------------------------------------------------------------------
167;;;
168(defParameter *structures-symbol-list*
169  (list 'copy-structure 'defstruct))
170
171(defParameter *structures*
172  (make-submenu-item "structures" *structures-symbol-list*))
173
174;;; ----------------------------------------------------------------------------
175;;;
176(defParameter *conditions-symbol-list*
177  (list 'abort 'assert 'break 'cell-error-name 'cerror 'check-type 'compute-restarts 'continue 
178        'define-condition 'error 'find-restart 'handler-bind 'handler-case 'ignore-errors 
179        'invalid-method-error 'invoke-debugger 'invoke-restart 'invoke-restart-interactively 
180        'make-condition 'method-combination-error 'muffle-warning 'restart-bind 'restart-case 
181        'restart-name 'signal 'simple-condition-format-arguments 'simple-condition-format-control 
182        'store-value 'use-value 'warn 'with-condition-restarts 'with-simple-restart))
183
184(defParameter *conditions*
185  (make-submenu-item "conditions" *conditions-symbol-list*))
186
187;;; ----------------------------------------------------------------------------
188;;;
189(defParameter *symbols-symbol-list*
190  (list 'boundp 'copy-symbol 'gensym 'gentemp 'get 'keywordp 'make-symbol 'makunbound 'set 
191        'symbol-function 'symbol-name 'symbolp 'symbol-package 'symbol-plist 'symbol-value 
192        'remprop))
193
194(defParameter *symbols*
195  (make-submenu-item "symbols" *symbols-symbol-list*))
196
197;;; ----------------------------------------------------------------------------
198;;;
199(defParameter *packages-symbol-list*
200  (list 'defpackage 'delete-package 'do-all-symbols 'do-external-symbols 'do-symbols 'export 
201        'find-all-symbols 'find-package 'find-symbol 'import 'in-package 'intern 
202        'list-all-packages 'make-package 'package-error-package 'package-name 'package-nicknames 
203        'packagep 'package-shadowing-symbols 'package-used-by-list 'package-use-list 
204        'rename-package 'shadow 'shadowing-import 'unexport 'unintern 'unuse-package 
205        'with-package-iterator))
206
207(defParameter *packages*
208  (make-submenu-item "packages" *packages-symbol-list*))
209
210;;; ----------------------------------------------------------------------------
211;;;
212(defParameter *numbers-symbol-list*
213  (list 'abs 'acos 'acosh 'arithmetic-error-operands 'arithmetic-error-operation 'ash 'asin 
214        'asinh 'atan 'atanh 'boole 'byte 'byte-position 'byte-size 'ceiling 'cis 'complex 
215        'complexp 'conjugate 'cos 'cosh 'decf 'decode-float 'denominator 'deposit-field 'dpb 
216        'evenp 'exp 'expt 'fceiling 'ffloor 'float 'float-digits 'floatp 'float-precision 
217        'float-radix 'float-sign 'floor 'fround 'ftruncate 'gcd 'imagpart 'incf 
218        'integer-decode-float 'integer-length 'integerp 'isqrt 'lcm 'ldb 'ldb-test 'log 'logand 
219        'logandc1 'logandc2 'logbitp 'logcount 'logeqv 'logior 'lognand 'lognor 'lognot 'logorc1 
220        'logorc2 'logtest 'logxor 'make-random-state 'mask-field 'max 'min 'minusp 'mod 'numberp 
221        'numerator 'oddp 'parse-integer 'phase 'plusp 'random 'random-state-p 'rational 
222        'rationalize 'rationalp 'realp 'realpart 'rem 'round 'scale-float 'signum 'sin 'sinh 
223        'sqrt 'tan 'tanh 'truncate 'upgraded-complex-part-type 'zerop '= '/= '> '< '<= '>= '* 
224        '+ '- '/ '1+ '1- ))
225
226(defParameter *numbers*
227  (make-submenu-item "numbers" *numbers-symbol-list*))
228
229;;; ----------------------------------------------------------------------------
230;;;
231(defParameter *characters-symbol-list*
232  (list 'alpha-char-p 'both-case-p 'alphanumericp 'character 'characterp 'char-code 
233        'char-downcase 'char-greaterp 'char-equal 'char-int 'char-lessp 'char-name 
234        'char-not-greaterp 'char-not-equal 'char-not-lessp 'char-upcase 'char= 'char/= 
235        'char> 'char< 'char<= 'char>= 'code-char 'digit-char 'digit-char-p 'graphic-char-p 
236        'lower-case-p 'name-char 'standard-char-p 'upper-case-p))
237
238(defParameter *characters*
239  (make-submenu-item "characters" *characters-symbol-list*))
240
241;;; ----------------------------------------------------------------------------
242;;;
243(defParameter *conses-symbol-list*
244  (list 'acons 'adjoin 'append 'assoc 'assoc-if 'assoc-if-not 'atom 'butlast 'nbutlast 'car 'cdr 
245        'cons 'consp 'copy-alist 'copy-list 'copy-tree 'endp 'first 'getf 'get-properties 
246        'intersection 'nintersection 'last 'ldiff 'list 'list-length 'listp 'make-list 'mapc 
247        'mapcan 'mapcar 'mapcon 'mapl 'maplist 'member 'member-if 'member-if-not 'nconc 'nth 
248        'nthcdr 'null 'pairlis 'pop 'push 'pushnew 'rassoc 'rassoc-if 'rassoc-if-not 'remf 'rest 
249        'revappend 'nreconc 'rplaca 'rplacd 'set-difference 'nset-difference 'set-exclusive-or 
250        'nset-exclusive-or 'sublis 'nsublis 'subsetp 'subst 'nsubst 'subst-if 'nsubst-if 
251        'subst-if-not 'nsubst-if-not 'tailp 'tree-equal 'union 'nunion))
252
253(defParameter *conses*
254  (make-submenu-item "conses" *conses-symbol-list*))
255
256;;; ----------------------------------------------------------------------------
257;;;
258(defParameter *arrays-symbol-list*
259  (list  'adjustable-array-p 'adjust-array 'aref 'array-dimension 'array-dimensions 
260         'array-displacement 'array-element-type 'array-has-fill-pointer-p 'array-in-bounds-p 
261         'arrayp 'array-rank 'array-row-major-index 'array-total-size 'bit 'bit-and 'bit-andc1 
262         'bit-andc2 'bit-eqv 'bit-ior 'bit-nand 'bit-nor 'bit-not 'bit-orc1 'bit-orc2 'bit-xor 
263         'bit-vector-p 'fill-pointer 'make-array 'row-major-aref 'sbit 'simple-bit-vector-p 
264         'simple-vector-p 'svref 'upgraded-array-element-type 'vector 'vectorp 'vector-pop 
265         'vector-push 'vector-push-extend))
266
267(defParameter *arrays*
268  (make-submenu-item "arrays" *arrays-symbol-list*))
269
270;;; ----------------------------------------------------------------------------
271;;;
272(defParameter *strings-symbol-list*
273  (list 'char 'make-string 'schar 'simple-string-p 'string 'string-capitalize 'nstring-capitalize 
274        'string-downcase 'nstring-downcase 'string-equal 'string-greaterp 'string-upcase 
275        'nstring-upcase 'string-left-trim 'string-lessp 'string-not-equal 'string-not-greaterp 
276        'string-not-lessp 'stringp 'string-right-trim 'string-trim 'string= 'string/= 'string< 
277        'string> 'string<= 'string>=))
278
279(defParameter *strings*
280  (make-submenu-item "strings" *strings-symbol-list*))
281
282;;; ----------------------------------------------------------------------------
283;;;
284(defParameter *sequences-symbol-list*
285  (list 'concatenate 'copy-seq 'count 'count-if 'elt 'fill 'find 'find-if 'find-if-not 'length 
286        'make-sequence 'map 'map-into 'merge 'mismatch 'position 'position-if 'position-if-not 
287        'reduce 'remove 'delete 'remove-duplicates 'delete-duplicates 'remove-if 'delete-if 
288        'remove-if-not 'delete-if-not 'replace 'reverse 'nreverse 'search 'sort 'stable-sort 
289        'subseq 'substitute 'nsubstitute 'substitute-if 'nsubstitute-if 'substitute-if-not 
290        'nsubstitute-if-not))
291
292(defParameter *sequences*
293  (make-submenu-item "sequences" *sequences-symbol-list*))
294
295;;; ----------------------------------------------------------------------------
296;;;
297(defParameter *hash-tables-symbol-list*
298  (list 'clrhash 'gethash 'hash-table-count 'hash-table-p 'hash-table-rehash-size 'hash-table-rehash-threshold 'hash-table-size 'hash-table-test 'make-hash-table 'maphash 'remhash 'sxhash 'with-hash-table-iterator))
299
300(defParameter *hash-tables*
301  (make-submenu-item "hash tables" *hash-tables-symbol-list*))
302
303;;; ----------------------------------------------------------------------------
304;;;
305(defParameter *filenames-symbol-list*
306  (list 'directory-namestring 'enough-namestring 'file-namestring 'host-namestring 
307        'load-logical-pathname-translations 'logical-pathname 'logical-pathname-translations 
308        'make-pathname 'merge-pathnames 'namestring 'parse-namestring 'pathname 'pathname-host 
309        'pathname-device 'pathname-directory 'pathname-match-p 'pathname-name 'pathnamep 
310        'pathname-type 'pathname-version 'translate-logical-pathname 'translate-pathname 
311        'wild-pathname-p))
312
313(defParameter *filenames*
314  (make-submenu-item "filenames" *filenames-symbol-list*))
315
316;;; ----------------------------------------------------------------------------
317;;;
318(defParameter *files-symbol-list*
319  (list 'delete-file 'directory 'ensure-directories-exist 'file-author 'file-error-pathname 
320        'file-write-date 'probe-file 'rename-file 'truename))
321
322(defParameter *files*
323  (make-submenu-item "files" *files-symbol-list*))
324
325;;; ----------------------------------------------------------------------------
326;;;
327(defParameter *streams-symbol-list*
328  (list 'broadcast-stream-streams 'clear-input 'clear-output 'close 'concatenated-stream-streams 
329        'echo-stream-input-stream 'echo-stream-output-stream 'file-length 'file-position 
330        'file-string-length 'finish-output 'force-output 'fresh-line 'get-output-stream-string 
331        'input-stream-p 'interactive-stream-p 'listen 'make-broadcast-stream 
332        'make-concatenated-stream 'make-echo-stream 'make-string-input-stream 
333        'make-string-output-stream 'make-synonym-stream 'make-two-way-stream 'open 
334        'open-stream-p 'output-stream-p 'peek-char 'read-byte 'read-char 'read-char-no-hang 
335        'read-line 'read-sequence 'stream-element-type 'stream-error-stream 
336        'stream-external-format 'streamp 'synonym-stream-symbol 'terpri 
337        'two-way-stream-input-stream 'two-way-stream-output-stream 'unread-char 
338        'with-input-from-string 'with-open-file 'with-open-stream 'with-output-to-string 
339        'write-byte 'write-char 'write-line 'write-sequence 'write-string 'yes-or-no-p 'y-or-n-p))
340
341(defParameter *streams*
342  (make-submenu-item "streams" *streams-symbol-list*))
343
344;;; ----------------------------------------------------------------------------
345;;;
346(defParameter *printer-symbol-list*
347  (list 'copy-pprint-dispatch 'format 'formatter 'pprint 'pprint-dispatch 
348        'pprint-exit-if-list-exhausted 'pprint-fill 'pprint-indent 'pprint-linear 
349        'pprint-logical-block 'pprint-newline 'pprint-pop 'pprint-tab 'pprint-tabular 'princ 
350        'princ-to-string 'print 'print-object 'print-not-readable-object 'print-unreadable-object 
351        'prin1 'prin1-to-string 'set-pprint-dispatch 'write 'write-to-string))
352
353(defParameter *printer*
354  (make-submenu-item "printer" *printer-symbol-list*))
355
356;;; ----------------------------------------------------------------------------
357;;;
358(defParameter *reader-symbol-list*
359  (list 'copy-readtable 'get-dispatch-macro-character 'get-macro-character 
360        'make-dispatch-macro-character 'read 'read-delimited-list 'read-from-string 
361        'read-preserving-whitespace 'readtable-case 'readtablep 'set-dispatch-macro-character 
362        'set-macro-character 'set-syntax-from-char 'with-standard-io-syntax))
363
364(defParameter *reader*
365  (make-submenu-item "reader" *reader-symbol-list*))
366
367;;; ----------------------------------------------------------------------------
368;;;
369(defParameter *system-construction-symbol-list*
370  (list 'copy-readtable 'get-dispatch-macro-character 'get-macro-character 
371        'make-dispatch-macro-character 'read 'read-delimited-list 'read-from-string 
372        'read-preserving-whitespace 'readtable-case 'readtablep 'set-dispatch-macro-character 
373        'set-macro-character 'set-syntax-from-char 'with-standard-io-syntax))
374
375(defParameter *system-construction*
376  (make-submenu-item "system construction" *system-construction-symbol-list*))
377
378;;; ----------------------------------------------------------------------------
379;;;
380(defParameter *environment-symbol-list*
381  (list 'apropos 'apropos-list 'decode-universal-time 'describe 'describe-object 'disassemble 
382        'documentation 'dribble 'ed 'encode-universal-time 'get-decoded-time 
383        'get-internal-real-time 'get-internal-run-time 'get-universal-time 'inspect 
384        'lisp-implementation-type 'lisp-implementation-version 'long-site-name 'machine-instance 
385        'machine-type 'machine-version 'room 'short-site-name 'sleep 'software-type 
386        'software-version 'step 'time 'trace 'untrace 'user-homedir-pathname))
387
388(defParameter *environment*
389  (make-submenu-item "environment" *environment-symbol-list*))
390
391;;; ----------------------------------------------------------------------------
392;;;
393(defParameter *constants-and-variables-symbol-list*
394  (list 'array-dimension-limit 'array-rank-limit 'array-total-size 'boole-1 '*break-on-signals* 
395        'call-arguments-limit 'char-code-limit '*compile-file-pathname* '*compile-file-truename* 
396        '*compile-print* '*compile-verbose* '*debug-io* '*debugger-hook* 
397        '*default-pathname-defaults* 'short-float-epsilon 'single-float-epsilon 
398        'double-float-epsilon 'long-float-epsilon 'short-float-negative-epsilon 
399        'single-float-negative-epsilon 'double-float-negative-epsilon 
400        'long-float-negative-epsilon '*error-output* '*features* '*gensym-counter* 
401        'internal-time-units-per-second 'lambda-list-keywords 'lambda-parameters-limit 
402        'least-negative-short-float 'least-negative-single-float 'least-negative-double-float 
403        'least-negative-long-float 'least-negative-normalized-short-float 
404        'least-negative-normalized-single-float 'least-negative-normalized-double-float 
405        'least-negative-normalized-long-float 'least-positive-short-float 
406        'least-positive-single-float 'least-positive-double-float 'least-positive-long-float
407        'least-positive-normalized-short-float 'least-positive-normalized-single-float 
408        'least-positive-normalized-double-float 'least-positive-normalized-long-float
409        '*load-pathname* '*load-print* '*load-truename* '*load-verbose* '*macroexpand-hook* 
410        '*modules* 'most-negative-fixnum 'most-negative-short-float 'most-negative-single-float 
411        'most-negative-double-float 'most-negative-long-float 'most-positive-fixnum
412        'most-positive-short-float 'most-positive-single-float 'most-positive-double-float 
413        'most-positive-long-float 'multiple-values-limit 'nil '*package* 'pi '*print-array* 
414        '*print-base* '*print-case* '*print-circle* '*print-escape* '*print-gensym* 
415        '*print-length* '*print-level* '*print-lines* '*print-miser-width* 
416        '*print-pprint-dispatch* '*print-pretty* '*print-radix* '*print-readably* 
417        '*print-right-margin* '*query-io* '*random-state* '*read-base* 
418        '*read-default-float-format* '*read-eval* '*read-suppress* '*readtable* 
419        '*standard-input* '*standard-output* 't '*terminal-io* '*trace-output* 
420        '* '** '*** '+ '++ '+++ '- '/ '// '///))
421
422(defParameter *constants-and-variables*
423  (make-submenu-item "constants and variables" *constants-and-variables-symbol-list*))
424
425;;; ----------------------------------------------------------------------------
426;;;
427(defParameter *type-specifiers-symbol-list*
428  (list 'and 'array 'simple-array 'base-string 'simple-base-string 'bit-vector 'simple-bit-vector 
429        'complex 'cons 'eql 'float 'short-float 'single-float 'double-float 'long-float 'function 
430        'integer 'member 'mod 'not 'or 'rational 'real 'satisfies 'signed-byte 'string 
431        'simple-string 'unsigned-byte 'values 'vector 'simple-vector))
432
433(defParameter *type-specifiers*
434  (make-submenu-item "type specifiers" *type-specifiers-symbol-list*))
435
436;;; ----------------------------------------------------------------------------
437;;;
438(defun add-cl-documentation-submenus (menu)
439  (let ((submenus '(*evaluation-and-compilation* *types-and-classes* 
440                                                 *control-and-data-flow* *iteration* *objects* *structures* 
441                                                 *conditions* *symbols* *packages* *numbers* *characters* 
442                                                 *conses* *arrays* *strings* *sequences* *hash-tables* 
443                                                 *filenames* *files* *streams* *printer* *reader* 
444                                                 *system-construction* *environment* *constants-and-variables* 
445                                                 *type-specifiers*)))
446    (dolist (submenu submenus)
447      (#/addItem: menu (symbol-value submenu)))))
448
449;;; ----------------------------------------------------------------------------
450;;;
451(defParameter *cl-symbol-lists*
452  (list 
453   *evaluation-and-compilation-symbol-list* *types-and-classes-symbol-list* 
454   *control-and-data-flow-symbol-list* *iteration-symbol-list* *objects-symbol-list* 
455   *structures-symbol-list* *conditions-symbol-list* *symbols-symbol-list* *packages-symbol-list* 
456   *numbers-symbol-list* *characters-symbol-list* *conses-symbol-list* *arrays-symbol-list* 
457   *strings-symbol-list* *sequences-symbol-list* *hash-tables-symbol-list* *filenames-symbol-list* 
458   *files-symbol-list* *streams-symbol-list* *printer-symbol-list* *reader-symbol-list* 
459   *system-construction-symbol-list* *environment-symbol-list* 
460   *constants-and-variables-symbol-list* *type-specifiers-symbol-list*))
461
462;;; ----------------------------------------------------------------------------
463;;;
464(defun test-symbol-list (sym-list &optional package)
465  (dolist (sym (rest sym-list))
466    (unless (find-symbol (string-upcase (format nil "~A" sym)) (or package :cl))
467      (format t "~%~A" sym))))
468
469;;; (dolist (list *cl-symbol-lists*) (test-symbol-list list))
470
471(add-cl-documentation-submenus *cl-documentation-menu*)
472
473(defun get-cl-documentation-menu (view event) 
474  (cond ((logtest #$NSCommandKeyMask (#/modifierFlags event))
475         (setf (text-view *cl-alphabetical-menu*) view)           
476         *cl-alphabetical-menu*)
477        (t
478         (setf (text-view *cl-documentation-menu*) view)           
479         *cl-documentation-menu*)))
480
481#-install-cl-doc-as-context-menu
482(defParameter *help-menu* 
483  (#/submenu (#/itemWithTitle: (#/mainMenu (ccl::application-ui-object ccl::*application*)) #@"Help")))
484
485#-install-cl-doc-as-context-menu
486(let ((menu-item (make-instance ns:ns-menu-item)))
487  (#/setTitle: menu-item (ccl::%make-nsstring "Common Lisp, Functional Groups"))
488  (#/setSubmenu: menu-item *cl-documentation-menu*)
489  (#/addItem: *help-menu* menu-item))
490
491#+install-cl-doc-as-context-menu
492(cmenu:register-tool "CL-Documentation-CM" #'get-cl-documentation-menu)
Note: See TracBrowser for help on using the repository browser.