Function: vhdl-scan-directory-contents
vhdl-scan-directory-contents is a byte-compiled function defined in
vhdl-mode.el.gz.
Signature
(vhdl-scan-directory-contents NAME &optional PROJECT UPDATE NUM-STRING NON-FINAL)
Documentation
Scan contents of VHDL files in directory or file pattern NAME.
Source Code
;; Defined in /usr/src/emacs/lisp/progmodes/vhdl-mode.el.gz
(defun vhdl-scan-directory-contents (name &optional project update num-string
non-final)
"Scan contents of VHDL files in directory or file pattern NAME."
(string-match "\\(.*[/\\]\\)\\(.*\\)" name)
(let* ((dir-name (match-string 1 name))
(file-pattern (match-string 2 name))
(is-directory (= 0 (length file-pattern)))
(file-list
(if update
(list name)
(if is-directory
(vhdl-get-source-files t dir-name)
(vhdl-directory-files
dir-name t (wildcard-to-regexp file-pattern)))))
(key (or project dir-name))
(file-exclude-regexp
(or (nth 3 (vhdl-aget vhdl-project-alist project)) ""))
(limit-design-file-size (nth 0 vhdl-speedbar-scan-limit))
(limit-hier-file-size (nth 0 (nth 1 vhdl-speedbar-scan-limit)))
(limit-hier-inst-no (nth 1 (nth 1 vhdl-speedbar-scan-limit)))
ent-alist conf-alist pack-alist ent-inst-list file-alist
tmp-list tmp-entry no-files files-exist big-files)
(when (or project update)
(setq ent-alist (vhdl-aget vhdl-entity-alist key)
conf-alist (vhdl-aget vhdl-config-alist key)
pack-alist (vhdl-aget vhdl-package-alist key)
ent-inst-list (car (vhdl-aget vhdl-ent-inst-alist key))
file-alist (vhdl-aget vhdl-file-alist key)))
(when (and (not is-directory) (null file-list))
(message "No such file: \"%s\"" name))
(setq files-exist file-list)
(when file-list
(setq no-files (length file-list))
(message "Scanning %s %s\"%s\"..."
(if is-directory "directory" "files") (or num-string "") name)
;; exclude files
(unless (equal file-exclude-regexp "")
(let ((case-fold-search nil)
file-tmp-list)
(while file-list
(unless (string-match file-exclude-regexp (car file-list))
(push (car file-list) file-tmp-list))
(setq file-list (cdr file-list)))
(setq file-list (nreverse file-tmp-list))))
;; do for all files
(while file-list
(unless noninteractive
(message "Scanning %s %s\"%s\"... (%2d%%)"
(if is-directory "directory" "files")
(or num-string "") name
(floor (* 100.0 (- no-files (length file-list))) no-files)))
(let ((file-name (abbreviate-file-name (car file-list)))
ent-list arch-list arch-ent-list conf-list
pack-list pack-body-list inst-list inst-ent-list)
;; scan file
(vhdl-visit-file
file-name nil
(vhdl-prepare-search-2
(save-excursion
;; scan for design units
(if (and limit-design-file-size
(< limit-design-file-size (buffer-size)))
(progn (message "WARNING: Scan limit (design units: file size) reached in file:\n \"%s\"" file-name)
(setq big-files t))
;; scan for entities
(goto-char (point-min))
(while (re-search-forward "^[ \t]*entity[ \t\n\r\f]+\\(\\w+\\)[ \t\n\r\f]+is\\>" nil t)
(let* ((ent-name (match-string-no-properties 1))
(ent-key (downcase ent-name))
(ent-entry (vhdl-aget ent-alist ent-key))
(lib-alist (vhdl-scan-context-clause)))
(if (nth 1 ent-entry)
(vhdl-warning-when-idle
"Entity declared twice (used 1.): \"%s\"\n 1. in \"%s\" (line %d)\n 2. in \"%s\" (line %d)"
ent-name (nth 1 ent-entry) (nth 2 ent-entry)
file-name (vhdl-current-line))
(push ent-key ent-list)
(vhdl-aput 'ent-alist ent-key
(list ent-name file-name (vhdl-current-line)
(nth 3 ent-entry) (nth 4 ent-entry)
lib-alist)))))
;; scan for architectures
(goto-char (point-min))
(while (re-search-forward "^[ \t]*architecture[ \t\n\r\f]+\\(\\w+\\)[ \t\n\r\f]+of[ \t\n\r\f]+\\(\\w+\\)[ \t\n\r\f]+is\\>" nil t)
(let* ((arch-name (match-string-no-properties 1))
(arch-key (downcase arch-name))
(ent-name (match-string-no-properties 2))
(ent-key (downcase ent-name))
(ent-entry (vhdl-aget ent-alist ent-key))
(arch-alist (nth 3 ent-entry))
(arch-entry (vhdl-aget arch-alist arch-key))
(lib-arch-alist (vhdl-scan-context-clause)))
(if arch-entry
(vhdl-warning-when-idle
"Architecture declared twice (used 1.): \"%s\" of \"%s\"\n 1. in \"%s\" (line %d)\n 2. in \"%s\" (line %d)"
arch-name ent-name (nth 1 arch-entry)
(nth 2 arch-entry) file-name (vhdl-current-line))
(setq arch-list (cons arch-key arch-list)
arch-ent-list (cons ent-key arch-ent-list))
(vhdl-aput 'arch-alist arch-key
(list arch-name file-name (vhdl-current-line)
nil lib-arch-alist))
(vhdl-aput 'ent-alist ent-key
(list (or (nth 0 ent-entry) ent-name)
(nth 1 ent-entry) (nth 2 ent-entry)
(vhdl-sort-alist arch-alist)
arch-key (nth 5 ent-entry))))))
;; scan for configurations
(goto-char (point-min))
(while (re-search-forward "^[ \t]*configuration[ \t\n\r\f]+\\(\\w+\\)[ \t\n\r\f]+of[ \t\n\r\f]+\\(\\w+\\)[ \t\n\r\f]+is\\>" nil t)
(let* ((conf-name (match-string-no-properties 1))
(conf-key (downcase conf-name))
(conf-entry (vhdl-aget conf-alist conf-key))
(ent-name (match-string-no-properties 2))
(ent-key (downcase ent-name))
(lib-alist (vhdl-scan-context-clause))
(conf-line (vhdl-current-line))
(end-of-unit (vhdl-get-end-of-unit))
arch-key comp-conf-list inst-key-list
inst-comp-key inst-ent-key inst-arch-key
inst-conf-key inst-lib-key)
(when (vhdl-re-search-forward "\\<for[ \t\n\r\f]+\\(\\w+\\)")
(setq arch-key (vhdl-match-string-downcase 1)))
(if conf-entry
(vhdl-warning-when-idle
"Configuration declared twice (used 1.): \"%s\" of \"%s\"\n 1. in \"%s\" (line %d)\n 2. in \"%s\" (line %d)"
conf-name ent-name (nth 1 conf-entry)
(nth 2 conf-entry) file-name conf-line)
(push conf-key conf-list)
;; scan for subconfigurations and subentities
(while (re-search-forward "^[ \t]*for[ \t\n\r\f]+\\(\\w+\\([ \t\n\r\f]*,[ \t\n\r\f]*\\w+\\)*\\)[ \t\n\r\f]*:[ \t\n\r\f]*\\(\\w+\\)[ \t\n\r\f]+" end-of-unit t)
(setq inst-comp-key (vhdl-match-string-downcase 3)
inst-key-list (split-string
(vhdl-match-string-downcase 1)
"[ \t\n\r\f]*,[ \t\n\r\f]*"))
(vhdl-forward-syntactic-ws)
(when (looking-at "use[ \t\n\r\f]+\\(\\(entity\\)\\|configuration\\)[ \t\n\r\f]+\\(\\w+\\)\\.\\(\\w+\\)[ \t\n\r\f]*\\((\\(\\w+\\))\\)?")
(setq
inst-lib-key (vhdl-match-string-downcase 3)
inst-ent-key (and (match-string 2)
(vhdl-match-string-downcase 4))
inst-arch-key (and (match-string 2)
(vhdl-match-string-downcase 6))
inst-conf-key (and (not (match-string 2))
(vhdl-match-string-downcase 4)))
(while inst-key-list
(setq comp-conf-list
(cons (list (car inst-key-list)
inst-comp-key inst-ent-key
inst-arch-key inst-conf-key
inst-lib-key)
comp-conf-list))
(setq inst-key-list (cdr inst-key-list)))))
(vhdl-aput 'conf-alist conf-key
(list conf-name file-name conf-line ent-key
arch-key comp-conf-list lib-alist)))))
;; scan for packages
(goto-char (point-min))
(while (re-search-forward "^[ \t]*package[ \t\n\r\f]+\\(body[ \t\n\r\f]+\\)?\\(\\w+\\)[ \t\n\r\f]+is\\>" nil t)
(let* ((pack-name (match-string-no-properties 2))
(pack-key (downcase pack-name))
(is-body (match-string-no-properties 1))
(pack-entry (vhdl-aget pack-alist pack-key))
(pack-line (vhdl-current-line))
(end-of-unit (vhdl-get-end-of-unit))
comp-name func-name comp-alist func-alist lib-alist)
(if (if is-body (nth 6 pack-entry) (nth 1 pack-entry))
(vhdl-warning-when-idle
"Package%s declared twice (used 1.): \"%s\"\n 1. in \"%s\" (line %d)\n 2. in \"%s\" (line %d)"
(if is-body " body" "") pack-name
(if is-body (nth 6 pack-entry) (nth 1 pack-entry))
(if is-body (nth 7 pack-entry) (nth 2 pack-entry))
file-name (vhdl-current-line))
;; scan for context clauses
(setq lib-alist (vhdl-scan-context-clause))
;; scan for component and subprogram declarations/bodies
(while (re-search-forward "^[ \t]*\\(component\\|function\\|procedure\\)[ \t\n\r\f]+\\(\\w+\\|\".*\"\\)" end-of-unit t)
(if (equal (upcase (match-string 1)) "COMPONENT")
(setq comp-name (match-string-no-properties 2)
comp-alist
(cons (list (downcase comp-name) comp-name
file-name (vhdl-current-line))
comp-alist))
(setq func-name (match-string-no-properties 2)
func-alist
(cons (list (downcase func-name) func-name
file-name (vhdl-current-line))
func-alist))))
(setq func-alist (nreverse func-alist))
(setq comp-alist (nreverse comp-alist))
(if is-body
(push pack-key pack-body-list)
(push pack-key pack-list))
(vhdl-aput
'pack-alist pack-key
(if is-body
(list (or (nth 0 pack-entry) pack-name)
(nth 1 pack-entry) (nth 2 pack-entry)
(nth 3 pack-entry) (nth 4 pack-entry)
(nth 5 pack-entry)
file-name pack-line func-alist lib-alist)
(list pack-name file-name pack-line
comp-alist func-alist lib-alist
(nth 6 pack-entry) (nth 7 pack-entry)
(nth 8 pack-entry) (nth 9 pack-entry))))))))
;; scan for hierarchy
(if (and limit-hier-file-size
(< limit-hier-file-size (buffer-size)))
(progn (message "WARNING: Scan limit (hierarchy: file size) reached in file:\n \"%s\"" file-name)
(setq big-files t))
;; scan for architectures
(goto-char (point-min))
(while (re-search-forward "^[ \t]*architecture[ \t\n\r\f]+\\(\\w+\\)[ \t\n\r\f]+of[ \t\n\r\f]+\\(\\w+\\)[ \t\n\r\f]+is\\>" nil t)
(let* ((ent-name (match-string-no-properties 2))
(ent-key (downcase ent-name))
(arch-name (match-string-no-properties 1))
(arch-key (downcase arch-name))
(ent-entry (vhdl-aget ent-alist ent-key))
(arch-alist (nth 3 ent-entry))
(arch-entry (vhdl-aget arch-alist arch-key))
(beg-of-unit (point))
(end-of-unit (vhdl-get-end-of-unit))
(inst-no 0)
inst-alist inst-path)
;; scan for contained instantiations
(while (and (re-search-forward
(concat "^[ \t]*\\(\\w+\\)[ \t\n\r\f]*:[ \t\n\r\f]*\\("
"\\(\\w+\\)[ \t\n\r\f]+\\(--[^\n]*\n[ \t\n\r\f]*\\)*\\(generic\\|port\\)[ \t\n\r\f]+map\\>\\|"
"component[ \t\n\r\f]+\\(\\w+\\)\\|"
"\\(\\(entity\\)\\|configuration\\)[ \t\n\r\f]+\\(\\(\\w+\\)\\.\\)?\\(\\w+\\)\\([ \t\n\r\f]*(\\(\\w+\\))\\)?\\|"
"\\(\\(for\\|if\\)\\>[^;:]+\\<generate\\>\\|block\\>\\)\\)\\|"
"\\(^[ \t]*end[ \t\n\r\f]+\\(generate\\|block\\)\\>\\)")
end-of-unit t)
(or (not limit-hier-inst-no)
(<= (if (or (match-string 14)
(match-string 16))
inst-no
(setq inst-no (1+ inst-no)))
limit-hier-inst-no)))
(cond
;; block/generate beginning found
((match-string 14)
(setq inst-path
(cons (match-string-no-properties 1) inst-path)))
;; block/generate end found
((match-string 16)
(setq inst-path (cdr inst-path)))
;; instantiation found
(t
(let* ((inst-name (match-string-no-properties 1))
(inst-key (downcase inst-name))
(inst-comp-name
(or (match-string-no-properties 3)
(match-string-no-properties 6)))
(inst-ent-key
(or (and (match-string 8)
(vhdl-match-string-downcase 11))
(and inst-comp-name
(downcase inst-comp-name))))
(inst-arch-key (vhdl-match-string-downcase 13))
(inst-conf-key
(and (not (match-string 8))
(vhdl-match-string-downcase 11)))
(inst-lib-key (vhdl-match-string-downcase 10)))
(goto-char (match-end 1))
(setq inst-list (cons inst-key inst-list)
inst-ent-list
(cons inst-ent-key inst-ent-list))
(setq inst-alist
(append
inst-alist
(list (list inst-key inst-name file-name
(vhdl-current-line) inst-comp-name
inst-ent-key inst-arch-key
inst-conf-key inst-lib-key
(reverse inst-path)))))))))
;; scan for contained configuration specifications
(goto-char beg-of-unit)
(while (re-search-forward
(concat "^[ \t]*for[ \t\n\r\f]+\\(\\w+\\([ \t\n\r\f]*,[ \t\n\r\f]*\\w+\\)*\\)[ \t\n\r\f]*:[ \t\n\r\f]*\\(\\w+\\)[ \t\n\r\f]+\\(--[^\n]*\n[ \t\n\r\f]*\\)*"
"use[ \t\n\r\f]+\\(\\(entity\\)\\|configuration\\)[ \t\n\r\f]+\\(\\(\\w+\\)\\.\\)?\\(\\w+\\)\\([ \t\n\r\f]*(\\(\\w+\\))\\)?") end-of-unit t)
(let* ((inst-comp-name (match-string-no-properties 3))
(inst-ent-key
(and (match-string 6)
(vhdl-match-string-downcase 9)))
(inst-arch-key (vhdl-match-string-downcase 11))
(inst-conf-key
(and (not (match-string 6))
(vhdl-match-string-downcase 9)))
(inst-lib-key (vhdl-match-string-downcase 8))
(inst-key-list
(split-string (vhdl-match-string-downcase 1)
"[ \t\n\r\f]*,[ \t\n\r\f]*"))
(tmp-inst-alist inst-alist)
inst-entry)
(while tmp-inst-alist
(when (and (or (equal "all" (car inst-key-list))
(member (nth 0 (car tmp-inst-alist))
inst-key-list))
(equal
(downcase
(or (nth 4 (car tmp-inst-alist)) ""))
(downcase inst-comp-name)))
(setq inst-entry (car tmp-inst-alist))
(setq inst-ent-list
(cons (or inst-ent-key (nth 5 inst-entry))
(vhdl-delete
(nth 5 inst-entry) inst-ent-list)))
(setq inst-entry
(list (nth 0 inst-entry) (nth 1 inst-entry)
(nth 2 inst-entry) (nth 3 inst-entry)
(nth 4 inst-entry)
(or inst-ent-key (nth 5 inst-entry))
(or inst-arch-key (nth 6 inst-entry))
inst-conf-key inst-lib-key))
(setcar tmp-inst-alist inst-entry))
(setq tmp-inst-alist (cdr tmp-inst-alist)))))
;; save in cache
(vhdl-aput 'arch-alist arch-key
(list (nth 0 arch-entry) (nth 1 arch-entry)
(nth 2 arch-entry) inst-alist
(nth 4 arch-entry)))
(vhdl-aput 'ent-alist ent-key
(list (nth 0 ent-entry) (nth 1 ent-entry)
(nth 2 ent-entry)
(vhdl-sort-alist arch-alist)
(nth 4 ent-entry) (nth 5 ent-entry)))
(when (and limit-hier-inst-no
(> inst-no limit-hier-inst-no))
(message "WARNING: Scan limit (hierarchy: instances per architecture) reached in file:\n \"%s\"" file-name)
(setq big-files t))
(goto-char end-of-unit))))
;; remember design units for this file
(vhdl-aput 'file-alist file-name
(list ent-list arch-list arch-ent-list conf-list
pack-list pack-body-list
inst-list inst-ent-list))
(setq ent-inst-list (append inst-ent-list ent-inst-list))))))
(setq file-list (cdr file-list))))
(when (or (and (not project) files-exist)
(and project (not non-final)))
;; consistency checks:
;; check whether each architecture has a corresponding entity
(setq tmp-list ent-alist)
(while tmp-list
(when (null (nth 2 (car tmp-list)))
(setq tmp-entry (car (nth 4 (car tmp-list))))
(vhdl-warning-when-idle
"Architecture of non-existing entity: \"%s\" of \"%s\"\n in \"%s\" (line %d)"
(nth 1 tmp-entry) (nth 1 (car tmp-list)) (nth 2 tmp-entry)
(nth 3 tmp-entry)))
(setq tmp-list (cdr tmp-list)))
;; check whether configuration has a corresponding entity/architecture
(setq tmp-list conf-alist)
(while tmp-list
(if (setq tmp-entry (vhdl-aget ent-alist (nth 4 (car tmp-list))))
(unless (vhdl-aget (nth 3 tmp-entry) (nth 5 (car tmp-list)))
(setq tmp-entry (car tmp-list))
(vhdl-warning-when-idle
"Configuration of non-existing architecture: \"%s\" of \"%s(%s)\"\n in \"%s\" (line %d)"
(nth 1 tmp-entry) (nth 4 tmp-entry) (nth 5 tmp-entry)
(nth 2 tmp-entry) (nth 3 tmp-entry)))
(setq tmp-entry (car tmp-list))
(vhdl-warning-when-idle
"Configuration of non-existing entity: \"%s\" of \"%s\"\n in \"%s\" (line %d)"
(nth 1 tmp-entry) (nth 4 tmp-entry)
(nth 2 tmp-entry) (nth 3 tmp-entry)))
(setq tmp-list (cdr tmp-list)))
;; check whether each package body has a package declaration
(setq tmp-list pack-alist)
(while tmp-list
(when (null (nth 2 (car tmp-list)))
(setq tmp-entry (car tmp-list))
(vhdl-warning-when-idle
"Package body of non-existing package: \"%s\"\n in \"%s\" (line %d)"
(nth 1 tmp-entry) (nth 7 tmp-entry) (nth 8 tmp-entry)))
(setq tmp-list (cdr tmp-list)))
;; sort lists
(setq ent-alist (vhdl-sort-alist ent-alist))
(setq conf-alist (vhdl-sort-alist conf-alist))
(setq pack-alist (vhdl-sort-alist pack-alist))
;; remember updated directory/project
(add-to-list 'vhdl-updated-project-list (or project dir-name)))
;; clear directory alists
(unless project
(vhdl-adelete 'vhdl-entity-alist key)
(vhdl-adelete 'vhdl-config-alist key)
(vhdl-adelete 'vhdl-package-alist key)
(vhdl-adelete 'vhdl-ent-inst-alist key)
(vhdl-adelete 'vhdl-file-alist key))
;; put directory contents into cache
(vhdl-aput 'vhdl-entity-alist key ent-alist)
(vhdl-aput 'vhdl-config-alist key conf-alist)
(vhdl-aput 'vhdl-package-alist key pack-alist)
(vhdl-aput 'vhdl-ent-inst-alist key (list ent-inst-list))
(vhdl-aput 'vhdl-file-alist key file-alist)
;; final messages
(message "Scanning %s %s\"%s\"...done"
(if is-directory "directory" "files") (or num-string "") name)
(unless project (message "Scanning directory...done"))
(when big-files
(vhdl-warning-when-idle "Scanning is incomplete.\n --> see user option `vhdl-speedbar-scan-limit'"))
;; save cache when scanned non-interactively
(when (or (not project) (not non-final))
(when (and noninteractive vhdl-speedbar-save-cache)
(vhdl-save-cache key)))
t))