Subversion Repositories Kolibri OS

Compare Revisions

No changes between revisions

Regard whitespace Rev 615 → Rev 616

/programs/develop/fp/rtl/_defines.inc
0,0 → 1,9
{$undef mswindows}
{$undef windows}
{$undef Windows}
{$undef win32}
{$undef os2}
{$undef linux}
 
{$define EMULATOR}
{$undef debug_mt}
/programs/develop/fp/rtl/build.bat
0,0 → 1,20
@echo off
 
set FPRTL={path to original freepascal rtl source code, example ... \fp\src\rtl}
set INCS=-Fi%FPRTL%\inc;%FPRTL%\i386;%FPRTL%\objpas;%FPRTL%\objpas\sysutils;%FPRTL%\objpas\classes
set UNTS=-Fu%FPRTL%\inc;%FPRTL%\i386;%FPRTL%\objpas
set FPCARGS=-Twin32 -Se5 -Sg -n -O3pPENTIUM3 -CfSSE -di386 -FU..\units %INCS% %UNTS%
 
fpc system.pp -Us %FPCARGS%
if errorlevel 1 goto error
 
fpc %FPRTL%\objpas\objpas.pp %FPCARGS%
if errorlevel 1 goto error
 
fpc buildrtl.pp %FPCARGS%
if errorlevel 0 goto end
 
:error
echo An error occured while building RTL
 
:end
/programs/develop/fp/rtl/buildrtl.pp
0,0 → 1,20
unit buildrtl;
 
interface
 
uses
sysinitpas, {sysinitcyg, sysinitgprof,}
ctypes, strings,
lineinfo, lnfodwrf, heaptrc, matrix,
{windows, winsock, winsock2, initc, cmem, dynlibs, signals,}
dos, crt, objects{, messages,
rtlconsts, sysconst}, sysutils{, math, types,
strutils, dateutils, varutils, variants, typinfo, fgl}, classes{,
convutils, stdconvs, cpu, mmx, charset, ucomplex, getopts,
winevent, sockets, printer,
video, mouse, keyboard, fmtbcd,
winsysut, sharemem};
 
implementation
 
end.
/programs/develop/fp/rtl/classes.pp
0,0 → 1,26
{$mode objfpc}
 
unit Classes;
 
{$i _defines.inc}
 
interface
 
uses
RTLConsts, SysUtils, Types, TypInfo;
 
{$i classesh.inc}
 
implementation
 
uses
SysConst;
 
{ OS - independent class implementations are in /inc directory. }
{$i classes.inc}
 
initialization
CommonInit;
finalization
CommonCleanup;
end.
/programs/develop/fp/rtl/crt.pp
0,0 → 1,7
unit Crt;
 
interface
 
implementation
 
end.
/programs/develop/fp/rtl/dos.pp
0,0 → 1,9
unit Dos;
 
interface
 
{$i filerec.inc}
 
implementation
 
end.
/programs/develop/fp/rtl/kos.inc
0,0 → 1,708
{cp866}
 
{ User interface }
procedure kos_definewindow(x, y, w, h: Word; style, header, clframe: DWord); assembler; register;
asm
pushl %ebx
pushl %ecx
pushl %edx
pushl %esi
pushl %edi
movl %eax, %ebx
xchgl %edx, %ecx
movl header, %esi
shll $16, %ebx
shll $16, %ecx
movl clframe, %edi
movw %dx, %bx
movw h, %cx
xorl %eax, %eax
movl style, %edx
decl %ebx {㬥­ìè¨âì è¨à¨­ã ­  1}
decl %ecx {㬥­ìè¨âì ¢ëá®âã ­  1}
int $0x40
popl %edi
popl %esi
popl %edx
popl %ecx
popl %ebx
end;
 
procedure kos_movewindow(x, y, w, h: DWord); assembler; register;
asm
pushl %eax
pushl %ebx
pushl %ecx
pushl %edx
pushl %esi
movl %eax, %ebx
xchgl %ecx, %edx
movl $67, %eax
movl h, %esi
decl %edx {㬥­ìè¨âì è¨à¨­ã ­  1}
decl %esi {㬥­ìè¨âì ¢ëá®âã ­  1}
int $0x40
popl %esi
popl %edx
popl %ecx
popl %ebx
popl %eax
end;
 
function kos_getkey(): DWord; assembler; register;
asm
movl $2, %eax
int $0x40
end;
 
function kos_getevent(wait: Boolean = True): DWord; assembler; register;
asm
andl $1, %eax
xorb $1, %al
addl $10, %eax
int $0x40
end;
 
function kos_waitevent(timeout: DWord): DWord; assembler; register;
asm
pushl %ebx
movl $23, %ebx
xchgl %eax, %ebx
int $0x40
popl %ebx
end;
 
function kos_getbutton(): DWord; assembler; register;
asm
movl $17, %eax
int $0x40
shrl $8, %eax
andl $0xFF, %eax
end;
 
function kos_getmousepos(): TKosPoint; assembler; register;
{@return: x*65536 + y}
asm
pushl %eax
pushl %ebx
pushl %ecx
pushl %eax
movl $37, %eax
xorl %ebx, %ebx
int $0x40
movswl %ax, %ecx
popl %ebx
shrl $16, %eax
movl %ecx, TKosPoint.Y(%ebx)
movl %eax, TKosPoint.X(%ebx)
popl %ecx
popl %ebx
popl %eax
end;
 
function kos_getmousewinpos(): TKosPoint; assembler; register;
{@return: x*65536 + y}
asm
pushl %eax
pushl %ebx
pushl %ecx
pushl %eax
movl $37, %eax
movl $1, %ebx
int $0x40
movswl %ax, %ecx
popl %ebx
shrl $16, %eax
movl %ecx, TKosPoint.Y(%ebx)
movl %eax, TKosPoint.X(%ebx)
popl %ecx
popl %ebx
popl %eax
end;
 
function kos_getmousebuttons(): DWord; assembler; register;
{@return:
¡¨â 0 ãáâ ­®¢«¥­ = «¥¢ ï ª­®¯ª  ­ ¦ â 
¡¨â 1 ãáâ ­®¢«¥­ = ¯à ¢ ï ª­®¯ª  ­ ¦ â 
¡¨â 2 ãáâ ­®¢«¥­ = á।­ïï ª­®¯ª  ­ ¦ â 
¡¨â 3 ãáâ ­®¢«¥­ = 4-ï ª­®¯ª  ­ ¦ â 
¡¨â 4 ãáâ ­®¢«¥­ = 5-ï ª­®¯ª  ­ ¦ â }
asm
pushl %ebx
movl $37, %eax
movl $2, %ebx
int $0x40
popl %ebx
end;
 
procedure kos_maskevents(mask: DWord); assembler; register;
asm
pushl %ebx
xchgl %eax, %ebx
movl $40, %eax
int $0x40
xchgl %eax, %ebx
popl %ebx
end;
 
procedure kos_setcaption(caption: PChar); assembler; register;
asm
pushl %ecx
pushl %ebx
xchgl %eax, %ecx
movl $1, %ebx
movl $71, %eax
int $0x40
xchgl %eax, %ecx
popl %ebx
popl %ecx
end;
 
 
{ Graphics }
 
procedure kos_begindraw(); assembler; register;
asm
pushl %ebx
movl $12, %eax
movl $1, %ebx
int $0x40
popl %ebx
end;
 
procedure kos_enddraw(); assembler; register;
asm
pushl %ebx
movl $12, %eax
movl $2, %ebx
int $0x40
popl %ebx
end;
 
procedure kos_putpixel(x, y: Word; color: DWord); assembler; register;
asm
pushl %ebx
movl %eax, %ebx
xchgl %edx, %ecx
movl $1, %eax
int $0x40
xchgl %edx, %ecx
popl %ebx
end;
 
procedure kos_drawtext(x, y: Word; text: String; flags, bgcolor: DWord); assembler; register;
label nobg;
asm
pusha
shll $16, %eax
pushl %ecx
movl flags, %ecx {ä« £¨, 梥â}
movl bgcolor, %edi
movw %dx, %ax
andl $0x7FFFFFFF, %ecx
btl $31, %edi
jnc nobg
orl $0x40000000, %ecx
nobg:
popl %edx
movl %eax, %ebx {ª®®à¤¨­ âë}
movzbl (%edx), %esi {¤«¨­  áâப¨}
movl $4, %eax {­®¬¥à ä㭪樨}
incl %edx {㪠§ â¥«ì ­  áâபã}
andl $0xFFFFFF, %edi
int $0x40
popa
end;
 
procedure kos_drawrect(x, y, w, h: Word; color: DWord); assembler; register;
asm
pushl %eax
pushl %ebx
pushl %ecx
pushl %edx
movl %eax, %ebx
xchgl %edx, %ecx
shll $16, %ebx
shll $16, %ecx
movl $13, %eax
movw %dx, %bx
movw h, %cx
movl color, %edx
int $0x40
popl %edx
popl %ecx
popl %ebx
popl %eax
end;
 
procedure kos_drawline(x1, y1, x2, y2: Word; color: DWord = $000000); assembler; register;
asm
pushl %eax
pushl %ebx
pushl %ecx
pushl %edx
 
xchgl %eax, %ecx
xchgl %ecx, %edx
movl color, %ebx
{eax - x2, ebx - color, ecx - y1, edx - x1}
shll $16, %ecx
shll $16, %edx
movw %ax, %dx
movw y2, %cx
movl $38, %eax
xchgl %ebx, %edx
int $0x40
 
popl %edx
popl %ecx
popl %ebx
popl %eax
end;
 
procedure kos_drawimage(x, y, w, h, depth: DWord; image: Pointer; palette: Pointer; xoffset: DWord); assembler; register;
asm
pusha
shll $16, %eax
shll $16, %ecx
orl %eax, %edx
orl h, %ecx
movl depth, %esi
movl image, %ebx
movl palette, %edi
movl xoffset, %ebp
movl $65, %eax
int $0x40
popa
end;
 
procedure kos_drawimage24(x, y, w, h: DWord; image: Pointer); assembler; register;
asm
pushl %eax
pushl %ebx
pushl %ecx
pushl %edx
shll $16, %eax
shll $16, %ecx
orl %eax, %edx
orl h, %ecx
movl image, %ebx
movl $7, %eax
int $0x40
popl %edx
popl %ecx
popl %ebx
popl %eax
end;
 
 
{ Work with system }
 
{ Work with system - System services }
 
function kos_killthread(tid: TThreadID): Boolean; assembler; register;
asm
pushl %ecx
pushl %ebx
movl $18, %ecx
movl $18, %ebx
xchgl %eax, %ecx
int $0x40
andl $1, %eax
popl %ebx
popl %ecx
xorb $1, %al
end;
 
procedure kos_setactivewindow(slot: TThreadSlot); assembler; register;
asm
pushl %ecx
pushl %ebx
movl $18, %ecx
movl $3, %ebx
xchgl %eax, %ecx
int $0x40
xchgl %eax, %ecx
popl %ebx
popl %ecx
end;
 
{$ifdef EMULATOR}
function kos_getthreadslot(tid: TThreadID): TThreadSlot;
var
ThreadInfo: TKosThreadInfo;
HighThreadSlot: TThreadSlot;
begin
Result := 0;
repeat
Inc(Result);
HighThreadSlot := kos_threadinfo(@ThreadInfo, Result);
until (Result > HighThreadSlot) or (ThreadInfo.ThreadID = tid);
end;
 
{$else}
 
function kos_getthreadslot(tid: TThreadID): TThreadSlot; assembler; register;
asm
pushl %ecx
pushl %ebx
movl $18, %ecx
movl $21, %ebx
xchgl %eax, %ecx
int $0x40
popl %ebx
popl %ecx
end;
{$endif}
 
{ Work with system - Set system parameters }
 
procedure kos_enablepci(); assembler; register;
asm
pushl %eax
pushl %ebx
pushl %ecx
movl $21, %eax
movl $12, %ebx
movl $1, %ecx
int $0x40
popl %ecx
popl %ebx
popl %eax
end;
 
{ Work with system - Internal system services }
 
procedure kos_switchthread(); assembler; register;
asm
pushl %eax
pushl %ebx
movl $68, %eax
movl $1, %ebx
int $0x40
popl %ebx
popl %eax
end;
 
function kos_initheap(): DWord; assembler; register;
asm
pushl %ebx
movl $68, %eax
movl $11, %ebx
int $0x40
popl %ebx
end;
 
function kos_alloc(size: DWord): Pointer; assembler; register;
asm
pushl %ebx
pushl %ecx
movl %eax, %ecx
movl $68, %eax
movl $12, %ebx
int $0x40
popl %ecx
popl %ebx
end;
 
function kos_free(ptr: Pointer): Boolean; assembler; register;
asm
pushl %ebx
pushl %ecx
movl %eax, %ecx
movl $68, %eax
movl $13, %ebx
int $0x40
popl %ecx
popl %ebx
end;
 
function kos_loaddriver(name: PChar): THandle; assembler; register;
asm
pushl %ebx
pushl %ecx
movl %eax, %ecx
movl $68, %eax
movl $16, %ebx
int $0x40
popl %ecx
popl %ebx
end;
 
 
{ Processes and threads }
 
function kos_threadinfo(info: PKosThreadInfo; slot: TThreadSlot): DWord; assembler; register;
asm
pushl %ebx
movl %eax, %ebx
xchgl %edx, %ecx
movl $9, %eax
int $0x40
xchgl %edx, %ecx
popl %ebx
end;
 
function kos_newthread(entry, stack: Pointer): TThreadID; assembler; register;
asm
pushl %ebx
pushl %ecx
movl $1, %ebx
movl %eax, %ecx
movl $51, %eax
int $0x40
popl %ecx
popl %ebx
end;
 
procedure kos_initipc(ipc: PKosIPC; size: DWord); assembler; register;
asm
pushl %ebx
pushl %ecx
movl $60, %ecx
movl $1, %ebx
xchgl %eax, %ecx
int $0x40
popl %ecx
popl %ebx
end;
 
function kos_sendmsg(tid: TThreadID; msg: Pointer; size: DWord): DWord; assembler; register;
{@return:
0 - ãᯥ譮
1 - ¯à¨ñ¬­¨ª ­¥ ®¯à¥¤¥«¨« ¡ãä¥à ¤«ï IPC-á®®¡é¥­¨©
(¬®¦¥â ¡ëâì, ¥éñ ­¥ ãᯥ«,   ¬®¦¥â ¡ëâì, íâ® ­¥ â®â ¯®â®ª, ª®â®àë© ­ã¦¥­)
2 - ¯à¨ñ¬­¨ª § ¡«®ª¨à®¢ « IPC-¡ãä¥à; ¯®¯à®¡ã©â¥ ­¥¬­®£® ¯®¤®¦¤ âì
3 - ¯¥à¥¯®«­¥­¨¥ IPC-¡ãä¥à  ¯à¨ñ¬­¨ª 
4 - ¯à®æ¥áá /¯®â®ª  á â ª¨¬ PID ­¥ áãé¥áâ¢ã¥â}
asm
pushl %esi
pushl %ebx
movl $60, %esi
movl $2, %ebx
xchgl %ecx, %esi
xchgl %eax, %ecx
int $0x40
xchgl %ecx, %esi
popl %ebx
popl %esi
end;
 
function kos_resizemem(size: DWord): Boolean; assembler; register;
asm
pushl %ebx
pushl %ecx
movl %eax, %ecx
movl $64, %eax
movl $1, %ebx
int $0x40
xorb $1, %al
popl %ecx
popl %ebx
end;
 
 
{ File system }
{ File system - Work with the current folder }
 
procedure kos_setdir(path: PChar); assembler; register;
asm
pushl %ecx
pushl %ebx
movl $30, %ecx
movl $1, %ebx
xchgl %eax, %ecx
int $0x40
popl %ebx
popl %ecx
end;
 
function kos_getdir(path: PChar; size: DWord): DWord; assembler; register;
asm
pushl %ecx
pushl %ebx
movl $30, %ecx
movl $2, %ebx
xchgl %eax, %ecx
int $0x40
popl %ebx
popl %ecx
end;
 
{ File system - Work with file system with long names support }
 
function kos_readfile(kosfile: PKosFile; var readed: Longint): DWord; assembler; register;
asm
pushl %ebx
movl $70, %ebx
xchgl %eax, %ebx
movl $0, (%ebx)
int $0x40
movl %ebx, (%edx)
popl %ebx
end;
 
function kos_rewritefile(kosfile: PKosFile; var writed: Longint): DWord; assembler; register;
asm
pushl %ebx
movl $70, %ebx
xchgl %eax, %ebx
movl $2, (%ebx)
int $0x40
movl %ebx, (%edx)
popl %ebx
end;
 
function kos_writefile(kosfile: PKosFile; var writed: Longint): DWord; assembler; register;
asm
pushl %ebx
movl $70, %ebx
xchgl %eax, %ebx
movl $3, (%ebx)
int $0x40
movl %ebx, (%edx)
popl %ebx
end;
 
function kos_fileinfo(kosfile: PKosFile): DWord; assembler; register;
asm
pushl %ebx
movl $70, %ebx
xchgl %eax, %ebx
movl $5, (%ebx)
int $0x40
popl %ebx
end;
 
 
{ Work with hardware }
 
function kos_readport(index: DWord): DWord; assembler; register;
label ok, exit;
asm
pushl %ecx
pushl %ebx
xchgl %eax, %ecx {index}
movl $43, %eax
orl $0x80000000, %ecx {index}
int $0x40
orl %eax, %eax
jzl ok
movl $-1, %eax
jmp exit
ok:
movl %ebx, %eax
exit:
popl %ebx
popl %ecx
end;
 
procedure kos_writeport(index, value: DWord); assembler; register;
asm
pushl %eax
pushl %ebx
pushl %ecx
xchgl %edx, %ebx {value}
xchgl %eax, %ecx {index}
movl $43, %eax
int $0x40
xchgl %edx, %ebx
popl %ecx
popl %ebx
popl %eax
end;
 
function kos_reserveport(port: DWord): Boolean; assembler; register;
asm
pushl %ebx
pushl %ecx
pushl %edx
movl %eax, %ecx {port}
movl $46, %eax
movl %ecx, %edx {port}
xorl %ebx, %ebx
int $0x40
xorb $1, %al
popl %edx
popl %ecx
popl %ebx
end;
 
{ Work with hardware - Low-level access to PCI}
 
function kos_lastpcibus(): Byte; assembler; register;
asm
pushl %ebx
movl $62, %eax
movl $1, %ebx
int $0x40
popl %ebx
end;
 
function kos_readpcib(bus, dev, func, reg: Byte): Byte; assembler; register;
asm
pushl %ebx
pushl %ecx
pushl %edx
shlb $3, %dl {dev}
movb %al, %bh {bus}
shlw $8, %cx {func}
movb $4, %bl
movb reg, %cl {func}
andb $7, %ch {func}
movl $62, %eax
orb %dl, %ch {dev/func}
int $0x40
popl %edx
popl %ecx
popl %ebx
end;
 
function kos_readpciw(bus, dev, func, reg: Byte): Word; assembler; register;
asm
pushl %ebx
pushl %ecx
pushl %edx
shlb $3, %dl {dev}
movb %al, %bh {bus}
shlw $8, %cx {func}
movb $5, %bl
movb reg, %cl {reg}
andb $7, %ch {func}
movl $62, %eax
orb %dl, %ch {dev/func}
int $0x40
popl %edx
popl %ecx
popl %ebx
end;
 
function kos_readpcid(bus, dev, func, reg: Byte): DWord; assembler; register;
asm
pushl %ebx
pushl %ecx
pushl %edx
shlb $3, %dl {dev}
movb %al, %bh {bus}
shlw $8, %cx {func}
movb $6, %bl
movb reg, %cl {reg}
andb $7, %ch {func}
movl $62, %eax
orb %dl, %ch {dev/func}
int $0x40
popl %edx
popl %ecx
popl %ebx
end;
 
 
{ Other }
procedure kos_delay(ms: DWord); assembler; register;
asm
pushl %ebx
movl %eax, %ebx
movl $5, %eax
int $0x40
popl %ebx
end;
/programs/develop/fp/rtl/kos_def.inc
0,0 → 1,115
{Ž¯à¥¤¥«¥­¨ï, ª®­áâ ­âë}
 
const
{‘¨á⥬­ë¥ ᮡëâ¨ï}
SE_PAINT = 1;
SE_KEYBOARD = 2;
SE_BUTTON = 3;
SE_MOUSE = 6;
SE_IPC = 7;
 
{Œ áª¨ ᮡë⨩}
ME_PAINT = 1 shl (SE_PAINT - 1);
ME_KEYBOARD = 1 shl (SE_KEYBOARD - 1);
ME_BUTTON = 1 shl (SE_BUTTON - 1);
ME_MOUSE = 1 shl (SE_MOUSE - 1);
ME_IPC = 1 shl (SE_IPC - 1);
 
{Š®¤ë ª« ¢¨è}
VK_LBUTTON = 1;
VK_RBUTTON = 2;
VK_CANCEL = 3;
VK_MBUTTON = 4;
VK_BACK = 8;
VK_TAB = 9;
VK_CLEAR = 12;
VK_RETURN = 13;
VK_SHIFT = 16;
VK_CONTROL = 17;
VK_MENU = 18;
VK_PAUSE = 19;
VK_CAPITAL = 20;
VK_ESCAPE = 27;
VK_SPACE = 32;
VK_PRIOR = 33;
VK_NEXT = 34;
VK_END = 35;
VK_HOME = 36;
VK_LEFT = 37;
VK_UP = 38;
VK_RIGHT = 39;
VK_DOWN = 40;
VK_SELECT = 41;
VK_PRINT = 42;
VK_EXECUTE = 43;
VK_SNAPSHOT = 44;
VK_INSERT = 45;
VK_DELETE = 46;
VK_HELP = 47;
VK_0 = 48;
VK_1 = 49;
VK_2 = 50;
VK_3 = 51;
VK_4 = 52;
VK_5 = 53;
VK_6 = 54;
VK_7 = 55;
VK_8 = 56;
VK_9 = 57;
VK_A = 65;
VK_B = 66;
VK_C = 67;
VK_D = 68;
VK_E = 69;
VK_F = 70;
VK_G = 71;
VK_H = 72;
VK_I = 73;
VK_J = 74;
VK_K = 75;
VK_L = 76;
VK_M = 77;
VK_N = 78;
VK_O = 79;
VK_P = 80;
VK_Q = 81;
VK_R = 82;
VK_S = 83;
VK_T = 84;
VK_U = 85;
VK_V = 86;
VK_W = 87;
VK_X = 88;
VK_Y = 89;
VK_Z = 90;
VK_LWIN = 91;
VK_RWIN = 92;
VK_APPS = 93;
VK_NUMPAD0 = 96;
VK_NUMPAD1 = 97;
VK_NUMPAD2 = 98;
VK_NUMPAD3 = 99;
VK_NUMPAD4 = 100;
VK_NUMPAD5 = 101;
VK_NUMPAD6 = 102;
VK_NUMPAD7 = 103;
VK_NUMPAD8 = 104;
VK_NUMPAD9 = 105;
VK_MULTIPLY = 106;
VK_ADD = 107;
VK_SEPARATOR = 108;
VK_SUBTRACT = 109;
VK_DECIMAL = 110;
VK_DIVIDE = 111;
VK_F1 = 112;
VK_F2 = 113;
VK_F3 = 114;
VK_F4 = 115;
VK_F5 = 116;
VK_F6 = 117;
VK_F7 = 118;
VK_F8 = 119;
VK_F9 = 120;
VK_F10 = 121;
VK_F11 = 122;
VK_F12 = 123;
/programs/develop/fp/rtl/kos_stdio.inc
0,0 → 1,355
{}
 
procedure OpenStdout(var f: TextRec); forward;
procedure WriteStdout(var f: TextRec); forward;
procedure CloseStdout(var f: TextRec); forward;
 
procedure OpenStdin(var f: TextRec); forward;
procedure ReadStdin(var f: TextRec); forward;
procedure CloseStdin(var f: TextRec); forward;
 
 
 
procedure AssignStdout(var f: Text);
begin
Assign(f, '');
TextRec(f).OpenFunc := @OpenStdout;
Rewrite(f);
end;
 
procedure OpenStdout(var f: TextRec);
begin
TextRec(f).InOutFunc := @WriteStdout;
TextRec(f).FlushFunc := @WriteStdout;
TextRec(f).CloseFunc := @CloseStdout;
end;
 
procedure WriteStdout(var f: TextRec);
var
msg: String;
begin
msg := StrPas(PChar(f.bufptr));
SetLength(msg, f.bufpos);
f.bufpos := 0;
Konsole.Write(msg);
end;
 
procedure CloseStdout(var f: TextRec);
begin
end;
 
 
 
procedure AssignStdin(var f: Text);
begin
Assign(f, '');
TextRec(f).OpenFunc := @OpenStdin;
Reset(f);
end;
 
procedure OpenStdin(var f: TextRec);
begin
TextRec(f).InOutFunc := @ReadStdin;
TextRec(f).FlushFunc := nil;
TextRec(f).CloseFunc := @CloseStdin;
end;
 
procedure ReadStdin(var f: TextRec);
var
max, curpos: Longint;
c: Longint;
begin
max := f.bufsize - Length(LineEnding);
curpos := 0;
repeat
c := 13{l4_getc()};
case c of
13:
begin
{f.bufptr^[curpos] := LineEnding;}
Inc(curpos);
f.bufpos := 0;
f.bufend := curpos;
{l4_putc(Longint(LineEnding));}
break;
end;
32..126: if curpos < max then
begin
f.bufptr^[curpos] := Char(c);
Inc(curpos);
{l4_putc(c);}
end;
end;
until False;
end;
 
procedure CloseStdin(var f: TextRec);
begin
end;
 
 
{ TKonsole }
 
procedure KonsoleThreadMain(Console: PKonsole);
{ ¡®ç¨© 横« ª®­á®«¨}
var
ThreadInfo: TKosThreadInfo;
Message: ShortString;
Event: DWord;
begin
kos_maskevents(ME_PAINT or ME_KEYBOARD or ME_IPC);
kos_threadinfo(@ThreadInfo);
Console^.FThreadSlot := kos_getthreadslot(ThreadInfo.ThreadID);
 
kos_initipc(Console^.FIPCBuffer, Console^.FIPCBufferSize);
 
{áࠧ㠮⮡ࠧ¨âì ¨  ªâ¨¢¨à®¢ âì ®ª­®}
Console^.Paint();
{$ifndef EMULATOR}
kos_setactivewindow(Console^.FThreadSlot);
{$endif}
 
{£®â®¢ ª ®¡à ¡®âª¥ ᮡë⨩}
Console^.FOpened := True;
while not Console^.FTerminate do
begin
Event := kos_getevent();
if Console^.FTerminate then
{Console^.ProcessMessage('[CONSOLE] Terminate...'#13#10)} else
case Event of
SE_PAINT: Console^.Paint();
SE_KEYBOARD: Console^.ProcessKeyboard(kos_getkey());
SE_IPC: while Console^.ReceiveMessage(Message) do Console^.ProcessMessage(Message);
end;
end;
Console^.FOpened := False;
end;
 
constructor TKonsole.Init(ACaption: String);
const
IPC_SIZE = 4096;
var
ThreadInfo: TKosThreadInfo;
begin
if ACaption <> '' then
FCaption := ACaption else
begin
kos_threadinfo(@ThreadInfo);
FCaption := StrPas(ThreadInfo.AppName);
end;
SetLength(FLines, 1);
FLines[0] := ' ';
FCursor.X := 1;
FCursor.Y := 0;
FMaxLines := 150;
FTerminate := False;
FOpened := False;
FIPCBufferSize := SizeOf(TKosIPC) + IPC_SIZE;
FIPCBuffer := GetMem(FIPCBufferSize);
{FIPCBufferSize := SizeOf(KonsoleIPCBuffer);
FIPCBuffer := @KonsoleIPCBuffer;}
FIPCBuffer^.Lock := False;
FIPCBuffer^.Size := 0;
FThreadSlot := -1;
FThreadID := BeginThread(TThreadFunc(@KonsoleThreadMain), @Self);
if FThreadID <> 0 then
while not FOpened do kos_delay(1);
end;
 
destructor TKonsole.Done();
begin
FTerminate := True;
Self.Write(#0);
if FOpened then kos_delay(1);
if FOpened then kos_delay(10);
if FOpened then kos_delay(20);
if FOpened then
begin
FOpened := False;
KillThread(FThreadID);
end;
FreeMem(FIPCBuffer);
SetLength(FLines, 0);
end;
 
function TKonsole.ReceiveMessage(var Message: ShortString): Boolean;
{ˆ§¢«¥çì ¯¥à¢®¥ á®®¡é¥­¨¥ ¨§ ¡ãä¥à }
var
PMsg: PKosMessage;
Size: Longword;
begin
if FIPCBuffer^.Size > 0 then
begin
FIPCBuffer^.Lock := True;
PMsg := Pointer(Longword(FIPCBuffer) + SizeOf(TKosIPC));
{TODO: ¯à®¢¥àª  PMsg^.SenderID}
{Size := PMsg^.Size;
Dec(FIPCBuffer^.Size, Size + SizeOf(TKosMessage));
if Size > 255 then Size := 255;
SetLength(Message, Size);
Move(Pointer(Longword(PMsg) + SizeOf(TKosMessage))^, Message[1], Size);
if FIPCBuffer^.Size > 0 then
Move(Pointer(Longword(PMsg) + SizeOf(TKosMessage) + PMsg^.Size)^, PMsg^, FIPCBuffer^.Size);}
 
{XXX}
Size := FIPCBuffer^.Size;
Dec(FIPCBuffer^.Size, Size);
if Size > 255 then Size := 255;
SetLength(Message, Size);
Move(PMsg^, Message[1], Size);
 
Result := True;
end else
begin
Message := '';
Result := False;
end;
 
{FIXME: ¥á«¨ FIPCBuffer^.Size = 0, â® FIPCBuffer^.Lock ¢á¥ à ¢­® > 0}
FIPCBuffer^.Lock := False;
end;
 
procedure TKonsole.ProcessMessage(Message: ShortString);
{‚뢥á⨠ᮮ¡é¥­¨¥ ­  ª®­á®«ì}
var
S: String;
LinesCount: Word;
CR, LF, W: Word;
BottomRow: Boolean = True;
begin
if Length(Message) < 1 then Exit;
 
repeat
CR := Pos(#13, Message);
LF := Pos(#10, Message);
if (CR > 0) and ((CR < LF) or (LF <= 0)) then
W := CR else
if LF > 0 then
W := LF else
W := Length(Message) + 1;
if W > 0 then
begin
if W > 1 then
begin
S := Copy(Message, 1, W - 1);
Delete(FLines[FCursor.Y], FCursor.X, Length(FLines[FCursor.Y]) - FCursor.X);
Insert(S, FLines[FCursor.Y], FCursor.X);
Inc(FCursor.X, Length(S));
end;
Delete(Message, 1, W);
if W = CR then
{¯¥à¥¢®¤ ª®à¥âª¨ ¢ ­ ç «® áâப¨}
FCursor.X := 1 else
if W = LF then
begin
{¯¥à¥¢®¤ ª®à¥âª¨ ­  á«¥¤ãîéãî áâபã}
BottomRow := False;
Inc(FCursor.Y);
LinesCount := Length(FLines);
while FCursor.Y >= FMaxLines do Dec(FCursor.Y, FMaxLines);
if FCursor.Y < LinesCount then FLines[FCursor.Y] := '';
while FCursor.Y >= LinesCount do
begin
SetLength(FLines, LinesCount + 1);
FLines[LinesCount] := '';
Inc(LinesCount);
end;
end;
end;
until Length(Message) <= 0;
 
Paint(BottomRow);
end;
 
procedure TKonsole.ProcessKeyboard(Key: Word);
begin
FKeyPressed := Key;
end;
 
function TKonsole.GetRect(): TKosRect;
var
ThreadInfo: TKosThreadInfo;
begin
kos_threadinfo(@ThreadInfo, FThreadSlot);
Result := ThreadInfo.WindowRect;
end;
 
function TKonsole.GetKeyPressed(): Word;
begin
Result := FKeyPressed;
FKeyPressed := 0;
end;
 
procedure TKonsole.Paint(BottomRow: Boolean);
var
Buffer: array[Byte] of Char;
Rect: TKosRect;
J: Longint;
Width, Height, Row: Longint;
CaptionHeight, BorderWidth, FontWidth, FontHeight: Longint;
begin
CaptionHeight := 16;
BorderWidth := 5;
FontWidth := 6;
FontHeight := 9;
 
kos_begindraw();
 
if not BottomRow then
begin
{®âà¨á®¢ª  ®ª­ }
kos_definewindow(60, 60, 400, 400, $63000000);
{¢ë¢®¤ § £®«®¢ª }
Move(FCaption[1], Buffer, Length(FCaption));
Buffer[Length(FCaption)] := #0;
kos_setcaption(Buffer);
end;
 
{¯®¤£®â®¢ª  ª ¢ë¢®¤ã áâப}
Rect := GetRect();
Dec(Rect.Width, BorderWidth * 2);
Dec(Rect.Height, CaptionHeight + BorderWidth * 2);
Width := Rect.Width div FontWidth;
Height := Rect.Height - FontHeight;
Row := FCursor.Y;
 
while Height > 0 do
begin
{¢ë¢®¤ ®¤­®© áâப¨}
J := Length(FLines[Row]);
if J > Width then J := Width;
kos_drawtext(0, Height, Copy(FLines[Row], 1, J), $00DD00, $FF000000);
{§ «¨¢ª  ®á⠢襣®áï ¯à®áâà ­á⢠ ¢ áâப¥}
J := J * FontWidth;
kos_drawrect(J, Height, Rect.Width - J + 1, FontHeight, $000000);
{¯®¤£®â®¢ª  ª ¢ë¢®¤ã á«¥¤ãî饩 áâப¨}
Dec(Height, FontHeight);
Dec(Row);
if BottomRow or ((Row < 0) and (Length(FLines) < FMaxLines)) then Break;
while Row < 0 do Inc(Row, FMaxLines);
end;
if FCursor.X <= Width then
{®âà¨á®¢ª  ªãàá®à }
kos_drawrect((FCursor.X - 1) * FontWidth, Rect.Height - 2, FontWidth, 2, $FFFFFF);
if not BottomRow then
{§ «¨¢ª  ®á⠢襩áï ç á⨠®ª­ }
kos_drawrect(0, 0, Rect.Width + 1, Height + FontHeight, $000000);
 
kos_enddraw();
end;
 
procedure TKonsole.Write(Message: ShortString);
var
I: Integer;
begin
{XXX: ¢®§¬®¦­  á¨âã æ¨ï ¯à¨ ª®â®à®© á®®¡é¥­¨¥ ­¥ ¡ã¤¥â ®â¯à ¢«¥­®}
if FOpened then
begin
I := 20;
while (kos_sendmsg(FThreadID, @Message[1], Length(Message)) = 2) and (I > 0) do
begin
Dec(I);
ThreadSwitch;
end;
end;
end;
/programs/develop/fp/rtl/kosh.inc
0,0 → 1,208
{}
 
type
TKosPoint = packed record
X: Longint;
Y: Longint;
end;
 
TKosRect = packed record
case Integer of
0: (Left, Top, Width, Height: Longint);
1: (TopLeft, HeightWidth: TKosPoint);
end;
 
{ User interface }
procedure kos_definewindow(x, y, w, h: Word; style: DWord = $23FFFFFF; header: DWord = $008899FF; clframe: DWord = $008899FF);
procedure kos_movewindow(x, y, w, h: DWord);
function kos_getkey(): DWord;
function kos_getevent(wait: Boolean = True): DWord;
function kos_waitevent(timeout: DWord): DWord;
function kos_getbutton(): DWord;
function kos_getmousepos(): TKosPoint;
function kos_getmousewinpos(): TKosPoint;
function kos_getmousebuttons(): DWord;
procedure kos_maskevents(mask: DWord);
procedure kos_setcaption(caption: PChar);
 
{ Graphics }
procedure kos_begindraw();
procedure kos_enddraw();
procedure kos_putpixel(x, y: Word; color: DWord = $000000);
procedure kos_drawtext(x, y: Word; text: String; flags: DWord = $000000; bgcolor: DWord = $00FFFFFF);
procedure kos_drawrect(x, y, w, h: Word; color: DWord = $000000);
procedure kos_drawline(x1, y1, x2, y2: Word; color: DWord = $000000);
procedure kos_drawimage(x, y, w, h, depth: DWord; image: Pointer; palette: Pointer = nil; xoffset: DWord = 0);
procedure kos_drawimage24(x, y, w, h: DWord; image: Pointer);
 
{ Work with system }
 
{ Work with system - System services }
function kos_killthread(tid: TThreadID): Boolean;
procedure kos_setactivewindow(slot: TThreadSlot);
function kos_getthreadslot(tid: TThreadID): TThreadSlot;
 
{ Work with system - Set system parameters }
procedure kos_enablepci();
 
{ Work with system - Internal system services }
procedure kos_switchthread();
function kos_initheap(): DWord;
function kos_alloc(size: DWord): Pointer;
function kos_free(ptr: Pointer): Boolean;
function kos_loaddriver(name: PChar): THandle;
 
{ Processes and threads }
type
PKosThreadInfo = ^TKosThreadInfo;
TKosThreadInfo = packed record
Speed: DWord;
WindowID: Word;
ThreadSlot: Word;
Reserved1: Word;
AppName: array[0..10] of Char;
Reserved2: Byte;
ProcessBase: Pointer;
MemoryUsage: DWord;
ThreadID: TThreadID;
WindowRect: TKosRect;
Unknown0: array[1..1066] of Byte;
end;
 
{ãä¥à IPC}
PKosIPC = ^TKosIPC;
TKosIPC = packed record
Lock: LongBool;
Size: DWord;
{á®®¡é¥­¨¥ #1...}
{á®®¡é¥­¨¥ #2...}
{...}
end;
 
{‘®®¡é¥­¨¥ IPC}
PKosMessage = ^TKosMessage;
TKosMessage = packed record
SenderID: TThreadID;
Size: DWord;
{⥫® á®®¡é¥­¨ï...}
end;
 
function kos_threadinfo(info: PKosThreadInfo; slot: TThreadSlot = -1): DWord;
function kos_newthread(entry, stack: Pointer): TThreadID;
procedure kos_initipc(ipc: PKosIPC; size: DWord);
function kos_sendmsg(tid: TThreadID; msg: Pointer; size: DWord): DWord;
function kos_resizemem(size: DWord): Boolean;
 
{ File system }
{ File system - Work with the current folder }
 
procedure kos_setdir(path: PChar);
function kos_getdir(path: PChar; size: DWord): DWord;
 
{ File system - Work with file system with long names support }
 
const
kfReadOnly = $01;
kfHidden = $02;
kfSystem = $04;
kfLabel = $08;
kfFolder = $10;
kfNotArchive = $20;
 
type
PKosFile = ^TKosFile;
TKosFile = packed record
SubFunc: DWord;
Position, PositionReserved: DWord;
Size: DWord;
Data: Pointer;
Name: array[0..0] of Char; {...ASCIIZ}
end;
 
PKosBDFE = ^TKosBDFE;
TKosBDFE = packed record
Attributes: DWord;
NameType: Byte; {bit0 - 0:ascii, 1:unicode}
Reserved: array[0..2] of Byte;
CTime: DWord; {ss,mm,hh,00}
CDate: DWord; {dd,mm,yyyy}
ATime: DWord;
ADate: DWord;
MTime: DWord;
MDate: DWord;
Size: QWord;
Name: array[0..519] of Char;
end;
 
function kos_readfile(kosfile: PKosFile; var readed: Longint): DWord;
function kos_rewritefile(kosfile: PKosFile; var writed: Longint): DWord;
function kos_writefile(kosfile: PKosFile; var writed: Longint): DWord;
function kos_fileinfo(kosfile: PKosFile): DWord;
 
{ Work with hardware }
function kos_readport(index: DWord): DWord;
procedure kos_writeport(index, value: DWord);
function kos_reserveport(port: DWord): Boolean;
 
{ Work with hardware - Low-level access to PCI}
function kos_lastpcibus(): Byte;
function kos_readpcib(bus, dev, func, reg: Byte): Byte;
function kos_readpciw(bus, dev, func, reg: Byte): Word;
function kos_readpcid(bus, dev, func, reg: Byte): DWord;
 
{ Other }
procedure kos_delay(ms: DWord); {1/100 s}
 
{ my }
type
TKosSign = array[0..7] of Byte;
PKosHeader = ^TKosHeader;
TKosHeader = packed record
sign : TKOSSign;
version: DWord;
start : DWord;
size : DWord;
memory : DWord;
stack : DWord;
args : PChar;
path : PChar;
end;
 
{var
KonsoleIPCBuffer: array[0..4096] of Byte;}
 
type
PKonsole = ^TKonsole;
TKonsole = object
private
FCaption: String;
FLines: array of String;
FCursor: TKosPoint;
FMaxLines: Word;
FThreadID: TThreadID;
FThreadSlot: TThreadSlot;
FIPCBuffer: PKosIPC;
FIPCBufferSize: DWord;
FTerminate: Boolean;
FOpened: Boolean;
FKeyPressed: Word;
function ReceiveMessage(var Message: ShortString): Boolean;
procedure ProcessMessage(Message: ShortString);
procedure ProcessKeyboard(Key: Word);
function GetRect(): TKosRect;
function GetKeyPressed(): Word;
procedure Paint(BottomRow: Boolean = False);
public
constructor Init(ACaption: String = '');
destructor Done();
procedure Write(Message: ShortString);
property KeyPressed: Word read GetKeyPressed;
property Opened: Boolean read FOpened;
property ThreadID: TThreadID read FThreadID; {JustForFun, must be hidden, do not use}
property ThreadSlot: TThreadSlot read FThreadSlot; {JustForFun, must be hidden, do not use}
end;
 
IStreamIO = interface
function Read(Size: DWord = 0): AnsiString;
procedure Write(Str: AnsiString; Error: Boolean = False);
end;
/programs/develop/fp/rtl/sysdir.inc
0,0 → 1,35
{TODO}
 
procedure mkdir(const s: String); [IOCHECK];
begin
InOutRes := 211;
end;
 
procedure rmdir(const s: String); [IOCHECK];
begin
InOutRes := 211;
end;
 
procedure chdir(const s: String); [IOCHECK];
var
Path: array[Byte] of Char;
begin
Path := s;
kos_setdir(Path);
InOutRes := 0;
end;
 
procedure getdir(DriveNr: Byte; var Dir: ShortString);
{ DriveNr ­¥ ¨á¯®«ì§ã¥âáï, ­® ¢á¥£¤  ¤®«¦¥­ ¡ëâì à ¢¥­ 0 }
var
Path: array[Byte] of Char;
Size: Longword;
begin
if DriveNr <> 0 then
InOutRes := 15 { Invalid drive number (­¥¯à ¢¨«ì­ë© ­®¬¥à ãáâனá⢠) } else
begin
Size := kos_getdir(@Path, SizeOf(Path));
Dir := StrPas(Path);
InOutRes := 0;
end;
end;
/programs/develop/fp/rtl/sysfile.inc
0,0 → 1,145
{cp866}
 
function DecodeErrNo(ErrNo: DWord): Word;
{0 = ãᯥ譮
1 = ­¥ ®¯à¥¤¥«¥­  ¡ §  ¨/¨«¨ à §¤¥« ¦ñá⪮£® ¤¨áª  (¯®¤äã­ªæ¨ï¬¨ 7, 8 ä㭪樨 21)
2 = äã­ªæ¨ï ­¥ ¯®¤¤¥à¦¨¢ ¥âáï ¤«ï ¤ ­­®© ä ©«®¢®© á¨á⥬ë
3 = ­¥¨§¢¥áâ­ ï ä ©«®¢ ï á¨á⥬ 
4 = § à¥§¥à¢¨à®¢ ­®, ­¨ª®£¤  ­¥ ¢®§¢à é ¥âáï ¢ ⥪ã饩 ॠ«¨§ æ¨¨
5 = ä ©« ­¥ ­ ©¤¥­
6 = ä ©« § ª®­ç¨«áï
7 = 㪠§ â¥«ì ¢­¥ ¯ ¬ï⨠¯à¨«®¦¥­¨ï
8 = ¤¨áª § ¯®«­¥­
9 = â ¡«¨æ  FAT à §àã襭 
10 = ¤®áâ㯠§ ¯à¥éñ­
11 = ®è¨¡ª  ãáâனá⢠}
begin
case ErrNo of
0: Result := 0;
1: Result := 152;
2: Result := 153;
3: Result := 151;
4: Result := 1;
5: Result := 2;
6: Result := 0;
8: Result := 101;
else
Result := 153; { Unknown command (­¥¨§¢¥áâ­ ï ª®¬ ­¤ ) }
end;
end;
 
function do_isdevice(handle:thandle): Boolean;
begin
InOutRes := 211;
Result := False;
end;
 
procedure do_close(handle: THandle);
begin
FreeMem(PKosFile(handle));
InOutRes := 0;
end;
 
procedure do_erase(p : pchar);
begin
InOutRes := 211;
end;
 
procedure do_rename(p1,p2 : pchar);
begin
InOutRes := 211;
end;
 
function do_write(handle: THandle; addr: Pointer; len: Longint): Longint;
begin
PKosFile(handle)^.Size := len;
PKosFile(handle)^.Data := addr;
InOutRes := DecodeErrNo(kos_writefile(PKosFile(handle), Result));
Inc(PKosFile(handle)^.Position, Result);
end;
 
function do_read(handle: THandle; addr: Pointer; len: Longint): Longint;
begin
PKosFile(handle)^.Size := len;
PKosFile(handle)^.Data := addr;
InOutRes := DecodeErrNo(kos_readfile(PKosFile(handle), Result));
Inc(PKosFile(handle)^.Position, Result);
end;
 
function do_filepos(handle: THandle): Int64;
begin
Result := PKosFile(handle)^.Position;
end;
 
procedure do_seek(handle: THandle; pos: Int64);
begin
PKosFile(handle)^.Position := pos;
end;
 
function do_seekend(handle: THandle): Int64;
begin
InOutRes := 211;
Result := 0;
end;
 
function do_filesize(handle: THandle): Int64;
var
BDFE: TKosBDFE;
begin
PKosFile(handle)^.Data := @BDFE;
InOutRes := DecodeErrNo(kos_fileinfo(PKosFile(handle)));
Result := BDFE.Size;
end;
 
procedure do_truncate(handle: THandle; pos: Int64);
begin
InOutRes := 211;
end;
 
procedure do_open(var f; p: PChar; flags: Longint);
var
KosFile: PKosFile;
FilePath: PChar;
FilePathLen: Longint;
RecSize: Longint;
CurrDir: array[0..2048] of Char;
CurrDirLen: Longint;
begin
case flags and 3 of
0: FileRec(f).Mode := fmInput;
1: FileRec(f).Mode := fmOutput;
2: FileRec(f).Mode := fmInOut;
end;
 
{”®à¬¨à®¢ ­¨¥ ¨¬¥­¨  ¡á®«îâ­®£® ¯ãâ¨}
FilePathLen := Length(p);
if p^ <> DirectorySeparator then
begin
{XXX: à §¬¥à ¡ãä¥à  CurrDir ¬®¦¥â ®ª § âìáï ­¥¤®áâ â®ç­ë¬}
CurrDirLen := kos_getdir(@CurrDir, SizeOf(CurrDir) - FilePathLen - 1) - 1;
FilePath := @CurrDir;
 
if FilePath[CurrDirLen - 1] <> DirectorySeparator then
begin
FilePath[CurrDirLen] := DirectorySeparator;
Inc(CurrDirLen);
end;
Move(p^, FilePath[CurrDirLen], FilePathLen + 1);
Inc(FilePathLen, CurrDirLen);
end else
FilePath := p;
 
{‘®§¤ ­¨¥ áâàãªâãàë TKosFile}
RecSize := SizeOf(TKosFile) + FilePathLen;
KosFile := GetMem(RecSize);
FillChar(KosFile^, RecSize, 0);
Move(FilePath^, KosFile^.Name, FilePathLen);
FileRec(f).Handle := DWord(KosFile);
 
if flags and $1000 <> 0 then
begin
{ ᮧ¤ âì ä ©« }
InOutRes := DecodeErrNo(kos_rewritefile(KosFile, RecSize));
end else
InOutRes := 0;
end;
/programs/develop/fp/rtl/sysheap.inc
0,0 → 1,56
{TODO}
 
function SysOSAlloc(Size: PtrInt): Pointer;
begin
Result := kos_alloc(Size);
end;
 
{$define HAS_SYSOSFREE}
procedure SysOSFree(P: Pointer; Size: PtrInt);
begin
kos_free(P);
end;
 
(*
{DEBUG version}
 
var
SysMemoryBlocks: array[Byte] of record
Used: Boolean;
Address: Pointer;
Size: Longint;
end;
 
function SysOSAlloc(Size: PtrInt): Pointer;
var
I: Longint;
begin
Result := kos_alloc(Size);
 
for I := 0 to High(SysMemoryBlocks) do
if not SysMemoryBlocks[I].Used then
begin
SysMemoryBlocks[I].Used := True;
SysMemoryBlocks[I].Address := Result;
SysMemoryBlocks[I].Size := Size;
Break;
end;
end;
 
{$define HAS_SYSOSFREE}
procedure SysOSFree(P: Pointer; Size: PtrInt);
var
B: Byte;
I: Longint;
begin
B := 0;
for I := 0 to High(SysMemoryBlocks) do
if SysMemoryBlocks[I].Address = P then
begin
SysMemoryBlocks[I].Used := False;
if SysMemoryBlocks[I].Size <> Size then B := 1 div B;
Break;
end;
 
kos_free(P);
end;*)
/programs/develop/fp/rtl/sysinitpas.pp
0,0 → 1,52
{}
 
unit sysinitpas;
 
interface
 
implementation
 
var
SysInstance: Longint; external name '_FPC_SysInstance';
 
procedure PascalMain; stdcall; external name 'PASCALMAIN';
procedure SystemExit; external name 'SystemExit';
 
procedure EntryConsole; [public, alias:'_mainCRTStartup'];
var
ESP_: Pointer;
begin
asm movl %esp, ESP_; end;
StackTop := ESP_ + 8;
IsConsole := True;
PascalMain;
SystemExit;
end;
 
procedure EntryWindow; [public, alias:'_WinMainCRTStartup'];
var
ESP_: Pointer;
begin
asm movl %esp, ESP_; end;
StackTop := ESP_ + 8;
IsConsole := False;
PascalMain;
SystemExit;
end;
 
procedure _FPC_DLLMainCRTStartup(_hinstance, _dllreason, _dllparam: Longint); stdcall; public name '_DLLMainCRTStartup';
begin
{TODO}
IsConsole := True;
SysInstance := _hinstance;
end;
 
 
procedure _FPC_DLLWinMainCRTStartup(_hinstance, _dllreason, _dllparam: Longint); stdcall; public name '_DLLWinMainCRTStartup';
begin
{TODO}
IsConsole := False;
SysInstance := _hinstance;
end;
 
end.
/programs/develop/fp/rtl/sysos.inc
0,0 → 1,11
{}
 
const
{ flags for CreateFile }
GENERIC_READ=$80000000;
GENERIC_WRITE=$40000000;
CREATE_NEW = 1;
CREATE_ALWAYS = 2;
OPEN_EXISTING = 3;
OPEN_ALWAYS = 4;
TRUNCATE_EXISTING = 5;
/programs/develop/fp/rtl/sysosh.inc
0,0 → 1,15
{}
 
type
THandle = DWord;
TThreadID = Longint;
TThreadSlot = Longint;
UINT = Cardinal;
BOOL = Longbool;
ULONG_PTR = DWord;
SIZE_T = ULONG_PTR;
 
PRTLCriticalSection = ^TRTLCriticalSection;
TRTLCriticalSection = packed record
OwningThread: TThreadID;
end;
/programs/develop/fp/rtl/system.pp
0,0 → 1,201
{cp866}
unit System;
 
{$i _defines.inc}
{$define HAS_CMDLINE}
 
interface
 
{$i systemh.inc}
{$i kos_def.inc}
{$i kosh.inc}
 
const
LineEnding = #13#10;
LFNSupport = True;
DirectorySeparator = '/';
DriveSeparator = '/';
PathSeparator = ';';
MaxExitCode = 65535;
MaxPathLen = 512;
 
UnusedHandle : THandle = -1;
StdInputHandle : THandle = 0;
StdOutputHandle: THandle = 0;
StdErrorHandle : THandle = 0;
FileNameCaseSensitive: Boolean = True;
CtrlZMarksEOF: Boolean = True;
sLineBreak = LineEnding;
DefaultTextLineBreakStyle: TTextLineBreakStyle = tlbsCRLF;
 
var
Argc: Longint = 0;
Argv: PPChar = nil;
 
Konsole: TKonsole;
 
 
implementation
 
var
SysInstance: Longint; public name '_FPC_SysInstance';
 
{$i system.inc}
 
 
procedure SetupCmdLine;
var
Ptrs: array of PChar;
Args: PChar;
InQuotes: Boolean;
I, L: Longint;
begin
Argc := 1;
Args := PKosHeader(0)^.args;
if Assigned(Args) then
begin
while Args^ <> #0 do
begin
{à®¯ãáâ¨âì «¨¤¨àãî騥 ¯à®¡¥«ë}
while Args^ in [#1..#32] do Inc(Args);
if Args^ = #0 then Break;
 
{‡ ¯®¬­¨âì 㪠§ â¥«ì ­  ¯ à ¬¥âà}
SetLength(Ptrs, Argc);
Ptrs[Argc - 1] := Args;
Inc(Argc);
 
{à®¯ãáâ¨âì ⥪ã騩 ¯ à ¬¥âà}
InQuotes := False;
while (Args^ <> #0) and (not (Args^ in [#1..#32]) or InQuotes) do
begin
if Args^ = '"' then InQuotes := not InQuotes;
Inc(Args);
end;
 
{“áâ ­®¢¨âì ®ª®­ç ­¨¥ ¯ à ¬¥âà }
if Args^ in [#1..#32] then
begin
Args^ := #0;
Inc(Args);
end;
end;
end;
Argv := GetMem(Argc * SizeOf(PChar)); {XXX: ¯ ¬ïâì ­¥ ®á¢®¡®¦¤ ¥âáï}
Argv[0] := PKosHeader(0)^.path;
for I := 1 to Argc - 1 do
begin
Argv[I] := Ptrs[I - 1];
{ˆáª«îç¨âì ª ¢ë窨 ¨§ áâப¨}
Args := Argv[I];
L := 0;
while Args^ <> #0 do begin Inc(Args); Inc(L); end;
Args := Argv[I];
while Args^ <> #0 do
begin
if Args^ = '"' then
begin
Move(PChar(Args + 1)^, Args^, L);
Dec(L);
end;
Inc(Args);
Dec(L);
end;
end;
end;
 
function ParamCount: Longint;
begin
Result := Argc - 1;
end;
 
function ParamStr(L: Longint): String;
begin
if (L >= 0) and (L < Argc) then
Result := StrPas(Argv[L]) else
Result := '';
end;
 
procedure Randomize;
begin
randseed := 0; {GetTickCount()}
end;
 
const
ProcessID: SizeUInt = 0;
 
function GetProcessID: SizeUInt;
begin
GetProcessID := ProcessID;
end;
 
function CheckInitialStkLen(stklen: SizeUInt): SizeUInt;
begin
{TODO}
Result := stklen;
end;
 
{$i kos_stdio.inc}
 
procedure SysInitStdIO;
begin
if IsConsole then
begin
AssignStdin(Input);
AssignStdout(Output);
AssignStdout(ErrOutput);
AssignStdout(StdOut);
AssignStdout(StdErr);
end;
end;
 
procedure System_Exit; [public, alias: 'SystemExit'];
var
event, count: DWord;
begin
if IsConsole then
begin
if ExitCode <> 0 then
begin
{XXX: ®¡ï§ â¥«ì­®¥ ãá«®¢¨¥ ­  ®¤­®¯®â®ç­ë© Konsole}
Write(StdErr, '[Error #', ExitCode,', press any key]');
{®¦¨¤ âì ­ ¦ â¨ï ª« ¢¨è¨}
Konsole.KeyPressed;
while Konsole.KeyPressed = 0 do kos_delay(2);
{TODO: ¨á¯à ¢¨âì ª®áïª ¯à¨ ¯¥à¥à¨á®¢ª¥ Konsole}
{íâ® ­¥¢®§¬®¦­®, â ª ª ª ªãç  ®á¢®¡®¦¤ ¥âáï ¥é¥ ¤® ¢ë§®¢  í⮩ ¯à®æ¥¤ãàë}
{¬®¦­® ­ ¯¨á âì ᢮© ¤¨á¯¥âç¥à ¯ ¬ïâ¨, ­® íâ® á«®¦­®}
{  ¥á«¨ ¢ Konsole ¨á¯®«ì§®¢ âì ¢ë¤¥«¥­¨¥ ¯ ¬ï⨠­ ¯àï¬ãî ç¥à¥§ KosAPI?!}
end;
Close(StdErr);
Close(StdOut);
Close(ErrOutput);
Close(Input);
Close(Output);
Konsole.Done();
end;
asm
movl $-1, %eax
int $0x40
end;
end;
 
{$i kos.inc}
 
begin
SysResetFPU;
StackLength := CheckInitialStkLen(InitialStkLen);
StackBottom := Pointer(StackTop - StackLength);
InitHeap;
kos_initheap();
SysInitExceptions;
FPC_CpuCodeInit();
InOutRes := 0;
InitSystemThreads;
Konsole.Init();
SysInitStdIO;
SetupCmdLine;
InitVariantManager;
{InitWideStringManager;}
DispCallByIDProc := @DoDispCallByIDError;
end.
/programs/develop/fp/rtl/systhrd.inc
0,0 → 1,386
{}
 
{XXX: Thread vars & TLS}
 
const
ThreadVarBlockSize: DWord = 0;
TLSGrowFor = 4096;
 
type
PTLSIndex = ^TTLSIndex;
TTLSIndex = record
CS: TRTLCriticalSection;
Slots: array[0..TLSGrowFor - 1] of record
TID: DWord;
Value: Pointer;
end;
end;
 
var
TLSKey: PTLSIndex;
 
 
function TLSAlloc(): PTLSIndex;
var
I: DWord;
begin
{New(Result);}
Result := kos_alloc(SizeOf(TTLSIndex));
InitCriticalSection(Result^.CS);
{SetLength(Result^.Slots, TLSGrowFor);}
for I := 0 to TLSGrowFor - 1 do
Result^.Slots[I].TID := 0;
end;
 
 
function TLSFree(TLSIndex: PTLSIndex): Boolean;
begin
DoneCriticalSection(TLSIndex^.CS);
{SetLength(TLSIndex^.Slots, 0);
Dispose(TLSIndex);}
kos_free(TLSIndex);
Result := True;
end;
 
 
procedure TLSSetValue(TLSIndex: PTLSIndex; Value: Pointer);
var
TID, I, Count, Slot: DWord;
begin
TID := GetCurrentThreadID();
EnterCriticalSection(TLSIndex^.CS);
 
Count := Length(TLSIndex^.Slots);
Slot := Count;
 
for I := 0 to Count - 1 do
if TLSIndex^.Slots[I].TID = TID then
begin
Slot := I;
Break;
end else
if TLSIndex^.Slots[I].TID = 0 then
Slot := I;
 
if Slot >= Count then
begin
Halt(123);
{SetLength(TLSIndex^.Slots, Count + TLSGrowFor);
FillChar(TLSIndex^.Slots[Count], TLSGrowFor * SizeOf(TLSIndex^.Slots[0]), #0);
Slot := Count;}
end;
 
TLSIndex^.Slots[Slot].TID := TID;
TLSIndex^.Slots[Slot].Value := Value;
 
LeaveCriticalSection(TLSIndex^.CS);
end;
 
 
function TLSGetValue(TLSIndex: PTLSIndex): Pointer;
var
TID, I, Count: DWord;
begin
Result := nil;
TID := GetCurrentThreadID();
 
EnterCriticalSection(TLSIndex^.CS);
 
Count := Length(TLSIndex^.Slots);
 
for I := 0 to Count - 1 do
if TLSIndex^.Slots[I].TID = TID then
begin
Result := TLSIndex^.Slots[I].Value;
break;
end;
 
LeaveCriticalSection(TLSIndex^.CS);
end;
 
 
procedure SysInitThreadVar(var Offset: DWord; Size: DWord);
begin
Offset := ThreadVarBlockSize;
Inc(ThreadVarBlockSize, Size);
end;
 
procedure SysAllocateThreadVars;
var
DataIndex: Pointer;
begin
{DataIndex := GetMem(ThreadVarBlockSize);}
DataIndex := kos_alloc(ThreadVarBlockSize);
FillChar(DataIndex^, ThreadVarBlockSize, #0);
TLSSetValue(TLSKey, DataIndex);
end;
 
function SysRelocateThreadVar(Offset: DWord): Pointer;
var
DataIndex: Pointer;
begin
DataIndex := TLSGetValue(TLSKey);
if DataIndex = nil then
begin
SysAllocateThreadVars;
DataIndex := TLSGetValue(TLSKey);
end;
Result := DataIndex + Offset;
end;
 
procedure SysReleaseThreadVars;
begin
{FreeMem(TLSGetValue(TLSKey));}
kos_free(TLSGetValue(TLSKey));
end;
 
 
 
{XXX: Thread}
type
PThreadInfo = ^TThreadInfo;
TThreadInfo = record
Func: TThreadFunc;
Arg: Pointer;
StackSize: PtrUInt;
Stack: Pointer;
end;
 
procedure DoneThread;
begin
SysReleaseThreadVars;
end;
 
procedure ThreadMain(ThreadInfo: PThreadInfo);
var
Result: PtrInt;
begin
SysAllocateThreadVars;
with ThreadInfo^ do
begin
InitThread(StackSize);
try
Result := Func(Arg);
except
{TODO: Ž¡à ¡®â âì ®è¨¡ª¨}
WriteLn(StdErr, 'Exception in thread');
end;
FreeMem(Stack);
end;
asm
movl $-1, %eax
int $0x40
end;
end;
 
function SysBeginThread(sa: Pointer; StackSize: PtrUInt; ThreadFunction: TThreadFunc; Arg: Pointer; CreationFlags: DWord; var ThreadID: TThreadID): TThreadID;
{Stack, esp, ThreadInfo}
 
procedure EntryThreadMain; assembler;
asm
movl %esp, %eax
jmp ThreadMain
end;
 
var
Stack: Pointer;
ThreadInfo: PThreadInfo;
begin
if not IsMultiThread then
begin
TLSKey := TLSAlloc();
InitThreadVars(@SysRelocateThreadVar); {XXX: must be @SysRelocateThreadvar}
IsMultiThread := True;
end;
 
StackSize := (StackSize + 3) div 4;
Stack := GetMem(StackSize + SizeOf(TThreadInfo));
ThreadInfo := PThreadInfo(PByte(Stack) + StackSize);
ThreadInfo^.Func := ThreadFunction;
ThreadInfo^.Arg := Arg;
ThreadInfo^.StackSize := StackSize;
ThreadInfo^.Stack := Stack;
ThreadID := kos_newthread(@EntryThreadMain, ThreadInfo);
Result := ThreadID;
end;
 
 
procedure SysEndThread(ExitCode: DWord);
begin
WriteLn('..SysEndThread');
{TODO: SysEndThread}
SysReleaseThreadVars;
end;
 
 
function SysSuspendThread(ThreadHandle: TThreadID): DWord;
begin
{TODO: SysSuspendThread}
Result := -1;
end;
 
 
function SysResumeThread(ThreadHandle: TThreadID): DWord;
begin
{TODO: SysResumeThread}
Result := -1;
end;
 
 
function SysKillThread(ThreadHandle: TThreadID): DWord;
begin
if kos_killthread(ThreadHandle) then
Result := 0 else
Result := -1;
end;
 
 
procedure SysThreadSwitch;
begin
{$ifdef EMULATOR}
kos_delay(0);{$else}
kos_switchthread();{$endif}
end;
 
 
function SysGetCurrentThreadID: TThreadID;
var
ThreadInfo: TKosThreadInfo;
begin
kos_threadinfo(@ThreadInfo);
Result := ThreadInfo.ThreadID;
end;
 
 
{XXX: CriticalSection}
procedure SysInitCriticalSection(var CS);
begin
PRTLCriticalSection(CS)^.OwningThread := -1;
end;
 
procedure SysDoneCriticalSection(var CS);
begin
PRTLCriticalSection(CS)^.OwningThread := -1;
end;
 
procedure SysEnterCriticalSection(var CS);
var
ThisThread: TThreadID;
begin
ThisThread := GetCurrentThreadId();
if PRTLCriticalSection(CS)^.OwningThread <> ThisThread then
while PRTLCriticalSection(CS)^.OwningThread <> -1 do;
PRTLCriticalSection(CS)^.OwningThread := ThisThread;
end;
 
procedure SysLeaveCriticalSection(var CS);
begin
if PRTLCriticalSection(CS)^.OwningThread = GetCurrentThreadId() then
PRTLCriticalSection(CS)^.OwningThread := -1;
end;
 
 
{TODO: RTLEvent}
function SysRTLEventCreate: PRTLEvent;
begin
Result := nil;
end;
 
procedure SysRTLEventDestroy(State: PRTLEvent);
begin
end;
 
 
 
{$ifndef HAS_MT_MEMORYMANAGER}
var
HeapMutex: TRTLCriticalSection;
 
procedure KosHeapMutexInit;
begin
InitCriticalSection(HeapMutex);
end;
 
procedure KosHeapMutexDone;
begin
DoneCriticalSection(HeapMutex);
end;
 
procedure KosHeapMutexLock;
begin
EnterCriticalSection(HeapMutex);
end;
 
procedure KosHeapMutexUnlock;
begin
LeaveCriticalSection(HeapMutex);
end;
 
const
KosMemoryMutexManager: TMemoryMutexManager = (
MutexInit: @KosHeapMutexInit;
MutexDone: @KosHeapMutexDone;
MutexLock: @KosHeapMutexLock;
MutexUnlock: @KosHeapMutexUnlock);
 
procedure InitHeapMutexes;
begin
SetMemoryMutexManager(KosMemoryMutexManager);
end;
{$endif HAS_MT_MEMORYMANAGER}
 
 
var
KosThreadManager: TThreadManager;
 
procedure InitSystemThreads;
begin
ThreadID := TThreadID(1);
with KosThreadManager do
begin
InitManager := nil;
DoneManager := nil;
 
BeginThread := @SysBeginThread;
EndThread := @SysEndThread;
SuspendThread := @SysSuspendThread;
ResumeThread := @SysResumeThread;
KillThread := @SysKillThread;
ThreadSwitch := @SysThreadSwitch;
WaitForThreadTerminate := nil; //@NoWaitForThreadTerminate;
ThreadSetPriority := nil; //@NoThreadSetPriority;
ThreadGetPriority := nil; //@NoThreadGetPriority;
 
GetCurrentThreadID := @SysGetCurrentThreadID;
InitCriticalSection := @SysInitCriticalSection;
DoneCriticalSection := @SysDoneCriticalSection;
EnterCriticalSection := @SysEnterCriticalSection;
LeaveCriticalSection := @SysLeaveCriticalSection;
InitThreadVar := @SysInitThreadVar;
RelocateThreadVar := @SysRelocateThreadVar;
AllocateThreadVars := @SysAllocateThreadVars;
ReleaseThreadVars := @SysReleaseThreadVars;
 
BasicEventCreate := @NoBasicEventCreate;
BasicEventDestroy := @NoBasicEventDestroy;
BasicEventResetEvent := @NoBasicEventResetEvent;
BasicEventSetEvent := @NoBasicEventSetEvent;
BasicEventWaitFor := @NoBasicEventWaitFor;
RTLEventCreate := @SysRTLEventCreate;
RTLEventDestroy := @SysRTLEventDestroy;
RTLEventSetEvent := @NoRTLEventSetEvent;
RTLEventWaitFor := @NoRTLEventWaitFor;
RTLEventSync := @NoRTLEventSync;
RTLEventWaitForTimeout := @NoRTLEventWaitForTimeout;
 
SemaphoreInit := @NoSemaphoreInit;
SemaphoreDestroy := @NoSemaphoreDestroy;
SemaphoreWait := @NoSemaphoreWait;
SemaphorePost := @NoSemaphorePost;
end;
SetThreadManager(KosThreadManager);
{$ifndef HAS_MT_MEMORYMANAGER}
InitHeapMutexes;
{$endif HAS_MT_MEMORYMANAGER}
ThreadID := GetCurrentThreadID;
end;
/programs/develop/fp/rtl/sysutils.pp
0,0 → 1,448
unit sysutils;
 
{$i _defines.inc}
 
interface
 
{$mode objfpc}
{ force ansistrings }
{$h+}
 
{$DEFINE HAS_SLEEP}
{-$DEFINE HAS_OSERROR}
{-$DEFINE HAS_OSCONFIG}
{-$DEFINE HAS_CREATEGUID}
 
 
{ Include platform independent interface part }
{$i sysutilh.inc}
 
implementation
 
 
uses
SysConst;
 
 
{-$define HASCREATEGUID}
{-$define HASEXPANDUNCFILENAME}
{-$DEFINE FPC_NOGENERICANSIROUTINES}
{-$DEFINE FPC_FEXPAND_UNC} (* UNC paths are supported *)
{-$DEFINE FPC_FEXPAND_DRIVES} (* Full paths begin with drive specification *)
 
{ Include platform independent implementation part }
{$i sysutils.inc}
 
 
{****************************************************************************
File Functions
****************************************************************************}
 
const
FILEHANDLEPREFIX = $4000;
type
PFileRecord = ^TFileRecord;
TFileRecord = record
Filled: Boolean;
F: File;
end;
var
FileHandles: array of TFileRecord;
 
function FileRecordByHandle(Handle: THandle): PFileRecord;
begin
Dec(Handle, FILEHANDLEPREFIX);
Result := @FileHandles[Handle];
end;
 
function CreateFileRecord(): THandle;
var
I, C: Longword;
begin
Result := -1;
C := Length(FileHandles);
for I := 0 to C - 1 do
if not FileHandles[I].Filled then
begin
Result := I;
Break;
end;
if Result < 0 then
begin
SetLength(FileHandles, C + 1);
Result := C;
end;
FileHandles[Result].Filled := True;
FillChar(FileHandles[Result].F, SizeOf(FileRec), 0);
Inc(Result, FILEHANDLEPREFIX);
end;
 
procedure ReleaseFileRecord(Handle: THandle);
begin
FileRecordByHandle(Handle)^.Filled := False;
end;
 
function FileOpen(const FileName: String; Mode: Integer): THandle;
var
F: File;
begin
Filemode := Mode;
Assign(F, FileName);
Reset(F, 1);
if InOutRes = 0 then
begin
Result := CreateFileRecord();
FileRecordByHandle(Result)^.F := F;
end else
Result := feInvalidHandle;
end;
 
function FileCreate(const FileName: String): THandle;
var
F: File;
begin
Assign(F, FileName);
Rewrite(F, 1);
if InOutRes = 0 then
begin
Result := CreateFileRecord();
FileRecordByHandle(Result)^.F := F;
end else
Result := feInvalidHandle;
end;
 
function FileCreate(const FileName: String; Mode: Integer): THandle;
var
F: File;
begin
Filemode := Mode;
Assign(F, FileName);
Rewrite(F, 1);
if InOutRes = 0 then
begin
Result := CreateFileRecord();
FileRecordByHandle(Result)^.F := F;
end else
Result := feInvalidHandle;
end;
 
function FileRead(Handle: THandle; var Buffer; Count: Longint): Longint;
begin
BlockRead(FileRecordByHandle(Handle)^.F, Buffer, Count, Result);
end;
 
function FileWrite(Handle: THandle; const Buffer; Count: Longint): Longint;
begin
BlockWrite(FileRecordByHandle(Handle)^.F, Buffer, Count, Result);
end;
 
function FileSeek(Handle: THandle; FOffset, Origin: Longint): Longint;
begin
Result := FileSeek(Handle, Int64(FOffset), Origin);
end;
 
function FileSeek(Handle: THandle; FOffset: Int64; Origin: Longint): Int64;
var
Position: Int64;
begin
case Origin of
fsFromBeginning: Position := FOffset;
fsFromCurrent: Position := FilePos(FileRecordByHandle(Handle)^.F) + FOffset;
fsFromEnd: Position := FileSize(FileRecordByHandle(Handle)^.F) + FOffset;
end;
{TODO: ¯à®¢¥àª  ᮮ⢥âá⢨ï [0..filesize]}
Seek(FileRecordByHandle(Handle)^.F, Position);
Result := Position;
end;
 
procedure FileClose(Handle: THandle);
begin
Close(FileRecordByHandle(Handle)^.F);
ReleaseFileRecord(Handle);
end;
 
function FileTruncate(Handle: THandle; Size: Longint): Boolean;
begin
Result := False;
end;
 
function FileAge(const FileName: String): Longint;
begin
Result := 0;
end;
 
function FileExists(const FileName: String): Boolean;
var
F: File;
begin
Assign(F, FileName);
try
Reset(F);
FileSize(F);
Result := True;
except
Result := False;
end;
Close(F);
end;
 
function DirectoryExists(const Directory: String): Boolean;
begin
Result := False;
end;
 
function FindMatch(var f: TSearchRec): Longint;
begin
Result := feInvalidHandle;
end;
 
function FindFirst(const Path: String; Attr: Longint; out Rslt: TSearchRec): Longint;
begin
Result := feInvalidHandle;
end;
 
function FindNext(var Rslt: TSearchRec): Longint;
begin
Result := feInvalidHandle;
end;
 
procedure FindClose(var F: TSearchrec);
begin
end;
 
function FileGetDate(Handle: THandle): Longint;
begin
Result := feInvalidHandle;
end;
 
function FileSetDate(Handle: THandle; Age: Longint): Longint;
begin
Result := feInvalidHandle;
end;
 
function FileGetAttr(const FileName: String): Longint;
begin
Result := feInvalidHandle;
end;
 
function FileSetAttr(const Filename: String; Attr: longint): Longint;
begin
Result := feInvalidHandle;
end;
 
function DeleteFile(const FileName: String): Boolean;
begin
Result := False;
end;
 
function RenameFile(const OldName, NewName: String): Boolean;
begin
Result := False;
end;
 
 
{****************************************************************************
Disk Functions
****************************************************************************}
 
function DiskFree(drive: Byte): Int64;
begin
Result := 0;
end;
 
function DiskSize(drive: Byte): Int64;
begin
Result := 0;
end;
 
function GetCurrentDir: String;
begin
GetDir(0, Result);
end;
 
function SetCurrentDir(const NewDir: String): Boolean;
var
Path: String;
begin
ChDir(NewDir);
GetDir(0, Path);
Result := Path = NewDir;
end;
 
function CreateDir(const NewDir: String): Boolean;
begin
Result := False;
end;
 
function RemoveDir(const Dir: String): Boolean;
begin
Result := False;
end;
 
 
{****************************************************************************
Time Functions
****************************************************************************}
 
procedure GetLocalTime(var SystemTime: TSystemTime);
begin
end;
 
 
{****************************************************************************
Misc Functions
****************************************************************************}
 
procedure Beep;
begin
end;
 
 
{****************************************************************************
Locale Functions
****************************************************************************}
 
procedure GetFormatSettings;
var
HF: String;
begin
ShortMonthNames[1] := SShortMonthNameJan;
ShortMonthNames[2] := SShortMonthNameFeb;
ShortMonthNames[3] := SShortMonthNameMar;
ShortMonthNames[4] := SShortMonthNameApr;
ShortMonthNames[5] := SShortMonthNameMay;
ShortMonthNames[6] := SShortMonthNameJun;
ShortMonthNames[7] := SShortMonthNameJul;
ShortMonthNames[8] := SShortMonthNameAug;
ShortMonthNames[9] := SShortMonthNameSep;
ShortMonthNames[10] := SShortMonthNameOct;
ShortMonthNames[11] := SShortMonthNameNov;
ShortMonthNames[12] := SShortMonthNameDec;
 
LongMonthNames[1] := SLongMonthNameJan;
LongMonthNames[2] := SLongMonthNameFeb;
LongMonthNames[3] := SLongMonthNameMar;
LongMonthNames[4] := SLongMonthNameApr;
LongMonthNames[5] := SLongMonthNameMay;
LongMonthNames[6] := SLongMonthNameJun;
LongMonthNames[7] := SLongMonthNameJul;
LongMonthNames[8] := SLongMonthNameAug;
LongMonthNames[9] := SLongMonthNameSep;
LongMonthNames[10] := SLongMonthNameOct;
LongMonthNames[11] := SLongMonthNameNov;
LongMonthNames[12] := SLongMonthNameDec;
 
ShortDayNames[1] := SShortDayNameMon;
ShortDayNames[2] := SShortDayNameTue;
ShortDayNames[3] := SShortDayNameWed;
ShortDayNames[4] := SShortDayNameThu;
ShortDayNames[5] := SShortDayNameFri;
ShortDayNames[6] := SShortDayNameSat;
ShortDayNames[7] := SShortDayNameSun;
 
LongDayNames[1] := SLongDayNameMon;
LongDayNames[2] := SLongDayNameTue;
LongDayNames[3] := SLongDayNameWed;
LongDayNames[4] := SLongDayNameThu;
LongDayNames[5] := SLongDayNameFri;
LongDayNames[6] := SLongDayNameSat;
LongDayNames[7] := SShortDayNameSun;
 
DateSeparator := '/';
ShortDateFormat := 'd/mm/yy';
LongDateFormat := 'd mmmm yyyy';
{ Time stuff }
TimeSeparator := ':';
TimeAMString := 'AM';
TimePMString := 'PM';
HF := 'hh';
// No support for 12 hour stuff at the moment...
ShortTimeFormat := HF + ':nn';
LongTimeFormat := HF + ':nn:ss';
{ Currency stuff }
CurrencyString := '';
CurrencyFormat := 0;
NegCurrFormat := 0;
{ Number stuff }
ThousandSeparator := ',';
DecimalSeparator := '.';
CurrencyDecimals := 2;
end;
 
Procedure InitInternational;
begin
InitInternationalGeneric;
GetFormatSettings;
end;
 
 
{****************************************************************************
Target Dependent
****************************************************************************}
 
function SysErrorMessage(ErrorCode: Integer): String;
const
MaxMsgSize = 255;
var
MsgBuffer: PChar;
begin
GetMem(MsgBuffer, MaxMsgSize);
FillChar(MsgBuffer^, MaxMsgSize, #0);
{TODO}
Result := StrPas(MsgBuffer);
FreeMem(MsgBuffer, MaxMsgSize);
end;
 
{****************************************************************************
Initialization code
****************************************************************************}
 
Function GetEnvironmentVariable(Const EnvVar: String): String;
begin
Result := '';
end;
 
Function GetEnvironmentVariableCount: Integer;
begin
Result := 0;
end;
 
Function GetEnvironmentString(Index : Integer) : String;
begin
Result := '';
end;
 
function ExecuteProcess(Const Path: AnsiString; Const ComLine: AnsiString): Integer;
begin
Result := 0;
end;
 
function ExecuteProcess(Const Path: AnsiString; Const ComLine: Array of AnsiString): Integer;
var
CommandLine: AnsiString;
i: Integer;
begin
Commandline:='';
For i:=0 to high(ComLine) Do
Commandline:=CommandLine+' '+Comline[i];
ExecuteProcess:=ExecuteProcess(Path,CommandLine);
end;
 
procedure Sleep(Milliseconds: Cardinal);
begin
kos_delay(Milliseconds div 10);
end;
 
function GetLastOSError: Integer;
begin
Result := -1;
end;
 
 
 
initialization
InitExceptions;
InitInternational;
finalization
DoneExceptions;
end.
/programs/develop/fp/rtl/tthread.inc
0,0 → 1,95
{ TODO }
{ Thread management routines }
 
type
PRaiseFrame = ^TRaiseFrame;
TRaiseFrame = record
NextRaise: PRaiseFrame;
ExceptAddr: Pointer;
ExceptObject: TObject;
ExceptionRecord: pointer; {PExceptionRecord}
end;
 
var
ThreadCount: Integer;
 
 
procedure AddThread;
begin
InterlockedIncrement(ThreadCount);
end;
 
procedure RemoveThread;
begin
InterlockedDecrement(ThreadCount);
end;
 
constructor TThread.Create(CreateSuspended: Boolean; const StackSize: SizeUInt = DefaultStackSize);
begin
inherited Create;
AddThread;
FSuspended := CreateSuspended;
{TODO}
FFatalException := nil;
end;
 
destructor TThread.Destroy;
begin
if not FFinished and not Suspended then
begin
Terminate;
WaitFor;
end;
FFatalException.Free;
FFatalException := nil;
inherited Destroy;
RemoveThread;
end;
 
procedure TThread.CallOnTerminate;
begin
FOnTerminate(Self);
end;
 
procedure TThread.DoTerminate;
begin
if Assigned(FOnTerminate) then
Synchronize(@CallOnTerminate);
end;
 
function TThread.GetPriority: TThreadPriority;
begin
{TODO}
end;
 
procedure TThread.SetPriority(Value: TThreadPriority);
begin
{TODO}
end;
 
procedure TThread.SetSuspended(Value: Boolean);
begin
if Value <> FSuspended then
if Value then Suspend else Resume;
end;
 
procedure TThread.Suspend;
begin
FSuspended := True;
SuspendThread(FHandle);
end;
 
procedure TThread.Resume;
begin
if ResumeThread(FHandle) = 1 then FSuspended := False;
end;
 
procedure TThread.Terminate;
begin
FTerminated := True;
end;
 
function TThread.WaitFor: Integer;
begin
{TODO}
end;
/programs/develop/fp/rtl/types.pp
0,0 → 1,396
{$mode objfpc}
 
unit Types;
 
interface
 
type
PLongint = System.PLongint;
PSmallInt = System.PSmallInt;
PDouble = System.PDouble;
PByte = System.PByte;
 
TIntegerDynArray = array of Integer;
TCardinalDynArray = array of Cardinal;
TWordDynArray = array of Word;
TSmallIntDynArray = array of SmallInt;
TByteDynArray = array of Byte;
TShortIntDynArray = array of ShortInt;
TInt64DynArray = array of Int64;
TQWordDynArray = array of QWord;
TLongWordDynArray = array of LongWord;
TSingleDynArray = array of Single;
TDoubleDynArray = array of Double;
TBooleanDynArray = array of Boolean;
TStringDynArray = array of AnsiString;
TWideStringDynArray = array of WideString;
TPointerDynArray = array of Pointer;
 
TPoint =
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
packed
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
record
X : Longint;
Y : Longint;
end;
PPoint = ^TPoint;
tagPOINT = TPoint;
 
TRect =
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
packed
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
record
case Integer of
0: (Left,Top,Right,Bottom : Longint);
1: (TopLeft,BottomRight : TPoint);
end;
PRect = ^TRect;
 
TSize =
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
packed
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
record
cx : Longint;
cy : Longint;
end;
PSize = ^TSize;
tagSIZE = TSize;
// SIZE = TSize;
 
 
TSmallPoint =
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
packed
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
record
x : SmallInt;
y : SmallInt;
end;
PSmallPoint = ^TSmallPoint;
 
TDuplicates = (dupIgnore, dupAccept, dupError);
 
type
TOleChar = WideChar;
POleStr = PWideChar;
PPOleStr = ^POleStr;
 
TListCallback = procedure(data,arg:pointer) of object;
TListStaticCallback = procedure(data,arg:pointer);
 
const
GUID_NULL: TGUID = '{00000000-0000-0000-0000-000000000000}';
 
STGTY_STORAGE = 1;
STGTY_STREAM = 2;
STGTY_LOCKBYTES = 3;
STGTY_PROPERTY = 4;
 
STREAM_SEEK_SET = 0;
STREAM_SEEK_CUR = 1;
STREAM_SEEK_END = 2;
 
LOCK_WRITE = 1;
LOCK_EXCLUSIVE = 2;
LOCK_ONLYONCE = 4;
 
E_FAIL = HRESULT($80004005);
 
STG_E_INVALIDFUNCTION = HRESULT($80030001);
STG_E_FILENOTFOUND = HRESULT($80030002);
STG_E_PATHNOTFOUND = HRESULT($80030003);
STG_E_TOOMANYOPENFILES = HRESULT($80030004);
STG_E_ACCESSDENIED = HRESULT($80030005);
STG_E_INVALIDHANDLE = HRESULT($80030006);
STG_E_INSUFFICIENTMEMORY = HRESULT($80030008);
STG_E_INVALIDPOINTER = HRESULT($80030009);
STG_E_NOMOREFILES = HRESULT($80030012);
STG_E_DISKISWRITEPROTECTED = HRESULT($80030013);
STG_E_SEEKERROR = HRESULT($80030019);
STG_E_WRITEFAULT = HRESULT($8003001D);
STG_E_READFAULT = HRESULT($8003001E);
STG_E_SHAREVIOLATION = HRESULT($80030020);
STG_E_LOCKVIOLATION = HRESULT($80030021);
STG_E_FILEALREADYEXISTS = HRESULT($80030050);
STG_E_INVALIDPARAMETER = HRESULT($80030057);
STG_E_MEDIUMFULL = HRESULT($80030070);
STG_E_PROPSETMISMATCHED = HRESULT($800300F0);
STG_E_ABNORMALAPIEXIT = HRESULT($800300FA);
STG_E_INVALIDHEADER = HRESULT($800300FB);
STG_E_INVALIDNAME = HRESULT($800300FC);
STG_E_UNKNOWN = HRESULT($800300FD);
STG_E_UNIMPLEMENTEDFUNCTION = HRESULT($800300FE);
STG_E_INVALIDFLAG = HRESULT($800300FF);
STG_E_INUSE = HRESULT($80030100);
STG_E_NOTCURRENT = HRESULT($80030101);
STG_E_REVERTED = HRESULT($80030102);
STG_E_CANTSAVE = HRESULT($80030103);
STG_E_OLDFORMAT = HRESULT($80030104);
STG_E_OLDDLL = HRESULT($80030105);
STG_E_SHAREREQUIRED = HRESULT($80030106);
STG_E_EXTANTMARSHALLINGS = HRESULT($80030108);
STG_E_DOCFILECORRUPT = HRESULT($80030109);
STG_E_BADBASEADDRESS = HRESULT($80030110);
STG_E_INCOMPLETE = HRESULT($80030201);
STG_E_TERMINATED = HRESULT($80030202);
 
STG_S_CONVERTED = $00030200;
STG_S_BLOCK = $00030201;
STG_S_RETRYNOW = $00030202;
STG_S_MONITORING = $00030203;
 
type
PCLSID = PGUID;
TCLSID = TGUID;
 
LARGE_INT = Int64;
Largeint = LARGE_INT;
PDWord = ^DWord;
 
PDisplay = Pointer;
PEvent = Pointer;
 
TXrmOptionDescRec = record
end;
XrmOptionDescRec = TXrmOptionDescRec;
PXrmOptionDescRec = ^TXrmOptionDescRec;
 
Widget = Pointer;
WidgetClass = Pointer;
ArgList = Pointer;
Region = Pointer;
 
_FILETIME =
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
packed
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
record
dwLowDateTime : DWORD;
dwHighDateTime : DWORD;
end;
TFileTime = _FILETIME;
FILETIME = _FILETIME;
PFileTime = ^TFileTime;
 
tagSTATSTG =
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
packed
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
record
pwcsName : POleStr;
dwType : Longint;
cbSize : Largeint;
mtime : TFileTime;
ctime : TFileTime;
atime : TFileTime;
grfMode : Longint;
grfLocksSupported : Longint;
clsid : TCLSID;
grfStateBits : Longint;
reserved : Longint;
end;
TStatStg = tagSTATSTG;
STATSTG = TStatStg;
PStatStg = ^TStatStg;
 
IClassFactory = Interface(IUnknown) ['{00000001-0000-0000-C000-000000000046}']
Function CreateInstance(Const unkOuter : IUnknown;Const riid : TGUID;Out vObject) : HResult;StdCall;
Function LockServer(fLock : LongBool) : HResult;StdCall;
End;
 
ISequentialStream = interface(IUnknown) ['{0c733a30-2a1c-11ce-ade5-00aa0044773d}']
function Read(pv : Pointer;cb : DWord;pcbRead : PDWord) : HRESULT;stdcall;
function Write(pv : Pointer;cb : DWord;pcbWritten : PDWord) : HRESULT;stdcall;
end;
 
IStream = interface(ISequentialStream) ['{0000000C-0000-0000-C000-000000000046}']
function Seek(dlibMove : LargeInt; dwOrigin : Longint;
out libNewPosition : LargeInt) : HResult;stdcall;
function SetSize(libNewSize : LargeInt) : HRESULT;stdcall;
function CopyTo(stm: IStream;cb : LargeInt;out cbRead : LargeInt;
out cbWritten : LargeInt) : HRESULT;stdcall;
function Commit(grfCommitFlags : Longint) : HRESULT;stdcall;
function Revert : HRESULT;stdcall;
function LockRegion(libOffset : LargeInt;cb : LargeInt;
dwLockType : Longint) : HRESULT;stdcall;
function UnlockRegion(libOffset : LargeInt;cb : LargeInt;
dwLockType : Longint) : HRESULT;stdcall;
Function Stat(out statstg : TStatStg;grfStatFlag : Longint) : HRESULT;stdcall;
function Clone(out stm : IStream) : HRESULT;stdcall;
end;
 
function EqualRect(const r1,r2 : TRect) : Boolean;
function Rect(Left,Top,Right,Bottom : Integer) : TRect;
function Bounds(ALeft,ATop,AWidth,AHeight : Integer) : TRect;
function Point(x,y : Integer) : TPoint;
function PtInRect(const Rect : TRect; const p : TPoint) : Boolean;
function IntersectRect(var Rect : TRect; const R1,R2 : TRect) : Boolean;
function UnionRect(var Rect : TRect; const R1,R2 : TRect) : Boolean;
function IsRectEmpty(const Rect : TRect) : Boolean;
function OffsetRect(var Rect : TRect;DX : Integer;DY : Integer) : Boolean;
function CenterPoint(const Rect: TRect): TPoint;
function InflateRect(var Rect: TRect; dx: Integer; dy: Integer): Boolean;
function Size(AWidth, AHeight: Integer): TSize;
function Size(ARect: TRect): TSize;
 
implementation
 
 
function EqualRect(const r1,r2 : TRect) : Boolean;
 
begin
EqualRect:=(r1.left=r2.left) and (r1.right=r2.right) and (r1.top=r2.top) and (r1.bottom=r2.bottom);
end;
 
 
function Rect(Left,Top,Right,Bottom : Integer) : TRect;
 
begin
Rect.Left:=Left;
Rect.Top:=Top;
Rect.Right:=Right;
Rect.Bottom:=Bottom;
end;
 
 
function Bounds(ALeft,ATop,AWidth,AHeight : Integer) : TRect;
 
begin
Bounds.Left:=ALeft;
Bounds.Top:=ATop;
Bounds.Right:=ALeft+AWidth;
Bounds.Bottom:=ATop+AHeight;
end;
 
 
function Point(x,y : Integer) : TPoint;
 
begin
Point.x:=x;
Point.y:=y;
end;
 
function PtInRect(const Rect : TRect;const p : TPoint) : Boolean;
 
begin
PtInRect:=(p.y>=Rect.Top) and
(p.y<Rect.Bottom) and
(p.x>=Rect.Left) and
(p.x<Rect.Right);
end;
 
 
function IntersectRect(var Rect : TRect;const R1,R2 : TRect) : Boolean;
 
begin
Rect:=R1;
with R2 do
begin
if Left>R1.Left then
Rect.Left:=Left;
if Top>R1.Top then
Rect.Top:=Top;
if Right<R1.Right then
Rect.Right:=Right;
if Bottom<R1.Bottom then
Rect.Bottom:=Bottom;
end;
if IsRectEmpty(Rect) then
begin
FillChar(Rect,SizeOf(Rect),0);
IntersectRect:=false;
end
else
IntersectRect:=true;
end;
 
function UnionRect(var Rect : TRect;const R1,R2 : TRect) : Boolean;
begin
Rect:=R1;
with R2 do
begin
if Left<R1.Left then
Rect.Left:=Left;
if Top<R1.Top then
Rect.Top:=Top;
if Right>R1.Right then
Rect.Right:=Right;
if Bottom>R1.Bottom then
Rect.Bottom:=Bottom;
end;
if IsRectEmpty(Rect) then
begin
FillChar(Rect,SizeOf(Rect),0);
UnionRect:=false;
end
else
UnionRect:=true;
end;
 
function IsRectEmpty(const Rect : TRect) : Boolean;
begin
IsRectEmpty:=(Rect.Right<=Rect.Left) or (Rect.Bottom<=Rect.Top);
end;
 
function OffsetRect(var Rect : TRect;DX : Integer;DY : Integer) : Boolean;
begin
if assigned(@Rect) then
begin
with Rect do
begin
inc(Left,dx);
inc(Top,dy);
inc(Right,dx);
inc(Bottom,dy);
end;
OffsetRect:=true;
end
else
OffsetRect:=false;
end;
 
function CenterPoint(const Rect: TRect): TPoint;
 
begin
With Rect do
begin
Result.X:=(Left+Right) div 2;
Result.Y:=(Top+Bottom) div 2;
end;
end;
 
function InflateRect(var Rect: TRect; dx: Integer; dy: Integer): Boolean;
begin
if Assigned(@Rect) then
begin
with Rect do
begin
dec(Left, dx);
dec(Top, dy);
inc(Right, dx);
inc(Bottom, dy);
end;
Result := True;
end
else
Result := False;
end;
 
function Size(AWidth, AHeight: Integer): TSize;
begin
Result.cx := AWidth;
Result.cy := AHeight;
end;
 
function Size(ARect: TRect): TSize;
begin
Result.cx := ARect.Right - ARect.Left;
Result.cy := ARect.Bottom - ARect.Top;
end;
 
 
 
end.
/programs/develop/fp/rtl/windows.pp
0,0 → 1,7
unit Windows;
 
interface
 
implementation
 
end.
/programs/develop/fp/rtl/.
Property changes:
Added: svn:ignore
+*.exe
+*.o
+*.ppu
+*.log