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