home *** CD-ROM | disk | FTP | other *** search
/ PC World 1997 November / PCWorld_1997-11_cd.bin / software / programy / komix / DATA.Z / ne_regen.tcl < prev    next >
Encoding:
Text File  |  1996-05-31  |  8.5 KB  |  315 lines
  1. #---------------------------------------------------------------------------
  2. #
  3. # Copyright (c) 1994-1995 by Cadre Technologies Inc.
  4. #
  5. # This software is furnished under a license and may be used only in
  6. # accordance with the terms of such license and with the inclusion of
  7. # the above copyright notice. This software or any other copies thereof
  8. # may not be provided or otherwise made available to any other person.
  9. # No title to and ownership of the software is hereby transferred.
  10. #
  11. # The information in this software is subject to change without notice
  12. # and should not be construed as a commitment by Cadre Technologies Inc.
  13. #
  14. #---------------------------------------------------------------------------
  15. #
  16. #    File        : @(#)ne_regen.tcl    1.4
  17. #    Original date    : 17-12-1994
  18. #    Description    : Regeneration code
  19. #              regenerates user added method bodies
  20. #              regenerates start-end bounded pieces of code
  21. #
  22. #---------------------------------------------------------------------------
  23. #
  24.  
  25. proc prepare_regeneration {class} {
  26.     global re_user_includes re_ctor re_found_ctor re_dtor re_user_source
  27.     global re_split
  28.     set re_user_includes ""
  29.     set re_ctor ""
  30.     set re_found_ctor 0
  31.     set re_dtor ""
  32.     set re_user_source ""
  33.     catch {unset re_split}
  34.  
  35.     class2tgtfiles $class src_file h_file
  36.     if {![fstorage::exists $src_file]} {
  37.         return
  38.     }
  39.     if [catch {set fd [fstorage::open $src_file r]}] {
  40.         return
  41.     }
  42.  
  43.     check_code $class $fd
  44.  
  45.     # include piece
  46.     seek $fd 0
  47.     global START_INCLUDE_MESSAGE END_INCLUDE_MESSAGE
  48.     process_start_end_piece $fd $START_INCLUDE_MESSAGE \
  49.                 $END_INCLUDE_MESSAGE re_user_includes
  50.     # constructor piece
  51.     # expect constructor/destructor after include part
  52.     set pos [tell $fd]
  53.     global START_CTOR_MESSAGE END_CTOR_MESSAGE
  54.     set re_found_ctor [process_start_end_piece $fd $START_CTOR_MESSAGE \
  55.                         $END_CTOR_MESSAGE re_ctor]
  56.     # destructor piece
  57.     # do NOT expect it after the constructor
  58.     # so reset to pos
  59.     seek $fd $pos
  60.     global START_DTOR_MESSAGE END_DTOR_MESSAGE
  61.     process_start_end_piece $fd $START_DTOR_MESSAGE \
  62.                         $END_DTOR_MESSAGE re_dtor
  63.  
  64.     seek $fd 0
  65.     set last_line [process_user_added_methods $fd]
  66.  
  67.     # user source piece
  68.     # expect it after user added methods
  69.     # so reset to the last line if appropriate
  70.     global START_SOURCE_MESSAGE END_SOURCE_MESSAGE
  71.     if {$last_line == $START_SOURCE_MESSAGE} {
  72.         set back [expr {[string length $START_SOURCE_MESSAGE] + 1}]
  73.         seek $fd -$back current
  74.         process_start_end_piece $fd $START_SOURCE_MESSAGE \
  75.                     $END_SOURCE_MESSAGE re_user_source
  76.     }
  77.  
  78.     fstorage::close $fd
  79. }
  80.  
  81. proc print_regen_code {} {
  82.     global re_user_includes re_ctor re_dtor re_split
  83.     if {![info exists re_split]} {
  84.         puts stdout "####NO REGEN CODE####"
  85.         return
  86.     }
  87.     puts stdout "####START REGEN CODE####"
  88.         foreach el [array names re_split] {
  89.         set len [llength $re_split($el)]
  90.         set i 0
  91.                 while {$i < $len} {
  92.             puts stdout "FUNCTION ${el} [lindex $re_split($el) $i]"
  93.             incr i
  94.             puts stdout [lindex $re_split($el) $i]
  95.             incr i
  96.             puts stdout "END FUNCTION"
  97.                 }
  98.         }
  99.     puts stdout "####END REGEN CODE####"
  100. }
  101.  
  102. # check for OLDCODE
  103. # check for OBSOLETE CODE
  104. # check for non matching FUNCTION and END FUNCTION pairs
  105.  
  106. proc check_code {class fd} {
  107.     set line [gets $fd]
  108.     set in_function 0
  109.     while {![eof $fd] && $line != "\{ START OLDCODE" && \
  110.                     $line != "\{ START OBSOLETE_CODE" } {
  111.         if {[regexp {^FUNCTION} $line]} {
  112.             if {$in_function} {
  113.                 error [function_delim_error $class $line]\
  114.                     "" ERR_REGEN
  115.             } else {
  116.                 set in_function 1
  117.             }
  118.         }
  119.         if {[regexp {^END FUNCTION} $line]} {
  120.             if {!$in_function} {
  121.                 error [function_delim_error $class $line]\
  122.                     "" ERR_REGEN
  123.             } else {
  124.                 set in_function 0
  125.             }
  126.         }
  127.         set line [gets $fd]
  128.     }
  129.     if {$line == "\{ START OLDCODE" || $line == "\{ START OBSOLETE_CODE"} {
  130.         error [oldcode_error_msg $class $line] "" ERR_REGEN
  131.     }
  132. }
  133.  
  134. proc process_start_end_piece {fd st_msg end_msg result} {
  135.     upvar $result lresult
  136.     set lresult ""
  137.     set found 0
  138.     set line [gets $fd]
  139.     while {![eof $fd] && ![string match *$st_msg $line]} {
  140.         set line [gets $fd]
  141.     }
  142.     set found [string match *$st_msg $line]
  143.     set line [gets $fd]
  144.     while {![eof $fd] && ![string match *$end_msg $line]} {
  145.         append lresult "$line\n"
  146.         set line [gets $fd]
  147.     }
  148.     return $found
  149. }
  150.  
  151. # Fill the global array 're_split' with all the method bodies.
  152. # The key is the method name.
  153. # The contents is a list of method type and method contents.
  154. # For each overloaded method this list is extended with
  155. # another type and contents. The order of this list is the file order.
  156.  
  157. proc process_user_added_methods {fd} {
  158.     global re_split
  159.  
  160.     while {![eof $fd]} {
  161.         set line [gets $fd]
  162.         if {$line == $REGEN_END || $line == $START_SOURCE_MESSAGE} {
  163.             break
  164.         }
  165.         set exp_method {^FUNCTION .*::([^\(][^\(]*)(.*[\):])}
  166.         if [regexp $exp_method $line dummy method type] {
  167.             set result ""
  168.  
  169.             # handle possible ':'
  170.             set tr_type [string trimright $type :]
  171.             if {$tr_type != $type} {
  172.                 # also remove whitespace from type
  173.                 set type [string trimright $tr_type]
  174.                 append result " :"
  175.             }
  176.  
  177.             # handle possible 'RETURNING CHAR(*)'
  178.             set ret_pos [string last RETURNING $type]
  179.             if {$ret_pos != -1} {
  180.                 incr ret_pos -1
  181.                 set type [string range $type 0 $ret_pos]
  182.                 set type [string trimright $type]
  183.             }
  184.  
  185.             append result "\n"
  186.             set exp_func_end {^END FUNCTION$}
  187.             set line [gets $fd]
  188.             while {![eof $fd] && ![regexp $exp_func_end $line]} {
  189.                 append result "$line\n"
  190.                 set line [gets $fd]
  191.             }
  192.             if [info exist re_split($method)] {
  193.                 lappend re_split($method) $type
  194.                 lappend re_split($method) $result
  195.             } else {
  196.                 set re_split($method) [list $type $result]
  197.             }
  198.         }
  199.     }
  200.     return $line
  201. }
  202.  
  203. # provide a method body; a default message or a previously edited one
  204. # look in global array 're_split' for user added method bodies.
  205.  
  206. proc get_method_body {method_name method_type section} {
  207.     global re_split
  208.     if {![info exists re_split($method_name)]} {
  209.         # no match, provide the default message
  210.         $section indent +
  211.         expand_text $section {
  212.  
  213.             -- Implement this function!
  214.             --
  215.         }
  216.         $section indent -
  217.         return
  218.     }
  219.  
  220.     set avail [lsearch $re_split($method_name) $method_type]
  221.     if {$avail != -1} {
  222.         # full match, name and type
  223.  
  224.         lvarpop re_split($method_name) $avail
  225.         expand_text $section {
  226.             ~[lvarpop re_split($method_name) $avail]}
  227.     } else {
  228.         # method name matched, method type not
  229.         # probabely this is the one, but the
  230.         # parameters have changed
  231.         # just pick the first one of the list
  232.  
  233.         global ne_error_state
  234.         if {! $ne_error_state } {
  235.             puts stdout "WARNING: generated OLDCODE section"
  236.         }
  237.  
  238.         lvarpop re_split($method_name)
  239.         expand_text $section {
  240.  
  241.             { START OLDCODE
  242.             ~[lvarpop re_split($method_name)
  243.             ]}
  244.                 -- Implement this function!
  245.                 --
  246.         }
  247.     }
  248.     if {[llength $re_split($method_name)] == 0} {
  249.         unset re_split($method_name)
  250.     }
  251. }
  252.  
  253. proc oldcode_error_msg {class line} {
  254.     class2tgtfiles $class src_file h_file
  255.     set msg "ERROR: Generation for class '[$class getName]' failed:\n"
  256.     append msg "    file '$src_file' still contains '$line' line"
  257.     return $msg
  258. }
  259.  
  260. proc function_delim_error {class line} {
  261.     class2tgtfiles $class src_file h_file
  262.     set msg "ERROR: Generation for class '[$class getName]' failed:\n"
  263.     append msg "    FUNCTION and END FUNCTION pairs do not match\n"
  264.     if {$line != ""} {
  265.         append msg "    code regeneration failed for line '$line'\n"
  266.     }
  267.     return $msg
  268. }
  269.  
  270. proc regen_unset {method_name method_type} {
  271.     global re_split
  272.     if {![info exists re_split($method_name)]} {
  273.         return
  274.     }
  275.  
  276.     set avail [lsearch $re_split($method_name) $method_type]
  277.     if {$avail != -1} {
  278.         set x [lvarpop re_split($method_name) $avail]
  279.         lvarpop re_split($method_name) $avail
  280.     } else {
  281.         # just pick the first one
  282.         lvarpop re_split($method_name)
  283.         lvarpop re_split($method_name)
  284.     }
  285.     if {[llength $re_split($method_name)] == 0} {
  286.         unset re_split($method_name)
  287.     }
  288. }
  289.  
  290. proc append_obsolete_code {class} {
  291.     global re_split
  292.     if {! [info exists re_split]} {
  293.         return
  294.     }
  295.     if {[array names re_split] == ""} {
  296.         return
  297.     }
  298.     global ne_error_state
  299.     if {! $ne_error_state } {
  300.         puts "WARNING: appending obsolete code section"
  301.     }
  302.     set sect $ne_sections(c_impl_no_regen_sect)
  303.     $sect append "\n\{ START OBSOLETE_CODE\n"
  304.  
  305.     foreach el [array names re_split] {
  306.         while {[llength $re_split($el)] != 0} {
  307.             set nmfc "[$class getName]::$el[lvarpop re_split($el)]"
  308.             $sect append "Function $nmfc:\n"
  309.             $sect append "[lvarpop re_split($el)]\n"
  310.         }
  311.     }
  312.     $sect append "\}\n"
  313. }
  314.  
  315.