development/compilers/freepascal/compiler/script.pas

   1 {
   2     $Id$
   3     Copyright (c) 1998-2000 by Peter Vreman
   4
   5     This unit handles the writing of script files
   6
   7     This program is free software; you can redistribute it and/or modify
   8     it under the terms of the GNU General Public License as published by
   9     the Free Software Foundation; either version 2 of the License, or
  10     (at your option) any later version.
  11
  12     This program is distributed in the hope that it will be useful,
  13     but WITHOUT ANY WARRANTY; without even the implied warranty of
  14     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15     GNU General Public License for more details.
  16
  17     You should have received a copy of the GNU General Public License
  18     along with this program; if not, write to the Free Software
  19     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20
  21  ****************************************************************************
  22 }
  23 unit Script;
  24 interface
  25
  26 uses
  27   CObjects;
  28
  29 type
  30   PScript=^TScript;
  31   TScript=object
  32     fn   : string[80];
  33     data : TStringQueue;
  34     executable : boolean;
  35     constructor Init(const s:string);
  36     constructor InitExec(const s:string);
  37     destructor Done;
  38     procedure AddStart(const s:string);
  39     procedure Add(const s:string);
  40     Function  Empty:boolean;
  41     procedure WriteToDisk;virtual;
  42   end;
  43
  44   PAsmScript = ^TAsmScript;
  45   TAsmScript = Object (TScript)
  46     Constructor Init (Const ScriptName : String);
  47     Procedure AddAsmCommand (Const Command, Options,FileName : String);
  48     Procedure AddLinkCommand (Const Command, Options, FileName : String);
  49     Procedure AddDeleteCommand (Const FileName : String);
  50     Procedure WriteToDisk;virtual;
  51   end;
  52
  53   PLinkRes = ^TLinkRes;
  54   TLinkRes = Object (TScript)
  55     procedure Add(const s:string);
  56     procedure AddFileName(const s:string);
  57   end;
  58
  59 var
  60   AsmRes : TAsmScript;
  61   LinkRes : TLinkRes;
  62
  63
  64 implementation
  65
  66 uses
  67 {$ifdef linux}
  68   linux,
  69 {$endif}
  70   globals,systems;
  71
  72
  73 {****************************************************************************
  74                                   TScript
  75 ****************************************************************************}
  76
  77 constructor TScript.Init(const s:string);
  78 begin
  79   fn:=FixFileName(s);
  80   executable:=false;
  81   data.Init;
  82 end;
  83
  84
  85 constructor TScript.InitExec(const s:string);
  86 begin
  87   fn:=FixFileName(s)+source_os.scriptext;
  88   executable:=true;
  89   data.Init;
  90 end;
  91
  92
  93 destructor TScript.Done;
  94 begin
  95   data.done;
  96 end;
  97
  98
  99 procedure TScript.AddStart(const s:string);
 100 begin
 101   data.Insert(s);
 102 end;
 103
 104
 105 procedure TScript.Add(const s:string);
 106 begin
 107   data.Concat(s);
 108 end;
 109
 110
 111 Function TScript.Empty:boolean;
 112 begin
 113   Empty:=Data.Empty;
 114 end;
 115
 116
 117 procedure TScript.WriteToDisk;
 118 var
 119   t : Text;
 120 begin
 121   Assign(t,fn);
 122   Rewrite(t);
 123   while not data.Empty do
 124    Writeln(t,data.Get);
 125   Close(t);
 126 {$ifdef linux}
 127   if executable then
 128    ChMod(fn,493);
 129 {$endif}
 130 end;
 131
 132
 133 {****************************************************************************
 134                                   Asm Response
 135 ****************************************************************************}
 136
 137 Constructor TAsmScript.Init (Const ScriptName : String);
 138 begin
 139   Inherited InitExec(ScriptName);
 140 end;
 141
 142
 143 Procedure TAsmScript.AddAsmCommand (Const Command, Options,FileName : String);
 144 begin
 145   {$ifdef linux}
 146   if FileName<>'' then
 147    Add('echo Assembling '+FileName);
 148   Add (Command+' '+Options);
 149   Add('if [ $? != 0 ]; then DoExitAsm '+FileName+'; fi');
 150   {$else}
 151   if FileName<>'' then
 152    begin
 153      Add('SET THEFILE='+FileName);
 154      Add('echo Assembling %THEFILE%');
 155    end;
 156   Add(command+' '+Options);
 157   Add('if errorlevel 1 goto asmend');
 158   {$endif}
 159 end;
 160
 161
 162 Procedure TasmScript.AddLinkCommand (Const Command, Options, FileName : String);
 163 begin
 164   {$ifdef linux}
 165   if FileName<>'' then
 166    Add('echo Linking '+FileName);
 167   Add (Command+' '+Options);
 168   Add('if [ $? != 0 ]; then DoExitLink '+FileName+'; fi');
 169   {$else}
 170   if FileName<>'' then
 171    begin
 172      Add('SET THEFILE='+FileName);
 173      Add('echo Linking %THEFILE%');
 174    end;
 175   Add (Command+' '+Options);
 176   Add('if errorlevel 1 goto linkend');
 177   {$endif}
 178 end;
 179
 180
 181 Procedure TAsmScript.AddDeleteCommand (Const FileName : String);
 182 begin
 183  {$ifdef linux}
 184  Add('rm '+FileName);
 185  {$else}
 186  Add('Del '+FileName);
 187  {$endif}
 188 end;
 189
 190
 191 Procedure TAsmScript.WriteToDisk;
 192 Begin
 193 {$ifdef linux}
 194   AddStart('{ echo "An error occurred while linking $1"; exit 1; }');
 195   AddStart('DoExitLink ()');
 196   AddStart('{ echo "An error occurred while assembling $1"; exit 1; }');
 197   AddStart('DoExitAsm ()');
 198   AddStart('#!/bin/sh');
 199 {$else}
 200   AddStart('@echo off');
 201   Add('goto end');
 202   Add(':asmend');
 203   Add('echo An error occured while assembling %THEFILE%');
 204   Add('goto end');
 205   Add(':linkend');
 206   Add('echo An error occured while linking %THEFILE%');
 207   Add(':end');
 208 {$endif}
 209   inherited WriteToDisk;
 210 end;
 211
 212
 213 {****************************************************************************
 214                                   Link Response
 215 ****************************************************************************}
 216
 217 procedure TLinkRes.Add(const s:string);
 218 begin
 219   if s<>'' then
 220    inherited Add(s);
 221 end;
 222
 223 procedure TLinkRes.AddFileName(const s:string);
 224 begin
 225   if s<>'' then
 226    begin
 227      if not(s[1] in ['a'..'z','A'..'Z','/','\','.']) then
 228       inherited Add('.'+DirSep+s)
 229      else
 230       inherited Add(s);
 231    end;
 232 end;
 233
 234 end.
 235 {
 236   $Log$
 237   Revision 1.1  2002/02/19 08:23:48  sasu
 238   Initial revision
 239
 240   Revision 1.1  2000/07/13 06:29:56  michael
 241   + Initial import
 242
 243   Revision 1.6  2000/02/09 13:23:04  peter
 244     * log truncated
 245
 246   Revision 1.5  2000/02/07 11:52:26  michael
 247   + Changed bash to sh
 248
 249   Revision 1.4  2000/01/07 01:14:39  peter
 250     * updated copyright to 2000
 251
 252   Revision 1.3  1999/10/21 14:29:37  peter
 253     * redesigned linker object
 254     + library support for linux (only procedures can be exported)
 255
 256 }