+(defvar idlwave-library-routines nil "Obsolete variable.")
+
+;;------ XML Help routine info system
+(defun idlwave-load-system-routine-info ()
+ ;; Load the system routine info from the cached routine info file,
+ ;; which, if necessary, will be re-created from the XML file on
+ ;; disk. As a last fallback, load the (likely outdated) idlw-rinfo
+ ;; file distributed with older IDLWAVE versions (<6.0)
+ (unless (and (load idlwave-xml-system-rinfo-converted-file
+ 'noerror 'nomessage)
+ (idlwave-xml-system-routine-info-up-to-date))
+ ;; See if we can create it from XML source
+ (condition-case nil
+ (idlwave-convert-xml-system-routine-info)
+ (error
+ (unless (load idlwave-xml-system-rinfo-converted-file
+ 'noerror 'nomessage)
+ (if idlwave-system-routines
+ (message
+ "Failed to load converted routine info, using old conversion.")
+ (message
+ "Failed to convert XML routine info, falling back on idlw-rinfo.")
+ (if (not (load "idlw-rinfo" 'noerror 'nomessage))
+ (message
+ "Could not locate any system routine information."))))))))
+
+(defun idlwave-xml-system-routine-info-up-to-date()
+ (let* ((dir (file-name-as-directory
+ (expand-file-name "help/online_help" (idlwave-sys-dir))))
+ (catalog-file (expand-file-name "idl_catalog.xml" dir)))
+ (file-newer-than-file-p ;converted file is newer than catalog
+ idlwave-xml-system-rinfo-converted-file
+ catalog-file)))
+
+(defvar idlwave-system-class-info nil) ; Gathered from idlw-rinfo
+(defvar idlwave-system-variables-alist nil
+ "Alist of system variables and the associated structure tags.
+Gets set in cached XML rinfo, or `idlw-rinfo.el'.")
+(defvar idlwave-executive-commands-alist nil
+ "Alist of system variables and their help files.")
+(defvar idlwave-help-special-topic-words nil)
+
+
+(defun idlwave-shorten-syntax (syntax name &optional class)
+ ;; From a list of syntax statments, shorten with %s and group with "or"
+ (let ((case-fold-search t))
+ (mapconcat
+ (lambda (x)
+ (while (string-match name x)
+ (setq x (replace-match "%s" t t x)))
+ (if class
+ (while (string-match class x)
+ (setq x (replace-match "%s" t t x))))
+ x)
+ (nreverse syntax)
+ " or ")))
+
+(defun idlwave-xml-create-class-method-lists (xml-entry)
+ ;; Create a class list entry from the xml parsed list., returning a
+ ;; cons of form (class-entry method-entries).
+ (let* ((nameblock (nth 1 xml-entry))
+ (class (cdr (assq 'name nameblock)))
+ (link (cdr (assq 'link nameblock)))
+ (params (cddr xml-entry))
+ (case-fold-search t)
+ class-entry
+ method methods-entry extra-kwds
+ props get-props set-props init-props inherits
+ pelem ptype)
+ (while params
+ (setq pelem (car params))
+ (when (listp pelem)
+ (setq ptype (car pelem)
+ props (car (cdr pelem)))
+ (cond
+ ((eq ptype 'SUPERCLASS)
+ (let ((pname (cdr (assq 'name props)))
+ (plink (cdr (assq 'link props))))
+ (unless (and (string= pname "None")
+ (string= plink "None"))
+ (push pname inherits))))
+
+ ((eq ptype 'PROPERTY)
+ (let ((pname (cdr (assq 'name props)))
+ (plink (cdr (assq 'link props)))
+ (get (string= (cdr (assq 'get props)) "Yes"))
+ (set (string= (cdr (assq 'set props)) "Yes"))
+ (init (string= (cdr (assq 'init props)) "Yes")))
+ (if get (push (list pname plink) get-props))
+ (if set (push (list pname plink) set-props))
+ (if init (push (list pname plink) init-props))))
+
+ ((eq ptype 'METHOD)
+ (setq method (cdr (assq 'name props)))
+ (setq extra-kwds ;;Assume all property keywords are gathered already
+ (cond
+ ((string-match (concat class "::Init") method)
+ (put 'init-props 'matched t)
+ init-props)
+ ((string-match (concat class "::GetProperty") method)
+ (put 'get-props 'matched t)
+ get-props)
+ ((string-match (concat class "::SetProperty") method)
+ (put 'set-props 'matched t)
+ set-props)
+ (t nil)))
+ (setq methods-entry
+ (nconc (idlwave-xml-create-rinfo-list pelem class extra-kwds)
+ methods-entry)))
+ (t)))
+ (setq params (cdr params)))
+ ;(unless (get 'init-props 'matched)
+ ; (message "Failed to match Init in class %s" class))
+ ;(unless (get 'get-props 'matched)
+ ; (message "Failed to match GetProperty in class %s" class))
+ ;(unless (get 'set-props 'matched)
+ ; (message "Failed to match SetProperty in class %s" class))
+ (setq class-entry
+ (if inherits
+ (list class (append '(inherits) inherits) (list 'link link))
+ (list class (list 'link link))))
+ (cons class-entry methods-entry)))
+
+(defun idlwave-xml-create-rinfo-list (xml-entry &optional class extra-kws)
+ ;; Create correctly structured list elements from ROUTINE or METHOD
+ ;; XML list structures. Return a list of list elements, with more
+ ;; than one sub-list possible if a routine can serve as both
+ ;; procedure and function (e.g. call_method).
+ (let* ((nameblock (nth 1 xml-entry))
+ (name (cdr (assq 'name nameblock)))
+ (link (cdr (assq 'link nameblock)))
+ (params (cddr xml-entry))
+ (syntax-vec (make-vector 3 nil)) ; procedure, function, exec command
+ (case-fold-search t)
+ syntax kwd klink pref-list kwds pelem ptype entry props result type)
+ (if class ;; strip out class name from class method name string
+ (if (string-match (concat class "::") name)
+ (setq name (substring name (match-end 0)))))
+ (while params
+ (setq pelem (car params))
+ (when (listp pelem)
+ (setq ptype (car pelem)
+ props (car (cdr pelem)))
+ (cond
+ ((eq ptype 'SYNTAX)
+ (setq syntax (cdr (assq 'name props)))
+ (if (string-match "->" syntax)
+ (setq syntax (replace-match "->" t nil syntax)))
+ (setq type (cdr (assq 'type props)))
+ (push syntax
+ (aref syntax-vec (cond
+ ((string-match "^pro" type) 0)
+ ((string-match "^fun" type) 1)
+ ((string-match "^exec" type) 2)))))
+ ((eq ptype 'KEYWORD)
+ (setq kwd (cdr (assq 'name props))
+ klink (cdr (assq 'link props)))
+ (if (string-match "^\\[XY\\(Z?\\)\\]" kwd)
+ (progn
+ (setq pref-list
+ (if (match-string 1 kwd) '("X" "Y" "Z") '("X" "Y"))
+ kwd (substring kwd (match-end 0)))
+ (loop for x in pref-list do
+ (push (list (concat x kwd) klink) kwds)))
+ (push (list kwd klink) kwds)))
+
+ (t))); Do nothing for the others
+ (setq params (cdr params)))
+
+ ;; Debug
+; (if (and (null (aref syntax-vec 0))
+; (null (aref syntax-vec 1))
+; (null (aref syntax-vec 2)))
+; (with-current-buffer (get-buffer-create "IDL_XML_catalog_complaints")
+; (if class
+; (insert (format "Missing SYNTAX entry for %s::%s\n" class name))
+; (insert (message "Missing SYNTAX entry for %s\n" name)))))
+
+ ;; Executive commands are treated specially
+ (if (aref syntax-vec 2)
+ (cons (substring name 1) link)
+ (if extra-kws (setq kwds (nconc kwds extra-kws)))
+ (setq kwds (idlwave-rinfo-group-keywords kwds link))
+ (loop for idx from 0 to 1 do
+ (if (aref syntax-vec idx)
+ (push (append (list name (if (eq idx 0) 'pro 'fun)
+ class '(system)
+ (idlwave-shorten-syntax
+ (aref syntax-vec idx) name class))
+ kwds) result)))
+ result)))
+
+
+(defun idlwave-rinfo-group-keywords (kwds master-link)
+ ;; Group keywords by link file, as a list with elements
+ ;; (linkfile ( ("KWD1" . link1) ("KWD2" . link2))
+ (let (kwd link anchor linkfiles block master-elt)
+ (while kwds
+ (setq kwd (car kwds)
+ link (idlwave-split-link-target (nth 1 kwd))
+ anchor (cdr link)
+ link (car link)
+ kwd (car kwd))
+ (if (setq block (assoc link linkfiles))
+ (push (cons kwd anchor) (cdr block))
+ (push (list link (cons kwd anchor)) linkfiles))
+ (setq kwds (cdr kwds)))
+ ;; Ensure the master link is there
+ (if (setq master-elt (assoc master-link linkfiles))
+ (if (eq (car linkfiles) master-elt)
+ linkfiles
+ (cons master-elt (delq master-elt linkfiles)))
+ (push (list master-link) linkfiles))))
+
+(defun idlwave-convert-xml-clean-statement-aliases (aliases)
+ ;; Clean up the syntax of routines which are actually aliases by
+ ;; removing the "OR" from the statements
+ (let (syntax entry)
+ (loop for x in aliases do
+ (setq entry (assoc x idlwave-system-routines))
+ (when entry
+ (while (string-match " +or +" (setq syntax (nth 4 entry)))
+ (setf (nth 4 entry) (replace-match ", " t t syntax)))))))
+
+(defun idlwave-convert-xml-clean-routine-aliases (aliases)
+ ;; Duplicate and trim original routine aliases from rinfo list
+ ;; This if for, e.g. OPENR/OPENW/OPENU
+ (let (alias remove-list new parts all-parts)
+ (loop for x in aliases do
+ (when (setq parts (split-string (cdr x) "/"))
+ (setq new (assoc (cdr x) all-parts))
+ (unless new
+ (setq new (cons (cdr x) parts))
+ (push new all-parts))
+ (setcdr new (delete (car x) (cdr new)))))
+
+ ;; Add any missing aliases (separate by slashes)
+ (loop for x in all-parts do
+ (if (cdr x)
+ (push (cons (nth 1 x) (car x)) aliases)))
+
+ (loop for x in aliases do
+ (when (setq alias (assoc (cdr x) idlwave-system-routines))
+ (unless (memq alias remove-list) (push alias remove-list))
+ (setq alias (copy-sequence alias))
+ (setcar alias (car x))
+ (push alias idlwave-system-routines)))
+ (loop for x in remove-list do
+ (delq x idlwave-system-routines))))
+
+(defun idlwave-convert-xml-clean-sysvar-aliases (aliases)
+ ;; Duplicate and trim original routine aliases from rinfo list
+ ;; This if for, e.g. !X, !Y, !Z.
+ (let (alias remove-list new parts all-parts)
+ (loop for x in aliases do
+ (when (setq alias (assoc (cdr x) idlwave-system-variables-alist))
+ (unless (memq alias remove-list) (push alias remove-list))
+ (setq alias (copy-sequence alias))
+ (setcar alias (car x))
+ (push alias idlwave-system-variables-alist)))
+ (loop for x in remove-list do
+ (delq x idlwave-system-variables-alist))))
+
+
+(defun idlwave-xml-create-sysvar-alist (xml-entry)
+ ;; Create a sysvar list entry from the xml parsed list.
+ (let* ((nameblock (nth 1 xml-entry))
+ (name (cdr (assq 'name nameblock)))
+ (sysvar (substring name (progn (string-match "^ *!" name)
+ (match-end 0))))
+ (link (cdr (assq 'link nameblock)))
+ (params (cddr xml-entry))
+ (case-fold-search t)
+ pelem ptype props fields tags)
+ (while params
+ (setq pelem (car params))
+ (when (listp pelem)
+ (setq ptype (car pelem)
+ props (car (cdr pelem)))
+ (cond
+ ((eq ptype 'FIELD)
+ (push (cons (cdr (assq 'name props))
+ (cdr
+ (idlwave-split-link-target (cdr (assq 'link props)))))
+ tags))))
+ (setq params (cdr params)))
+ (delq nil
+ (list sysvar (if tags (cons 'tags tags)) (list 'link link)))))
+
+
+(defvar idlwave-xml-routine-info-file nil)
+
+(defun idlwave-save-routine-info ()
+ (if idlwave-xml-routine-info-file
+ (with-temp-file idlwave-xml-system-rinfo-converted-file
+ (insert
+ (concat ";; *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
+;; IDLWAVE Routine Information File (IDLWAVE version " idlwave-mode-version ")
+;; Automatically generated from source file:
+;; " idlwave-xml-routine-info-file "
+;; on " (current-time-string) "
+;; Do not edit."))
+ (insert (format "\n(setq idlwave-xml-routine-info-file \n \"%s\")"
+ idlwave-xml-routine-info-file))
+ (insert "\n(setq idlwave-system-routines\n '")
+ (prin1 idlwave-system-routines (current-buffer))
+ (insert ")")
+ (insert "\n(setq idlwave-system-variables-alist\n '")
+ (prin1 idlwave-system-variables-alist (current-buffer))
+ (insert ")")
+ (insert "\n(setq idlwave-system-class-info\n '")
+ (prin1 idlwave-system-class-info (current-buffer))
+ (insert ")")
+ (insert "\n(setq idlwave-executive-commands-alist\n '")
+ (prin1 idlwave-executive-commands-alist (current-buffer))
+ (insert ")")
+ (insert "\n(setq idlwave-help-special-topic-words\n '")
+ (prin1 idlwave-help-special-topic-words (current-buffer))
+ (insert ")"))))
+
+(defun idlwave-convert-xml-system-routine-info ()
+ "Convert XML supplied IDL routine info into internal form.
+Cache to disk for quick recovery."
+ (interactive)
+ (let* ((dir (file-name-as-directory
+ (expand-file-name "help/online_help" (idlwave-sys-dir))))
+ (catalog-file (expand-file-name "idl_catalog.xml" dir))
+ (elem-cnt 0)
+ props rinfo msg-cnt elem type nelem class-result alias
+ routines routine-aliases statement-aliases sysvar-aliases
+ version-string)
+ (if (not (file-exists-p catalog-file))
+ (error "No such XML routine info file: %s" catalog-file)
+ (if (not (file-readable-p catalog-file))
+ (error "Cannot read XML routine info file: %s" catalog-file)))
+ (require 'xml)
+ (message "Reading XML routine info...")
+ (setq rinfo (xml-parse-file catalog-file))
+ (message "Reading XML routine info...done")
+ (setq rinfo (assq 'CATALOG rinfo))
+ (unless rinfo (error "Failed to parse XML routine info"))
+ ;;(setq rinfo (car rinfo)) ; Skip the catalog stuff.
+
+ (setq version-string (cdr (assq 'version (nth 1 rinfo)))
+ rinfo (cddr rinfo))
+
+ (setq nelem (length rinfo)
+ msg-cnt (/ nelem 20))
+
+ (setq idlwave-xml-routine-info-file nil)
+ (message "Converting XML routine info...")
+ (setq idlwave-system-routines nil
+ idlwave-system-variables-alist nil
+ idlwave-system-class-info nil
+ idlwave-executive-commands-alist nil
+ idlwave-help-special-topic-words nil)
+
+ (while rinfo
+ (setq elem (car rinfo)
+ rinfo (cdr rinfo))
+ (incf elem-cnt)
+ (when (listp elem)
+ (setq type (car elem)
+ props (car (cdr elem)))
+ (if (= (mod elem-cnt msg-cnt) 0)
+ (message "Converting XML routine info...%2d%%"
+ (/ (* elem-cnt 100) nelem)))
+ (cond
+ ((eq type 'ROUTINE)
+ (if (setq alias (assq 'alias_to props))
+ (push (cons (cdr (assq 'name props)) (cdr alias))
+ routine-aliases)
+ (setq routines (idlwave-xml-create-rinfo-list elem))
+ (if (listp (cdr routines))
+ (setq idlwave-system-routines
+ (nconc idlwave-system-routines routines))
+ ;; a cons cell is an executive commands
+ (push routines idlwave-executive-commands-alist))))
+
+ ((eq type 'CLASS)
+ (setq class-result (idlwave-xml-create-class-method-lists elem))
+ (push (car class-result) idlwave-system-class-info)
+ (setq idlwave-system-routines
+ (nconc idlwave-system-routines (cdr class-result))))
+
+ ((eq type 'STATEMENT)
+ (push (cons (cdr (assq 'name props))
+ (cdr (assq 'link props)))
+ idlwave-help-special-topic-words)
+ ;; Save the links to those which are statement aliases (not routines)
+ (if (setq alias (assq 'alias_to props))
+ (unless (member (cdr alias) statement-aliases)
+ (push (cdr alias) statement-aliases))))
+
+ ((eq type 'SYSVAR)
+ (if (setq alias (cdr (assq 'alias_to props)))
+ (push (cons (substring (cdr (assq 'name props)) 1)
+ (substring alias 1))
+ sysvar-aliases)
+ (push (idlwave-xml-create-sysvar-alist elem)
+ idlwave-system-variables-alist)))
+ (t))))
+ (idlwave-convert-xml-clean-routine-aliases routine-aliases)
+ (idlwave-convert-xml-clean-statement-aliases statement-aliases)
+ (idlwave-convert-xml-clean-sysvar-aliases sysvar-aliases)
+
+ (setq idlwave-xml-routine-info-file catalog-file)
+ (idlwave-save-routine-info)
+ (message "Converting XML routine info...done")))
+
+
+;; ("ROUTINE" type class
+;; (system) | (lib pro_file dir "LIBNAME") | (user pro_file dir "USERLIB") |
+;; (buffer pro_file dir) | (compiled pro_file dir)
+;; "calling_string" ("HELPFILE" (("KWD1" . link1) ...))
+;; ("HELPFILE2" (("KWD2" . link) ...)) ...)
+
+