home *** CD-ROM | disk | FTP | other *** search
/ PC World 1998 October / PCWorld_1998-10_cd.bin / software / prehled / komix / DATA.Z / cpp_regen.tcl < prev    next >
Text File  |  1997-04-10  |  8KB  |  292 lines
  1. #---------------------------------------------------------------------------
  2. #
  3. # Copyright (c) 1993-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        : @(#)cpp_regen.tcl    /main/titanic/1
  17. #    Original date    : 14-7-1993
  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_split
  27.     catch {unset re_split}
  28.     set re_user_includes ""
  29.     set re_ctor ""
  30.     set re_found_ctor 0
  31.     set re_dtor ""
  32.  
  33.     class2tgtfiles $class src_file h_file
  34.     if {![fstorage::exists $src_file]} {
  35.         return
  36.     }
  37.     if [catch {set fd [fstorage::open $src_file r]}] {
  38.         return
  39.     }
  40.  
  41.     check_code $class $fd 
  42.  
  43.     # include piece
  44.     seek $fd 0
  45.     global START_INCLUDE_MESSAGE END_INCLUDE_MESSAGE
  46.     process_start_end_piece $fd $START_INCLUDE_MESSAGE \
  47.                 $END_INCLUDE_MESSAGE re_user_includes
  48.     # constructor piece
  49.     # expect constructor/destructor after include part
  50.     set pos [tell $fd]
  51.     global START_CTOR_MESSAGE END_CTOR_MESSAGE
  52.     set re_found_ctor [process_start_end_piece $fd $START_CTOR_MESSAGE \
  53.                         $END_CTOR_MESSAGE re_ctor]
  54.     # destructor piece
  55.     # do NOT expect it after the constructor
  56.     # so reset to pos
  57.     seek $fd $pos
  58.     global START_DTOR_MESSAGE END_DTOR_MESSAGE
  59.     process_start_end_piece $fd $START_DTOR_MESSAGE \
  60.                         $END_DTOR_MESSAGE re_dtor
  61.     
  62.     seek $fd 0
  63.     process_user_added_methods $fd
  64.     fstorage::close $fd
  65. }
  66.  
  67. # check for OLDCODE
  68. # check for OBSOLETE CODE
  69. # check for braces that disturb regeneration process (=braces at column 0)
  70.  
  71. proc check_code {class fd} {
  72.     set line [gets $fd]
  73.     set opener 0
  74.     set closer 0
  75.     while {![eof $fd] && $line != "#ifdef OLDCODE" && \
  76.                     $line != "#ifdef OBSOLETE_CODE" } {
  77.         if {[regexp {^\}.+} $line] || [regexp {^\{.+} $line]} {
  78.             m4_error $E_REGEN [braces_error_msg $class $line]
  79.         }
  80.         if {[regexp {^\{$} $line] } {
  81.             incr opener
  82.         }
  83.         if {[regexp {^\}$} $line] } {
  84.             if {($opener - $closer) >= 1} {
  85.                 incr closer
  86.             } else {
  87.                 m4_error $E_REGEN [braces_error_msg $class $line]
  88.             }
  89.         }
  90.         set line [gets $fd]
  91.     }
  92.     if {$opener != $closer} {
  93.         m4_error $E_REGEN [braces_error_msg $class $line]
  94.     }
  95.     if {$line == "#ifdef OLDCODE" || $line == "#ifdef OBSOLETE_CODE"} {
  96.         m4_error $E_REGEN [oldcode_error_msg $class $line]
  97.     }
  98. }
  99.  
  100. proc process_start_end_piece {fd st_msg end_msg result} {
  101.     upvar $result lresult
  102.     set lresult ""
  103.     set found 0
  104.     set line [gets $fd]
  105.     while {![eof $fd] && ![string match *$st_msg $line]} {
  106.         set line [gets $fd]
  107.     }
  108.     set found [string match *$st_msg $line]
  109.     set line [gets $fd]
  110.     while {![eof $fd] && ![string match *$end_msg $line]} {
  111.         append lresult "$line\n"
  112.         set line [gets $fd]
  113.     }
  114.     return $found
  115. }
  116.  
  117. # Fill the global array 're_split' with all the method bodies.
  118. # The key is the method name.
  119. # The contents is a list of method type and method contents.
  120. # For each overloaded method this list is extended with
  121. # another type and contents. The order of this list is the file order.
  122.  
  123. proc process_user_added_methods {fd} {
  124.         global re_split
  125.     while {![eof $fd]} {
  126.         set line [gets $fd]
  127.         if {$line == $REGEN_END} {
  128.             break
  129.         }
  130.         set exp_method {^[^     ].*::(.*)(\(.*[\)t:]$)}
  131.         if [regexp $exp_method $line dummy method type] {
  132.             set result ""
  133.             set tr_type [string trimright $type :]
  134.             if {$tr_type != $type} {
  135.                 # also remove whitspace from type
  136.                 set type [string trimright $tr_type]
  137.                 append result " :"
  138.             }
  139. #            append result "\n"
  140.             set line [gets $fd]
  141.             set f 0
  142.             set br 0
  143.             while {![eof $fd] && \
  144.                 ($f == 0 || ($br > 0 && $f == 1))} {
  145.                 append result "\n"
  146.                 if {[regexp {^\{$} $line]} {
  147.                     set f 1
  148.                     incr br
  149.                 }
  150.                 if {$f == 1 && [regexp {^\}$} $line] } {
  151.                     incr br -1
  152.                 }
  153.                 append result "$line"
  154.                 set line [gets $fd]
  155.             }
  156.             if [info exist re_split($method)] {
  157.                 lappend re_split($method) $type
  158.                 lappend re_split($method) $result
  159.             } else {
  160.                 set re_split($method) [list $type $result]
  161.             }
  162.         }
  163.     }
  164. }
  165.  
  166. # provide a method body; a default message or a previously edited one
  167. # look in global array 're_split' for user added method bodies. 
  168. #
  169. # if var_name is not empty, this name is used for the ...not_yet_implemented
  170. # variable
  171.  
  172. proc get_method_body {method_name method_type section {var_name ""}} {
  173.     global re_split
  174.         if {$var_name == ""} {
  175.             set var_name ${method_name}_is_not_yet_implemented
  176.         } else {
  177.             set var_name ${var_name}_is_not_yet_implemented
  178.         }
  179.     if {![info exists re_split($method_name)]} {
  180.         # no match, provide the default message
  181.         expand_text $section {
  182.  
  183.             {
  184.                 // !! Implement this function !!
  185.                 int ~${var_name};
  186.             }
  187.         
  188.         }
  189.         return
  190.     }
  191.  
  192.     set avail [lsearch $re_split($method_name) $method_type]
  193.     if {$avail != -1} {
  194.         # full match, name and type
  195.  
  196.         lvarpop re_split($method_name) $avail
  197.         expand_text $section {
  198.             ~[lvarpop re_split($method_name) $avail]
  199.  
  200.         }
  201.     } else {
  202.         # method name matched, method type not
  203.         # probabely this is the one, but the
  204.         # parameters have changed 
  205.         # just pick the first one of the list
  206.  
  207.         global cpp_error_state
  208.         if {! $cpp_error_state } {
  209.             puts stdout "WARNING: generated OLDCODE section"
  210.         }
  211.  
  212.         lvarpop re_split($method_name)
  213.         expand_text $section {
  214.  
  215.             #ifdef OLDCODE
  216.             ~[lvarpop re_split($method_name)]
  217.             #else
  218.             {
  219.                 // !! Implement this function !!
  220.                 int ~${var_name};
  221.             }
  222.             #endif
  223.  
  224.         }
  225.     }
  226.     if {[llength $re_split($method_name)] == 0} {
  227.         unset re_split($method_name)
  228.     }
  229. }
  230.  
  231. proc oldcode_error_msg {class line} {
  232.     class2tgtfiles $class src_file h_file
  233.     set msg "file '$src_file' still contains '$line' line"
  234.     return $msg
  235. }
  236.  
  237. proc braces_error_msg {class line} {
  238.     class2tgtfiles $class src_file h_file
  239.     set msg "braces in file '$src_file' do not match"
  240.     if {$line != ""} {
  241.         append msg " code regeneration failed for line '$line'"
  242.     }
  243.     append msg " (code regeneration is based on method-braces at start of line)"
  244.     return $msg
  245. }
  246.  
  247. proc regen_unset {method_name method_type} {
  248.     global re_split
  249.     if {![info exists re_split($method_name)]} {
  250.         return
  251.     }
  252.  
  253.     set avail [lsearch $re_split($method_name) $method_type]
  254.     if {$avail != -1} {
  255.         set x [lvarpop re_split($method_name) $avail]
  256.         lvarpop re_split($method_name) $avail
  257.     } else {
  258.         # just pick the first one
  259.         lvarpop re_split($method_name)
  260.         lvarpop re_split($method_name)
  261.     }
  262.     if {[llength $re_split($method_name)] == 0} {
  263.         unset re_split($method_name)
  264.     }
  265. }
  266.  
  267. proc append_obsolete_code {class} {
  268.     global re_split
  269.     if {! [info exists re_split]} {
  270.         return
  271.     }
  272.     if {[array names re_split] == ""} {
  273.         return
  274.     }
  275.     global cpp_error_state
  276.     if {! $cpp_error_state } {
  277.         puts "WARNING: appending obsolete code section"
  278.     }
  279.     set sect $cpp_sections(c_impl_no_regen_sect)
  280.     $sect append "\n#ifdef OBSOLETE_CODE\n"
  281.  
  282.     foreach el [array names re_split] {
  283.         while {[llength $re_split($el)] != 0} {
  284.             set nmfc "[$class getName]::$el[lvarpop re_split($el)]"
  285.             $sect append "// Function $nmfc:\n"
  286.             $sect append "[lvarpop re_split($el)]\n"
  287.         }
  288.     }
  289.     section    append $sect "#endif\n"
  290. }
  291.  
  292.