starting from r20123

git-svn-id: http://svn.freepascal.org/svn/fpc/branches/blaise@20126 3ad0048d-3df7-0310-abae-a5850022a9f2

1 files changed, 526 insertions, 0 deletions

diff --git a/closures/compiler/script.pas b/closures/compiler/script.pas
new file mode 100644
index 0000000000..eaeed314f0
--- /dev/null
+++ b/closures/compiler/script.pas
@@ -0,0 +1,526 @@
+{
+    Copyright (c) 1998-2002 by Peter Vreman
+
+    This unit handles the writing of script files
+
+    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.
+
+    You should have received a copy of the GNU General Public License
+    along with this program; if not, write to the Free Software
+    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ ****************************************************************************
+}
+unit script;
+
+{$i fpcdefs.inc}
+
+interface
+{$H+}
+uses
+  sysutils,
+  globtype,
+  cclasses;
+
+type
+  TScript=class
+    fn   : TCmdStr;
+    data : TCmdStrList;
+    executable : boolean;
+    constructor Create(const s:TCmdStr);
+    constructor CreateExec(const s:TCmdStr);
+    destructor Destroy;override;
+    procedure AddStart(const s:TCmdStr);
+    procedure Add(const s:TCmdStr);
+    Function  Empty:boolean;
+    procedure WriteToDisk;virtual;
+  end;
+
+  TAsmScript = class (TScript)
+    Constructor Create(Const ScriptName : TCmdStr); virtual;
+    Procedure AddAsmCommand (Const Command, Options,FileName : TCmdStr);virtual;abstract;
+    Procedure AddLinkCommand (Const Command, Options, FileName : TCmdStr);virtual;abstract;
+    Procedure AddDeleteCommand (Const FileName : TCmdStr);virtual;abstract;
+    Procedure AddDeleteDirCommand (Const FileName : TCmdStr);virtual;abstract;
+  end;
+
+  TAsmScriptDos = class (TAsmScript)
+    Constructor Create (Const ScriptName : TCmdStr); override;
+    Procedure AddAsmCommand (Const Command, Options,FileName : TCmdStr);override;
+    Procedure AddLinkCommand (Const Command, Options, FileName : TCmdStr);override;
+    Procedure AddDeleteCommand (Const FileName : TCmdStr);override;
+    Procedure AddDeleteDirCommand (Const FileName : TCmdStr);override;
+    Procedure WriteToDisk;override;
+  end;
+
+  TAsmScriptAmiga = class (TAsmScript)
+    Constructor Create (Const ScriptName : TCmdStr); override;
+    Procedure AddAsmCommand (Const Command, Options,FileName : TCmdStr);override;
+    Procedure AddLinkCommand (Const Command, Options, FileName : TCmdStr);override;
+    Procedure AddDeleteCommand (Const FileName : TCmdStr);override;
+    Procedure AddDeleteDirCommand (Const FileName : TCmdStr);override;
+    Procedure WriteToDisk;override;
+  end;
+
+  TAsmScriptUnix = class (TAsmScript)
+    Constructor Create (Const ScriptName : TCmdStr);override;
+    Procedure AddAsmCommand (Const Command, Options,FileName : TCmdStr);override;
+    Procedure AddLinkCommand (Const Command, Options, FileName : TCmdStr);override;
+    Procedure AddDeleteCommand (Const FileName : TCmdStr);override;
+    Procedure AddDeleteDirCommand (Const FileName : TCmdStr);override;
+    Procedure WriteToDisk;override;
+  end;
+
+  TAsmScriptMPW = class (TAsmScript)
+    Constructor Create (Const ScriptName : TCmdStr); override;
+    Procedure AddAsmCommand (Const Command, Options,FileName : TCmdStr);override;
+    Procedure AddLinkCommand (Const Command, Options, FileName : TCmdStr);override;
+    Procedure AddDeleteCommand (Const FileName : TCmdStr);override;
+    Procedure AddDeleteDirCommand (Const FileName : TCmdStr);override;
+    Procedure WriteToDisk;override;
+  end;
+
+  TLinkRes = Class (TScript)
+    section: string[30];
+    procedure Add(const s:TCmdStr);
+    procedure AddFileName(const s:TCmdStr);
+    procedure EndSection(const s:TCmdStr);
+    procedure StartSection(const s:TCmdStr);
+  end;
+
+var
+  AsmRes : TAsmScript;
+
+Function ScriptFixFileName(const s:TCmdStr):TCmdStr;
+Procedure GenerateAsmRes(const st : TCmdStr);
+
+
+implementation
+
+uses
+{$ifdef hasUnix}
+  BaseUnix,
+{$endif}
+  cutils,cfileutl,
+  globals,systems,verbose;
+
+
+{****************************************************************************
+                                   Helpers
+****************************************************************************}
+
+    Function ScriptFixFileName(const s:TCmdStr):TCmdStr;
+     begin
+       if cs_link_on_target in current_settings.globalswitches then
+         ScriptFixFileName:=TargetFixFileName(s)
+       else
+         ScriptFixFileName:=FixFileName(s);
+     end;
+
+{****************************************************************************
+                                  TScript
+****************************************************************************}
+
+constructor TScript.Create(const s: TCmdStr);
+begin
+  fn:=FixFileName(s);
+  executable:=false;
+  data:=TCmdStrList.Create;
+end;
+
+
+constructor TScript.CreateExec(const s:TCmdStr);
+begin
+  fn:=FixFileName(s);
+  if cs_link_on_target in current_settings.globalswitches then
+    fn:=ChangeFileExt(fn,target_info.scriptext)
+  else
+    fn:=ChangeFileExt(fn,source_info.scriptext);
+  executable:=true;
+  data:=TCmdStrList.Create;
+end;
+
+
+destructor TScript.Destroy;
+begin
+  data.Free;
+end;
+
+
+procedure TScript.AddStart(const s:TCmdStr);
+begin
+  data.Insert(s);
+end;
+
+
+procedure TScript.Add(const s:TCmdStr);
+begin
+   data.Concat(s);
+end;
+
+
+Function TScript.Empty:boolean;
+begin
+  Empty:=Data.Empty;
+end;
+
+procedure TScript.WriteToDisk;
+var
+  t : file;
+  i : longint;
+  s : TCmdStr;
+  le: string[2];
+
+begin
+  Assign(t,fn);
+  if cs_link_on_target in current_settings.globalswitches then
+    le:= target_info.newline
+  else
+    le:= source_info.newline;
+
+  {$push}{$I-}
+  Rewrite(t,1);
+  if ioresult<>0 then
+    exit;
+  while not data.Empty do
+    begin
+      s:=data.GetFirst;
+      Blockwrite(t,s[1],length(s),i);
+      Blockwrite(t,le[1],length(le),i);
+    end;
+  Close(t);
+  {$pop}
+  i:=ioresult;
+{$ifdef hasUnix}
+  if executable then
+   fpchmod(fn,493);
+{$endif}
+end;
+
+{****************************************************************************
+                                  Asm Response
+****************************************************************************}
+
+Constructor TAsmScript.Create (Const ScriptName : TCmdStr);
+begin
+  Inherited CreateExec(ScriptName);
+end;
+
+
+{****************************************************************************
+                                  DOS Asm Response
+****************************************************************************}
+
+Constructor TAsmScriptDos.Create (Const ScriptName : TCmdStr);
+begin
+  Inherited Create(ScriptName);
+end;
+
+
+Procedure TAsmScriptDos.AddAsmCommand (Const Command, Options,FileName : TCmdStr);
+begin
+  if FileName<>'' then
+   begin
+     Add('SET THEFILE='+ScriptFixFileName(FileName));
+     Add('echo Assembling %THEFILE%');
+   end;
+  Add(maybequoted(command)+' '+Options);
+  Add('if errorlevel 1 goto asmend');
+end;
+
+
+Procedure TAsmScriptDos.AddLinkCommand (Const Command, Options, FileName : TCmdStr);
+begin
+  if FileName<>'' then
+   begin
+     Add('SET THEFILE='+ScriptFixFileName(FileName));
+     Add('echo Linking %THEFILE%');
+   end;
+  Add(maybequoted(command)+' '+Options);
+  Add('if errorlevel 1 goto linkend');
+end;
+
+
+Procedure TAsmScriptDos.AddDeleteCommand (Const FileName : TCmdStr);
+begin
+ Add('Del ' + MaybeQuoted (ScriptFixFileName (FileName)));
+end;
+
+
+Procedure TAsmScriptDos.AddDeleteDirCommand (Const FileName : TCmdStr);
+begin
+ Add('Rmdir ' + MaybeQuoted (ScriptFixFileName (FileName)));
+end;
+
+
+Procedure TAsmScriptDos.WriteToDisk;
+Begin
+  AddStart('@echo off');
+  Add('goto end');
+  Add(':asmend');
+  Add('echo An error occured while assembling %THEFILE%');
+  Add('goto end');
+  Add(':linkend');
+  Add('echo An error occured while linking %THEFILE%');
+  Add(':end');
+  inherited WriteToDisk;
+end;
+
+{****************************************************************************
+                                  Amiga Asm Response
+****************************************************************************}
+
+
+Constructor TAsmScriptAmiga.Create (Const ScriptName : TCmdStr);
+begin
+  Inherited Create(ScriptName);
+end;
+
+
+Procedure TAsmScriptAmiga.AddAsmCommand (Const Command, Options,FileName : TCmdStr);
+begin
+  if FileName<>'' then
+   begin
+     Add('SET THEFILE '+ScriptFixFileName(FileName));
+     Add('echo Assembling $THEFILE');
+   end;
+  Add(maybequoted(command)+' '+Options);
+  { There is a problem here,
+    as always return with a non zero error value PM  }
+  Add('if error');
+  Add('why');
+  Add('skip asmend');
+  Add('endif');
+end;
+
+
+Procedure TAsmScriptAmiga.AddLinkCommand (Const Command, Options, FileName : TCmdStr);
+begin
+  if FileName<>'' then
+   begin
+     Add('SET THEFILE '+ScriptFixFileName(FileName));
+     Add('echo Linking $THEFILE');
+   end;
+  Add(maybequoted(command)+' '+Options);
+  Add('if error');
+  Add('skip linkend');
+  Add('endif');
+end;
+
+
+Procedure TAsmScriptAmiga.AddDeleteCommand (Const FileName : TCmdStr);
+begin
+ Add('Delete ' + Unix2AmigaPath(MaybeQuoted(ScriptFixFileName(FileName))) + ' Quiet');
+end;
+
+
+Procedure TAsmScriptAmiga.AddDeleteDirCommand (Const FileName : TCmdStr);
+begin
+ Add('Delete ' + Unix2AmigaPath(MaybeQuoted(ScriptFixFileName(FileName))) + ' All Quiet');
+end;
+
+
+Procedure TAsmScriptAmiga.WriteToDisk;
+Begin
+  Add('skip end');
+  Add('lab asmend');
+  Add('why');
+  Add('echo An error occured while assembling $THEFILE');
+  Add('skip end');
+  Add('lab linkend');
+  Add('why');
+  Add('echo An error occured while linking $THEFILE');
+  Add('lab end');
+  inherited WriteToDisk;
+end;
+
+
+{****************************************************************************
+                              Unix Asm Response
+****************************************************************************}
+
+Constructor TAsmScriptUnix.Create (Const ScriptName : TCmdStr);
+begin
+  Inherited Create(ScriptName);
+end;
+
+
+Procedure TAsmScriptUnix.AddAsmCommand (Const Command, Options,FileName : TCmdStr);
+begin
+  if FileName<>'' then
+   Add('echo Assembling '+ScriptFixFileName(FileName));
+  Add(maybequoted(command)+' '+Options);
+  Add('if [ $? != 0 ]; then DoExitAsm '+ScriptFixFileName(FileName)+'; fi');
+end;
+
+
+Procedure TAsmScriptUnix.AddLinkCommand (Const Command, Options, FileName : TCmdStr);
+begin
+  if FileName<>'' then
+   Add('echo Linking '+ScriptFixFileName(FileName));
+  Add('OFS=$IFS');
+  Add('IFS="');
+  Add('"');
+  Add(maybequoted(command)+' '+Options);
+  Add('if [ $? != 0 ]; then DoExitLink '+ScriptFixFileName(FileName)+'; fi');
+  Add('IFS=$OFS');
+end;
+
+
+Procedure TAsmScriptUnix.AddDeleteCommand (Const FileName : TCmdStr);
+begin
+ Add('rm ' + MaybeQuoted (ScriptFixFileName(FileName)));
+end;
+
+
+Procedure TAsmScriptUnix.AddDeleteDirCommand (Const FileName : TCmdStr);
+begin
+ Add('rmdir ' + MaybeQuoted (ScriptFixFileName(FileName)));
+end;
+
+
+Procedure TAsmScriptUnix.WriteToDisk;
+Begin
+  AddStart('{ echo "An error occurred while linking $1"; exit 1; }');
+  AddStart('DoExitLink ()');
+  AddStart('{ echo "An error occurred while assembling $1"; exit 1; }');
+  AddStart('DoExitAsm ()');
+  {$ifdef BEOS}
+   AddStart('#!/boot/beos/bin/sh');
+  {$else}
+   AddStart('#!/bin/sh');
+  {$endif}
+  inherited WriteToDisk;
+end;
+
+
+{****************************************************************************
+                                  MPW (MacOS) Asm Response
+****************************************************************************}
+
+Constructor TAsmScriptMPW.Create (Const ScriptName : TCmdStr);
+begin
+  Inherited Create(ScriptName);
+end;
+
+
+Procedure TAsmScriptMPW.AddAsmCommand (Const Command, Options,FileName : TCmdStr);
+begin
+  if FileName<>'' then
+    Add('Echo Assembling '+ScriptFixFileName(FileName));
+  Add(maybequoted(command)+' '+Options);
+  Add('Exit If "{Status}" != 0');
+end;
+
+
+Procedure TAsmScriptMPW.AddLinkCommand (Const Command, Options, FileName : TCmdStr);
+begin
+  if FileName<>'' then
+    Add('Echo Linking '+ScriptFixFileName(FileName));
+  Add(maybequoted(command)+' '+Options);
+  Add('Exit If "{Status}" != 0');
+
+  {Add resources}
+  if apptype = app_cui then {If SIOW}
+    begin
+      Add('Rez -append "{RIncludes}"SIOW.r -o '+ ScriptFixFileName(FileName));
+      Add('Exit If "{Status}" != 0');
+    end;
+end;
+
+
+Procedure TAsmScriptMPW.AddDeleteCommand (Const FileName : TCmdStr);
+begin
+ Add('Delete ' + MaybeQuoted (ScriptFixFileName(FileName)));
+end;
+
+
+Procedure TAsmScriptMPW.AddDeleteDirCommand (Const FileName : TCmdStr);
+begin
+ Add('Delete ' + MaybeQuoted (ScriptFixFileName (FileName)));
+end;
+
+
+Procedure TAsmScriptMPW.WriteToDisk;
+Begin
+  AddStart('# Script for assembling and linking a FreePascal program on MPW (MacOS)');
+  Add('Echo Done');
+  inherited WriteToDisk;
+end;
+
+
+
+Procedure GenerateAsmRes(const st : TCmdStr);
+var
+  scripttyp : tscripttype;
+begin
+  if cs_link_on_target in current_settings.globalswitches then
+    scripttyp := target_info.script
+  else
+    scripttyp := source_info.script;
+  case scripttyp of
+    script_unix :
+      AsmRes:=TAsmScriptUnix.Create(st);
+    script_dos :
+      AsmRes:=TAsmScriptDos.Create(st);
+    script_amiga :
+      AsmRes:=TAsmScriptAmiga.Create(st);
+    script_mpw :
+      AsmRes:=TAsmScriptMPW.Create(st);
+  end;
+end;
+
+
+{****************************************************************************
+                                  Link Response
+****************************************************************************}
+
+procedure TLinkRes.Add(const s:TCmdStr);
+begin
+  if s<>'' then
+   inherited Add(s);
+end;
+
+procedure TLinkRes.AddFileName(const s:TCmdStr);
+begin
+  if section<>'' then
+   begin
+    inherited Add(section);
+    section:='';
+   end;
+  if s<>'' then
+   begin
+     if not(s[1] in ['a'..'z','A'..'Z','/','\','.','"']) then
+      begin
+        if cs_link_on_target in current_settings.globalswitches then
+          inherited Add('.'+target_info.DirSep+s)
+        else
+          inherited Add('.'+source_info.DirSep+s);
+      end
+     else
+      inherited Add(s);
+   end;
+end;
+
+procedure TLinkRes.EndSection(const s:TCmdStr);
+begin
+  { only terminate if we started the section }
+  if section='' then
+    inherited Add(s);
+  section:='';
+end;
+
+procedure TLinkRes.StartSection(const s:TCmdStr);
+begin
+  section:=s;
+end;
+
+end.