+;;; ------------------------------------------------------------------------
+;;; Stucture parsing code, and code to manage class info
+
+;;
+;; - Go again over the documentation how to write a completion
+;; plugin. It is in self.el, but currently still very bad.
+;; This could be in a separate file in the distribution, or
+;; in an appendix for the manual.
+
+(defvar idlwave-struct-skip
+ "[ \t]*\\(\\$.*\n\\(^[ \t]*\\(\\$[ \t]*\\)?\\(;.*\\)?\n\\)*\\)?[ \t]*"
+ "Regexp for skipping continued blank or comment-only lines in
+structures")
+
+(defvar idlwave-struct-tag-regexp
+ (concat "[{,]" ;leading comma/brace
+ idlwave-struct-skip ; 4 groups
+ "\\([a-zA-Z][a-zA-Z0-9_]*\\)" ;the tag itself, group 5
+ "[ \t]*:") ; the final colon
+ "Regexp for structure tags.")
+
+(defun idlwave-struct-tags ()
+ "Return a list of all tags in the structure defined at point.
+Point is expected just before the opening `{' of the struct definition."
+ (save-excursion
+ (let* ((borders (idlwave-struct-borders))
+ (beg (car borders))
+ (end (cdr borders))
+ tags)
+ (goto-char beg)
+ (save-restriction
+ (narrow-to-region beg end)
+ (while (re-search-forward idlwave-struct-tag-regexp end t)
+ ;; Check if we are still on the top level of the structure.
+ (if (and (condition-case nil (progn (up-list -1) t) (error nil))
+ (= (point) beg))
+ (push (match-string-no-properties 5) tags))
+ (goto-char (match-end 0))))
+ (nreverse tags))))
+
+(defun idlwave-find-struct-tag (tag)
+ "Find a given TAG in the structure defined at point."
+ (let* ((borders (idlwave-struct-borders))
+ (beg (car borders))
+ (end (cdr borders))
+ (case-fold-search t))
+ (re-search-forward (concat "\\(^[ \t]*\\|[,{][ \t]*\\)" tag "[ \t]*:")
+ end t)))
+
+(defun idlwave-struct-inherits ()
+ "Return a list of all `inherits' names in the struct at point.
+Point is expected just before the opening `{' of the struct definition."
+ (save-excursion
+ (let* ((borders (idlwave-struct-borders))
+ (beg (car borders))
+ (end (cdr borders))
+ (case-fold-search t)
+ names)
+ (goto-char beg)
+ (save-restriction
+ (narrow-to-region beg end)
+ (while (re-search-forward
+ (concat "[{,]" ;leading comma/brace
+ idlwave-struct-skip ; 4 groups
+ "inherits" ; The INHERITS tag
+ idlwave-struct-skip ; 4 more
+ "\\([a-zA-Z][a-zA-Z0-9_]*\\)") ; The super-group, #9
+ end t)
+ ;; Check if we are still on the top level of the structure.
+ (if (and (condition-case nil (progn (up-list -1) t) (error nil))
+ (= (point) beg))
+ (push (match-string-no-properties 9) names))
+ (goto-char (match-end 0))))
+ (nreverse names))))
+
+(defun idlwave-in-structure ()
+ "Return t if point is inside an IDL structure definition."
+ (let ((beg (point)))
+ (save-excursion
+ (if (not (or (idlwave-in-comment) (idlwave-in-quote)))
+ (if (idlwave-find-structure-definition nil nil 'back)
+ (let ((borders (idlwave-struct-borders)))
+ (or (= (car borders) (cdr borders)) ;; struct not yet closed...
+ (and (> beg (car borders)) (< beg (cdr borders))))))))))
+
+(defun idlwave-struct-borders ()
+ "Return the borders of the {...} after point as a cons cell."
+ (let (beg)
+ (save-excursion
+ (skip-chars-forward "^{")
+ (setq beg (point))
+ (condition-case nil (forward-list 1)
+ (error (goto-char beg)))
+ (cons beg (point)))))
+
+(defun idlwave-find-structure-definition (&optional var name bound)
+ "Search forward for a structure definition. If VAR is non-nil,
+search for a structure assigned to variable VAR. If NAME is non-nil,
+search for a named structure NAME, if a string, or a generic named
+structure otherwise. If BOUND is an integer, limit the search. If
+BOUND is the symbol `all', we search first back and then forward
+through the entire file. If BOUND is the symbol `back' we search only
+backward."
+ (let* ((ws "[ \t]*\\(\\$.*\n[ \t]*\\)*")
+ (case-fold-search t)
+ (lim (if (integerp bound) bound nil))
+ (re (concat
+ (if var
+ (concat "\\<" (regexp-quote (downcase var)) "\\>" ws)
+ "\\(\\)")
+ "=" ws "\\({\\)"
+ (if name
+ (if (stringp name)
+ (concat ws "\\(\\<" (downcase name) "\\)[^a-zA-Z0-9_$]")
+ ;; Just a generic name
+ (concat ws "\\<\\([a-zA-Z_0-9$]+\\)" ws ","))
+ ""))))
+ (if (or (and (or (eq bound 'all) (eq bound 'back))
+ (re-search-backward re nil t))
+ (and (not (eq bound 'back)) (re-search-forward re lim t)))
+ (progn
+ (goto-char (match-beginning 3))
+ (match-string-no-properties 5)))))
+
+(defvar idlwave-class-info nil)
+(defvar idlwave-class-reset nil) ; to reset buffer-local classes
+
+(add-hook 'idlwave-update-rinfo-hook
+ (lambda () (setq idlwave-class-reset t)))
+(add-hook 'idlwave-after-load-rinfo-hook
+ (lambda () (setq idlwave-class-info nil)))
+
+(defun idlwave-class-info (class)
+ (let (list entry)
+ (if idlwave-class-info
+ (if idlwave-class-reset
+ (setq
+ idlwave-class-reset nil
+ idlwave-class-info ; Remove any visited in a buffer
+ (delq nil (mapcar
+ (lambda (x)
+ (let ((filebuf
+ (idlwave-class-file-or-buffer
+ (or (cdr (assq 'found-in x)) (car x)))))
+ (if (cdr filebuf)
+ nil
+ x)))
+ idlwave-class-info))))
+ ;; Info is nil, put in the system stuff to start.
+ (setq idlwave-class-info idlwave-system-class-info)
+ (setq list idlwave-class-info)
+ (while (setq entry (pop list))
+ (idlwave-sintern-class-info entry)))
+ (setq class (idlwave-sintern-class class))
+ (or (assq class idlwave-class-info)
+ (progn (idlwave-scan-class-info class)
+ (assq class idlwave-class-info)))))
+
+(defun idlwave-sintern-class-info (entry)
+ "Sintern the class names in a class-info entry."
+ (let ((taglist (assq 'tags entry))
+ (inherits (assq 'inherits entry)))
+ (setcar entry (idlwave-sintern-class (car entry) 'set))
+ (if inherits
+ (setcdr inherits (mapcar (lambda (x) (idlwave-sintern-class x 'set))
+ (cdr inherits))))))
+
+(defun idlwave-find-class-definition (class &optional all-hook alt-class)
+ "Find class structure definition(s)
+If ALL-HOOK is set, find all named structure definitions in a given
+class__define routine, on which ALL-HOOK will be run. If ALT-CLASS is
+set, look for the name__define pro, and inside of it, for the ALT-CLASS
+class/struct definition"
+ (let ((case-fold-search t) end-lim list name)
+ (when (re-search-forward
+ (concat "^[ \t]*pro[ \t]+" (downcase class) "__define" "\\>") nil t)
+ (if all-hook
+ (progn
+ ;; For everything there
+ (setq end-lim (save-excursion (idlwave-end-of-subprogram) (point)))
+ (while (setq name
+ (idlwave-find-structure-definition nil t end-lim))
+ (funcall all-hook name)))
+ (idlwave-find-structure-definition nil (or alt-class class))))))
+
+
+(defun idlwave-class-file-or-buffer (class)
+ "Find buffer visiting CLASS definition"
+ (let* ((pro (concat (downcase class) "__define"))
+ (file (idlwave-routine-source-file
+ (nth 3 (idlwave-rinfo-assoc pro 'pro nil
+ (idlwave-routines))))))
+ (cons file (if file (idlwave-get-buffer-visiting file)))))
+
+
+(defun idlwave-scan-class-info (class)
+ "Scan all class and named structure info in the class__define pro"
+ (let* ((idlwave-auto-routine-info-updates nil)
+ (filebuf (idlwave-class-file-or-buffer class))
+ (file (car filebuf))
+ (buf (cdr filebuf))
+ (class (idlwave-sintern-class class)))
+ (if (or
+ (not file)
+ (and ;; neither a regular file nor a visited buffer
+ (not buf)
+ (not (file-regular-p file))))
+ nil ; Cannot find the file/buffer to get any info
+ (save-excursion
+ (if buf (set-buffer buf)
+ ;; Read the file in temporarily
+ (set-buffer (get-buffer-create " *IDLWAVE-tmp*"))
+ (erase-buffer)
+ (unless (eq major-mode 'idlwave-mode)
+ (idlwave-mode))
+ (insert-file-contents file))
+ (save-excursion
+ (goto-char 1)
+ (idlwave-find-class-definition class
+ ;; Scan all of the structures found there
+ (lambda (name)
+ (let* ((this-class (idlwave-sintern-class name))
+ (entry
+ (list this-class
+ (cons 'tags (idlwave-struct-tags))
+ (cons 'inherits (idlwave-struct-inherits)))))
+ (if (not (eq this-class class))
+ (setq entry (nconc entry (list (cons 'found-in class)))))
+ (idlwave-sintern-class-info entry)
+ (push entry idlwave-class-info)))))))))
+
+(defun idlwave-class-found-in (class)
+ "Return the FOUND-IN property of the class."
+ (cdr (assq 'found-in (idlwave-class-info class))))
+(defun idlwave-class-tags (class)
+ "Return the native tags in CLASS."
+ (cdr (assq 'tags (idlwave-class-info class))))
+(defun idlwave-class-inherits (class)
+ "Return the direct superclasses of CLASS."
+ (cdr (assq 'inherits (idlwave-class-info class))))
+
+
+(defun idlwave-all-class-tags (class)
+ "Return a list of native and inherited tags in CLASS."
+ (condition-case err
+ (apply 'append (mapcar 'idlwave-class-tags
+ (cons class (idlwave-all-class-inherits class))))
+ (error
+ (idlwave-class-tag-reset)
+ (error "%s" (error-message-string err)))))
+
+
+(defun idlwave-all-class-inherits (class)
+ "Return a list of all superclasses of CLASS (recursively expanded).
+The list is cached in `idlwave-class-info' for faster access."
+ (cond
+ ((not idlwave-support-inheritance) nil)
+ ((eq class nil) nil)
+ ((eq class t) nil)
+ (t
+ (let ((info (idlwave-class-info class))
+ entry)
+ (if (setq entry (assq 'all-inherits info))
+ (cdr entry)
+ ;; Save the depth of inheritance scan to check for circular references
+ (let ((inherits (mapcar (lambda (x) (cons x 0))
+ (idlwave-class-inherits class)))
+ rtn all-inherits cl)
+ (while inherits
+ (setq cl (pop inherits)
+ rtn (cons (car cl) rtn)
+ inherits (append (mapcar (lambda (x)
+ (cons x (1+ (cdr cl))))
+ (idlwave-class-inherits (car cl)))
+ inherits))
+ (if (> (cdr cl) 999)
+ (error
+ "Class scan: inheritance depth exceeded. Circular inheritance?")
+ ))
+ (setq all-inherits (nreverse rtn))
+ (nconc info (list (cons 'all-inherits all-inherits)))
+ all-inherits))))))
+
+(defun idlwave-entry-keywords (entry &optional record-link)
+ "Return the flat entry keywords alist from routine-info entry.
+If RECORD-LINK is non-nil, the keyword text is copied and a text
+property indicating the link is added."
+ (let (kwds)
+ (mapcar
+ (lambda (key-list)
+ (let ((file (car key-list)))
+ (mapcar (lambda (key-cons)
+ (let ((key (car key-cons))
+ (link (cdr key-cons)))
+ (when (and record-link file)
+ (setq key (copy-sequence key))
+ (put-text-property
+ 0 (length key)
+ 'link
+ (concat
+ file
+ (if link
+ (concat idlwave-html-link-sep
+ (number-to-string link))))
+ key))
+ (push (list key) kwds)))
+ (cdr key-list))))
+ (nthcdr 5 entry))
+ (nreverse kwds)))
+
+(defun idlwave-entry-find-keyword (entry keyword)
+ "Find keyword KEYWORD in entry ENTRY, and return (with link) if set"
+ (catch 'exit
+ (mapc
+ (lambda (key-list)
+ (let ((file (car key-list))
+ (kwd (assoc keyword (cdr key-list))))
+ (when kwd
+ (setq kwd (cons (car kwd)
+ (if (and file (cdr kwd))
+ (concat file
+ idlwave-html-link-sep
+ (number-to-string (cdr kwd)))
+ (cdr kwd))))
+ (throw 'exit kwd))))
+ (nthcdr 5 entry))))
+
+;;==========================================================================
+;;
+;; Completing class structure tags. This is a completion plugin.
+;; The necessary taglist is constructed dynamically
+
+(defvar idlwave-current-tags-class nil)
+(defvar idlwave-current-class-tags nil)
+(defvar idlwave-current-native-class-tags nil)
+(defvar idlwave-sint-class-tags nil)
+(idlwave-new-sintern-type 'class-tag)
+(add-to-list 'idlwave-complete-special 'idlwave-complete-class-structure-tag)
+(add-hook 'idlwave-update-rinfo-hook 'idlwave-class-tag-reset)
+
+(defun idlwave-complete-class-structure-tag ()
+ "Complete a structure tag on a `self' argument in an object method."
+ (interactive)
+ (let ((pos (point))
+ (case-fold-search t))
+ (if (save-excursion
+ ;; Check if the context is right
+ (skip-chars-backward "a-zA-Z0-9._$")
+ (and (< (point) (- pos 4))
+ (looking-at "self\\.")))
+ (let* ((class-selector (nth 2 (idlwave-current-routine)))
+ (super-classes (idlwave-all-class-inherits class-selector)))
+ ;; Check if we are in a class routine
+ (unless class-selector
+ (error "Not in a method procedure or function"))
+ ;; Check if we need to update the "current" class
+ (if (not (equal class-selector idlwave-current-tags-class))
+ (idlwave-prepare-class-tag-completion class-selector))
+ (setq idlwave-completion-help-info
+ (list 'idlwave-complete-class-structure-tag-help
+ (idlwave-sintern-routine
+ (concat class-selector "__define"))
+ nil))
+ (let ((idlwave-cpl-bold idlwave-current-native-class-tags))
+ (idlwave-complete-in-buffer
+ 'class-tag 'class-tag
+ idlwave-current-class-tags nil
+ (format "Select a tag of class %s" class-selector)
+ "class tag"
+ 'idlwave-attach-class-tag-classes))
+ t) ; return t to skip other completions
+ nil)))
+
+(defun idlwave-class-tag-reset ()
+ (setq idlwave-current-tags-class nil))
+
+(defun idlwave-prepare-class-tag-completion (class)
+ "Find and parse the necessary class definitions for class structure tags."
+ (setq idlwave-sint-class-tags nil)
+ (setq idlwave-current-tags-class class)
+ (setq idlwave-current-class-tags
+ (mapcar (lambda (x)
+ (list (idlwave-sintern-class-tag x 'set)))
+ (idlwave-all-class-tags class)))
+ (setq idlwave-current-native-class-tags
+ (mapcar 'downcase (idlwave-class-tags class))))
+
+;===========================================================================
+;;
+;; Completing system variables and their structure fields
+;; This is also a plugin.
+
+(defvar idlwave-sint-sysvars nil)
+(defvar idlwave-sint-sysvartags nil)
+(idlwave-new-sintern-type 'sysvar)
+(idlwave-new-sintern-type 'sysvartag)
+(add-to-list 'idlwave-complete-special 'idlwave-complete-sysvar-or-tag)
+(add-hook 'idlwave-update-rinfo-hook 'idlwave-sysvars-reset)
+(add-hook 'idlwave-after-load-rinfo-hook 'idlwave-sintern-sysvar-alist)
+
+
+(defun idlwave-complete-sysvar-or-tag ()
+ "Complete a system variable."
+ (interactive)
+ (let ((pos (point))
+ (case-fold-search t))
+ (cond ((save-excursion
+ ;; Check if the context is right for system variable
+ (skip-chars-backward "[a-zA-Z0-9_$]")
+ (equal (char-before) ?!))
+ (setq idlwave-completion-help-info '(idlwave-complete-sysvar-help))
+ (idlwave-complete-in-buffer 'sysvar 'sysvar
+ idlwave-system-variables-alist nil
+ "Select a system variable"
+ "system variable")
+ t) ; return t to skip other completions
+ ((save-excursion
+ ;; Check if the context is right for sysvar tag
+ (skip-chars-backward "a-zA-Z0-9_$.")
+ (and (equal (char-before) ?!)
+ (looking-at "\\([a-zA-Z][a-zA-Z0-9_$]*\\)\\.")
+ (<= (match-end 0) pos)))
+ ;; Complete a system variable tag
+ (let* ((var (idlwave-sintern-sysvar (match-string 1)))
+ (entry (assq var idlwave-system-variables-alist))
+ (tags (cdr (assq 'tags entry))))
+ (or entry (error "!%s is not a known system variable" var))
+ (or tags (error "System variable !%s is not a structure" var))
+ (setq idlwave-completion-help-info
+ (list 'idlwave-complete-sysvar-tag-help var))
+ (idlwave-complete-in-buffer 'sysvartag 'sysvartag
+ tags nil
+ "Select a system variable tag"
+ "system variable tag")
+ t)) ; return t to skip other completions
+ (t nil))))
+
+(defvar link) ;dynamic variables set by help callback
+(defvar props)
+(defun idlwave-complete-sysvar-help (mode word)
+ (let ((word (or (nth 1 idlwave-completion-help-info) word))
+ (entry (assoc word idlwave-system-variables-alist)))
+ (cond
+ ((eq mode 'test)
+ (and (stringp word) entry (nth 1 (assq 'link entry))))
+ ((eq mode 'set)
+ (if entry (setq link (nth 1 (assq 'link entry))))) ;; setting dynamic!!!
+ (t (error "This should not happen")))))
+
+(defun idlwave-complete-sysvar-tag-help (mode word)
+ (let* ((var (nth 1 idlwave-completion-help-info))
+ (entry (assoc var idlwave-system-variables-alist))
+ (tags (cdr (assq 'tags entry)))
+ (main (nth 1 (assq 'link entry)))
+ target main-base)
+ (cond
+ ((eq mode 'test) ; we can at least link the main
+ (and (stringp word) entry main))
+ ((eq mode 'set)
+ (if entry
+ (setq link
+ (if (setq target (cdr (assoc word tags)))
+ (idlwave-substitute-link-target main target)
+ main)))) ;; setting dynamic!!!
+ (t (error "This should not happen")))))
+
+(defun idlwave-split-link-target (link)
+ "Split a given link into link file and anchor."
+ (if (string-match idlwave-html-link-sep link)
+ (cons (substring link 0 (match-beginning 0))
+ (string-to-number (substring link (match-end 0))))))
+
+(defun idlwave-substitute-link-target (link target)
+ "Substitute the target anchor for the given link."
+ (let (main-base)
+ (setq main-base (if (string-match "#" link)
+ (substring link 0 (match-beginning 0))
+ link))
+ (if target
+ (concat main-base idlwave-html-link-sep (number-to-string target))
+ link)))
+
+;; Fake help in the source buffer for class structure tags.
+;; KWD AND NAME ARE GLOBAL-VARIABLES HERE.
+(defvar name)
+(defvar kwd)
+(defvar idlwave-help-do-class-struct-tag nil)
+(defun idlwave-complete-class-structure-tag-help (mode word)
+ (cond
+ ((eq mode 'test) ; nothing gets fontified for class tags
+ nil)
+ ((eq mode 'set)
+ (let (class-with found-in)
+ (when (setq class-with
+ (idlwave-class-or-superclass-with-tag
+ idlwave-current-tags-class
+ word))
+ (if (assq (idlwave-sintern-class class-with)
+ idlwave-system-class-info)
+ (error "No help available for system class tags"))
+ (if (setq found-in (idlwave-class-found-in class-with))
+ (setq name (cons (concat found-in "__define") class-with))
+ (setq name (concat class-with "__define")))))
+ (setq kwd word
+ idlwave-help-do-class-struct-tag t))
+ (t (error "This should not happen"))))
+
+(defun idlwave-class-or-superclass-with-tag (class tag)
+ "Find and return the CLASS or one of its superclass with the
+associated TAG, if any."
+ (let ((sclasses (cons class (cdr (assq 'all-inherits
+ (idlwave-class-info class)))))
+ cl)
+ (catch 'exit
+ (while sclasses
+ (setq cl (pop sclasses))
+ (let ((tags (idlwave-class-tags cl)))
+ (while tags
+ (if (eq t (compare-strings tag 0 nil (car tags) 0 nil t))
+ (throw 'exit cl))
+ (setq tags (cdr tags))))))))
+
+
+(defun idlwave-sysvars-reset ()
+ (if (and (fboundp 'idlwave-shell-is-running)
+ (idlwave-shell-is-running)
+ idlwave-idlwave_routine_info-compiled)
+ (idlwave-shell-send-command "idlwave_get_sysvars"
+ 'idlwave-process-sysvars 'hide)))
+
+(defun idlwave-process-sysvars ()
+ (idlwave-shell-filter-sysvars)
+ (setq idlwave-sint-sysvars nil
+ idlwave-sint-sysvartags nil)
+ (idlwave-sintern-sysvar-alist))
+
+(defun idlwave-sintern-sysvar-alist ()
+ (let ((list idlwave-system-variables-alist) entry tags)
+ (while (setq entry (pop list))
+ (setcar entry (idlwave-sintern-sysvar (car entry) 'set))
+ (setq tags (assq 'tags entry))
+ (if tags
+ (setcdr tags
+ (mapcar (lambda (x)
+ (cons (idlwave-sintern-sysvartag (car x) 'set)
+ (cdr x)))
+ (cdr tags)))))))
+
+(defvar idlwave-shell-command-output)
+(defun idlwave-shell-filter-sysvars ()
+ "Get any new system variables and tags."
+ (let ((text idlwave-shell-command-output)
+ (start 0)
+ (old idlwave-system-variables-alist)
+ var tags type name class link old-entry)
+ (setq idlwave-system-variables-alist nil)
+ (while (string-match "^IDLWAVE-SYSVAR: !\\([a-zA-Z0-9_$]+\\)\\( \\(.*\\)\\)?"
+ text start)
+ (setq start (match-end 0)
+ var (match-string 1 text)
+ tags (if (match-end 3)
+ (idlwave-split-string (match-string 3 text))))
+ ;; Maintain old links, if present
+ (setq old-entry (assq (idlwave-sintern-sysvar var) old))
+ (setq link (assq 'link old-entry))
+ (setq idlwave-system-variables-alist
+ (cons (list var
+ (cons
+ 'tags
+ (mapcar (lambda (x)
+ (cons x
+ (cdr (assq
+ (idlwave-sintern-sysvartag x)
+ (cdr (assq 'tags old-entry))))))
+ tags)) link)
+ idlwave-system-variables-alist)))
+ ;; Keep the old value if query was not successful
+ (setq idlwave-system-variables-alist
+ (or idlwave-system-variables-alist old))))
+