summaryrefslogtreecommitdiff
path: root/lib/rightpanel/subprograms.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'lib/rightpanel/subprograms.tcl')
-rwxr-xr-xlib/rightpanel/subprograms.tcl704
1 files changed, 704 insertions, 0 deletions
diff --git a/lib/rightpanel/subprograms.tcl b/lib/rightpanel/subprograms.tcl
new file mode 100755
index 0000000..6385266
--- /dev/null
+++ b/lib/rightpanel/subprograms.tcl
@@ -0,0 +1,704 @@
+#!/usr/bin/tclsh
+# Part of MCU 8051 IDE ( http://mcu8051ide.sf.net )
+
+############################################################################
+# Copyright (C) 2007-2009 by Martin Ošmera #
+# martin.osmera@gmail.com #
+# #
+# This program is free software; you can redistribute it and#or modify #
+# it under the terms of the GNU General Public License as published by #
+# the Free Software Foundation; either version 2 of the License, or #
+# (at your option) any later version. #
+# #
+# This program is distributed in the hope that it will be useful, #
+# but WITHOUT ANY WARRANTY; without even the implied warranty of #
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the #
+# GNU General Public License for more details. #
+# #
+# You should have received a copy of the GNU General Public License #
+# along with this program; if not, write to the #
+# Free Software Foundation, Inc., #
+# 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. #
+############################################################################
+
+# --------------------------------------------------------------------------
+# DESCRIPTION
+# Provides panel for watching subprogram calls
+# --------------------------------------------------------------------------
+
+class SubPrograms {
+ ## COMMON
+ common fsd_filename {} ;# Filename choosen by FSD
+ # Main font for the text widget
+ common main_font [font create \
+ -family {helvetica} \
+ -size -14 \
+ ]
+ # Bold font for the text widget
+ common bold_font [font create \
+ -family {helvetica} \
+ -size -14 -weight {bold} \
+ ]
+ # Font for status bar below the text box
+ common large_font [font create \
+ -family {helvetica} \
+ -size -14 \
+ ]
+ # Bold font for status bar below the text box
+ common large_bold_font [font create \
+ -family {helvetica} \
+ -size -14 -weight {bold} \
+ ]
+
+ ## PRIVATE
+ private variable parent ;# Widget: parent widget
+ private variable gui_initialized 0 ;# Bool: GUI initialized
+
+ private variable text_widget ;# Widget: Text widget containg almost all the information
+ private variable scrollbar ;# Widget: Scrollbar for the text widget
+ private variable enable_chbut ;# Widget: Check button "Enable"
+ private variable intr_chbut ;# Widget: Check button "Include interrupts"
+ private variable total_val_lbl ;# Widget: Label containg the count of subprograms recorded
+ private variable menu {} ;# Widget: Popup menu for the text widget
+ private variable enabled 1 ;# Bool: Panel active
+ private variable ena_intr 1 ;# Bool: Taking interrupts enabled
+ private variable return_but ;# Widget: Button "RETURN"
+ private variable save_but ;# Widget: Button "Save"
+ private variable clear_but ;# Widget: Button "Clear"
+ private variable count 0 ;# Int: Number of subprograms mentioned in the text widget
+ private variable menu_source {} ;# String: Auxiliary variable for the popup menu -- Source address
+ private variable menu_target {} ;# String: Auxiliary variable for the popup menu -- Target address
+
+ constructor {} {
+ }
+
+ destructor {
+ if {$gui_initialized} {
+ menu_Sbar_remove $menu
+ }
+ }
+
+ ## Prepare this panel for initialization of its GUI
+ # MUST BE called before "CreateSubProgramsGUI"
+ # @parm Widget _parent - Frame where this panel would be created
+ # @return void
+ public method PrepareSubPrograms {_parent} {
+ set parent $_parent
+ set gui_initialized 0
+ load_config $::CONFIG(SUBP_MON_CONFIG)
+ }
+
+ ## Finalize initialization of this panel
+ # @return void
+ public method CreateSubProgramsGUI {} {
+ create_gui
+ subprograms_create_tags
+ create_menus
+ set_bindings
+ }
+
+ ## Get configuration list for this panel
+ # @return void
+ public method subprograms_get_config {} {
+ return [list $enabled $ena_intr]
+ }
+
+ ## Load configuration list for this panel
+ # @parm List conf - Configuration list
+ # @return void
+ private method load_config {conf} {
+ if {![regexp {^[01] [01]$} $conf]} {
+ return
+ }
+ set enabled [lindex $conf 0]
+ set ena_intr [lindex $conf 1]
+ }
+
+ ## Create all widgets which this panel consist of
+ # @return void
+ private method create_gui {} {
+ if {$gui_initialized} {return}
+ set gui_initialized 1
+
+ # Create top frame (checkbuttons)
+ set top_frame [frame $parent.top]
+ set enable_chbut [checkbutton $top_frame.enable_chbut \
+ -text [mc "Enable"] \
+ -command "$this subprograms_dis_ena" \
+ ]
+ set intr_chbut [checkbutton $top_frame.intr_chbut \
+ -text [mc "Include interrupts"] \
+ -command "$this subprograms_intr_yesno" \
+ ]
+ pack $enable_chbut -side left -padx 10
+ pack $intr_chbut -side left -padx 10
+
+ # Adjust check buttons
+ if {$enabled} {
+ $enable_chbut select
+ } {
+ $enable_chbut deselect
+ }
+ if {$ena_intr} {
+ $intr_chbut select
+ } {
+ $intr_chbut deselect
+ }
+
+ # Create button frame (Buttons: Save, Clear and Return)
+ set button_frame [frame $parent.button_frame]
+ set return_but [ttk::button $button_frame.return_but \
+ -text [mc "RETURN"] \
+ -compound left \
+ -image ::ICONS::16::button_cancel \
+ -command "$this subprograms_force_return" \
+ -state disabled \
+ -width 6 \
+ ]
+ set clear_but [ttk::button $button_frame.clear_but \
+ -text [mc "Clear"] \
+ -style Flat.TButton \
+ -compound left \
+ -state disabled \
+ -image ::ICONS::16::editdelete \
+ -command "$this subprograms_clear" \
+ -width 5 \
+ ]
+ set save_but [ttk::button $button_frame.filesaveas \
+ -text [mc "Save"] \
+ -style Flat.TButton \
+ -compound left \
+ -state disabled \
+ -image ::ICONS::16::filesaveas \
+ -command "$this subprograms_save" \
+ -width 5 \
+ ]
+ pack $save_but -pady 0 -side left
+ pack $clear_but -pady 0 -side left -padx 5
+ pack $return_but -pady 0 -side right
+
+ # Create middle frame (text widget and its scrollbar)
+ set middle_frame [frame $parent.middle]
+ set text_widget [text $middle_frame.text \
+ -yscrollcommand "$middle_frame.scrollbar set" \
+ -bg {#FFFFFF} -width 0 -height 0 \
+ -font $main_font -insertontime 0 -wrap none \
+ -cursor left_ptr -takefocus 0 \
+ -tabstyle wordprocessor \
+ ]
+ set scrollbar [ttk::scrollbar $middle_frame.scrollbar \
+ -orient vertical \
+ -command "$text_widget yview" \
+ ]
+ pack $text_widget -side left -fill both -expand 1
+ pack $scrollbar -side right -fill y -after $text_widget
+
+ # Create bottom frame
+ set bottom_frame [frame $parent.bottom]
+ pack [label $bottom_frame.total_lbl \
+ -text [mc "TOTAL: "] -font $large_font \
+ -fg {#555555} \
+ ] -side left
+ set total_val_lbl [label $bottom_frame.total_val_lbl \
+ -font $large_bold_font -text {0} \
+ ]
+ pack $total_val_lbl -side left
+
+ # Pack all main frames
+ pack $top_frame -fill x
+ pack $button_frame -fill x
+ pack $middle_frame -fill both -expand 1
+ pack $bottom_frame -fill x -side bottom
+ }
+
+ ## Set event bindings for the text widget
+ # @return void
+ private method set_bindings {} {
+ foreach event {
+ <B1-Enter> <B1-Leave>
+ <B2-Motion> <Button-5> <Button-4>
+ <MouseWheel>
+ } {
+ bind $text_widget $event [bind Text $event]
+ }
+ bind $text_widget <Button-1> "$this subprograms_click %x %y"
+ bind $text_widget <ButtonRelease-3> "$this subprograms_popup %x %y %X %Y"
+ bindtags $text_widget $text_widget
+ }
+
+ ## Create popup menu for the text widget
+ # @return void
+ private method create_menus {} {
+ set menu "$text_widget.popup_menu"
+ if {[winfo exists $menu]} {destroy $menu}
+ menuFactory {
+ {command {Go to source line} {} 0 "subprograms_menu_action 0"
+ {goto} "Navigate code editor to the line from which this subprogram was invoked"}
+ {command {Go to target line} {} 0 "subprograms_menu_action 1"
+ {goto} "Navigate code editor to the line from where this subprogram resides"}
+ {separator}
+ {command {Copy source address to clipboard} {} 0 "subprograms_menu_action 2"
+ {editcopy} "Copy return address to clipboard (hexadecimal representation)"}
+ {command {Copy target address to clipboard} {} 0 "subprograms_menu_action 3"
+ {editcopy} "Copy address where this subprogram begins to the clipboard"}
+ {separator}
+ {command {Remove this} {} 0 "subprograms_menu_action 4"
+ {editdelete} "Remove this entry"}
+ } $menu 0 "$this " 0 {}
+ }
+
+ ## Create highlighting tags for the text widget
+ # @return void
+ private method subprograms_create_tags {} {
+ $text_widget tag configure tag_sel -borderwidth 1 -relief raised
+ $text_widget tag configure tag_from -foreground {#00AA00}
+ $text_widget tag configure tag_to -foreground {#0000AA}
+ $text_widget tag configure tag_ins -font $bold_font
+ $text_widget tag configure tag_first -background {#DDDDDD}
+ }
+
+ ## Toggle state enabled for whole panel
+ # @return void
+ public method subprograms_dis_ena {} {
+ set enabled [expr {!$enabled}]
+ if {$enabled} subprograms_clear
+ }
+
+ ## Toggle flag "Enable interrupts"
+ # @return void
+ public method subprograms_intr_yesno {} {
+ set ena_intr [expr {!$ena_intr}]
+ }
+
+ ## Event handler for the text widget: <Button-1>
+ # @parm Int x - Relative pointer position
+ # @parm Int y - Relative pointer position
+ # @return void
+ public method subprograms_click {x y} {
+ set menu_source {}
+ set menu_target {}
+ $text_widget configure -state normal
+
+ # Remove selection and determinate line number
+ $text_widget tag remove tag_sel 1.0 end
+ set line [expr {int([$text_widget index @$x,$y])}]
+
+ # Adjust selection
+ if {$line % 3} {
+ set line [expr {($line / 3) * 3}]
+ if {($line / 3) < $count} {
+ # Set selection
+ incr line
+ $text_widget tag add tag_sel $line.0 [expr {$line+2}].0
+
+ # Determinate source address of the selected subprogram
+ regexp {\w+\s*$} [$text_widget get \
+ $line.0 [list $line.0 lineend] \
+ ] menu_target
+ set menu_target [string trimright $menu_target { h}]
+ if {![string is xdigit $menu_target]} {
+ set menu_target {}
+ }
+
+ # Determinate target address of the selected subprogram
+ regexp {\w+\s*$} [$text_widget get \
+ [expr {$line + 1}].0 \
+ [list [expr {$line + 1}].0 lineend] \
+ ] menu_source
+ set menu_source [string trimright $menu_source { h}]
+ if {![string is xdigit $menu_source]} {
+ set menu_source {}
+ }
+ }
+ }
+
+ # Disable the text widget again
+ $text_widget configure -state disabled
+ }
+
+ ## Perform certain menu action (popup menu for the text widget)
+ # @parm Int action - ID of action to execute
+ # @return void
+ public method subprograms_menu_action {action} {
+ switch -- $action {
+ 0 { ;# Action: "Go to source line"
+ if {$menu_source != {}} {
+ goto_line [expr {"0x$menu_source" - 1}]
+ }
+ }
+ 1 { ;# Action: "Go to target line"
+ if {$menu_target != {}} {
+ goto_line [expr "0x$menu_target"]
+ }
+ }
+ 2 { ;# Action: "Copy source address to clipboard"
+ clipboard clear
+ clipboard append $menu_source
+ }
+ 3 { ;# Action: "Copy target address to clipboard"
+ clipboard clear
+ clipboard append $menu_target
+ }
+ 4 { ;# Remove this entry
+ if {[llength [$text_widget tag nextrange tag_sel 1.0]]} {
+ $text_widget configure -state normal
+ $text_widget delete tag_sel.first tag_sel.last+1l
+ $text_widget configure -state disabled
+ }
+ }
+ }
+ }
+
+ ## Action: "Go to source line" / "Go to target line"
+ # @parm Int address - Address in code memory
+ # @return void
+ private method goto_line {address} {
+ # Resolve line number and source address
+ set line [$this simulator_address2line $address]
+ set address [$this simulator_line2address [lindex $line 0] [lindex $line 1]]
+
+ # Line resolved
+ if {$line != {}} {
+ # Simulator is running
+ if {[$this is_frozen]} {
+ $this setPC $address
+ $this Simulator_sync_PC_etc
+ $this move_simulator_line $line
+ # Simulator is not running
+ } {
+ set filename [$this simulator_get_filename [lindex $line 1]]
+ set filename [file tail $filename]
+ if {[$this fucus_specific_editor $filename 0]} {
+ $this editor_procedure {} goto [lindex $line 0]
+ }
+ }
+ # Line unresolved
+ } {
+ tk_messageBox \
+ -parent . \
+ -title [mc "Line not found"] \
+ -message [mc "There is no matching line in the source code"]
+ }
+ }
+
+ ## Invoke popup menu for the text widget
+ # @parm Int x - Relative position of mouse pointer
+ # @parm Int y - Relative position of mouse pointer
+ # @parm Int X - Absolute position of mouse pointer
+ # @parm Int Y - Absolute position of mouse pointer
+ # @return void
+ public method subprograms_popup {x y X Y} {
+ # Adjust selection
+ subprograms_click $x $y
+
+ # Determinate line and what to do with the menu
+ set line [expr {int([$text_widget index @$x,$y])}]
+ if {$line % 3} {
+ set line [expr {$line / 3}]
+ if {$line >= $count} {
+ set state {disabled}
+ } {
+ set state {normal}
+ }
+ } {
+ set state {disabled}
+ }
+
+ # Adjust states of certain items in the menu
+ foreach entry {
+ {Go to source line}
+ {Go to target line}
+ {Copy source address to clipboard}
+ {Copy target address to clipboard}
+ {Remove this}
+ } {
+ $menu entryconfigure [::mc $entry] -state $state
+ }
+
+ # Invoke the menu
+ tk_popup $menu $X $Y
+ }
+
+ ## Register subprogram call
+ # @parm Int type - Invoked by: 0 == LCALL; 1 == ACALL; 2 == Interrupt; 3 == LCALL or ACALL
+ # @parm Int from - Source address (return address)
+ # @parm Int to - Target address
+ # @return void
+ public method subprograms_call {type from to} {
+ if {!$enabled} {return}
+ if {!$gui_initialized} CreateSubProgramsGUI
+
+ # Determinate string to print as an instruction
+ switch -- $type {
+ 0 {set ins " LCALL\t"}
+ 1 {set ins " ACALL\t"}
+ 2 {
+ set ins " Interrupt\t"
+ if {!$ena_intr} {
+ return
+ }
+ }
+ 3 {set ins " CALL\t"}
+ }
+
+ # Convert value of source address to hexadecimal representation
+ if {$from < 0} {
+ set from {-----}
+ } {
+ set from [format %X $from]
+ set len [string length $from]
+ if {$len < 4} {
+ set from "[string repeat {0} [expr {4 - $len}]]$from"
+ }
+ append from {h}
+ }
+
+ # Convert value of target address to hexadecimal representation
+ if {$to < 0} {
+ set to {-----}
+ } {
+ set to [format %X $to]
+ set len [string length $to]
+ if {$len < 4} {
+ set to "[string repeat {0} [expr {4 - $len}]]$to"
+ }
+ append to {h}
+ }
+
+ # Enable the text widget
+ $text_widget configure -state normal
+
+ # Insert separator
+ if {$count} {
+ $text_widget insert 1.0 "\n"
+ }
+
+ # Print return address
+ $text_widget insert 1.0 "\n"
+ $text_widget insert 1.0 [mc " Return address:\t"]
+ set idx [$text_widget index {1.0 lineend}]
+ $text_widget insert {1.0 lineend} $from
+ $text_widget tag add tag_from $idx {1.0 lineend}
+
+ # Print type and target address
+ $text_widget insert 1.0 "\n"
+ $text_widget insert 1.0 "$ins\t"
+ $text_widget tag add tag_ins 1.0 {1.0 lineend}
+ set idx [$text_widget index {1.0 lineend}]
+ $text_widget insert {1.0 lineend} $to
+ $text_widget tag add tag_to $idx {1.0 lineend}
+
+ $text_widget tag remove tag_first 1.0 end
+ $text_widget tag add tag_first 1.0 3.0
+
+ # Disable the text widget, adjust button bar, labels on the bottom
+ $text_widget configure -state disabled
+ incr count
+ $total_val_lbl configure -text $count
+ disena_buttonbar $count
+ }
+
+ ## Disable or enable buttons on the button bar
+ # @parm Bool bool - 1 == enable; 0 == diable
+ # @return void
+ private method disena_buttonbar {bool} {
+ if {$bool} {
+ set state {normal}
+ } {
+ set state {disabled}
+ }
+ $return_but configure -state $state
+ $clear_but configure -state $state
+ $save_but configure -state $state
+ }
+
+ ## Register return for subprogram
+ # @parm Bool intr__sub - 0 == Common subprogram; 1== Interrupt
+ # @return void
+ public method subprograms_return {intr__sub} {
+ if {!$enabled} {return}
+ if {!$count} {return}
+ if {$intr__sub && !$ena_intr} {return}
+ if {!$gui_initialized} CreateSubProgramsGUI
+
+ $text_widget configure -state normal
+ $text_widget delete 1.0 4.0
+ $text_widget configure -state disabled
+ incr count -1
+ if {$count} {
+ $text_widget tag remove tag_first 1.0 end
+ $text_widget tag add tag_first 1.0 3.0
+ }
+ $total_val_lbl configure -text $count
+ disena_buttonbar $count
+ }
+
+ ## Clear the text widget
+ # @return void
+ public method subprograms_clear {} {
+ if {!$gui_initialized} {return}
+ set count 0
+ $total_val_lbl configure -text 0
+ $text_widget configure -state normal
+ $text_widget delete 1.0 end
+ $text_widget configure -state disabled
+ disena_buttonbar 0
+ }
+
+ ## Enable or disable this panel
+ # @parm Bool bool - 1 == Enable; 0 == Disbale
+ # @return void
+ public method subprograms_setEnabled {bool} {
+ if {!$gui_initialized} {return}
+ if {!$bool} {
+ $return_but configure -state disabled
+ }
+ }
+
+ ## Force return from active subprogram (the topmost entry)
+ # Binding for button "RETURN" on the button bar
+ # @return void
+ public method subprograms_force_return {} {
+ if {![regexp {^\s*\w+} [$text_widget get 1.0 3.0] word]} {
+ return
+ }
+ set word [string trim $word]
+ if {$word == {Interrupt}} {
+ set word 1
+ } {
+ set word 0
+ }
+ $this simulator_return_from_SP $word
+ }
+
+ ## Invoke file selection dialog to save file
+ # Binding for button "Save" on the button bar
+ # @return void
+ public method subprograms_save {} {
+
+ # Invoke the dialog
+ catch {delete object fsd}
+ KIFSD::FSD fsd \
+ -title [mc "Save file - MCU 8051 IDE"] \
+ -directory [$this cget -projectPath] \
+ -defaultmask 0 -multiple 0 -filetypes {
+ {{Plain text} {*.txt} }
+ {{All files} {*} }
+ }
+
+ # Ok button
+ fsd setokcmd {
+ set fsd_filename [::SubPrograms::fsd get]
+ if {!$::MICROSOFT_WINDOWS} { ;# POSIX way
+ if {![regexp "^(~|/)" $fsd_filename]} {
+ set filename "[${::X::actualProject} cget -ProjectDir]/$fsd_filename"
+ }
+ } { ;# Microsoft windows way
+ if {![regexp "^\w:" $fsd_filename]} {
+ set filename [file join [${::X::actualProject} cget -ProjectDir] $fsd_filename]
+ }
+ }
+
+ set ::SubPrograms::fsd_filename [file normalize $fsd_filename]
+ }
+
+ # Activate the dialog
+ fsd activate
+ if {$fsd_filename != {}} {
+ subprograms_save_proc $fsd_filename
+ }
+ }
+
+ ## Save content of the text widget under certain filename
+ # @parm String filename - Target filename
+ # @return void
+ public method subprograms_save_proc {filename} {
+ # Adjust file extension
+ if {[file extension [file tail $filename]] != {.txt}} {
+ append filename {.txt}
+ }
+ # Make backup copy of the file
+ if {[file exists $filename] && [file isfile $filename]} {
+ # Ask user for overwrite existing file
+ if {[tk_messageBox \
+ -type yesno \
+ -icon question \
+ -parent . \
+ -title [mc "Overwrite file"] \
+ -message [mc "A file name '%s' already exists. Are you sure you want to overwrite it ?" [file tail $filename]]
+ ] != {yes}
+ } {
+ return
+ }
+ # Create a backup file
+ catch {
+ file rename -force $filename "$filename~"
+ }
+ }
+ # Try to open the file
+ if {[catch {
+ set file [open $filename w 420]
+ }]} {
+ tk_messageBox \
+ -parent . \
+ -icon warning \
+ -type ok \
+ -title [mc "Permission denied"] \
+ -message [mc "Unable to write to file:\n\"%s\"" $filename]
+ return
+ }
+ # Write content of the text widget into the file and close the file
+ puts -nonewline $file [$text_widget get 1.0 end]
+ close $file
+ }
+
+ ## Get number of recorder active subprograms
+ # @return Int - Count
+ public method subprograms_get_count {} {
+ if {!$gui_initialized} {return 0}
+ return $count
+ }
+
+ ## Get content for purpose of program hibernation
+ # @return String - Text
+ public method subprograms_get_formated_content {} {
+ if {!$gui_initialized} {return {}}
+ set result {}
+ set source {}
+ set target {}
+ set type {}
+ set line_num 0
+
+ foreach line [split [$text_widget get 1.0 end] "\n"] {
+ if {$line == {}} {
+ if {$source != {} && $target != {} && $type != {}} {
+ lappend result [list $source $target $type]
+ }
+ set line 0
+ set source {}
+ set target {}
+ set type {}
+ continue
+ }
+ if {$line_num} {
+ regexp {\w+\s*$} $line source
+ set source [string range $source 0 3]
+ set source [expr "0x$source"]
+ } {
+ regexp {\w+\s*$} $line target
+ set target [string range $target 0 3]
+ set target [expr "0x$target"]
+
+ regexp {^\s*\w+} $line type
+ switch -- [string trim $type] {
+ {LCALL} {set type 0}
+ {ACALL} {set type 1}
+ {Interrupt} {set type 2}
+ {CALL} {set type 3}
+ }
+ }
+ incr line_num
+ }
+ return $result
+ }
+}
generated by cgit v1.2.3 (git 2.25.1) at 2024-04-24 17:54:17 +0000