home *** CD-ROM | disk | FTP | other *** search
/ PC World 1998 October / PCWorld_1998-10_cd.bin / software / prehled / komix / DATA.Z / ne_regen.tcl < prev    next >
Text File  |  1997-10-24  |  9KB  |  317 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    /main/titanic/1
  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.         process_start_end_piece $fd "" \
  73.                     $END_SOURCE_MESSAGE re_user_source
  74.     }
  75.  
  76.     fstorage::close $fd
  77. }
  78.  
  79. proc print_regen_code {} {
  80.     global re_user_includes re_ctor re_dtor re_split
  81.     if {![info exists re_split]} {
  82.         puts stdout "####NO REGEN CODE####"
  83.         return
  84.     }
  85.     puts stdout "####START REGEN CODE####"
  86.         foreach el [array names re_split] {
  87.         set len [llength $re_split($el)]
  88.         set i 0
  89.                 while {$i < $len} {
  90.             puts stdout "FUNCTION ${el} [lindex $re_split($el) $i]"
  91.             incr i
  92.             puts stdout [lindex $re_split($el) $i]
  93.             incr i
  94.             puts stdout "END FUNCTION"
  95.                 }
  96.         }
  97.     puts stdout "####END REGEN CODE####"
  98. }
  99.  
  100. # check for OLDCODE
  101. # check for OBSOLETE CODE
  102. # check for non matching FUNCTION and END FUNCTION pairs
  103.  
  104. proc check_code {class fd} {
  105.     set line [gets $fd]
  106.     set in_function 0
  107.     while {![eof $fd] && $line != "\{ START OLDCODE" && \
  108.                     $line != "\{ START OBSOLETE_CODE" } {
  109.         if {[regexp {^FUNCTION} $line]} {
  110.             if {$in_function} {
  111.                 error [function_delim_error $class $line]\
  112.                     "" ERR_REGEN
  113.             } else {
  114.                 set in_function 1
  115.             }
  116.         }
  117.         if {[regexp {^END FUNCTION} $line]} {
  118.             if {!$in_function} {
  119.                 error [function_delim_error $class $line]\
  120.                     "" ERR_REGEN
  121.             } else {
  122.                 set in_function 0
  123.             }
  124.         }
  125.         set line [gets $fd]
  126.     }
  127.     if {$line == "\{ START OLDCODE" || $line == "\{ START OBSOLETE_CODE"} {
  128.         error [oldcode_error_msg $class $line] "" ERR_REGEN
  129.     }
  130. }
  131.  
  132. proc process_start_end_piece {fd st_msg end_msg result} {
  133.     upvar $result lresult
  134.     set lresult ""
  135.     set found 0
  136.     if {$st_msg != ""} {
  137.         set line [gets $fd]
  138.         while {![eof $fd] && ![string match *$st_msg $line]} {
  139.             set line [gets $fd]
  140.         }
  141.         set found [string match *$st_msg $line]
  142.     } else {
  143.         set found 1
  144.     }
  145.     set line [gets $fd]
  146.     while {![eof $fd] && ![string match *$end_msg $line]} {
  147.         append lresult "$line\n"
  148.         set line [gets $fd]
  149.     }
  150.     return $found
  151. }
  152.  
  153. # Fill the global array 're_split' with all the method bodies.
  154. # The key is the method name.
  155. # The contents is a list of method type and method contents.
  156. # For each overloaded method this list is extended with
  157. # another type and contents. The order of this list is the file order.
  158.  
  159. proc process_user_added_methods {fd} {
  160.     global re_split
  161.  
  162.     while {![eof $fd]} {
  163.         set line [gets $fd]
  164.         if {$line == $REGEN_END || $line == $START_SOURCE_MESSAGE} {
  165.             break
  166.         }
  167.         set exp_method {^FUNCTION .*::([^\(][^\(]*)(.*[\):])}
  168.         if [regexp $exp_method $line dummy method type] {
  169.             set result ""
  170.  
  171.             # handle possible ':'
  172.             set tr_type [string trimright $type :]
  173.             if {$tr_type != $type} {
  174.                 # also remove whitespace from type
  175.                 set type [string trimright $tr_type]
  176.                 append result " :"
  177.             }
  178.  
  179.             # handle possible 'RETURNING CHAR(*)'
  180.             set ret_pos [string last RETURNING $type]
  181.             if {$ret_pos != -1} {
  182.                 incr ret_pos -1
  183.                 set type [string range $type 0 $ret_pos]
  184.                 set type [string trimright $type]
  185.             }
  186.  
  187.             append result "\n"
  188.             set exp_func_end {^END FUNCTION$}
  189.             set line [gets $fd]
  190.             while {![eof $fd] && ![regexp $exp_func_end $line]} {
  191.                 append result "$line\n"
  192.                 set line [gets $fd]
  193.             }
  194.             if [info exist re_split($method)] {
  195.                 lappend re_split($method) $type
  196.                 lappend re_split($method) $result
  197.             } else {
  198.                 set re_split($method) [list $type $result]
  199.             }
  200.         }
  201.     }
  202.     return $line
  203. }
  204.  
  205. # provide a method body; a default message or a previously edited one
  206. # look in global array 're_split' for user added method bodies.
  207.  
  208. proc get_method_body {method_name method_type section} {
  209.     global re_split
  210.     if {![info exists re_split($method_name)]} {
  211.         # no match, provide the default message
  212.         $section indent +
  213.         expand_text $section {
  214.  
  215.             -- Implement this function!
  216.             --
  217.         }
  218.         $section indent -
  219.         return
  220.     }
  221.  
  222.     set avail [lsearch $re_split($method_name) $method_type]
  223.     if {$avail != -1} {
  224.         # full match, name and type
  225.  
  226.         lvarpop re_split($method_name) $avail
  227.         expand_text $section {
  228.             ~[lvarpop re_split($method_name) $avail]}
  229.     } else {
  230.         # method name matched, method type not
  231.         # probabely this is the one, but the
  232.         # parameters have changed
  233.         # just pick the first one of the list
  234.  
  235.         global ne_error_state
  236.         if {! $ne_error_state } {
  237.             puts stdout "WARNING: generated OLDCODE section"
  238.         }
  239.  
  240.         lvarpop re_split($method_name)
  241.         expand_text $section {
  242.  
  243.             { START OLDCODE
  244.             ~[lvarpop re_split($method_name)
  245.             ]}
  246.                 -- Implement this function!
  247.                 --
  248.         }
  249.     }
  250.     if {[llength $re_split($method_name)] == 0} {
  251.         unset re_split($method_name)
  252.     }
  253. }
  254.  
  255. proc oldcode_error_msg {class line} {
  256.     class2tgtfiles $class src_file h_file
  257.     set msg "ERROR: Generation for class '[$class getName]' failed:\n"
  258.     append msg "    file '$src_file' still contains '$line' line"
  259.     return $msg
  260. }
  261.  
  262. proc function_delim_error {class line} {
  263.     class2tgtfiles $class src_file h_file
  264.     set msg "ERROR: Generation for class '[$class getName]' failed:\n"
  265.     append msg "    FUNCTION and END FUNCTION pairs do not match\n"
  266.     if {$line != ""} {
  267.         append msg "    code regeneration failed for line '$line'\n"
  268.     }
  269.     return $msg
  270. }
  271.  
  272. proc regen_unset {method_name method_type} {
  273.     global re_split
  274.     if {![info exists re_split($method_name)]} {
  275.         return
  276.     }
  277.  
  278.     set avail [lsearch $re_split($method_name) $method_type]
  279.     if {$avail != -1} {
  280.         set x [lvarpop re_split($method_name) $avail]
  281.         lvarpop re_split($method_name) $avail
  282.     } else {
  283.         # just pick the first one
  284.         lvarpop re_split($method_name)
  285.         lvarpop re_split($method_name)
  286.     }
  287.     if {[llength $re_split($method_name)] == 0} {
  288.         unset re_split($method_name)
  289.     }
  290. }
  291.  
  292. proc append_obsolete_code {class} {
  293.     global re_split
  294.     if {! [info exists re_split]} {
  295.         return
  296.     }
  297.     if {[array names re_split] == ""} {
  298.         return
  299.     }
  300.     global ne_error_state
  301.     if {! $ne_error_state } {
  302.         puts "WARNING: appending obsolete code section"
  303.     }
  304.     set sect $ne_sections(c_impl_no_regen_sect)
  305.     $sect append "\n\{ START OBSOLETE_CODE\n"
  306.  
  307.     foreach el [array names re_split] {
  308.         while {[llength $re_split($el)] != 0} {
  309.             set nmfc "[$class getName]::$el[lvarpop re_split($el)]"
  310.             $sect append "Function $nmfc:\n"
  311.             $sect append "[lvarpop re_split($el)]\n"
  312.         }
  313.     }
  314.     $sect append "\}\n"
  315. }
  316.  
  317.