[semi-long] GNATMake REXX command for OS/2

[semi-long] GNATMake REXX command for OS/2

[Pat Rogers]

Although I have it on _very_ good authority that GNAT 2.04 for OS/2
will soon supply a 'make' for GNAT, I am providing this one now because 
1) it took me an entire sick-day to do it, and 2) I don't know how soon 
"soon" exactly is (but mainly reason #1:).  Since it is the first (and 
perhaps last) REXX routine I have ever written, and since I wasn't all there 
the day I wrote it, use it at your own risk.  I have been using it for 
a few days on a relatively large project with no further bugs discovered.
It is based rather directly on the Perl version found in the 'contrib'
subdirectory at cs.nyu.edu.

"Use it in good health!"

pat rogers
progers@acm.org
Team Ada

PS: Make sure the first line is a coment -- ie, don't leave any blank lines
at the top of the file!

-------------------- cut here ------------------------------------
/**********************************************************************

Description      : Uses GNAT to bring source files up to date
Author           : Pat Rogers (progers@acm.org)
Created On       : 3 March 1995
Version          : 1.0  (Use with caution!!!)
Acknowledgeemnts : Based on a Perl script by Rolf Ebert
Limitations      : Doesn't do the bind yet

Copyright (C) 1995 by Patrick Rogers

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

***********************************************************************/

if ARG() = 0 then do
  call usage;
  exit;
end;

verbose   = 0;
action    = 1;
continue  = 0;
main = "";
gcc_options = " ";

parse arg params; /* don't convert to upper for sake of gcc_options */
do while params <> "";
  parse var params param params
  if substr(param,1,1) = '-' then
    select
       when substr(param,2,1) = 'v' then
         verbose = 1;
       when substr(param,2,1) = 'n' then
         action = 0;
       when substr(param,2,1) = 'k' then
         continue = 1;
       otherwise
         gcc_options = param;
    end  /* select */
  else do
    main = param;
    leave;
  end  /* if */
end; /* while */

if main = "" then do
  call usage;
  exit;
end  /* if */

call RxFuncAdd 'SysLoadFuncs', 'RexxUtil', 'SysLoadFuncs'
call SysLoadFuncs

call SysFileTree main".adb", 'result', 'T'
if result.0 = 0 then do
  say "Unit" main".adb" "not found";
  exit;
end;

updated_list = " ";

call check( main );

exit;  /* GNATMake */




check: procedure expose verbose action continue updated_list gcc_options
  arg main

  if updated( main ) then
    nop;
    /*  say "Avoiding branch for" main  */
  else do

    if verbose then
      say "Analyzing" main

    ali_time = "";
    body_time = "";
    decl_time = "";

    call SysFileTree main".obj", 'result', 'T'
    if result.0 <> 0 then do
      parse var result.1 ali_time result.1
    end
    
    call SysFileTree main".adb", 'result', 'T'
    if result.0 <> 0 then do
      parse var result.1 body_time result.1
    end

    call SysFileTree main".ads", 'result', 'T'
    if result.0 <> 0 then do
      parse var result.1 decl_time result.1
    end

    recompile = 1;

    if (ali_time < body_time ) | (ali_time < decl_time) then do
      if body_time = "" then /* no body */
        call compile( main".ads" );
      else
        call compile( main".adb" );
      recompile = 0;
    end  /* ali is newer */

    dependencies = "";
    do while lines(main".ali");
      line = translate( linein(main".ali"), ' ', '09'x ); /* convert tabs to blanks */
      parse var line flag file time;
      if flag = 'D' then do
        if gnatlibfile(file) then
          nop;
        else
          dependencies = file dependencies 
      end  /* if */
    end /* do */
    call stream main".ali", 'c', "close" 

    save_dependencies = dependencies;

    if recompile then do
      recompile = 0;
      parse upper var dependencies file dependencies;
      do while file <> "";
        call SysFileTree file, 'result', 'T'
        parse var result.1 file_time result.1
        if file_time > ali_time then do
          recompile = 1;
          if verbose then do
            say "";
            say "GNATMake:" main "must be recompiled because" file "has been modified";
          end; /*verbose */
        end  /* file modified */
        parse upper var dependencies file dependencies;
      end /* do */
    end  /* recompile */
    
    if recompile then do
      if body_time = "" then /* no body */
        call compile( main".ads" );
      else
        call compile( main".adb" );
    end; /* if */

    call update( main );

    dependencies = save_dependencies;
    parse upper var dependencies file dependencies;
    do while file <> "";
      dot = pos( '.', file );        
      file = substr( file, 1, dot-1 );  /* strip off extension */
      call check( file );
      parse upper var dependencies file dependencies;
    end /* do */

  end  /* if */
return; /* check */




update: procedure expose updated_list
  arg updated_file
  updated_list = updated_file updated_list
return;


updated: procedure expose updated_list
  arg test_file

  found = 0;
  temp = updated_list;
  do until next_file = "";
    parse var temp next_file temp
    if next_file = test_file then do
      found = 1;
      leave;
    end;  /* if */
  end; /* do */
return found;



compile: procedure expose action continue gcc_options
  arg file
  command = "gcc -c -I\gcc\include" gcc_options file
  if action then do
    command;  /* issues command to OS/2 */  
    if (rc <> 0) & (\continue) then /* problem and we aren't supposed to go on */
      exit "compilation of" file "failed";
  end /* if */
return;



usage:
  say "";
  say "gnatmake [-v] [-n] [-k] [gcc-opts] main";
  say " -v       : verbose";
  say " -n       : no action";
  say " -k       : continue on error";
  say " gcc-opts : other options passed to gcc";
  say " main     : name of the main subprogram, without extension";
  say "";
return;




gnatlibfile: procedure
  arg file

  if ( substr(file,1,1) = 'S' ) & ( substr(file,2,1) = '-' ) then
    return 1;
  if ( substr(file,1,1) = 'A' ) & ( substr(file,2,1) = '-' ) then
    return 1;
  if ( substr(file,1,1) = 'I' ) & ( substr(file,2,1) = '-' ) then
    return 1;
  if ( substr(file,1,1) = 'G' ) & ( substr(file,2,1) = '-' ) then
    return 1;

  /* failing that, look in the list of gnat lib file names */

  found = pos( file, "ADA.ADS SYSTEM.ADS SYSTEM.ADB UNCHDEAL.ADS UNCHDEAL.ADB" );
  if found <> 0 then
    return 1;
  found = pos( file, "UNCHCONV.ADS INTERFAC.ADS TEXT_IO.ADS SEQUENIO.ADS GNAT.ADS" );
  if found <> 0 then
    return 1;
  found = pos( file, "IOEXCEPT.ADS CALENDAR.ADS DIRECTIO.ADS" );
  if found <> 0 then
    return 1;
return 0;

 

\x1a-- 
Pat Rogers
progers@acm.org