mirror of https://gitlab.com/QEF/q-e.git
497 lines
14 KiB
Tcl
497 lines
14 KiB
Tcl
#
|
|
# This file is sourced by "gen-emacs-mode" script and contains the
|
|
# machinery for generating the Emacs major mode files for Quantum
|
|
# ESPRESSO. It relies heavily on: (1) helpdoc utility, (2) INPUT_*.def
|
|
# files, and (3) templates provided in ../GUI/QE-modes/qe-modes.templates/ directory.
|
|
#
|
|
|
|
###
|
|
# Purpose: extract the module name from INPUT_*.def filename
|
|
proc ::helpdoc::modulename_from_defname {deffile} {
|
|
|
|
# strip the path from $deffile
|
|
|
|
set def_file [file tail $deffile]
|
|
|
|
# the module-name of INPUT_XX.def is [string tolower XX]
|
|
|
|
return [string tolower [regsub {^INPUT_} [file rootname $def_file] {}]]
|
|
}
|
|
|
|
# Purpose: quote the list elements, i.e., transform {a b c} to either {"a" "b" "c"},
|
|
# or {"${prefix}a" "${prefix}b" "${prefix}c"} if $prefix != ""
|
|
#
|
|
# prefix = optional argument (default = "")
|
|
proc ::helpdoc::quote_list {lst {prefix {}}} {
|
|
set result ""
|
|
foreach item $lst {
|
|
append result "\"${prefix}$item\" "
|
|
}
|
|
return $result
|
|
}
|
|
|
|
|
|
# Purpose: store the namelists, variables, cards, etc. that are stated in the def file
|
|
# (this proc is used by tree's walkproc method; see qe_mode_process_def)
|
|
proc ::helpdoc::getFontlockKeys {tree node action} {
|
|
variable arr
|
|
variable inside_namelist
|
|
variable fontlock
|
|
variable defun
|
|
variable module
|
|
|
|
set tag [$tree get $node tag]
|
|
set attr [getFromTree $tree $node attributes]
|
|
|
|
catch {unset arr}
|
|
attr2array_ arr $attr
|
|
set name [arr name]
|
|
|
|
if { $action == "enter" } {
|
|
|
|
switch -- $tag {
|
|
supercard {
|
|
set start [supercardStarttag]
|
|
set end [arr endtag]
|
|
lappend defun($module,supercards) [list $start $end]
|
|
|
|
if { $end ne {} } {
|
|
lappend fontlock(begin_supercards) $start
|
|
lappend fontlock(end_supercards) $end
|
|
} else {
|
|
lappend fontlock(open_supercards) $start
|
|
}
|
|
}
|
|
namelist {
|
|
set inside_namelist 1
|
|
lappend fontlock(namelists) $name
|
|
lappend defun($module,namelists) $name
|
|
}
|
|
var - dimension - multidimension {
|
|
if { $inside_namelist } {
|
|
set bare_name [lindex [split $name \(] 0]; # strips "(index)" from variable's name if var is a dimension
|
|
lappend fontlock(vars) $bare_name
|
|
lappend defun($module,vars) $bare_name
|
|
|
|
# is the variable of string-type ?
|
|
set type [arr type]
|
|
if { "$type" eq "CHARACTER" } {
|
|
#set fontlock(stringvar,$bare_name) 1
|
|
set defun($module,stringvar,$bare_name) 1
|
|
}
|
|
}
|
|
}
|
|
keyword {
|
|
lappend fontlock(keywords) $name
|
|
lappend defun($module,cards) $name; # make it easier (glue cards and keywords immediately)
|
|
}
|
|
card {
|
|
set nameless [arr nameless]
|
|
switch -- [string tolower $nameless] {
|
|
1 - true - yes - .true. {
|
|
set name ""
|
|
}
|
|
}
|
|
if { $name != "" } {
|
|
lappend fontlock(cards) $name
|
|
lappend defun($module,cards) $name
|
|
|
|
set flags_txt [getDescendantText $tree $node flag enum]
|
|
set flags_use [getDescendantAttribute $tree $node flag use]
|
|
set flags [regsub -all -- {\|} $flags_txt {}]
|
|
|
|
if { $flags != "" } {
|
|
append fontlock(flags) "$flags "
|
|
#append defun($module,flags) "$flags "
|
|
|
|
if { $flags_use == "optional" } {
|
|
#set fontlock(card_flags,$name) "\{ [string trim $flags_txt { }] \}"
|
|
set defun($module,card_flags,$name) "\{ [string trim $flags_txt { }] \}"
|
|
} else {
|
|
#set fontlock(card_flags,$name) [string trim $flags_txt { }]
|
|
set defun($module,card_flags,$name) [string trim $flags_txt { }]
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
} else {
|
|
if { $tag == "namelist" } {
|
|
set inside_namelist 0
|
|
}
|
|
}
|
|
}
|
|
|
|
|
|
# Purpose: initialize the machinery for generating qe-modes
|
|
proc ::helpdoc::qe_mode_init {} {
|
|
variable init_qe_mode
|
|
global qe_modes_template_dir
|
|
variable fontlock
|
|
variable defun
|
|
|
|
#catch {unset fontlock}
|
|
#catch {unset defun}
|
|
|
|
set init_qe_mode 1
|
|
|
|
if { ! [info exists qe_modes_template_dir] } {
|
|
# try with this
|
|
puts stderr "
|
|
### variable \"qe_modes_template_dir\" is not defined ... aborting"
|
|
exit 1
|
|
}
|
|
|
|
if { ! [file isdirectory $qe_modes_template_dir] } {
|
|
puts stderr "
|
|
### variable \"qe_modes_template_dir\" points to nonexistent directory: $qe_modes_template_dir
|
|
"
|
|
exit 1
|
|
}
|
|
|
|
# read the schema (and load tag's commands)
|
|
|
|
readSchema
|
|
}
|
|
|
|
|
|
# Purpose: process a given *.def file for the purpose of generating qe-modes
|
|
proc ::helpdoc::qe_mode_process_def {deffile} {
|
|
variable tree
|
|
variable inside_namelist
|
|
variable init_qe_mode
|
|
|
|
if { ! [info exists init_qe_mode] || ! $init_qe_mode } {
|
|
puts stderr "
|
|
### call ::helpdoc::qe_mode_init before the ::helpdoc::qe_mode_process_def
|
|
"
|
|
exit 1
|
|
}
|
|
|
|
set inside_namelist 0
|
|
|
|
# read the deffile
|
|
|
|
puts "\n\n***\n*** Parsing definition file: $deffile\n***\n"
|
|
namespace eval tag [list source $deffile]
|
|
puts ""
|
|
|
|
# walk through the $deffile and extract the info we need (i.e. names of namelists, variables, cards, and flags)
|
|
|
|
$tree walkproc root -order both helpdoc::getFontlockKeys
|
|
}
|
|
|
|
|
|
# Purpose: generate requested qe-mode
|
|
proc ::helpdoc::qe_mode_generate {module_list} {
|
|
variable fontlock
|
|
variable defun
|
|
variable opt
|
|
global qe_modes_template_dir
|
|
# load the variables needed by $opt(template), e.g., qe-mode.el.tcl
|
|
|
|
set mode [string tolower $opt(mode)]
|
|
|
|
if { $opt(modename) eq {} } {
|
|
set modeName QE-$mode.x
|
|
} else {
|
|
set modeName $opt(modename)
|
|
}
|
|
|
|
# closed supercards, i.e., with starttag & endtag
|
|
set sc_l [concat [value_of fontlock(begin_supercards)] [value_of fontlock(end_supercards)]]
|
|
set closed_supercards [quote_list [lsort -unique $sc_l]]
|
|
|
|
# open supercards, i.e., with only starttag
|
|
set open_supercards [quote_list [lsort -unique [value_of fontlock(open_supercards)]]]
|
|
|
|
# cards & flags, namelists & vars
|
|
set cards_l [concat [value_of fontlock(keywords)] [value_of fontlock(cards)]]
|
|
#
|
|
# N.B: if there are no cards, the auto-indentation will not work in emacs;
|
|
# Workaround: create a dummy __NO-CARDS card
|
|
if { $cards_l == "" } {
|
|
set cards_l "__NO-CARDS"
|
|
}
|
|
set cards [quote_list [lsort -unique $cards_l]]
|
|
|
|
set flags [quote_list [lsort -unique [value_of fontlock(flags)]]]
|
|
set namelists [quote_list [lsort -unique [value_of fontlock(namelists)]] $opt(nmlprefix)]
|
|
set vars [quote_list [lsort -unique [value_of fontlock(vars)]]]
|
|
set cmds [quote_list [lsort -unique [value_of opt(cmds)]]]
|
|
#set namelists [quote_list [lsort -nocase -unique [value_of fontlock(namelists)]] $opt(nmlprefix)]
|
|
#set vars [quote_list [lsort -nocase -unique [value_of fontlock(vars)]]]
|
|
#set cmds [quote_list [lsort -nocase -unique [value_of opt(cmds)]]]
|
|
|
|
# PWTK uses uppercase namelist and card names !!!
|
|
if { $opt(mode) == "pwtk" } {
|
|
set namelists [string toupper $namelists]
|
|
set cards [string toupper $cards]
|
|
|
|
# filter-out cmds that already exists in cards
|
|
set newL {}
|
|
foreach cmd $cmds {
|
|
if { [lsearch -nocase $cards $cmd] < 0 && [lsearch -nocase $namelists $cmd] < 0 } {
|
|
lappend newL $cmd
|
|
}
|
|
}
|
|
set cmds [quote_list $newL]
|
|
}
|
|
|
|
# load the templates
|
|
|
|
set qe_template [tclu::readFile [file join $qe_modes_template_dir $opt(template)]]; # default for opt(template) = qe-mode.el.tcl
|
|
|
|
set header_template [tclu::readFile [file join $qe_modes_template_dir header.el.tcl]]
|
|
set namelist_template [tclu::readFile [file join $qe_modes_template_dir namelist.el.tcl]]
|
|
set var_template [tclu::readFile [file join $qe_modes_template_dir var.el.tcl]]
|
|
set stringvar_template [tclu::readFile [file join $qe_modes_template_dir stringvar.el.tcl]]
|
|
set card_template [tclu::readFile [file join $qe_modes_template_dir card.el.tcl]]
|
|
set card_noflags_template [tclu::readFile [file join $qe_modes_template_dir card-noflags.el.tcl]]
|
|
|
|
set closed_supercard_template [tclu::readFile [file join $qe_modes_template_dir supercard.el.tcl]]
|
|
set open_supercard_template [tclu::readFile [file join $qe_modes_template_dir supercard-open.el.tcl]]
|
|
|
|
# substitute the Tcl variables inside the qe-mode.el.tcl and write the resulting content
|
|
|
|
set file $mode-mode.el
|
|
puts "
|
|
writing Emacs major-mode file : $file
|
|
"
|
|
set header [subst -nocommands -nobackslashes $header_template]
|
|
tclu::writeFile $file [subst -nocommands -nobackslashes $qe_template]
|
|
|
|
# are we done ?
|
|
|
|
if { ! $opt(funcs) } {
|
|
# qe-mode function generation was not requested, we are done
|
|
return
|
|
}
|
|
|
|
########################################################################
|
|
# make utility functions for each module in $Module_list
|
|
|
|
set utility_functions ""
|
|
|
|
puts "list-of-modules = $module_list\n"
|
|
|
|
# create $module-insert-template functions for all modules for which the $module.in file exists
|
|
|
|
foreach module $module_list {
|
|
|
|
set in [file join $qe_modes_template_dir $module.in]
|
|
|
|
if { [file exists $in] } {
|
|
set template [tclu::readFile $in]
|
|
set insert_template [tclu::readFile [file join $qe_modes_template_dir insert-template.el.tcl]]
|
|
|
|
if { $utility_functions eq "" } {
|
|
set utility_functions "
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; utility functions ...
|
|
;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
"
|
|
}
|
|
append utility_functions [subst -nocommands -nobackslashes $insert_template]\n\n
|
|
}
|
|
}
|
|
|
|
# make keyword functions for this $mode
|
|
|
|
set keyword_functions ""
|
|
|
|
foreach module $module_list {
|
|
|
|
##################################################
|
|
# create elisp functions for each namelist
|
|
if { [value_of defun($module,namelists)] ne "" } {
|
|
|
|
append keyword_functions "
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; $module- namelists functions ...
|
|
;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
"
|
|
set module_nmls [lsort -nocase -unique [value_of defun($module,namelists)]]
|
|
|
|
foreach nml $module_nmls {
|
|
set namelist "$opt(nmlprefix)[string toupper [string trimleft $nml &]]"
|
|
set namelist_uc [string toupper [string trimleft $nml &]]
|
|
append keyword_functions [subst -nocommands -nobackslashes $namelist_template]\n\n
|
|
}
|
|
}
|
|
|
|
##################################################
|
|
# create elisp functions for each namelist's variable
|
|
|
|
if { [value_of defun($module,vars)] ne "" } {
|
|
|
|
append keyword_functions "
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; $module- namelist's variables functions ...
|
|
;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
"
|
|
set module_vars [lsort -nocase -unique [value_of defun($module,vars)]]
|
|
|
|
foreach var $module_vars {
|
|
|
|
set var_lc [string tolower $var]
|
|
|
|
# check if var is of string type
|
|
|
|
if { [info exists defun($module,stringvar,$var)] } {
|
|
|
|
set read_cmd read-string
|
|
|
|
if { [string match {*dir} $var_lc] } {
|
|
|
|
# variable probably want a directory name
|
|
set read_cmd read-directory-name
|
|
|
|
} elseif { [string match {*file*} $var_lc] } {
|
|
|
|
# variable probably want a filename name
|
|
set read_cmd read-file-name
|
|
}
|
|
append keyword_functions [subst -nocommands -nobackslashes $stringvar_template]\n\n
|
|
|
|
} else {
|
|
|
|
append keyword_functions [subst -nocommands -nobackslashes $var_template]\n\n
|
|
}
|
|
}
|
|
}
|
|
|
|
##################################################
|
|
# create elisp functions for each supercard
|
|
|
|
if { [value_of defun($module,supercards)] ne "" } {
|
|
|
|
append keyword_functions "
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; $module- supercards functions ...
|
|
;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
"
|
|
foreach start_end [lsort -unique $defun($module,supercards)] {
|
|
|
|
set starttag [lindex $start_end 0]
|
|
set endtag [lindex $start_end 1]
|
|
|
|
set supercard_uc [string toupper $starttag]
|
|
|
|
if { $endtag ne {} } {
|
|
# it's a closed supercard
|
|
append keyword_functions [subst -nocommands -nobackslashes $closed_supercard_template]\n\n
|
|
} else {
|
|
# it's an open supercard
|
|
append keyword_functions [subst -nocommands -nobackslashes $open_supercard_template]\n\n
|
|
}
|
|
}
|
|
}
|
|
|
|
##################################################
|
|
# create elisp functions for each card
|
|
|
|
if { [value_of defun($module,cards)] ne "" } {
|
|
|
|
append keyword_functions "
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; $module- cards functions ...
|
|
;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
"
|
|
set module_cards [lsort -unique $defun($module,cards)]
|
|
|
|
foreach card $module_cards {
|
|
|
|
set card_uc [string toupper $card]
|
|
set card_lc [string tolower $card]
|
|
|
|
if { [info exists defun($module,card_flags,$card)] } {
|
|
# it's a card with flags
|
|
|
|
set card_flags $defun($module,card_flags,$card)
|
|
append keyword_functions [subst -nocommands -nobackslashes $card_template]\n\n
|
|
} else {
|
|
# it's a flagless card
|
|
|
|
append keyword_functions [subst -nocommands -nobackslashes $card_noflags_template]\n\n
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
set qe_func_template [tclu::readFile [file join $qe_modes_template_dir qe-funcs.el.tcl]]
|
|
|
|
set file qe-funcs.el
|
|
puts "
|
|
writing function file : $file
|
|
"
|
|
set header [subst -nocommands -nobackslashes $header_template]
|
|
tclu::writeFile $file [subst -nocommands -nobackslashes $qe_func_template]
|
|
}
|
|
|
|
|
|
proc ::helpdoc::qe_master_generate {deffile_list} {
|
|
variable opt
|
|
global qe_modes_template_dir
|
|
|
|
if { "$opt(mode)" ne "qe" } {
|
|
puts stderr "
|
|
ERROR: so far master mode file can be generated only for mode = qe
|
|
"
|
|
exit 1
|
|
}
|
|
|
|
puts "pwd = [pwd]
|
|
"
|
|
set header_template [tclu::readFile [file join $qe_modes_template_dir header.el.tcl]]
|
|
set master_template [tclu::readFile [file join $qe_modes_template_dir $opt(mode)-modes.el.tcl]]
|
|
set specific_template [tclu::readFile [file join $qe_modes_template_dir autoload-specific.el.tcl]]
|
|
|
|
set autoload_specific_modes ""
|
|
|
|
foreach deffile $deffile_list {
|
|
|
|
set module [modulename_from_defname $deffile]
|
|
|
|
switch -exact -- $module {
|
|
atomic {
|
|
set prog ld1.x
|
|
}
|
|
default {
|
|
set prog $module.x
|
|
}
|
|
}
|
|
|
|
puts "mode file = $module-mode.el"
|
|
|
|
if { [file exists $module-mode.el] } {
|
|
|
|
# autolad only for those modules that have the specific mode defined
|
|
|
|
append autoload_specific_modes [subst -nocommands -nobackslashes $specific_template]\n
|
|
}
|
|
}
|
|
set file $opt(mode)-modes.el
|
|
puts "
|
|
|
|
writing master mode file : $file
|
|
"
|
|
set header [subst -nocommands -nobackslashes $header_template]
|
|
tclu::writeFile $opt(mode)-modes.el [subst -nocommands -nobackslashes $master_template]
|
|
}
|