[semi-long] GNATmake for emx GNAT 2.03

[semi-long] GNATmake for emx GNAT 2.03

[Pat Rogers]

Here is the first emx version of the REXX gnatmake for OS/2.
--------------cut here ----------------------------------------------------
/**********************************************************************

Description      : Uses GNAT to bring source files up to date
GNAT version     : at least 2.03, the first emx version of GNAT
Author           : Pat Rogers (progers@acm.org)
Created On       : 3 March 1995
Version          : 1.1  (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
  file = translate( file, 'abcdefghijklmnopqrstuvwxyz', 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' );
  command = "gcc -c -I\emx\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