Mercurial > emacs
diff lisp/cedet/srecode/dictionary.el @ 110534:826d60163924
Merge changes from emacs-23 branch.
author | Chong Yidong <cyd@stupidchicken.com> |
---|---|
date | Thu, 23 Sep 2010 22:10:54 -0400 |
parents | 67ff8ad45bd5 |
children | 376148b31b5e |
line wrap: on
line diff
--- a/lisp/cedet/srecode/dictionary.el Fri Sep 24 00:38:10 2010 +0000 +++ b/lisp/cedet/srecode/dictionary.el Thu Sep 23 22:10:54 2010 -0400 @@ -37,6 +37,7 @@ (declare-function srecode-compile-parse-inserter "srecode/compile") (declare-function srecode-dump-code-list "srecode/compile") (declare-function srecode-load-tables-for-mode "srecode/find") +(declare-function srecode-template-table-in-project-p "srecode/find") (declare-function srecode-insert-code-stream "srecode/insert") (declare-function data-debug-new-buffer "data-debug") (declare-function data-debug-insert-object-slots "eieio-datadebug") @@ -157,40 +158,49 @@ If BUFFER-OR-PARENT is t, then this dictionary should not be associated with a buffer or parent." (save-excursion + ;; Handle the parent (let ((parent nil) (buffer nil) (origin nil) (initfrombuff nil)) - (cond ((bufferp buffer-or-parent) - (set-buffer buffer-or-parent) - (setq buffer buffer-or-parent - origin (buffer-name buffer-or-parent) - initfrombuff t)) - ((srecode-dictionary-child-p buffer-or-parent) - (setq parent buffer-or-parent - buffer (oref buffer-or-parent buffer) - origin (concat (object-name buffer-or-parent) " in " - (if buffer (buffer-name buffer) - "no buffer"))) - (when buffer - (set-buffer buffer))) - ((eq buffer-or-parent t) - (setq buffer nil - origin "Unspecified Origin")) - (t - (setq buffer (current-buffer) - origin (concat "Unspecified. Assume " - (buffer-name buffer)) - initfrombuff t) - ) - ) + (cond + ;; Parent is a buffer + ((bufferp buffer-or-parent) + (set-buffer buffer-or-parent) + (setq buffer buffer-or-parent + origin (buffer-name buffer-or-parent) + initfrombuff t)) + + ;; Parent is another dictionary + ((srecode-dictionary-child-p buffer-or-parent) + (setq parent buffer-or-parent + buffer (oref buffer-or-parent buffer) + origin (concat (object-name buffer-or-parent) " in " + (if buffer (buffer-name buffer) + "no buffer"))) + (when buffer + (set-buffer buffer))) + + ;; No parent + ((eq buffer-or-parent t) + (setq buffer nil + origin "Unspecified Origin")) + + ;; Default to unspecified parent + (t + (setq buffer (current-buffer) + origin (concat "Unspecified. Assume " + (buffer-name buffer)) + initfrombuff t))) + + ;; Create the new dictionary object. (let ((dict (srecode-dictionary major-mode - :buffer buffer - :parent parent - :namehash (make-hash-table :test 'equal - :size 20) - :origin origin))) + :buffer buffer + :parent parent + :namehash (make-hash-table :test 'equal + :size 20) + :origin origin))) ;; Only set up the default variables if we are being built ;; directroy for a particular buffer. (when initfrombuff @@ -211,34 +221,37 @@ TPL is an object representing a compiled template file." (when tpl (let ((tabs (oref tpl :tables))) + (require 'srecode/find) ; For srecode-template-table-in-project-p (while tabs - (let ((vars (oref (car tabs) variables))) - (while vars - (srecode-dictionary-set-value - dict (car (car vars)) (cdr (car vars))) - (setq vars (cdr vars)))) - (setq tabs (cdr tabs)))))) + (when (srecode-template-table-in-project-p (car tabs)) + (let ((vars (oref (car tabs) variables))) + (while vars + (srecode-dictionary-set-value + dict (car (car vars)) (cdr (car vars))) + (setq vars (cdr vars))))) + (setq tabs (cdr tabs)))))) (defmethod srecode-dictionary-set-value ((dict srecode-dictionary) name value) "In dictionary DICT, set NAME to have VALUE." ;; Validate inputs - (if (not (stringp name)) - (signal 'wrong-type-argument (list name 'stringp))) + (unless (stringp name) + (signal 'wrong-type-argument (list name 'stringp))) + ;; Add the value. (with-slots (namehash) dict (puthash name value namehash)) ) (defmethod srecode-dictionary-add-section-dictionary ((dict srecode-dictionary) - name &optional show-only) + name &optional show-only force) "In dictionary DICT, add a section dictionary for section macro NAME. Return the new dictionary. -You can add several dictionaries to the same section macro. -For each dictionary added to a macro, the block of codes in the -template will be repeated. +You can add several dictionaries to the same section entry. +For each dictionary added to a variable, the block of codes in +the template will be repeated. If optional argument SHOW-ONLY is non-nil, then don't add a new dictionary if there is already one in place. Also, don't add FIRST/LAST entries. @@ -255,10 +268,11 @@ Adding a new dictionary will alter these values in previously inserted dictionaries." ;; Validate inputs - (if (not (stringp name)) - (signal 'wrong-type-argument (list name 'stringp))) + (unless (stringp name) + (signal 'wrong-type-argument (list name 'stringp))) + (let ((new (srecode-create-dictionary dict)) - (ov (srecode-dictionary-lookup-name dict name))) + (ov (srecode-dictionary-lookup-name dict name t))) (when (not show-only) ;; Setup the FIRST/NOTFIRST and LAST/NOTLAST entries. @@ -275,7 +289,9 @@ (srecode-dictionary-show-section new "LAST")) ) - (when (or (not show-only) (null ov)) + (when (or force + (not show-only) + (null ov)) (srecode-dictionary-set-value dict name (append ov (list new)))) ;; Return the new sub-dictionary. new)) @@ -283,8 +299,9 @@ (defmethod srecode-dictionary-show-section ((dict srecode-dictionary) name) "In dictionary DICT, indicate that the section NAME should be exposed." ;; Validate inputs - (if (not (stringp name)) - (signal 'wrong-type-argument (list name 'stringp))) + (unless (stringp name) + (signal 'wrong-type-argument (list name 'stringp))) + ;; Showing a section is just like making a section dictionary, but ;; with no dictionary values to add. (srecode-dictionary-add-section-dictionary dict name t) @@ -294,51 +311,120 @@ "In dictionary DICT, indicate that the section NAME should be hidden." ;; We need to find the has value, and then delete it. ;; Validate inputs - (if (not (stringp name)) - (signal 'wrong-type-argument (list name 'stringp))) + (unless (stringp name) + (signal 'wrong-type-argument (list name 'stringp))) + ;; Add the value. (with-slots (namehash) dict (remhash name namehash)) nil) -(defmethod srecode-dictionary-merge ((dict srecode-dictionary) otherdict) - "Merge into DICT the dictionary entries from OTHERDICT." +(defmethod srecode-dictionary-add-entries ((dict srecode-dictionary) + entries &optional state) + "Add ENTRIES to DICT. + +ENTRIES is a list of even length of dictionary entries to +add. ENTRIES looks like this: + + (NAME_1 VALUE_1 NAME_2 VALUE_2 ...) + +The following rules apply: + * NAME_N is a string +and for values + * If VALUE_N is t, the section NAME_N is shown. + * If VALUE_N is a string, an ordinary value is inserted. + * If VALUE_N is a dictionary, it is inserted as entry NAME_N. + * Otherwise, a compound variable is created for VALUE_N. + +The optional argument STATE has to non-nil when compound values +are inserted. An error is signaled if ENTRIES contains compound +values but STATE is nil." + (while entries + (let ((name (nth 0 entries)) + (value (nth 1 entries))) + (cond + ;; Value is t; show a section. + ((eq value t) + (srecode-dictionary-show-section dict name)) + + ;; Value is a simple string; create an ordinary dictionary + ;; entry + ((stringp value) + (srecode-dictionary-set-value dict name value)) + + ;; Value is a dictionary; insert as child dictionary. + ((srecode-dictionary-child-p value) + (srecode-dictionary-merge + (srecode-dictionary-add-section-dictionary dict name) + value t)) + + ;; Value is some other object; create a compound value. + (t + (unless state + (error "Cannot insert compound values without state.")) + + (srecode-dictionary-set-value + dict name + (srecode-dictionary-compound-variable + name :value value :state state))))) + (setq entries (nthcdr 2 entries))) + dict) + +(defmethod srecode-dictionary-merge ((dict srecode-dictionary) otherdict + &optional force) + "Merge into DICT the dictionary entries from OTHERDICT. +Unless the optional argument FORCE is non-nil, values in DICT are +not modified, even if there are values of the same names in +OTHERDICT." (when otherdict (maphash (lambda (key entry) - ;; Only merge in the new values if there was no old value. + ;; The new values is only merged in if there was no old value + ;; or FORCE is non-nil. + ;; ;; This protects applications from being whacked, and basically ;; makes these new section dictionary entries act like ;; "defaults" instead of overrides. - (when (not (srecode-dictionary-lookup-name dict key)) - (cond ((and (listp entry) (srecode-dictionary-p (car entry))) - ;; A list of section dictionaries. - ;; We need to merge them in. - (while entry - (let ((new-sub-dict - (srecode-dictionary-add-section-dictionary - dict key))) - (srecode-dictionary-merge new-sub-dict (car entry))) - (setq entry (cdr entry))) - ) + (when (or force + (not (srecode-dictionary-lookup-name dict key t))) + (cond + ;; A list of section dictionaries. We need to merge them in. + ((and (listp entry) + (srecode-dictionary-p (car entry))) + (dolist (sub-dict entry) + (srecode-dictionary-merge + (srecode-dictionary-add-section-dictionary + dict key t t) + sub-dict force))) - (t - (srecode-dictionary-set-value dict key entry))) - )) + ;; Other values can be set directly. + (t + (srecode-dictionary-set-value dict key entry))))) (oref otherdict namehash)))) (defmethod srecode-dictionary-lookup-name ((dict srecode-dictionary) - name) - "Return information about the current DICT's value for NAME." + name &optional non-recursive) + "Return information about DICT's value for NAME. +DICT is a dictionary, and NAME is a string that is treated as the +name of an entry in the dictionary. If such an entry exists, its +value is returned. Otherwise, nil is returned. Normally, the +lookup is recursive in the sense that the parent of DICT is +searched for NAME if it is not found in DICT. This recursive +lookup can be disabled by the optional argument NON-RECURSIVE. + +This function derives values for some special NAMEs, such as +'FIRST' and 'LAST'." (if (not (slot-boundp dict 'namehash)) nil - ;; Get the value of this name from the dictionary - (or (with-slots (namehash) dict - (gethash name namehash)) - (and (not (member name '("FIRST" "LAST" "NOTFIRST" "NOTLAST"))) - (oref dict parent) - (srecode-dictionary-lookup-name (oref dict parent) name)) - ))) + ;; Get the value of this name from the dictionary or its parent + ;; unless the lookup should be non-recursive. + (with-slots (namehash parent) dict + (or (gethash name namehash) + (and (not non-recursive) + (not (member name '("FIRST" "LAST" "NOTFIRST" "NOTLAST"))) + parent + (srecode-dictionary-lookup-name parent name))))) + ) (defmethod srecode-root-dictionary ((dict srecode-dictionary)) "For dictionary DICT, return the root dictionary. @@ -431,10 +517,22 @@ (start (point)) (name (oref sti :object-name))) - (if (or (not dv) (string= dv "")) - (insert name) - (insert dv)) + (cond + ;; No default value. + ((not dv) (insert name)) + ;; A compound value as the default? Recurse. + ((srecode-dictionary-compound-value-child-p dv) + (srecode-compound-toString dv function dictionary)) + ;; A string that is empty? Use the name. + ((and (stringp dv) (string= dv "")) + (insert name)) + ;; Insert strings + ((stringp dv) (insert dv)) + ;; Some other issue + (t + (error "Unknown default value for value %S" name))) + ;; Create a field from the inserter. (srecode-field name :name name :start start :end (point) @@ -482,6 +580,53 @@ (setq sectiondicts (cdr sectiondicts))) new))) +(defun srecode-create-dictionaries-from-tags (tags state) + "Create a dictionary with entries according to TAGS. + +TAGS should be in the format produced by the template file +grammar. That is + +TAGS = (ENTRY_1 ENTRY_2 ...) + +where + +ENTRY_N = (NAME ENTRY_N_1 ENTRY_N_2 ...) | TAG + +where TAG is a semantic tag of class 'variable. The (NAME ... ) +form creates a child dictionary which is stored under the name +NAME. The TAG form creates a value entry or section dictionary +entry whose name is the name of the tag. + +STATE is the current compiler state." + (let ((dict (srecode-create-dictionary t)) + (entries (apply #'append + (mapcar + (lambda (entry) + (cond + ;; Entry is a tag + ((semantic-tag-p entry) + (let ((name (semantic-tag-name entry)) + (value (semantic-tag-variable-default entry))) + (list name + (if (and (listp value) + (= (length value) 1) + (stringp (car value))) + (car value) + value)))) + + ;; Entry is a nested dictionary + (t + (let ((name (car entry)) + (entries (cdr entry))) + (list name + (srecode-create-dictionaries-from-tags + entries state)))))) + tags)))) + (srecode-dictionary-add-entries + dict entries state) + dict) + ) + ;;; DUMP DICTIONARY ;; ;; Make a dictionary, and dump it's contents.