+ emx target added

This commit is contained in:
Tomas Hajny 2003-03-23 23:11:17 +00:00
parent 504571d024
commit 8e7124f9f8
29 changed files with 1739 additions and 161 deletions

View File

@ -164,7 +164,11 @@ uses
,i_nwm
{$endif nwm}
{$ifdef os2}
{$ifdef emx}
,i_emx
{$else emx}
,i_os2
{$endif emx}
{$endif os2}
{$ifdef palmos}
,i_palmos
@ -386,7 +390,10 @@ end;
end.
{
$Log$
Revision 1.36 2003-02-02 19:25:54 carl
Revision 1.37 2003-03-23 23:20:38 hajny
+ emx target added
Revision 1.36 2003/02/02 19:25:54 carl
* Several bugfixes for m68k target (register alloc., opcode emission)
+ VIS target
+ Generic add more complete (still not verified)

View File

@ -134,7 +134,7 @@ var
hr : presourcefile;
begin
{ OS/2 (EMX) must be processed elsewhere (in the linking/binding stage). }
if target_info.system<>system_i386_os2 then
if not (target_info.system in [system_i386_os2,system_i386_emx]) then
While not current_module.ResourceFiles.Empty do
begin
case target_info.system of
@ -154,7 +154,10 @@ end;
end.
{
$Log$
Revision 1.17 2003-01-30 21:45:40 peter
Revision 1.18 2003-03-23 23:20:38 hajny
+ emx target added
Revision 1.17 2003/01/30 21:45:40 peter
* path fix (merged)
Revision 1.16 2003/01/12 15:42:23 peter

View File

@ -113,7 +113,7 @@ begin
exit;
{$ifdef i386}
case target_info.system of
system_i386_Os2 :
system_i386_Os2, system_i386_emx:
begin
write(t,'NAME '+inputfile);
if usewindowapi then
@ -160,7 +160,10 @@ end;
end.
{
$Log$
Revision 1.11 2002-07-26 21:15:38 florian
Revision 1.12 2003-03-23 23:20:38 hajny
+ emx target added
Revision 1.11 2002/07/26 21:15:38 florian
* rewrote the system handling
Revision 1.10 2002/05/18 13:34:08 peter

View File

@ -496,7 +496,8 @@ implementation
begin
{ these operating systems have dos type drives }
if source_info.system in [system_m68k_atari,system_i386_go32v2,
system_i386_win32,system_i386_os2] then
system_i386_win32,system_i386_os2,
system_i386_emx,system_i386_wdosx] then
Begin
if (Length(f)=3) and (F[2]=':') and (F[3] in ['/','\']) then
begin
@ -1526,7 +1527,10 @@ implementation
end.
{
$Log$
Revision 1.83 2003-01-30 21:45:53 peter
Revision 1.84 2003-03-23 23:21:42 hajny
+ emx target added
Revision 1.83 2003/01/30 21:45:53 peter
* amiga path fix (merged)
Revision 1.82 2003/01/12 15:42:23 peter

View File

@ -1815,10 +1815,14 @@ option_help_pages=11025_[
3*3Op2_Optimierungen f<>r Pentium/PentiumMMX (R)
3*3Op3_Optimierungen f<>r PPro/PII/c6x86/K6 (R)
3*1T<x>_Ziel-Betriebssystem
3*2TEMX_OS/2 via EMX (EMX/RSX extender inclusive)
3*2TGO32V2_Version 2 von DJ Delorie's DOS extender
3*2TLINUX_Linux
3*2TOS2_OS/2 2.x
3*2TWin32_Windows 32 Bit
3*2TNETWARE_Novell Netware Module (experimental)
3*2TOS2_OS/2 / eComStation
3*2TSUNOS_SunOS/Solaris
3*2TWDOSX_WDOSX DOS extender
3*2TWIN32_Windows 32 Bit
6*1A<x>_Ausgabe Format:
6*2Aas_Unix o-Datei mit Hilfe von GNU AS
6*2Agas_GNU Motorola Assembler

View File

@ -2109,14 +2109,15 @@ option_help_pages=11025_[
3*3Op2_set target processor to Pentium/PentiumMMX (tm)
3*3Op3_set target processor to PPro/PII/c6x86/K6 (tm)
3*1T<x>_Target operating system:
3*2TGO32V2_version 2 of DJ Delorie DOS extender
3*2TWDOSX DOS 32 Bit Extender
3*2TEMX_OS/2 via EMX (including EMX/RSX extender)
3*2TGO32V2_Version 2 of DJ Delorie DOS extender
3*2TLINUX_Linux
3*2Tnetware_Novell Netware Module (experimental)
3*2TOS2_OS/2 2.x
3*2TNETWARE_Novell Netware Module (experimental)
3*2TOS2_OS/2 / eComStation
3*2TSUNOS_SunOS/Solaris
3*2TWin32_Windows 32 Bit
3*1W<x>_Win32 target options
3*2TWDOSX_WDOSX DOS extender
3*2TWIN32_Windows 32 Bit
3*1W<x>_Win32-like target options
3*2WB<x>_Set Image base to Hexadecimal <x> value
3*2WC_Specify console type application
3*2WD_Use DEFFILE to export functions of DLL or EXE

View File

@ -1870,8 +1870,8 @@ option_help_pages=11025_[
3*1T<x>_Sistema operativo de destino
3*2TGO32V2_versi¢n 2 del extensor del DOS de DJ Delorie
3*2TLINUX_Linux
3*2TOS2_OS/2 2.x
3*2TWin32_Windows 32 Bit
3*2TOS2_OS/2
3*2TWIN32_Windows 32 Bit
6*1A<x>_formato de salida
6*2Aas_Unix o-file usando GNU AS
6*2Agas_Ensamblador GNU Motorola

View File

@ -1853,11 +1853,15 @@ option_help_pages=11025_[
3*3Op1_dfinit 386/486 comme processeur cible
3*3Op2_dfinit Pentium/PentiumMMX (tm) comme processeur cycle
3*3Op3_dfinit PPro/PII/c6x86/K6 (tm) comme processeur cycle
3*1T<x>_systŠme d'explioitation cible :
3*1T<x>_systŠme d'expliotation cible:
3*2TEMX_OS/2 via EMX (et les extensions EMX/RSX)
3*2TGO32V2_version 2 de l'extension DOS de DJ Delorie
3*2TLINUX_Linux
3*2TOS2_OS/2 2.x
3*2TWin32_Windows 32 Bits
3*2TNETWARE_Novell Netware Module (experimental)
3*2TOS2_OS/2 / eComStation
3*2TSUNOS_SunOS/Solaris
3*2TWDOSX_WDOSX DOS extension
3*2TWIN32_Windows 32 Bits
6*1A<x>_output format
6*2Aas_Unix o-file using GNU AS
6*2Agas_GNU Motorola assembler

View File

@ -1900,8 +1900,8 @@ option_help_pages=11025_[
6*1T<x>_Doel besturingssysteem:
3*2TGO32V2_version 2 of DJ Delorie DOS extender
3*2TLINUX_Linux
3*2TOS2_OS/2 2.x
3*2TWin32_Windows 32 Bit
3*2TOS2_OS/2 / eComStation
3*2TWIN32_Windows 32 Bit
3*1W<x>_Win32 Doel opties
3*2WB<x>_Stel Image base in op (hexadecimale) waarde <x>
3*2WC_Maak een console applicatie

View File

@ -1980,8 +1980,8 @@ option_help_pages=11025_[
3*1T<x>_⨯ ®¯¥à æ¨®­­ ï á¨á⥬ë, ¤«ï ª®â®p®© ¯p®¨á室¨â ª®¬¯¨«ïæ¨ï:
3*2TGO32V2_version 2 (DJ Delorie à áè¨à¨â¥«ì DOS)
3*2TLINUX_Linux
3*2TOS2_OS/2 2.x
3*2TWin32_Windows 32 Bit
3*2TOS2_OS/2 / eComStation
3*2TWIN32_Windows 32 Bit
3*1W<x>_Win32 ®¯æ¨¨
3*1WB<x>_ “áâ ­®¢ª  Image ¡ §ë ¢ è¥áâ­ ¤æ¥â¨à¨ç­®¥ <x> §­ ç¥­¨¥
3*1WC_ Ž¯à¥¤¥«¨âì, çâ® íâ® ¡ã¤¥â ª®­á®«ì­®¥ ¯à¨«®¦¥­¨¥

View File

@ -1980,8 +1980,8 @@ option_help_pages=11025_[
3*1T<x>_тип операционная системы, для котоpой пpоисходит компиляция:
3*2TGO32V2_version 2 (DJ Delorie расширитель DOS)
3*2TLINUX_Linux
3*2TOS2_OS/2 2.x
3*2TWin32_Windows 32 Bit
3*2TOS2_OS/2 / eComStation
3*2TWIN32_Windows 32 Bit
3*1W<x>_Win32 опции
3*1WB<x>_ Установка Image базы в шестнадцетиричное <x> значение
3*1WC_ Определить, что это будет консольное приложение

View File

@ -608,7 +608,7 @@ const
option_info=11024;
option_help_pages=11025;
MsgTxtSize = 34382;
MsgTxtSize = 34446;
MsgIdxMax : array[1..20] of longint=(
17,62,195,50,57,44,98,19,35,43,

View File

@ -796,42 +796,43 @@ const msgtxt : array[0..000143,1..240] of char=(
'3*3Op2_set target processor to Pentium/PentiumMMX (tm)'#010+
'3*3Op3_set target processor to PPro/PII/c6x86/K6 (tm)'#010+
'3*1T<x>_Target ','operating system:'#010+
'3*2TGO32V2_version 2 of DJ Delorie DOS extender'#010+
'3*2TWDOSX DOS 32 Bit Extender'#010+
'3*2TEMX_OS/2 via EMX (including EMX/RSX extender)'#010+
'3*2TGO32V2_Version 2 of DJ Delorie DOS extender'#010+
'3*2TLINUX_Linux'#010+
'3*2Tnetware_Novell Netware Module (experimental)'#010+
'3*2TOS2_OS/2 2.x'#010+
'3*2TNETWARE_Novell Netware Module (experimental)'#010+
'3*2TOS2_OS/2 / eComStation'#010+
'3*2TSUNOS_SunOS/Solaris'#010+
'3*2TWin32_Windows 32 Bit'#010+
'3*1W<x>_Win32',' target options'#010+
'3*2TWDOS','X_WDOSX DOS extender'#010+
'3*2TWIN32_Windows 32 Bit'#010+
'3*1W<x>_Win32-like target options'#010+
'3*2WB<x>_Set Image base to Hexadecimal <x> value'#010+
'3*2WC_Specify console type application'#010+
'3*2WD_Use DEFFILE to export functions of DLL or EXE'#010+
'3*2WF_Specify full-screen type application (OS/2 only)'#010+
'3*2WG_Specify graphic type ap','plication'#010+
'3*2WF_Specify full-s','creen type application (OS/2 only)'#010+
'3*2WG_Specify graphic type application'#010+
'3*2WN_Do not generate relocation code (necessary for debugging)'#010+
'3*2WR_Generate relocation code'#010+
'6*1A<x>_output format'#010+
'6*2Aas_Unix o-file using GNU AS'#010+
'6*2Agas_GNU Motorola assembler'#010+
'6*2Agas_GNU Motor','ola assembler'#010+
'6*2Amit_MIT Syntax (old GAS)'#010+
'6*2Amot_Standard Moto','rola assembler'#010+
'6*2Amot_Standard Motorola assembler'#010+
'6*1O_optimizations:'#010+
'6*2Oa_turn on the optimizer'#010+
'6*2Og_generate smaller code'#010+
'6*2OG_generate faster code (default)'#010+
'6*2Ox_optimize maximum (still BUGGY!!!)'#010+
'6*2O0_set target processor to a MC68000'#010+
'6*2O2_set target processor to a ','MC68020+ (default)'#010+
'6*2O0_se','t target processor to a MC68000'#010+
'6*2O2_set target processor to a MC68020+ (default)'#010+
'6*1R<x>_assembler reading style:'#010+
'6*2RMOT_read motorola style assembler'#010+
'6*1T<x>_Target operating system:'#010+
'6*2TAMIGA_Commodore Amiga'#010+
'6*2TATARI_Atari ST/STe/TT'#010+
'6*2TMACOS_Macintosh m68k'#010+
'6','*2TMACOS_Macintosh m68k'#010+
'6*2TLINUX_Linux-68k'#010+
'6*2TPALMOS_PalmOS'#010+
'**','1*_'#010+
'**1*_'#010+
'**1?_shows this help'#010+
'**1h_shows this help without waiting'#000
);

View File

@ -1033,7 +1033,12 @@ begin
'D':
ForceDeffileForExport:=not UnsetBool(More, j);
'F':
apptype:=app_fs;
begin
if UnsetBool(More, j) then
apptype:=app_cui
else
apptype:=app_fs;
end;
'G':
begin
if UnsetBool(More, j) then
@ -1048,7 +1053,7 @@ begin
end;
'R':
begin
{ support -WR+ / -WR- as synonims to -WR / -WN }
{ support -WR+ / -WR- as synonyms to -WR / -WN }
RelocSection:=not UnsetBool(More,j);
RelocSectionSetExplicitly:=true;
end;
@ -1893,7 +1898,10 @@ finalization
end.
{
$Log$
Revision 1.92 2003-03-08 08:59:07 daniel
Revision 1.93 2003-03-23 23:20:38 hajny
+ emx target added
Revision 1.92 2003/03/08 08:59:07 daniel
+ $define newra will enable new register allocator
+ getregisterint will return imaginary registers with $newra
+ -sr switch added, will skip register allocation so you can see

View File

@ -844,8 +844,8 @@ begin
Message(parser_e_methods_dont_be_export);
if lexlevel<>normal_function_level then
Message(parser_e_dont_nest_export);
{ only os/2 needs this }
if target_info.system=system_i386_os2 then
{ only os/2 and emx need this }
if target_info.system in [system_i386_os2,system_i386_emx] then
begin
aktprocdef.aliasnames.insert(aktprocsym.realname);
procinfo.exported:=true;
@ -2123,7 +2123,10 @@ const
end.
{
$Log$
Revision 1.108 2003-03-19 17:34:04 peter
Revision 1.109 2003-03-23 23:21:42 hajny
+ emx target added
Revision 1.108 2003/03/19 17:34:04 peter
* only allow class [procedure|function]
Revision 1.107 2003/03/17 18:56:02 peter

View File

@ -362,7 +362,7 @@ implementation
;
{$endif x86_64}
{$ifdef i386}
system_i386_OS2:
system_i386_OS2,system_i386_EMX:
;
{$endif i386}
{$ifdef powerpc}
@ -1444,7 +1444,10 @@ So, all parameters are passerd into registers in sparc architecture.}
end.
{
$Log$
Revision 1.98 2003-03-17 22:20:08 peter
Revision 1.99 2003-03-23 23:21:42 hajny
+ emx target added
Revision 1.98 2003/03/17 22:20:08 peter
*** empty log message ***
Revision 1.97 2003/03/17 13:36:39 peter

View File

@ -181,8 +181,8 @@ implementation
var
hs : string;
begin
if (target_info.system<>system_i386_win32)
and (target_info.system<>system_i386_os2) then
if not (target_info.system in [system_i386_win32,system_i386_os2,
system_i386_emx]) then
Message(scan_w_app_type_not_support);
if not current_module.in_global then
Message(scan_w_switch_is_global)
@ -194,7 +194,8 @@ implementation
apptype:=app_gui
else if hs='CONSOLE' then
apptype:=app_cui
else if (hs='FS') and (target_info.system=system_i386_os2) then
else if (hs='FS') and (target_info.system in [system_i386_os2,
system_i386_emx]) then
apptype:=app_fs
else
Message1(scan_w_unsupported_app_type,hs);
@ -236,7 +237,8 @@ implementation
procedure dir_description;
begin
if not (target_info.system in [system_i386_os2,system_i386_win32,system_i386_netware,system_i386_wdosx]) then
if not (target_info.system in [system_i386_os2,system_i386_emx,
system_i386_win32,system_i386_netware,system_i386_wdosx]) then
Message(scan_w_description_not_support);
{ change description global var in all cases }
{ it not used but in win32, os2 and netware }
@ -763,7 +765,8 @@ implementation
major, minor, revision : longint;
error : integer;
begin
if not (target_info.system in [system_i386_os2,system_i386_win32,system_i386_netware,system_i386_wdosx]) then
if not (target_info.system in [system_i386_os2,system_i386_emx,
system_i386_win32,system_i386_netware,system_i386_wdosx]) then
begin
Message(scan_n_version_not_support);
exit;
@ -980,7 +983,10 @@ implementation
end.
{
$Log$
Revision 1.24 2003-01-03 21:25:01 peter
Revision 1.25 2003-03-23 23:20:38 hajny
+ emx target added
Revision 1.24 2003/01/03 21:25:01 peter
* OBJECTCHECKS added, equivalent of -CR
* WRITEABLECONST added, equivalent of $J

View File

@ -109,7 +109,8 @@ interface
target_i386_openbsd, { 24 }
target_m68k_openbsd, { 25 }
system_x86_64_linux, { 26 }
system_powerpc_macosx { 27 }
system_powerpc_macosx, { 27 }
system_i386_EMX { 28 }
);
tasm = (as_none
@ -678,7 +679,10 @@ finalization
end.
{
$Log$
Revision 1.59 2003-01-12 15:42:23 peter
Revision 1.60 2003-03-23 23:21:42 hajny
+ emx target added
Revision 1.59 2003/01/12 15:42:23 peter
* m68k pathexist update from 1.0.x
* palmos res update from 1.0.x

123
compiler/systems/i_emx.pas Normal file
View File

@ -0,0 +1,123 @@
{
$Id$
Copyright (c) 1998-2002 by Peter Vreman
This unit implements support information structures for OS/2 via EMX
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.
****************************************************************************
}
{ This unit implements support information structures for OS/2 via EMX. }
unit i_emx;
interface
uses
systems;
const
res_emxbind_info : tresinfo =
(
id : res_emxbind;
resbin : 'emxbind';
rescmd : '-b -r $RES $OBJ'
(* Not really used - see TLinkerEMX.SetDefaultInfo in t_emx.pas. *)
);
system_i386_emx_info : tsysteminfo =
(
system : system_i386_EMX;
name : 'OS/2 via EMX';
shortname : 'EMX';
flags : [tf_need_export];
cpu : cpu_i386;
unit_env : 'EMXUNITS';
extradefines : 'OS2';
sourceext : '.pas';
pasext : '.pp';
exeext : '.exe';
defext : '.def';
scriptext : '.cmd';
smartext : '.sl';
unitext : '.ppu';
unitlibext : '.ppl';
asmext : '.s';
objext : '.o';
resext : '.res';
resobjext : '.or';
sharedlibext : '.dll';
staticlibext : '.a';
staticlibprefix : '';
sharedlibprefix : '';
sharedClibext : '.dll';
staticClibext : '.a';
staticClibprefix : '';
sharedClibprefix : '';
Cprefix : '_';
newline : #13#10;
dirsep : '\';
files_case_relevent : false;
assem : as_i386_as_aout;
assemextern : as_i386_as_aout;
link : nil;
linkextern : nil;
ar : ar_gnu_ar;
res : res_emxbind;
script : script_dos;
endian : endian_little;
alignment :
(
procalign : 4;
loopalign : 4;
jumpalign : 0;
constalignmin : 0;
constalignmax : 4;
varalignmin : 0;
varalignmax : 4;
localalignmin : 0;
localalignmax : 4;
paraalign : 4;
recordalignmin : 0;
recordalignmax : 2;
maxCrecordalign : 4
);
first_parm_offset : 8;
heapsize : 256*1024;
stacksize : 256*1024;
DllScanSupported:true;
use_function_relative_addresses : false
);
implementation
initialization
{$ifdef CPU86}
{$ifdef EMX}
{$IFNDEF VER1_0}
set_source_info(system_i386_emx_info);
{ OS/2 via EMX can be run under DOS as well }
if (OS_Mode=osDOS) or (OS_Mode=osDPMI) then
source_info.scriptext := '.bat';
{$ENDIF VER1_0}
{$endif EMX}
{$endif CPU86}
end.
{
$Log$
Revision 1.1 2003-03-23 23:28:33 hajny
+ emx target added
}

523
compiler/systems/t_emx.pas Normal file
View File

@ -0,0 +1,523 @@
{
$Id$
Copyright (c) 1998-2002 by Daniel Mantione
Portions Copyright (c) 1998-2002 Eberhard Mattes
Unit to write out import libraries and def files for OS/2 via EMX
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.
****************************************************************************
}
{
A lot of code in this unit has been ported from C to Pascal from the
emximp utility, part of the EMX development system. Emximp is copyrighted
by Eberhard Mattes. Note: Eberhard doesn't know much about the Pascal
port, please send questions to Daniel Mantione
<d.s.p.mantione@twi.tudelft.nl>.
}
unit t_emx;
{$i fpcdefs.inc}
interface
implementation
uses
{$ifdef Delphi}
sysutils,
dmisc,
{$else Delphi}
strings,
dos,
{$endif Delphi}
cutils,cclasses,
globtype,comphook,systems,symsym,
globals,verbose,fmodule,script,
import,link,i_emx,ppu;
type
TImportLibEMX=class(timportlib)
procedure preparelib(const s:string);override;
procedure importprocedure(const func,module:string;index:longint;const name:string);override;
procedure generatelib;override;
end;
TLinkerEMX=class(texternallinker)
private
Function WriteResponseFile(isdll:boolean) : Boolean;
public
constructor Create;override;
procedure SetDefaultInfo;override;
function MakeExecutable:boolean;override;
end;
const profile_flag:boolean=false;
const n_ext = 1;
n_abs = 2;
n_text = 4;
n_data = 6;
n_bss = 8;
n_imp1 = $68;
n_imp2 = $6a;
type reloc=packed record {This is the layout of a relocation table
entry.}
address:longint; {Fixup location}
remaining:longint;
{Meaning of bits for remaining:
0..23: Symbol number or segment
24: Self-relative fixup if non-zero
25..26: Fixup size (0: 1 byte, 1: 2, 2: 4 bytes)
27: Reference to symbol or segment
28..31 Not used}
end;
nlist=packed record {This is the layout of a symbol table entry.}
strofs:longint; {Offset in string table}
typ:byte; {Type of the symbol}
other:byte; {Other information}
desc:word; {More information}
value:longint; {Value (address)}
end;
a_out_header=packed record
magic:word; {Magic word, must be $0107}
machtype:byte; {Machine type}
flags:byte; {Flags}
text_size:longint; {Length of text, in bytes}
data_size:longint; {Length of initialized data, in bytes}
bss_size:longint; {Length of uninitialized data, in bytes}
sym_size:longint; {Length of symbol table, in bytes}
entry:longint; {Start address (entry point)}
trsize:longint; {Length of relocation info for text, bytes}
drsize:longint; {Length of relocation info for data, bytes}
end;
ar_hdr=packed record
ar_name:array[0..15] of char;
ar_date:array[0..11] of char;
ar_uid:array[0..5] of char;
ar_gid:array[0..5] of char;
ar_mode:array[0..7] of char;
ar_size:array[0..9] of char;
ar_fmag:array[0..1] of char;
end;
var aout_str_size:longint;
aout_str_tab:array[0..2047] of byte;
aout_sym_count:longint;
aout_sym_tab:array[0..5] of nlist;
aout_text:array[0..63] of byte;
aout_text_size:longint;
aout_treloc_tab:array[0..1] of reloc;
aout_treloc_count:longint;
aout_size:longint;
seq_no:longint;
ar_member_size:longint;
out_file:file;
procedure write_ar(const name:string;size:longint);
var ar:ar_hdr;
time:datetime;
dummy:word;
numtime:longint;
tmp:string[19];
begin
ar_member_size:=size;
fillchar(ar.ar_name,sizeof(ar.ar_name),' ');
move(name[1],ar.ar_name,length(name));
getdate(time.year,time.month,time.day,dummy);
gettime(time.hour,time.min,time.sec,dummy);
packtime(time,numtime);
str(numtime,tmp);
fillchar(ar.ar_date,sizeof(ar.ar_date),' ');
move(tmp[1],ar.ar_date,length(tmp));
ar.ar_uid:='0 ';
ar.ar_gid:='0 ';
ar.ar_mode:='100666'#0#0;
str(size,tmp);
fillchar(ar.ar_size,sizeof(ar.ar_size),' ');
move(tmp[1],ar.ar_size,length(tmp));
ar.ar_fmag:='`'#10;
blockwrite(out_file,ar,sizeof(ar));
end;
procedure finish_ar;
var a:byte;
begin
a:=0;
if odd(ar_member_size) then
blockwrite(out_file,a,1);
end;
procedure aout_init;
begin
aout_str_size:=sizeof(longint);
aout_sym_count:=0;
aout_text_size:=0;
aout_treloc_count:=0;
end;
function aout_sym(const name:string;typ,other:byte;desc:word;
value:longint):longint;
begin
if aout_str_size+length(name)+1>sizeof(aout_str_tab) then
Do_halt($da);
if aout_sym_count>=sizeof(aout_sym_tab) div sizeof(aout_sym_tab[0]) then
Do_halt($da);
aout_sym_tab[aout_sym_count].strofs:=aout_str_size;
aout_sym_tab[aout_sym_count].typ:=typ;
aout_sym_tab[aout_sym_count].other:=other;
aout_sym_tab[aout_sym_count].desc:=desc;
aout_sym_tab[aout_sym_count].value:=value;
strPcopy(@aout_str_tab[aout_str_size],name);
aout_str_size:=aout_str_size+length(name)+1;
aout_sym:=aout_sym_count;
inc(aout_sym_count);
end;
procedure aout_text_byte(b:byte);
begin
if aout_text_size>=sizeof(aout_text) then
Do_halt($da);
aout_text[aout_text_size]:=b;
inc(aout_text_size);
end;
procedure aout_text_dword(d:longint);
type li_ar=array[0..3] of byte;
begin
aout_text_byte(li_ar(d)[0]);
aout_text_byte(li_ar(d)[1]);
aout_text_byte(li_ar(d)[2]);
aout_text_byte(li_ar(d)[3]);
end;
procedure aout_treloc(address,symbolnum,pcrel,len,ext:longint);
begin
if aout_treloc_count>=sizeof(aout_treloc_tab) div sizeof(reloc) then
Do_halt($da);
aout_treloc_tab[aout_treloc_count].address:=address;
aout_treloc_tab[aout_treloc_count].remaining:=symbolnum+pcrel shl 24+
len shl 25+ext shl 27;
inc(aout_treloc_count);
end;
procedure aout_finish;
begin
while (aout_text_size and 3)<>0 do
aout_text_byte ($90);
aout_size:=sizeof(a_out_header)+aout_text_size+aout_treloc_count*
sizeof(reloc)+aout_sym_count*sizeof(aout_sym_tab[0])+aout_str_size;
end;
procedure aout_write;
var ao:a_out_header;
begin
ao.magic:=$0107;
ao.machtype:=0;
ao.flags:=0;
ao.text_size:=aout_text_size;
ao.data_size:=0;
ao.bss_size:=0;
ao.sym_size:=aout_sym_count*sizeof(aout_sym_tab[0]);
ao.entry:=0;
ao.trsize:=aout_treloc_count*sizeof(reloc);
ao.drsize:=0;
blockwrite(out_file,ao,sizeof(ao));
blockwrite(out_file,aout_text,aout_text_size);
blockwrite(out_file,aout_treloc_tab,sizeof(reloc)*aout_treloc_count);
blockwrite(out_file,aout_sym_tab,sizeof(aout_sym_tab[0])*aout_sym_count);
longint((@aout_str_tab)^):=aout_str_size;
blockwrite(out_file,aout_str_tab,aout_str_size);
end;
procedure TImportLibEMX.preparelib(const s:string);
{This code triggers a lot of bugs in the compiler.
const armag='!<arch>'#10;
ar_magic:array[1..length(armag)] of char=armag;}
const ar_magic:array[1..8] of char='!<arch>'#10;
var
libname : string;
begin
LibName:=FixFileName(S + Target_Info.StaticCLibExt);
seq_no:=1;
current_module.linkotherstaticlibs.add(libname,link_allways);
assign(out_file,current_module.outputpath^+libname);
rewrite(out_file,1);
blockwrite(out_file,ar_magic,sizeof(ar_magic));
end;
procedure TImportLibEMX.ImportProcedure(const func,module:string;index:longint;const name:string);
{func = Name of function to import.
module = Name of DLL to import from.
index = Index of function in DLL. Use 0 to import by name.
name = Name of function in DLL. Ignored when index=0;}
var tmp1,tmp2,tmp3:string;
sym_mcount,sym_import:longint;
fixup_mcount,fixup_import:longint;
begin
{ force the current mangledname }
aktprocdef.has_mangledname:=true;
aout_init;
tmp2:=func;
if profile_flag and not (copy(func,1,4)='_16_') then
begin
{sym_entry:=aout_sym(func,n_text+n_ext,0,0,aout_text_size);}
sym_mcount:=aout_sym('__mcount',n_ext,0,0,0);
{Use, say, "_$U_DosRead" for "DosRead" to import the
non-profiled function.}
tmp2:='__$U_'+func;
sym_import:=aout_sym(tmp2,n_ext,0,0,0);
aout_text_byte($55); {push ebp}
aout_text_byte($89); {mov ebp, esp}
aout_text_byte($e5);
aout_text_byte($e8); {call _mcount}
fixup_mcount:=aout_text_size;
aout_text_dword(0-(aout_text_size+4));
aout_text_byte($5d); {pop ebp}
aout_text_byte($e9); {jmp _$U_DosRead}
fixup_import:=aout_text_size;
aout_text_dword(0-(aout_text_size+4));
aout_treloc(fixup_mcount,sym_mcount,1,2,1);
aout_treloc (fixup_import, sym_import,1,2,1);
end;
str(seq_no,tmp1);
tmp1:='IMPORT#'+tmp1;
if name='' then
begin
str(index,tmp3);
tmp3:=func+'='+module+'.'+tmp3;
end
else
tmp3:=func+'='+module+'.'+name;
aout_sym(tmp2,n_imp1+n_ext,0,0,0);
aout_sym(tmp3,n_imp2+n_ext,0,0,0);
aout_finish;
write_ar(tmp1,aout_size);
aout_write;
finish_ar;
inc(seq_no);
end;
procedure TImportLibEMX.GenerateLib;
begin
close(out_file);
end;
{****************************************************************************
TLinkerEMX
****************************************************************************}
Constructor TLinkerEMX.Create;
begin
Inherited Create;
{ allow duplicated libs (PM) }
SharedLibFiles.doubles:=true;
StaticLibFiles.doubles:=true;
end;
procedure TLinkerEMX.SetDefaultInfo;
begin
with Info do
begin
ExeCmd[1]:='ld $OPT -o $EXE.out @$RES';
ExeCmd[2]:='emxbind -b $STRIP $APPTYPE $RSRC -k$STACKKB -h$HEAPMB -o $EXE.exe $EXE.out -aim -s$DOSHEAPKB';
ExeCmd[3]:='del $EXE.out';
end;
end;
Function TLinkerEMX.WriteResponseFile(isdll:boolean) : Boolean;
Var
linkres : TLinkRes;
i : longint;
HPath : TStringListItem;
s : string;
begin
WriteResponseFile:=False;
{ Open link.res file }
LinkRes:=TLinkRes.Create(outputexedir+Info.ResName);
{ Write path to search libraries }
HPath:=TStringListItem(current_module.locallibrarysearchpath.First);
while assigned(HPath) do
begin
LinkRes.Add('-L'+HPath.Str);
HPath:=TStringListItem(HPath.Next);
end;
HPath:=TStringListItem(LibrarySearchPath.First);
while assigned(HPath) do
begin
LinkRes.Add('-L'+HPath.Str);
HPath:=TStringListItem(HPath.Next);
end;
{ add objectfiles, start with prt0 always }
LinkRes.AddFileName(FindObjectFile('prt0',''));
while not ObjectFiles.Empty do
begin
s:=ObjectFiles.GetFirst;
if s<>'' then
LinkRes.AddFileName(s);
end;
{ Write staticlibraries }
{ No group !! This will not work correctly PM }
While not StaticLibFiles.Empty do
begin
S:=StaticLibFiles.GetFirst;
LinkRes.AddFileName(s)
end;
{ Write sharedlibraries like -l<lib>, also add the needed dynamic linker
here to be sure that it gets linked this is needed for glibc2 systems (PFV) }
While not SharedLibFiles.Empty do
begin
S:=SharedLibFiles.GetFirst;
i:=Pos(target_info.sharedlibext,S);
if i>0 then
Delete(S,i,255);
LinkRes.Add('-l'+s);
end;
{ Write and Close response }
linkres.writetodisk;
LinkRes.Free;
WriteResponseFile:=True;
end;
function TLinkerEMX.MakeExecutable:boolean;
var
binstr,
cmdstr : string;
success : boolean;
i : longint;
AppTypeStr,
StripStr: string[40];
RsrcStr : string;
begin
if not(cs_link_extern in aktglobalswitches) then
Message1(exec_i_linking,current_module.exefilename^);
{ Create some replacements }
if (cs_link_strip in aktglobalswitches) then
StripStr := '-s'
else
StripStr := '';
if (usewindowapi) or (AppType = app_gui) then
AppTypeStr := '-p'
else if AppType = app_fs then
AppTypeStr := '-f'
else AppTypeStr := '-w';
if not (Current_module.ResourceFiles.Empty) then
RsrcStr := '-r ' + Current_module.ResourceFiles.GetFirst
else
RsrcStr := '';
(* Only one resource file supported, discard everything else
(should be already empty anyway, however. *)
Current_module.ResourceFiles.Clear;
{ Write used files and libraries }
WriteResponseFile(false);
{ Call linker }
success:=false;
for i:=1 to 3 do
begin
SplitBinCmd(Info.ExeCmd[i],binstr,cmdstr);
if binstr<>'' then
begin
{ Is this really required? Not anymore according to my EMX docs }
Replace(cmdstr,'$HEAPMB',tostr((heapsize+1048575) shr 20));
{Size of the stack when an EMX program runs in OS/2.}
Replace(cmdstr,'$STACKKB',tostr((stacksize+1023) shr 10));
{When an EMX program runs in DOS, the heap and stack share the
same memory pool. The heap grows upwards, the stack grows downwards.}
Replace(cmdstr,'$DOSHEAPKB',tostr((stacksize+heapsize+1023) shr 10));
Replace(cmdstr,'$STRIP',StripStr);
Replace(cmdstr,'$APPTYPE',AppTypeStr);
Replace(cmdstr,'$RES',outputexedir+Info.ResName);
Replace(cmdstr,'$OPT',Info.ExtraOptions);
Replace(cmdstr,'$RSRC',RsrcStr);
Replace(cmdstr,'$EXE',current_module.exefilename^);
if i<>3 then
success:=DoExec(FindUtil(binstr),cmdstr,(i=1),false)
else
success:=DoExec(binstr,cmdstr,(i=1),true);
(* We still want to have the PPAS script complete, right?
if not success then
break;
*)
end;
end;
{ Remove ReponseFile }
if (success) and not(cs_link_extern in aktglobalswitches) then
RemoveFile(outputexedir+Info.ResName);
MakeExecutable:=success; { otherwise a recursive call to link method }
end;
{*****************************************************************************
Initialize
*****************************************************************************}
initialization
RegisterExternalLinker(system_i386_emx_info,TLinkerEMX);
RegisterImport(system_i386_emx,TImportLibEMX);
RegisterRes(res_emxbind_info);
RegisterTarget(system_i386_emx_info);
end.
{
$Log$
Revision 1.1 2003-03-23 23:28:33 hajny
+ emx target added
}

View File

@ -39,6 +39,7 @@ includedir_netbsd=unix
includedir_openbsd=unix
includedir_sunos=posix
includedir_qnx=posix
includedir_emx=os2
sourcedir=$(OS_TARGET) inc
[libs]

View File

@ -22,6 +22,7 @@ dirs_openbsd=unzip uncgi \
dirs_win32=unzip uncgi opengl gtk \
zlib mmsystem tcl cdrom fpgtk
dirs_os2=unzip uncgi zlib os2units rexx x11 gtk fpgtk
dirs_emx=unzip uncgi zlib os2units rexx x11 gtk fpgtk
dirs_go32v2=unzip uncgi
dirs_netware=cmem zlib

View File

@ -12,6 +12,7 @@ dirs_win32=win32
dirs_go32v2=go32v2
dirs_go32v1=go32v1
dirs_os2=os2
dirs_emx=emx
dirs_freebsd=freebsd
dirs_beos=beos
dirs_amiga=amiga

View File

@ -9,7 +9,7 @@ main=rtl
loaders=prt0 prt1
units=$(SYSTEMUNIT) objpas strings \
ports os2def doscalls moncalls kbdcalls moucalls viocalls \
pmbitmap pmwin pmgpi pmstddlg pmhelp pmdev pmspl dive \
pmbitmap pmwin pmgpi pmstddlg pmhelp pmdev pmspl pmshl \
dos crt objects printer \
sysutils math typinfo varutils \
charset ucomplex cpu mmx getopts heaptrc lineinfo dynlibs \
@ -28,8 +28,8 @@ target=emx
cpu=i386
[compiler]
includedir=$(INC) $(PROCINC) ../os2
sourcedir=$(INC) $(PROCINC) ../os2
includedir=$(INC) $(PROCINC) $(OS2INC)
sourcedir=$(INC) $(PROCINC) $(OS2INC)
targetdir=.
@ -37,6 +37,7 @@ targetdir=.
RTL=..
INC=$(RTL)/inc
PROCINC=$(RTL)/$(CPU_TARGET)
OS2INC=$(RTL)/os2
UNITPREFIX=rtl
@ -102,31 +103,31 @@ strings$(PPUEXT) : $(INC)/strings.pp $(INC)/stringsi.inc \
ports$(PPUEXT) : ports.pas objpas$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
doscalls$(PPUEXT) : doscalls.pas strings$(PPUEXT) objects$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
doscalls$(PPUEXT) : $(OS2INC)/doscalls.pas strings$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
kbdcalls$(PPUEXT) : kbdcalls.pas $(SYSTEMUNIT)$(PPUEXT)
kbdcalls$(PPUEXT) : $(OS2INC)/kbdcalls.pas $(SYSTEMUNIT)$(PPUEXT)
moucalls$(PPUEXT) : moucalls.pas $(SYSTEMUNIT)$(PPUEXT)
moucalls$(PPUEXT) : $(OS2INC)/moucalls.pas $(SYSTEMUNIT)$(PPUEXT)
moncalls$(PPUEXT) : moncalls.pas strings$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
moncalls$(PPUEXT) : $(OS2INC)/moncalls.pas strings$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
os2def$(PPUEXT) : os2def.pas $(SYSTEMUNIT)$(PPUEXT)
os2def$(PPUEXT) : $(OS2INC)/os2def.pas $(SYSTEMUNIT)$(PPUEXT)
pmwin$(PPUEXT) : pmwin.pas os2def$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
pmwin$(PPUEXT) : $(OS2INC)/pmwin.pas os2def$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
pmbitmap$(PPUEXT) : pmbitmap.pas $(SYSTEMUNIT)$(PPUEXT)
pmbitmap$(PPUEXT) : $(OS2INC)/pmbitmap.pas $(SYSTEMUNIT)$(PPUEXT)
pmgpi$(PPUEXT) : pmgpi.pas pmbitmap$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
pmgpi$(PPUEXT) : $(OS2INC)/pmgpi.pas pmbitmap$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
pmstddlg$(PPUEXT) : pmstddlg.pas os2def$(PPUEXT) doscalls$(PPUEXT) pmwin$(PPUEXT) pmgpi$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
pmstddlg$(PPUEXT) : $(OS2INC)/pmstddlg.pas os2def$(PPUEXT) doscalls$(PPUEXT) pmwin$(PPUEXT) pmgpi$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
pmhelp$(PPUEXT) : pmhelp.pas os2def$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
pmhelp$(PPUEXT) : $(OS2INC)/pmhelp.pas os2def$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
pmdev$(PPUEXT) : pmdev.pas os2def$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
pmdev$(PPUEXT) : $(OS2INC)/pmdev.pas os2def$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
pmspl$(PPUEXT) : pmspl.pas os2def$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
pmspl$(PPUEXT) : $(OS2INC)/pmspl.pas os2def$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
dive$(PPUEXT) : dive.pas os2def$(PPUEXT) pmwin$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
pmshl$(PPUEXT) : $(OS2INC)/pmshl.pas os2def$(PPUEXT) pmwin$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
dynlibs$(PPUEXT) : $(INC)/dynlibs.pp doscalls$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
@ -139,9 +140,9 @@ dos$(PPUEXT) : dos.pas $(INC)/filerec.inc $(INC)/textrec.inc strings$(PPUEXT) \
crt$(PPUEXT) : crt.pas $(INC)/textrec.inc $(SYSTEMUNIT)$(PPUEXT)
objects$(PPUEXT) : $(INC)/objects.pp $(SYSTEMUNIT)$(PPUEXT)
objects$(PPUEXT) : $(INC)/objects.pp dos$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
printer$(PPUEXT) : printer.pas $(INC)/textrec.inc $(SYSTEMUNIT)$(PPUEXT)
printer$(PPUEXT) : $(OS2INC)/printer.pas $(INC)/textrec.inc $(SYSTEMUNIT)$(PPUEXT)
#graph$(PPUEXT) : graph.pp
@ -160,8 +161,8 @@ math$(PPUEXT): $(OBJPASDIR)/math.pp objpas$(PPUEXT) sysutils$(PPUEXT)
$(COMPILER) $(OBJPASDIR)/math.pp $(REDIR)
varutils$(PPUEXT) : $(OBJPASDIR)/cvarutil.inc $(OBJPASDIR)/varutils.inc \
$(OBJPASDIR)/varutilh.inc varutils.pp
$(COMPILER) -I$(OBJPASDIR) varutils.pp $(REDIR)
$(OBJPASDIR)/varutilh.inc $(OS2INC)/varutils.pp
$(COMPILER) -I$(OBJPASDIR) $(OS2INC)/varutils.pp $(REDIR)
types$(PPUEXT) : $(OBJPASDIR/types.pp objpas$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
$(COMPILER) $(OBJPASDIR)/types.pp

901
rtl/emx/crt.pas Normal file
View File

@ -0,0 +1,901 @@
{****************************************************************************
$Id$
Standard CRT unit.
Free Pascal runtime library for EMX.
Copyright (c) 1997 Daniel Mantione.
This file may be reproduced and modified under the same conditions
as all other Free Pascal source code.
****************************************************************************}
unit crt;
{$ASMMODE ATT}
interface
uses dos;
const _40cols=0;
_80cols=1;
_132cols=2;
_25rows=0;
_28rows=16;
_43rows=32;
_50rows=48;
font8x8=_50rows;
black =0;
blue =1;
green =2;
cyan =3;
red =4;
magenta =5;
brown =6;
lightgray =7;
darkgray =8;
lightblue =9;
lightgreen =10;
lightcyan =11;
lightred =12;
lightmagenta =13;
yellow =14;
white =15;
blink =128;
{cemodeset means that the procedure textmode has failed to set up a mode.}
type cexxxx=(cenoerror,cemodeset);
var textattr:byte; {Text attribute. RW}
windmin,windmax:word; {Window coordinates. R-}
lastmode:word; {Last videomode. R-}
crt_error:cexxxx; {Crt-status. RW}
function keypressed:boolean;
function readkey:char;
procedure clrscr;
procedure clreol;
function whereX:byte;
function whereY:byte;
procedure gotoXY(x,y:byte);
procedure window(left,top,right,bottom : byte);
procedure textmode(mode:integer);
procedure textcolor(colour:byte);
procedure textbackground(colour:byte);
procedure insline;
procedure delline;
procedure lowvideo;
procedure normvideo;
procedure highvideo;
procedure assigncrt(var f:text);
procedure delay(ms:word);
procedure sound(hz:word);
procedure nosound;
{***************************************************************************}
{***************************************************************************}
implementation
const extkeycode:char=#0;
var maxrows,maxcols:word;
calibration:longint;
type Tkbdkeyinfo=record
charcode,scancode:char;
fbstatus,bnlsshift:byte;
fsstate:word;
time:longint;
end;
{if you have information on the folowing datastructure, please
send them to me at d.s.p.mantione@twi.tudelft.nl}
{This datastructure is needed when we ask in what video mode we are,
or we want to set up a new mode.}
viomodeinfo=record
cb:word; { length of the entire data
structure }
fbtype, { bit mask of mode being set}
color: byte; { number of colors (power of 2) }
col, { number of text columns }
row, { number of text rows }
hres, { horizontal resolution }
vres: word; { vertical resolution }
fmt_ID, { attribute format
! more info wanted !}
attrib: byte; { number of attributes }
buf_addr, { physical address of
videobuffer, e.g. $0b800}
buf_length, { length of a videopage (bytes)}
full_length, { total video-memory on video-
card (bytes)}
partial_length:longint; { ????? info wanted !}
ext_data_addr:pointer; { ????? info wanted !}
end;
Pviomodeinfo=^viomodeinfo;
{EMXWRAP.DLL has strange calling conventions: All parameters must have
a 4 byte size.}
function kbdcharin(var Akeyrec:Tkbdkeyinfo;wait,kbdhandle:longint):word; cdecl;
external 'EMXWRAP' index 204;
function kbdpeek(var Akeyrec:TkbdkeyInfo;kbdhandle:word):word; cdecl;
external 'EMXWRAP' index 222;
function dossleep(time:longint):word; cdecl;
external 'DOSCALLS' index 229;
function vioscrollup(top,left,bottom,right,lines:longint;
var screl:word;viohandle:longint):word; cdecl;
external 'EMXWRAP' index 107;
function vioscrolldn(top,left,bottom,right,lines:longint;
var screl:word;viohandle:longint):word; cdecl;
external 'EMXWRAP' index 147;
function viogetcurpos(var row,column:word;viohandle:longint):word; cdecl;
external 'EMXWRAP' index 109;
function viosetcurpos(row,column,viohandle:longint):word; cdecl;
external 'EMXWRAP' index 115;
function viowrtTTY(s:Pchar;len,viohandle:longint):word; cdecl;
external 'EMXWRAP' index 119;
function viowrtcharstratt(s:Pchar;len,row,col:longint;var attr:byte;
viohandle:longint):word; cdecl;
external 'EMXWRAP' index 148;
function viogetmode(var Amodeinfo:viomodeinfo;viohandle:longint):word; cdecl;
external 'EMXWRAP' index 121;
function viosetmode(var Amodeinfo:viomodeinfo;viohandle:longint):word; cdecl;
external 'EMXWRAP' index 122;
procedure setscreenmode(mode:word);
{ This procedure sets a new videomode. Note that the constants passes to
this procedure are different than in the dos mode.}
const modecols:array[0..2] of word=(40,80,132);
moderows:array[0..3] of word=(25,28,43,50);
var newmode:viomodeinfo;
begin
if os_mode=osOS2 then
begin
newmode.cb:=8;
newmode.fbtype:=1; {Non graphics colour mode.}
newmode.color:=4; {We want 16 colours, 2^4=16.}
newmode.col:=modecols[mode and 15];
newmode.row:=moderows[mode shr 4];
if viosetmode(newmode,0)=0 then
crt_error:=cenoerror
else
crt_error:=cemodeset;
maxcols:=newmode.col;
maxrows:=newmode.row;
end
else
begin
maxcols:=modecols[mode and 15];
maxrows:=moderows[mode shr 4];
crt_error:=cenoerror;
{Set correct vertical resolution.}
asm
movw $0x1202,%ax
movw 8(%ebp),%bx
shrw $4,%bx
cmpb $2,%bl
jne .L_crtsetmode_a1
decw %ax
.L_crtsetmode_a1:
mov $0x30,%bl
int $0x10
end;
{132 column mode in DOS is videocard dependend.}
if mode and 15=2 then
begin
crt_error:=cemodeset;
exit;
end;
{Switch to correct mode.}
asm
mov 8(%ebp),%bx
and $15,%bl
mov $1,%ax
cmp $1,%bl
jne .L_crtsetmode_b1
mov $3,%al
.L_crtsetmode_b1:
int $0x10
{Use alternate print-screen function.}
mov $0x12,%ah
mov $0x20,%bl
int $0x10
end;
{Set correct font.}
case mode shr 4 of
1:
{Set 8x14 font.}
asm
mov $0x1111,%ax
mov $0,%bl
int $0x10
end;
2,3:
{Set 8x8 font.}
asm
mov $0x1112,%ax
mov $0,%bl
int $0x10
end;
end;
end;
end;
procedure getcursor(var y,x:word);
{Get the cursor position.}
begin
if os_mode=osOS2 then
viogetcurpos(y,x,0)
else
asm
movb $3,%ah
movb $0,%bh
int $0x10
movl y,%eax
movl x,%ebx
movzbl %dh,%edi
andw $255,%dx
movw %di,(%eax)
movw %dx,(%ebx)
end;
end;
{$ASMMODE INTEL}
procedure setcursor(y,x:word);
{Set the cursor position.}
begin
if os_mode=osOS2 then
viosetcurpos(y,x,0)
else
asm
mov ah, 2
mov bh, 0
mov dh, byte ptr y
mov dl, byte ptr x
int 10h
end;
end;
procedure scroll_up(top,left,bottom,right,lines:word;var screl:word);
begin
if os_mode=osOS2 then
vioscrollup(top,left,bottom,right,lines,screl,0)
else
asm
mov ah, 6
mov al, byte ptr lines
mov edi, screl
mov bh, [edi + 1]
mov ch, byte ptr top
mov cl, byte ptr left
mov dh, byte ptr bottom
mov dl, byte ptr right
int 10h
end;
end;
procedure scroll_dn(top,left,bottom,right,lines:word;var screl:word);
begin
if os_mode=osOS2 then
vioscrolldn(top,left,bottom,right,lines,screl,0)
else
asm
mov ah, 7
mov al, byte ptr lines
mov edi, screl
mov bh, [edi + 1]
mov ch, byte ptr top
mov cl, byte ptr left
mov dh, byte ptr bottom
mov dl, byte ptr right
int 10h
end;
end;
{$ASMMODE ATT}
function keypressed:boolean;
{Checks if a key is pressed.}
var Akeyrec:Tkbdkeyinfo;
begin
if os_mode=osOS2 then
begin
kbdpeek(Akeyrec,0);
keypressed:=(extkeycode<>#0) or ((Akeyrec.fbstatus and $40)<>0);
end
else
begin
if extkeycode<>#0 then
begin
keypressed:=true;
exit
end
else
asm
movb $1,%ah
int $0x16
setnz %al
movb %al,__RESULT
end;
end;
end;
function readkey:char;
{Reads the next character from the keyboard.}
var Akeyrec:Tkbdkeyinfo;
c,s:char;
begin
if extkeycode<>#0 then
begin
readkey:=extkeycode;
extkeycode:=#0
end
else
begin
if os_mode=osOS2 then
begin
kbdcharin(Akeyrec,0,0);
c:=Akeyrec.charcode;
s:=Akeyrec.scancode;
if (c=#224) and (s<>#0) then
c:=#0;
end
else
begin
asm
movb $0,%ah
int $0x16
movb %al,c
movb %ah,s
end;
end;
if c=#0 then
extkeycode:=s;
readkey:=c;
end;
end;
procedure clrscr;
{Clears the current window.}
var screl:word;
begin
screl:=$20+textattr shl 8;
scroll_up(hi(windmin),lo(windmin),
hi(windmax),lo(windmax),
hi(windmax)-hi(windmin)+1,
screl);
gotoXY(1,1);
end;
procedure gotoXY(x,y:byte);
{Positions the cursor on (x,y) relative to the window origin.}
begin
if x<1 then
x:=1;
if y<1 then
y:=1;
if y+hi(windmin)-2>=hi(windmax) then
y:=hi(windmax)-hi(windmin)+1;
if x+lo(windmin)-2>=lo(windmax) then
x:=lo(windmax)-lo(windmin)+1;
setcursor(y+hi(windmin)-1,x+lo(windmin)-1);
end;
function whereX:byte;
{Returns the x position of the cursor.}
var x,y:word;
begin
getcursor(y,x);
whereX:=x-lo(windmin)+1;
end;
function whereY:byte;
{Returns the y position of the cursor.}
var x,y:word;
begin
getcursor(y,x);
whereY:=y-hi(windmin)+1;
end;
procedure clreol;
{Clear from current position to end of line.
Contributed by Michail A. Baikov}
var i:byte;
begin
{not fastest, but compatible}
for i:=wherex to lo(windmax) do write(' ');
gotoxy(1,wherey); {may be not}
end;
procedure delline;
{Deletes the line at the cursor.}
var row,left,right,bot:longint;
fil:word;
begin
row:=whereY;
left:=lo(windmin)+1;
right:=lo(windmax)+1;
bot:=hi(windmax)+1;
fil:=$20 or (textattr shl 8);
scroll_up(row+1,left,bot,right,1,fil);
end;
procedure insline;
{Inserts a line at the cursor position.}
var row,left,right,bot:longint;
fil:word;
begin
row:=whereY;
left:=lo(windmin)+1;
right:=lo(windmax)+1;
bot:=hi(windmax);
fil:=$20 or (textattr shl 8);
scroll_dn(row,left,bot-1,right,1,fil);
end;
procedure textmode(mode:integer);
{ Use this procedure to set-up a specific text-mode.}
begin
textattr:=$07;
lastmode:=mode;
mode:=mode and $ff;
setscreenmode(mode);
windmin:=0;
windmax:=(maxcols-1) or ((maxrows-1) shl 8);
clrscr;
end;
procedure textcolor(colour:byte);
{All text written after calling this will have color as foreground colour.}
begin
textattr:=(textattr and $70) or (colour and $f)+colour and 128;
end;
procedure textbackground(colour:byte);
{All text written after calling this will have colour as background colour.}
begin
textattr:=(textattr and $8f) or ((colour and $7) shl 4);
end;
procedure normvideo;
{Changes the text-background to black and the foreground to white.}
begin
textattr:=$7;
end;
procedure lowvideo;
{All text written after this will have low intensity.}
begin
textattr:=textattr and $f7;
end;
procedure highvideo;
{All text written after this will have high intensity.}
begin
textattr:=textattr or $8;
end;
procedure delay(ms:word);
var i,j:longint;
{Waits ms microseconds. The DOS code is copied from the DOS rtl.}
begin
{Under OS/2 we could also calibrate like under DOS. But this is
unreliable, because OS/2 can hold our programs while calibrating,
if it needs the processor for other things.}
if os_mode=osOS2 then
dossleep(ms)
else
begin
for i:=1 to ms do
for j:=1 to calibration do
begin
end;
end;
end;
procedure window(left,top,right,bottom:byte);
{Change the write window to the given coordinates.}
begin
if (left<1) or
(top<1) or
(right>maxcols) or
(bottom>maxrows) or
(left>right) or
(top>bottom) then
exit;
windmin:=(left-1) or ((top-1) shl 8);
windmax:=(right-1) or ((bottom-1) shl 8);
gotoXY(1,1);
end;
{$ASMMODE INTEL}
procedure writePchar(s:Pchar;len:word);
{Write a series of characters to the screen.
Not very fast, but is just text-mode isn't it?}
var x,y:word;
c:char;
i,n:integer;
screl:word;
ca:Pchar;
begin
i:=0;
getcursor(y,x);
while i<=len-1 do
begin
case s[i] of
#8:
x:=x-1;
#9:
x:=(x-lo(windmin)) and $fff8+8+lo(windmin);
#10:
;
#13:
begin
x:=lo(windmin);
inc(y);
end;
else
begin
ca:=@s[i];
n:=1;
while not(s[i+1] in [#8,#9,#10,#13]) and
{ (x+n<=lo(windmax)+1) and (i<len-1) do}
(x+n<=lo(windmax)) and (i<len-1) do
begin
inc(n);
inc(i);
end;
if os_mode=osOS2 then
viowrtcharstratt(ca,n,y,x,textattr,0)
else
asm
mov ax, 1300h
mov bh, 0
mov bl, TEXTATTR
mov dh, byte ptr y
mov dl, byte ptr x
mov cx, n
push ebp
mov ebp, ca
int 10h
pop ebp
end;
x:=x+n;
end;
end;
if x>lo(windmax) then
begin
x:=lo(windmin);
inc(y);
end;
if y>hi(windmax) then
begin
screl:=$20+textattr shl 8;
scroll_up(hi(windmin),lo(windmin),
hi(windmax),lo(windmax),
1,screl);
y:=hi(windmax);
end;
{ writeln(stderr,x,' ',y);}
inc(i);
end;
setcursor(y,x);
end;
{$ASMMODE ATT}
function crtread(var f:textrec):word;
{Read a series of characters from the console.}
var max,curpos:integer;
c:char;
clist:array[0..2] of char;
begin
max:=f.bufsize-2;
curpos:=0;
repeat
c:=readkey;
case c of
#0:
readkey;
#8:
if curpos>0 then
begin
clist:=#8' '#8;
writePchar(@clist,3);
dec(curpos);
end;
#13:
begin
f.bufptr^[curpos]:=#13;
inc(curpos);
f.bufptr^[curpos]:=#10;
inc(curpos);
f.bufpos:=0;
f.bufend:=curpos;
clist[0]:=#13;
writePchar(@clist,1);
break;
end;
#32..#255:
if curpos<max then
begin
f.bufptr^[curpos]:=c;
inc(curpos);
writePchar(@c,1);
end;
end;
until false;
crtread:=0;
end;
function crtwrite(var f:textrec):word;
{Write a series of characters to the console.}
begin
writePchar(Pchar(f.bufptr),f.bufpos);
f.bufpos:=0;
crtwrite:=0;
end;
function crtopen(var f:textrec):integer;
begin
if f.mode=fmoutput then
crtopen:=0
else
crtopen:=5;
end;
function crtinout(var f:textrec):integer;
begin
case f.mode of
fminput:
crtinout:=crtread(f);
fmoutput:
crtinout:=crtwrite(f);
end;
end;
function crtclose(var f:textrec):integer;
begin
f.mode:=fmclosed;
crtclose:=0;
end;
procedure assigncrt(var f:text);
{Assigns a file to the crt console.}
begin
textrec(f).mode:=fmclosed;
textrec(f).bufsize:=128;
textrec(f).bufptr:=@textrec(f).buffer;
textrec(f).bufpos:=0;
textrec(f).openfunc:=@crtopen;
textrec(f).inoutfunc:=@crtinout;
textrec(f).flushfunc:=@crtinout;
textrec(f).closefunc:=@crtclose;
textrec(f).name[0]:='.';
textrec(f).name[0]:=#0;
end;
procedure sound(hz:word);
{sound and nosound are not implemented because the OS/2 API supports a freq/
duration procedure instead of start/stop procedures.}
begin
end;
procedure nosound;
begin
end;
function get_ticks:word;
type Pword=^word;
begin
get_ticks:=Pword(longint(first_meg)+$46c)^;
end;
procedure initdelay;
{Calibrate the delay procedure. Copied from DOS rtl.}
var first:word;
begin
calibration:=0;
{ wait for new tick }
first:=get_ticks;
while get_ticks=first do
begin
end;
first:=get_ticks;
{ this estimates calibration }
while get_ticks=first do
inc(calibration);
{ calculate this to ms }
calibration:=calibration div 70;
while true do
begin
first:=get_ticks;
while get_ticks=first do
begin
end;
first:=get_ticks;
delay(55);
if first=get_ticks then
exit
else
begin
{ decrement calibration two percent }
calibration:=calibration-calibration div 50;
dec(calibration);
end;
end;
end;
{Initialization.}
type Pbyte=^byte;
var curmode:viomodeinfo;
mode:byte;
begin
textattr:=lightgray;
if os_mode=osOS2 then
begin
curmode.cb:=sizeof(curmode);
viogetmode(curmode,0);
maxcols:=curmode.col;
maxrows:=curmode.row;
lastmode:=0;
case maxcols of
40:
lastmode:=0;
80:
lastmode:=1;
132:
lastmode:=2;
end;
case maxrows of
25:;
28:
lastmode:=lastmode+16;
43:
lastmode:=lastmode+32;
50:
lastmode:=lastmode+48;
end
end
else
begin
{Request video mode to determine columns.}
asm
mov $0x0f,%ah
int $0x10
{ mov %al,_MODE }
mov %al,MODE
end;
case mode of
0,1:
begin
lastmode:=0;
maxcols:=40;
end;
else
begin
lastmode:=1;
maxcols:=80;
end;
end;
{Get number of rows from realmode $0040:$0084.}
maxrows:=Pbyte(longint(first_meg)+$484)^;
case maxrows of
25:;
28:
lastmode:=lastmode+16;
43:
lastmode:=lastmode+32;
50:
lastmode:=lastmode+48;
end
end;
windmin:=0;
windmax:=((maxrows-1) shl 8) or (maxcols-1);
if os_mode=osDOS then
initdelay;
crt_error:=cenoerror;
assigncrt(input);
textrec(input).mode:=fminput;
assigncrt(output);
textrec(output).mode:=fmoutput;
end.
{
$Log$
Revision 1.1 2003-03-23 23:11:17 hajny
+ emx target added
}

View File

@ -175,6 +175,7 @@ function exec(path:pathstr;runflags:execrunflags;winflags:execwinflags;
const comline:comstr):longint;
function envcount:longint;
function envstr(index:longint) : string;
function GetEnvPChar (EnvVar: string): PChar;
function getenv(const envvar:string): string;
implementation
@ -846,7 +847,7 @@ procedure FindFirst (const Path: PathStr; Attr: word; var F: SearchRec);
var path0: array[0..255] of char;
Count: longint;
Count: cardinal;
begin
{No error.}
@ -854,9 +855,9 @@ begin
if os_mode = osOS2 then
begin
New (F.FStat);
F.Handle := $FFFFFFFF;
F.Handle := longint ($FFFFFFFF);
Count := 1;
DosError := Integer(DosFindFirst (Path, F.Handle,
DosError := integer (DosFindFirst (Path, F.Handle,
Attr and FindResvdMask, F.FStat, SizeOf (F.FStat^),
Count, ilStandard));
if (DosError = 0) and (Count = 0) then DosError := 18;
@ -883,7 +884,7 @@ end;
procedure FindNext (var F: SearchRec);
var Count: longint;
var Count: cardinal;
begin
@ -893,7 +894,8 @@ begin
if os_mode = osOS2 then
begin
Count := 1;
DosError := Integer(DosFindNext (F.Handle, F.FStat, SizeOf (F.FStat^), Count));
DosError := integer (DosFindNext (F.Handle, F.FStat, SizeOf (F.FStat^),
Count));
if (DosError = 0) and (Count = 0) then DosError := 18;
end else _findnext (F);
DosSearchRec2SearchRec (F);
@ -932,18 +934,17 @@ begin
envstr:=strpas(hp);
end;
function GetEnv (const EnvVar: string): string;
function GetEnvPChar (EnvVar: string): PChar;
(* The assembler version is more than three times as fast as Pascal. *)
var
P: PChar;
_EnvVar: string;
begin
_EnvVar := UpCase (EnvVar);
EnvVar := UpCase (EnvVar);
{$ASMMODE INTEL}
asm
cld
mov edi, Environment
lea esi, _EnvVar
lea esi, EnvVar
xor eax, eax
lodsb
@NewVar:
@ -988,7 +989,14 @@ begin
mov P, edi { place pointer to variable contents in P }
@End:
end;
GetEnv := StrPas (P);
GetEnvPChar := P;
end;
{$ASMMODE ATT}
function GetEnv (const EnvVar: string): string;
(* The assembler version is more than three times as fast as Pascal. *)
begin
GetEnv := StrPas (GetEnvPChar (EnvVar));
end;
{$ASMMODE ATT}
@ -1153,7 +1161,8 @@ var
ptr : pchar;
base : pchar;
i: integer;
tib : pprocessinfoblock;
PIB: PProcessInfoBlock;
TIB: PThreadInfoBlock;
begin
{ We need to setup the environment }
{ only in the case of OS/2 }
@ -1162,8 +1171,8 @@ begin
exit;
cnt := 0;
{ count number of environment pointers }
dosgetinfoblocks (nil, PPProcessInfoBlock (@tib));
ptr := pchar(tib^.env);
DosGetInfoBlocks (PPThreadInfoBlock (@TIB), PPProcessInfoBlock (@PIB));
ptr := pchar(PIB^.env);
{ stringz,stringz...,#0 }
i := 0;
repeat
@ -1180,7 +1189,7 @@ begin
{ got count of environment strings }
GetMem(envp, cnt*sizeof(pchar)+16384);
cnt := 0;
ptr := pchar(tib^.env);
ptr := pchar(PIB^.env);
i:=0;
repeat
envp[cnt] := ptr;
@ -1213,22 +1222,13 @@ begin
end.
{
$Log$
Revision 1.2 2002-12-15 22:50:29 hajny
Revision 1.3 2003-03-23 23:11:17 hajny
+ emx target added
Revision 1.2 2002/12/15 22:50:29 hajny
* GetEnv fix merged from os2 target
Revision 1.1 2002/11/17 16:22:53 hajny
+ RTL for emx target
Revision 1.19 2002/09/07 16:01:24 peter
* old logs removed and tabs fixed
Revision 1.18 2002/07/11 16:00:05 hajny
* FindFirst fix (invalid attribute bits masked out)
Revision 1.17 2002/07/07 18:00:48 hajny
* DosGetInfoBlock modification to allow overloaded version (in DosCalls)
Revision 1.16 2002/03/03 11:19:20 hajny
* GetEnv rewritten to assembly - 3x faster now
}

View File

@ -37,7 +37,11 @@ Coding style:
interface
{Link the startup code.}
{$l prt1.oo2}
{$ifdef VER1_0}
{$l prt1.oo2}
{$else}
{$l prt1.o}
{$endif}
{$I systemh.inc}
@ -589,9 +593,9 @@ begin
exit;
end;
Action := Action or (Flags and $FF);
(* DenyAll if sharing not specified. *)
(* DenyNone if sharing not specified. *)
if Flags and 112 = 0 then
Action := Action or 16;
Action := Action or 64;
asm
movl $0x7f2b, %eax
movl Action, %ecx
@ -1237,7 +1241,10 @@ begin
end.
{
$Log$
Revision 1.3 2002-12-15 22:46:29 hajny
Revision 1.4 2003-03-23 23:11:17 hajny
+ emx target added
Revision 1.3 2002/12/15 22:46:29 hajny
* First_Meg fixed + Environment initialization under Dos
Revision 1.2 2002/11/17 22:32:05 hajny
@ -1246,31 +1253,4 @@ end.
Revision 1.1 2002/11/17 16:22:54 hajny
+ RTL for emx target
Revision 1.26 2002/10/27 14:29:00 hajny
* heap management (hopefully) fixed
Revision 1.25 2002/10/14 19:39:17 peter
* threads unit added for thread support
Revision 1.24 2002/10/13 09:28:45 florian
+ call to initvariantmanager inserted
Revision 1.23 2002/09/07 16:01:25 peter
* old logs removed and tabs fixed
Revision 1.22 2002/07/01 16:29:05 peter
* sLineBreak changed to normal constant like Kylix
Revision 1.21 2002/04/21 15:54:20 carl
+ initialize some global variables
Revision 1.20 2002/04/12 17:42:16 carl
+ generic stack checking
Revision 1.19 2002/03/11 19:10:33 peter
* Regenerated with updated fpcmake
Revision 1.18 2002/02/10 13:46:20 hajny
* heap management corrected (heap_brk)
}

View File

@ -379,7 +379,10 @@ initialization
end.
{
$Log$
Revision 1.2 2002-11-17 22:32:05 hajny
Revision 1.3 2003-03-23 23:11:17 hajny
+ emx target added
Revision 1.2 2002/11/17 22:32:05 hajny
* type corrections (longing x cardinal)
Revision 1.1 2002/11/17 16:45:35 hajny
@ -392,4 +395,3 @@ end.
* threads unit added for thread support
}

View File

@ -192,11 +192,12 @@ function DosScanEnv (Name: PChar; var Value: PChar): longint; cdecl;
external 'DOSCALLS' index 227;
function DosFindFirst (FileMask: PChar; var Handle: longint; Attrib: longint;
AFileStatus: PFileStatus; FileStatusLen: longint;
var Count: longint; InfoLevel: longint): longint; cdecl;
AFileStatus: PFileStatus; FileStatusLen: cardinal;
var Count: cardinal; InfoLevel: cardinal): longint; cdecl;
external 'DOSCALLS' index 264;
function DosFindNext (Handle: longint; AFileStatus: PFileStatus;
FileStatusLen: longint; var Count: longint): longint; cdecl;
FileStatusLen: cardinal; var Count: cardinal): longint; cdecl;
external 'DOSCALLS' index 265;
function DosFindClose (Handle: longint): longint; cdecl;
@ -283,6 +284,12 @@ begin
end;
Function FileCreate (Const FileName : String; Mode:longint) : Longint;
begin
FileCreate:=FileCreate(FileName);
end;
function FileRead (Handle: longint; var Buffer; Count: longint): longint;
assembler;
asm
@ -331,7 +338,7 @@ end;
procedure FileClose (Handle: longint);
begin
if (Handle <= 4) or (os_mode = osOS2) and (Handle <= 2) then
if (Handle > 4) or (os_mode = osOS2) and (Handle > 2) then
asm
mov eax, 3E00h
mov ebx, Handle
@ -410,7 +417,7 @@ function FindFirst (const Path: string; Attr: longint; var Rslt: TSearchRec): lo
var SR: PSearchRec;
FStat: PFileFindBuf3;
Count: longint;
Count: cardinal;
Err: longint;
begin
@ -459,7 +466,7 @@ function FindNext (var Rslt: TSearchRec): longint;
var SR: PSearchRec;
FStat: PFileFindBuf3;
Count: longint;
Count: cardinal;
Err: longint;
begin
@ -929,12 +936,8 @@ end;
Function GetEnvironmentVariable(Const EnvVar : String) : String;
var P: PChar;
begin
if DosScanEnv (PChar (EnvVar), P) = 0
then GetEnvironmentVariable := StrPas (P)
else GetEnvironmentVariable := '';
GetEnvironmentVariable := StrPas (GetEnvPChar (EnvVar));
end;
@ -951,19 +954,10 @@ end.
{
$Log$
Revision 1.1 2002-11-17 16:22:54 hajny
Revision 1.2 2003-03-23 23:11:17 hajny
+ emx target added
Revision 1.1 2002/11/17 16:22:54 hajny
+ RTL for emx target
Revision 1.18 2002/09/23 17:42:37 hajny
* AnsiString to PChar typecast
Revision 1.17 2002/09/07 16:01:25 peter
* old logs removed and tabs fixed
Revision 1.16 2002/07/11 16:00:05 hajny
* FindFirst fix (invalid attribute bits masked out)
Revision 1.15 2002/01/25 16:23:03 peter
* merged filesearch() fix
}