home *** CD-ROM | disk | FTP | other *** search
/ PC World 1997 November / PCWorld_1997-11_cd.bin / software / programy / komix / DATA.Z / ada_regen.tcl < prev    next >
Encoding:
Text File  |  1997-05-15  |  19.9 KB  |  658 lines
  1. ###########################################################################
  2. ##
  3. ##  Copyright (c) 1996 by Cadre Technologies Inc.
  4. ##                          and Scientific Toolworks Inc.
  5. ##
  6. ##  This software is furnished under a license and may be used only in
  7. ##  accordance with the terms of such license and with the inclusion of
  8. ##  the above copyright notice. This software or any other copies thereof
  9. ##  may not be provided or otherwise made available to any other person.
  10. ##  No title to and ownership of the software is hereby transferred.
  11. ##
  12. ##  The information in this software is subject to change without notice
  13. ##  and should not be construed as a commitment by Cadre Technologies Inc.
  14. ##  or Scientific Toolworks Inc.
  15. ##
  16. ###########################################################################
  17.  
  18. global re_old_spec_def_sect
  19. global re_old_body_def_sect
  20. global re_old_subp_arr
  21.  
  22. proc re_echo {line} {
  23. #    puts stdout $line
  24. }
  25.  
  26. proc prepare_regeneration {clname sysflag} {
  27.     global re_old_spec_def_sect
  28.     set re_old_spec_def_sect [section create]
  29.     global re_old_body_def_sect
  30.     set re_old_body_def_sect [section create]
  31.     global re_old_subp_arr
  32.     catch {unset re_old_subp_arr}
  33.     parse_spec_file $clname
  34.     if {$sysflag == 0} {parse_body_file $clname}
  35. }
  36.  
  37. proc parse_spec_file {clname} {
  38.     re_echo "Entering parse_spec_file: class: $clname"
  39.  
  40.     global ada_sections
  41.     global re_old_spec_def_sect
  42.     global USERINITLINE
  43.     global OLDUSERINITLINE
  44.     global USERINITINFO
  45.     global WS
  46.  
  47.     class2tgtfiles $clname body_file spec_file
  48.     if {![fstorage::exists $spec_file]} {
  49.         init_user_sect ada_sections(h_user_sect_1)
  50.         init_user_sect ada_sections(h_user_sect_2)
  51.         init_user_sect ada_sections(h_user_sect_3)
  52.         init_user_sect ada_sections(h_user_sect_4)
  53.         return
  54.     }
  55.  
  56.     puts stdout "Scanning $spec_file"
  57.     #HM Added catch here - failure to open files causing tcl stack dump
  58.     if { [ catch {set fd [fstorage::open $spec_file r]} reason ] }  {
  59.         puts stderr $reason
  60.         m4_error $E_FILE_OPEN_READ $spec_file
  61.         init_user_sect ada_sections(h_user_sect_1)
  62.         init_user_sect ada_sections(h_user_sect_2)
  63.         init_user_sect ada_sections(h_user_sect_3)
  64.         init_user_sect ada_sections(h_user_sect_4)
  65.         return
  66.     }
  67.     set line ""
  68.     set lineno 0
  69.  
  70.     # skip the h_hdr_sect section
  71.     skip_file_upto $spec_file $USERINITINFO $fd $USERINITLINE $OLDUSERINITLINE line lineno
  72.  
  73.     # load the h_user_sect_1 section
  74.     load_user_sect $spec_file $fd ada_sections(h_user_sect_1) line lineno
  75.  
  76.     # skip the h_incl_sect section
  77.     skip_file_upto $spec_file "package $clname is" \
  78.         $fd "^${WS}*package ${clname} is" "" line lineno
  79.  
  80.     # skip the h_class_nm_sect section
  81.     skip_file_upto $spec_file $USERINITINFO $fd $USERINITLINE $OLDUSERINITLINE line lineno
  82.  
  83.     # load the h_user_sect_2 section
  84.     load_user_sect $spec_file $fd ada_sections(h_user_sect_2) line lineno
  85.  
  86.     # load the h_pub_data_sect .. h_priv_func_sect sections into the
  87.     # re_old_spec_def_sect section
  88.     load_sect_upto $spec_file $USERINITINFO $fd $USERINITLINE $OLDUSERINITLINE \
  89.         re_old_spec_def_sect line lineno
  90.  
  91.     # load the h_user_sect_3 section
  92.     load_user_sect $spec_file $fd ada_sections(h_user_sect_3) line lineno
  93.  
  94.     # skip the h_trailer_sect section
  95.     skip_file_upto $spec_file "end $clname;" \
  96.         $fd "^${WS}*end ${clname};" "" line lineno
  97.     skip_file_upto $spec_file $USERINITINFO $fd $USERINITLINE $OLDUSERINITLINE line lineno
  98.  
  99.     # load the h_user_sect_4 section
  100.     load_user_sect $spec_file $fd ada_sections(h_user_sect_4) line lineno
  101.  
  102.     while {[read_next_line $spec_file $fd line lineno 0]} {}
  103.     fstorage::close $fd
  104.     re_echo "Exitting parse_spec_file"
  105. }
  106.  
  107. proc parse_body_file {clname} {
  108.     re_echo "Entering parse_body_file: class: $clname"
  109.  
  110.     global ada_sections
  111.     global re_old_body_def_sect
  112.     global USERINITLINE
  113.     global OLDUSERINITLINE
  114.     global USERINITINFO
  115.     global WS
  116.  
  117.     class2tgtfiles $clname body_file spec_file
  118.     if {![fstorage::exists $body_file]} {
  119.         init_user_sect ada_sections(c_user_sect_1)
  120.         init_user_sect ada_sections(c_user_sect_2)
  121.         init_user_sect ada_sections(c_user_sect_3)
  122.         init_user_sect ada_sections(c_user_sect_4)
  123.         init_user_sect ada_sections(c_user_sect_5)
  124.         return
  125.     }
  126.  
  127.     puts stdout "Scanning $body_file"
  128.     #HM Added catch here - failure to open files causing tcl stack dump
  129.     if { [ catch {set fd [fstorage::open $body_file r]} reason ] }  {
  130.         puts stderr $reason
  131.         m4_error $E_FILE_OPEN_READ $body_file
  132.         init_user_sect ada_sections(c_user_sect_1)
  133.         init_user_sect ada_sections(c_user_sect_2)
  134.         init_user_sect ada_sections(c_user_sect_3)
  135.         init_user_sect ada_sections(c_user_sect_4)
  136.         init_user_sect ada_sections(c_user_sect_5)
  137.         return
  138.     }
  139.     set line ""
  140.     set lineno 0
  141.  
  142.     # skip the c_hdr_sect section
  143.     skip_file_upto $body_file $USERINITINFO $fd $USERINITLINE $OLDUSERINITLINE line lineno
  144.  
  145.     # load the c_user_sect_1 section
  146.     load_user_sect $body_file $fd ada_sections(c_user_sect_1) line lineno
  147.  
  148.     # skip the c_class_nm_sect section
  149.     skip_file_upto $body_file "package body $clname is" \
  150.         $fd "^${WS}*package body ${clname} is" "" line lineno
  151.     skip_file_upto $body_file $USERINITINFO $fd $USERINITLINE $OLDUSERINITLINE line lineno
  152.  
  153.     # load the c_user_sect_2 section
  154.     load_user_sect $body_file $fd ada_sections(c_user_sect_2) line lineno
  155.  
  156.     # load the c_opaque_sect section into the re_old_body_def_sect
  157.     load_sect_upto $body_file $USERINITINFO $fd $USERINITLINE $OLDUSERINITLINE \
  158.         re_old_body_def_sect line lineno
  159.  
  160.     # load the c_user_sect_3 section
  161.     load_user_sect $body_file $fd ada_sections(c_user_sect_3) line lineno
  162.  
  163.     # load the c_access_func_sect and c_impl_sect sections
  164.     load_access_impl_sect $body_file $fd line lineno
  165.  
  166.     # load the c_user_sect_4 section
  167.     load_user_sect $body_file $fd ada_sections(c_user_sect_4) line lineno
  168.  
  169.     # skip the c_trailer_sect section
  170.     skip_file_upto $body_file "end $clname;" \
  171.         $fd "^${WS}*end ${clname};" "" line lineno
  172.     skip_file_upto $body_file $USERINITINFO $fd $USERINITLINE $OLDUSERINITLINE line lineno
  173.  
  174.     # load the c_user_sect_5 section
  175.     load_user_sect $body_file $fd ada_sections(c_user_sect_5) line lineno
  176.  
  177.     while {[read_next_line $body_file $fd line lineno 0]} {}
  178.     fstorage::close $fd
  179.     re_echo "Exitting parse_body_file"
  180. }
  181.  
  182. proc parse_separate_file {class subpname implsect} {
  183.     set s 1
  184.         if [catch {set s [parse_separate_file_actual \
  185.             $class $subpname $implsect]} result] {
  186.                 switch $errorCode {
  187.                         ERR_REGEN {
  188.                                 puts stderr $result
  189.                                 set s 0
  190.                         }
  191.                         default {error $result $errorInfo $errorCode}
  192.                 }
  193.         }
  194.     return $s
  195. }
  196.  
  197. proc parse_separate_file_actual {class subpname implsect} {
  198.     # returns 1 and appends to separate_sections(c_user_sect_1), impl_sect
  199.     #           if file found
  200.     # returns 0 and initializes separate_sections(c_user_sect_1)
  201.     #           if file not found
  202.  
  203.     global separate_sections
  204.     global USERINITLINE
  205.     global OLDUSERINITLINE
  206.     global USERINITINFO
  207.  
  208.         class2separatefiles $class $subpname separate_file
  209.     if {![fstorage::exists $separate_file]} {
  210.         init_user_sect separate_sections(c_user_sect_1)
  211.         return 0
  212.     }
  213.  
  214.     puts stdout "Scanning $separate_file"
  215.     #HM Added catch here - failure to open files causing tcl stack dump
  216.     if { [ catch {set fd [fstorage::open $separate_file r]} reason ] }  {
  217.         puts stderr $reason
  218.         m4_error $E_FILE_OPEN_READ $separate_file
  219.         init_user_sect separate_sections(c_user_sect_1)
  220.         return
  221.     }
  222.     set clname [get_name $class]
  223.     set line ""
  224.     set lineno 0
  225.  
  226.     # skip the file header section
  227.     skip_file_upto $separate_file $USERINITINFO $fd $USERINITLINE $OLDUSERINITLINE \
  228.         line lineno
  229.  
  230.     # load the c_user_sect_1 section
  231.     load_user_sect $separate_file $fd separate_sections(c_user_sect_1) \
  232.         line lineno
  233.     re_echo "parse_separate_file_actual: c_user_sect_1:\n[section get_contents $separate_sections(c_user_sect_1)]"
  234.  
  235.     # skip the separate subprogram header section
  236.     skip_file_upto $separate_file $USERINITINFO $fd $USERINITLINE $OLDUSERINITLINE \
  237.         line lineno
  238.  
  239.     # load the c_impl_sect section
  240.     load_user_sect $separate_file $fd implsect line lineno
  241.     re_echo "parse_separate_file_actual: implsect:\n[section get_contents $implsect]"
  242.  
  243.     while {[read_next_line $separate_file $fd line lineno 0]} {}
  244.     fstorage::close $fd
  245.     puts stdout "Done scanning $separate_file"
  246.     return 1
  247. }
  248.  
  249. proc read_next_line {filename fd upline uplineno {erreof 0} {expmsg ""}} {
  250.     upvar $upline line
  251.     upvar $uplineno lineno
  252.     if {[gets $fd line] < 0} {
  253.         if {$erreof} {
  254.             fstorage::close $fd
  255.             set errmsg "File $filename terminated unexpectedly"
  256.             append errmsg " at line $lineno"
  257.             if {$expmsg != ""} {
  258.                 append errmsg "; expected to find line: $expmsg"
  259.             }
  260.             error "ERROR: ${errmsg}" "STOP" ERR_REGEN
  261.         } else {
  262.             return 0
  263.         }
  264.     }
  265.     incr lineno
  266.     if {[regexp "${WS}*${OBSOLETE}" $line] || [regexp "${WS}*${OLDOBSOLETE}" $line]} {
  267.         fstorage::close $fd
  268.         set errmsg "File $filename contains ${OBSOLETE} line"
  269.         append errmsg "; regeneration failed"
  270.         error "ERROR: ${errmsg}" "STOP" ERR_REGEN
  271.     }
  272.     return 1
  273. }
  274.  
  275. proc init_user_sect {upsect} {
  276.     global USERINITINFO
  277.     global USEREXITINFO
  278.     upvar $upsect sect
  279.     section append $sect "${USERINITINFO}\n"
  280.     section append $sect "${USEREXITINFO}\n"
  281. }
  282.  
  283. proc skip_file_upto {filename userinfo fd expr oldexpr upline uplineno} {
  284.     upvar $upline line
  285.     upvar $uplineno lineno
  286.     while {1} {
  287.         if {[regexp -nocase $expr $line]} {return}
  288.                 if {$oldexpr != ""}  {
  289.                    if {[regexp -nocase $oldexpr $line]} { return }
  290.                 }
  291.         read_next_line $filename $fd line lineno 1 $userinfo
  292.     }
  293. }
  294.  
  295. proc load_sect_upto {filename userinfo fd expr oldexpr upsect upline uplineno} {
  296.     upvar $upline line
  297.     upvar $uplineno lineno
  298.     upvar $upsect sect
  299.     re_echo "Entering load_sect_upto: line: '$line'"
  300.     while {1} {
  301.         if {[regexp -nocase $expr $line] || [regexp -nocase $oldexpr $line]} {
  302.             re_echo "Exitting load_sect_upto: line: '$line'"
  303.             return
  304.         }
  305.         section append $sect "$line\n"
  306.         read_next_line $filename $fd line lineno 1 $userinfo
  307.     }
  308. }
  309.  
  310. proc load_user_sect {filename fd upsect upline uplineno} {
  311.     upvar $upsect sect
  312.     upvar $upline line
  313.     upvar $uplineno lineno
  314.     load_user_sect_or_text $filename $fd sect 1 line lineno
  315. }
  316.  
  317. proc load_user_text {filename fd uptext upline uplineno} {
  318.     upvar $uptext text
  319.     upvar $upline line
  320.     upvar $uplineno lineno
  321.     load_user_sect_or_text $filename $fd text 0 line lineno
  322. }
  323.  
  324. proc load_user_sect_or_text {filename fd upresult issect upline uplineno} {
  325.     global USEREXITLINE
  326.     global OLDUSEREXITLINE
  327.     global USEREXITINFO
  328.     global WS
  329.     global OBSOLETE
  330.     global OLDOBSOLETE
  331.  
  332.     upvar $upresult result
  333.     upvar $upline line
  334.     upvar $uplineno lineno
  335.  
  336.     re_echo "Entering load_user_sect_or_text: line: '$line'"
  337.     if {$issect} {
  338.         if {[section get_indent_string $result] != "$OBSOLETE" &&
  339.                     [section get_indent_string $result] != "$OLDOBSOLETE"} {
  340.             section set_indent $result 0 "    "
  341.         }
  342.     }
  343.     while {1} {
  344.         if {$issect} {
  345.             section append $result "$line\n"
  346.         } else {
  347.             append result "$line\n"
  348.         }
  349.         if {[regexp -nocase $USEREXITLINE $line] || [regexp -nocase $OLDUSEREXITLINE $line]} {
  350.             # read next line before exitting
  351.             read_next_line $filename $fd line lineno 0
  352.             re_echo "Exitting load_user_sect_or_text: line: '$line'"
  353.             return
  354.         }
  355.         read_next_line $filename $fd line lineno 1 $USEREXITINFO
  356.     }
  357. }
  358.  
  359. proc load_access_impl_sect {filename fd upline uplineno} {
  360.     global USERINITLINE
  361.     global OLDUSERINITLINE
  362.     global USERINITINFO
  363.     global WS
  364.     upvar $upline line
  365.     upvar $uplineno lineno
  366.     re_echo "Entering load_access_impl_sect: line: '$line'"
  367.     while {1} {
  368.         if {[regexp -nocase $USERINITLINE $line] || [regexp -nocase $OLDUSERINITLINE $line]} {
  369.             re_echo "Exitting load_access_impl_sect: line: '$line'"
  370.             return
  371.         } elseif {[regexp -nocase "^${WS}*procedure${WS}+" $line]} {
  372.             load_subp $filename $fd line lineno 1
  373.         } elseif {[regexp -nocase "^${WS}*function${WS}+" $line]} {
  374.             load_subp $filename $fd line lineno 0
  375.         } else {
  376.             read_next_line $filename $fd line lineno 1 $USERINITINFO
  377.         }
  378.     }
  379. }
  380.  
  381. proc load_subp {filename fd upline uplineno isproc} {
  382.     global USERINITLINE
  383.     global OLDUSERINITLINE
  384.     global USERINITINFO
  385.     global WS
  386.     global ID
  387.     global re_old_subp_arr
  388.  
  389.     upvar $upline line
  390.     upvar $uplineno lineno
  391.  
  392.     set name ""
  393.     set args ""
  394.     set header ""
  395.     set body ""
  396.  
  397.     if {$isproc} {
  398.         set pat1 "^${WS}*procedure${WS}+(${ID})"
  399.         set pat2 ""
  400.     } else {
  401.         set pat1 "^${WS}*function${WS}+(${ID}|\".*\")"
  402.         set pat2 "return${WS}+${ID}"
  403.     }
  404.  
  405.     re_echo "Entering load_subp: line: '$line'"
  406.     if {[regexp -nocase "(${pat1})${WS}*\$" $line junk header name]} {
  407.         #
  408.         # matched: "procedure Name"
  409.         # or:      "function Name"
  410.         #
  411.         set header [string trim $header]
  412.         while {[read_next_line $filename $fd line lineno 1 \
  413.             "\[...) \]is\[ separate;\]"]} {
  414.  
  415.             if {[regexp -nocase \
  416.             "(${WS}*${pat2})?${WS}*is${WS}*( separate;)?\$" \
  417.             $line junk temp body]} {
  418.                 #
  419.                 # matched: "is[ separate;]"
  420.                 # or:      "return Type is[ separate;]"
  421.                 #
  422.                 set temp [string trim $temp]
  423.                 if {$temp != ""} {
  424.                     append header " $temp"
  425.                 }
  426.                 break
  427.  
  428.             } elseif {[regexp -nocase \
  429.             "(.+\\)(${WS}*${pat2})?)${WS}*is${WS}*( separate;)?\$" \
  430.             $line junk1 temp junk2 body]} {
  431.                 #
  432.                 # matched: "...) is[ separate;]"
  433.                 # or:      "...) return Type is[ separate;]"
  434.                 #
  435.                 set temp [string trim $temp]
  436.                 if {$temp != ""} {
  437.                     append header " $temp"
  438.                 }
  439.                 break
  440.             }
  441.             set line [string trim $line]
  442.             if {$line != ""} {
  443.                 append header " $line"
  444.             }
  445.         }
  446.  
  447.     } elseif {[regexp -nocase \
  448.     "(${pat1}(${WS}+${pat2})?)${WS}+is${WS}*( separate;)?\$" \
  449.     $line junk1 header name junk2 body]} {
  450.         #
  451.         # matched: "procedure Name is[ separate;]"
  452.         # or:      "function Name return Type is[ separate;]"
  453.         #
  454.         set header [string trim $header]
  455.  
  456.     } elseif {[regexp -nocase \
  457.     "(${pat1}${WS}*\\(.*\\)(${WS}*${pat2})?)${WS}*is${WS}*( separate;)?\$" \
  458.     $line junk1 header name junk2 body]} {
  459.         #
  460.         # matched: "procedure Name (Args) is[ separate;]"
  461.         # or:      "function Name (Args) return Type is[ separate;]"
  462.         #
  463.         set header [string trim $header]
  464.  
  465.     } else {
  466.         fstorage::close $fd
  467.         error "file $filename, line $lineno: improper subprogram header format" "STOP" ERR_REGEN
  468.     }
  469.  
  470.     if {$body == ""} {
  471.         #
  472.         # look for a user-written body
  473.         #
  474.         while {[read_next_line $filename $fd line lineno 1 \
  475.             "'begin' or '${USERINITINFO}'"]} {
  476.             if {[regexp -nocase "^${WS}*begin(\$|${WS}+|--)" $line]} {
  477.                 break
  478.             } elseif {[regexp -nocase ${USERINITLINE} $line] || [regexp -nocase ${OLDUSERINITLINE} $line]} {
  479.                 #
  480.                 # load the user-written body
  481.                 #
  482.                 load_user_text $filename $fd body line lineno
  483.                 break
  484.             }
  485.         }
  486.     } else {
  487.         # read next line before exitting
  488.         read_next_line $filename $fd line lineno 0
  489.     }
  490.  
  491.     re_echo "load_subp: name: '$name'"
  492.     re_echo "load_subp: header: '$header'"
  493.     re_echo "load_subp: body: '$body'"
  494.  
  495.     # If a user-written body (or the "separate;" clause) was found for the
  496.     # subprogram, add the header and body (or "separate;") to the global
  497.     # array 're_old_subp_arr'.  The index to the array is the name of the
  498.     # subprogram.  The value of an array element is a list of (overloaded)
  499.     # subprogram header and body pairs.  For each overloaded subprogram
  500.     # this list is extended with another header and body pair.  The order
  501.     # of this list is the file order.
  502.  
  503.     if {$body != ""} {
  504.         if [info exists re_old_subp_arr($name)] {
  505.             lappend re_old_subp_arr($name) $header
  506.             lappend re_old_subp_arr($name) $body
  507.         } else {
  508.             set re_old_subp_arr($name) [list $header $body]
  509.         }
  510.     }
  511.  
  512.     re_echo "Exitting load_subp: line: '$line'"
  513. }
  514.  
  515. # provide a method body; a default message or a previously edited one
  516. # look in global array 're_old_subp_arr' for user added method bodies. 
  517. #
  518. # if var_name is not empty, this name is used for the ...not_yet_implemented
  519. # variable
  520.  
  521. proc get_method_body {name method_type c_sect opername} {
  522.     puts stdout "WARNING: use get_subp_user_body instead of get_method_body"
  523. }
  524.  
  525. proc get_subp_user_body {class subpname subpheader implsect} {
  526.     # returns  1 and appends user-written body to implsect if found, and if
  527.     #            separate file is parsed, also sets separate_sections(c_
  528.     #         user_sect_1) from file
  529.     # returns -1 and appends user-written body prefixed by "-- OBSOLETE:"
  530.     #            to implsect if name matched but not header
  531.     # returns  0 and appends dummy body if body not found
  532.  
  533.     global re_old_subp_arr
  534.     global separate_sections
  535.  
  536.     if {![info exists re_old_subp_arr($subpname)]} {
  537.         if {[info exists separate_sections(c_user_sect_1)]} {
  538.             init_user_sect separate_sections(c_user_sect_1)
  539.         }
  540.         append_null_body $subpname $implsect
  541.         return 0
  542.     }
  543.  
  544.     re_echo "get_subp_user_body: inp header: $subpheader"
  545.     regsub -all "${WS}*\n${WS}*" [string trim $subpheader] " " subpheader
  546.     re_echo "get_subp_user_body: trm header: $subpheader"
  547.     set avail [lsearch -exact $re_old_subp_arr($subpname) $subpheader]
  548.     if {$avail != -1} {
  549.         #
  550.         # full match, name and header, pop the header, append the body
  551.         #
  552.         lvarpop re_old_subp_arr($subpname) $avail
  553.         set body [lvarpop re_old_subp_arr($subpname) $avail]
  554.         if {[llength $re_old_subp_arr($subpname)] == 0} {
  555.             unset re_old_subp_arr($subpname)
  556.         }
  557.         if {[regexp -nocase "^${WS}*separate;${WS}*\$" $body]} {
  558.             if {[parse_separate_file $class $subpname $implsect]} {
  559.                 return 1
  560.             } else {
  561.                 append_null_body $subpname $implsect
  562.                 return 0
  563.             }    
  564.         } else {
  565.             set indcnt 0
  566.             while {[section get_indent $implsect] > 0} {
  567.                 section set_indent $implsect -
  568.                 incr indcnt
  569.             }
  570.             section append $implsect "$body"
  571.             while {$indcnt > 0} {
  572.                 section set_indent $implsect +
  573.                 incr indcnt -1
  574.             }
  575.             return 1
  576.         }
  577.     } else {
  578.         # name matched, but not the header, parameters probably changed
  579.         # just pick the first one of the list
  580.  
  581.         puts stdout "WARNING: generated OBSOLETE section"
  582.  
  583.         lvarpop re_old_subp_arr($subpname)
  584.         set body [lvarpop re_old_subp_arr($subpname)]
  585.         if {[llength $re_old_subp_arr($subpname)] == 0} {
  586.             unset re_old_subp_arr($subpname)
  587.         }
  588.         set tempsect [section create]
  589.         section set_indent $tempsect 1 "${OBSOLETE}"
  590.         if {[regexp -nocase "^${WS}*separate;${WS}*\$" $body]} {
  591.             parse_separate_file $class $subpname $tempsect
  592.         } else {
  593.             section append $tempsect "$body"
  594.         }
  595.         section append $implsect "${USERINITINFO}\nbegin\n"
  596.         section append_section $implsect $tempsect
  597.         section append $implsect "end ${subpname};\n${USEREXITINFO}\n"
  598.         section dealloc $tempsect
  599.         return -1
  600.     }
  601.     return 0
  602. }
  603.  
  604. proc append_null_body {subpname sect} {
  605.     section append $sect "${USERINITINFO}\nbegin\n"
  606.     section append $sect "    -- !! Implement this subprogram !!\n"
  607.     section append $sect "end ${subpname};\n${USEREXITINFO}\n"
  608. }
  609.  
  610. proc del_subp_info {class subpname subpheader} {
  611.     # returns 1 and deletes header and body if subprogram found
  612.     # returns 0 if body not found
  613.  
  614.     puts stdout "proc del_subp_info called!!"
  615.  
  616.     global re_old_subp_arr
  617.     if {![info exists re_old_subp_arr($subpname)]} {
  618.         return 0
  619.     }
  620.  
  621.     set avail [lsearch -exact $re_old_subp_arr($subpname) $subpheader]
  622.     if {$avail != -1} {
  623.         lvarpop re_old_subp_arr($subpname) $avail
  624.         lvarpop re_old_subp_arr($subpname) $avail
  625.     } else {
  626.         # just delete the first one
  627.         lvarpop re_old_subp_arr($subpname)
  628.         lvarpop re_old_subp_arr($subpname)
  629.     }
  630.     if {[llength $re_old_subp_arr($subpname)] == 0} {
  631.         unset re_old_subp_arr($subpname)
  632.     }
  633. }
  634.  
  635. proc append_obsolete_code {class} {
  636.     global re_old_subp_arr
  637.     global OBSOLETE
  638.  
  639.     if {![info exists re_old_subp_arr]} {
  640.         return
  641.     }
  642.     if {[array names re_old_subp_arr] == ""} {
  643.         return
  644.     }
  645.  
  646.     puts "WARNING: appending obsolete code section"
  647.  
  648.     set sect [section create]
  649.     section set_indent $sect 1 "${OBSOLETE}"
  650.     foreach subp [array names re_old_subp_arr] {
  651.         while {[llength $re_old_subp_arr($subp)] != 0} {
  652.             section append $sect "[lvarpop re_old_subp_arr($subp)]\n"      
  653.         }
  654.     }
  655.     section append_section $ada_sections(c_user_sect_5) $sect
  656.     section dealloc $sect
  657. }
  658.