diff options
| -rw-r--r-- | packages/Makefile.fpc | 8 | ||||
| -rw-r--r-- | packages/fcl-xml/Makefile.fpc | 4 | ||||
| -rwxr-xr-x | packages/iconvenc/src/iconvenc.pas | 5 | ||||
| -rw-r--r-- | packages/pthreads/src/pthreads.pp | 8 | ||||
| -rw-r--r-- | rtl/beos/ostypes.inc | 24 | ||||
| -rw-r--r-- | rtl/beos/termios.inc | 6 | ||||
| -rw-r--r-- | rtl/haiku/baseunix.pp | 36 | ||||
| -rw-r--r-- | rtl/haiku/osdefs.inc | 23 | ||||
| -rw-r--r-- | rtl/haiku/ostypes.inc | 6 | ||||
| -rw-r--r-- | rtl/haiku/pthread.inc | 8 | ||||
| -rw-r--r-- | rtl/haiku/signal.inc | 58 | ||||
| -rw-r--r-- | rtl/haiku/system.pp | 53 | ||||
| -rw-r--r-- | rtl/haiku/termios.inc | 6 | ||||
| -rw-r--r-- | rtl/haiku/tthread.inc | 613 | ||||
| -rw-r--r-- | rtl/inc/stdsock.inc | 25 | ||||
| -rw-r--r-- | rtl/unix/cthreads.pp | 8 | ||||
| -rw-r--r-- | rtl/unix/cwstring.pp | 21 | ||||
| -rw-r--r-- | rtl/unix/oscdeclh.inc | 6 |
18 files changed, 235 insertions, 683 deletions
diff --git a/packages/Makefile.fpc b/packages/Makefile.fpc index 6790e3d215..bb029f4169 100644 --- a/packages/Makefile.fpc +++ b/packages/Makefile.fpc @@ -15,10 +15,12 @@ dirs_arm_linux=graph dirs_m68k_linux=graph dirs_beos=fv fcl-web fcl-async ibase mysql ncurses zlib oracle odbc postgres sqlite pthreads imagemagick \ gdbint libpng x11 gdbm tcl syslog libcurl opengl bfd aspell svgalib \ - imlib utmp fpgtk xforms fftw pcap ggi sdl openssl graph gnome1 gtk1 gtk2 librsvg httpd13 httpd20 httpd22 pxlib numlib + imlib utmp fpgtk xforms fftw pcap ggi sdl openssl graph gnome1 gtk1 gtk2 librsvg httpd13 httpd20 httpd22 pxlib numlib \ + iconvenc dirs_haiku=fv fcl-web fcl-async ibase mysql ncurses zlib oracle odbc postgres sqlite pthreads imagemagick \ gdbint libpng x11 gdbm tcl syslog libcurl opengl bfd aspell svgalib \ - imlib utmp fpgtk xforms fftw pcap ggi sdl openssl graph gnome1 gtk1 gtk2 librsvg httpd13 httpd20 httpd22 pxlib numlib + imlib utmp fpgtk xforms fftw pcap ggi sdl openssl graph gnome1 gtk1 gtk2 librsvg httpd13 httpd20 httpd22 pxlib numlib \ + iconvenc dirs_freebsd=fv fcl-web fcl-async ibase mysql ncurses zlib oracle odbc postgres sqlite pthreads imagemagick \ gdbint libpng x11 gdbm tcl syslog libcurl opengl cairo bfd aspell svgalib \ imlib utmp fpgtk xforms fftw pcap ggi sdl openssl graph gnome1 gtk1 gtk2 librsvg httpd13 httpd20 httpd22 pxlib numlib \ @@ -317,4 +319,4 @@ fcl-xml_shared: iconvenc_shared fcl-xml_smart: iconvenc_smart fcl-xml_debug: iconvenc_debug fcl-xml_release: iconvenc_release -endif +endif
\ No newline at end of file diff --git a/packages/fcl-xml/Makefile.fpc b/packages/fcl-xml/Makefile.fpc index a3efc208e5..bb5556687d 100644 --- a/packages/fcl-xml/Makefile.fpc +++ b/packages/fcl-xml/Makefile.fpc @@ -17,6 +17,8 @@ rsts=sax xpath htmlwriter xmlconf [require] packages=fcl-base +packages_beos=iconvenc +packages_haiku=iconvenc packages_linux=iconvenc packages_darwin=iconvenc packages_freebsd=iconvenc @@ -32,4 +34,4 @@ fpcpackage=y fpcdir=../.. [rules] -.NOTPARALLEL: +.NOTPARALLEL:
\ No newline at end of file diff --git a/packages/iconvenc/src/iconvenc.pas b/packages/iconvenc/src/iconvenc.pas index a1b0c337b9..d151daf1bd 100755 --- a/packages/iconvenc/src/iconvenc.pas +++ b/packages/iconvenc/src/iconvenc.pas @@ -31,6 +31,10 @@ uses const n = 1; +{$ifdef beos} + ESysEILSEQ = EILSEQ; +{$endif} + type piconv_t = ^iconv_t; iconv_t = pointer; @@ -171,4 +175,3 @@ begin end; end. - diff --git a/packages/pthreads/src/pthreads.pp b/packages/pthreads/src/pthreads.pp index 11c107af3b..2ace16a57b 100644 --- a/packages/pthreads/src/pthreads.pp +++ b/packages/pthreads/src/pthreads.pp @@ -35,7 +35,11 @@ uses initc,BaseUnix, unixtype; {$else} {$ifdef beos} uses initc, ctypes, baseunix, unixtype; - {$i pthrbeos.inc} + {$ifdef haiku} + {$i pthrhaiku.inc} + {$else} + {$i pthrbeos.inc} + {$endif} {$else} {$error operating system not detected} {$endif} @@ -45,4 +49,4 @@ uses initc,BaseUnix, unixtype; implementation -end. +end.
\ No newline at end of file diff --git a/rtl/beos/ostypes.inc b/rtl/beos/ostypes.inc index 907a90531f..45996b5432 100644 --- a/rtl/beos/ostypes.inc +++ b/rtl/beos/ostypes.inc @@ -364,3 +364,27 @@ const B_SYMBOL_TYPE_ANY = $5; { Constansts for MMAP } const MAP_ANONYMOUS =$1000; + +const + POLLIN = $0001; + POLLOUT = $0002; + POLLERR = $0004; + POLLPRI = $0020; + POLLHUP = $0080; + POLLNVAL = $1000; + + { XOpen, XPG 4.2 } + POLLRDNORM = POLLIN; + POLLRDBAND = $0008; + POLLWRNORM = POLLOUT; + POLLWRBAND = $0010; + +type + pollfd = record + fd: cint; + events: cshort; + revents: cshort; + end; + tpollfd = pollfd; + ppollfd = ^pollfd; + diff --git a/rtl/beos/termios.inc b/rtl/beos/termios.inc index 6ccdc8dc98..b0ccdee823 100644 --- a/rtl/beos/termios.inc +++ b/rtl/beos/termios.inc @@ -415,3 +415,9 @@ struct winsize { Chr(VINTR), Chr(VQUIT), Chr(VERASE), Chr(VKILL), Chr(VEOF), Chr(VEOL), Chr(VEOL2), Chr(VSWTCH), Chr(VSTART), Chr(VSTOP), Chr(VSUSP)); +{ + According to posix/sys/ioctl.h + /* these currently work only on sockets */ +} + FIONBIO = $be000000; + FIONREAD = $be000001;
\ No newline at end of file diff --git a/rtl/haiku/baseunix.pp b/rtl/haiku/baseunix.pp index fd56004ac4..852656e378 100644 --- a/rtl/haiku/baseunix.pp +++ b/rtl/haiku/baseunix.pp @@ -15,32 +15,28 @@ Unit BaseUnix; Interface +{$inline on} +Uses UnixType; -uses UnixType; +{$i osdefs.inc} { Compile time defines } {$i aliasptp.inc} {$packrecords C} -{$define oldreaddir} // Keep using readdir system call instead - // of userland getdents stuff. -{$define usedomain} // Allow uname with "domain" entry. - // (which is a GNU extension) -{$define posixworkaround} // Temporary ugly workaround for signal handler. - // (mainly until baseunix migration is complete) {$ifndef FPC_USE_LIBC} -{$define FPC_USE_SYSCALL} + {$define FPC_USE_SYSCALL} {$endif} -{$i errno.inc} { Error numbers } +{$i errno.inc} { Error numbers } {$i ostypes.inc} {$ifdef FPC_USE_LIBC} -const clib = 'root'; -const netlib = 'network'; -{$i oscdeclh.inc} + const clib = 'root'; + const netlib = 'network'; + {$i oscdeclh.inc} {$ELSE} -{$i bunxh.inc} { Functions} + {$i bunxh.inc} { Functions} {$ENDIF} function fpgeterrno:longint; @@ -62,6 +58,8 @@ Function FpNanoSleep (req : ptimespec;rem : ptimespec):cint; {$endif} {$endif} +{$i genfunch.inc} + { Fairly portable constants. I'm not going to waste time to duplicate and alias them anywhere} @@ -83,14 +81,20 @@ Const implementation +{$ifdef hassysctl} +Uses Sysctl; +{$endif} + {$i genfuncs.inc} // generic calls. (like getenv) {$I gensigset.inc} // general sigset funcs implementation. {$I genfdset.inc} // general fdset funcs. -{$ifndef FPC_USE_LIBC} +{$ifdef FPC_USE_LIBC} + {$i oscdecl.inc} // implementation of wrappers in oscdeclh.inc +{$else} {$i syscallh.inc} // do_syscall declarations themselves {$i sysnr.inc} // syscall numbers. - {$i bsyscall.inc} // cpu specific syscalls + {$i bsyscall.inc} // cpu specific syscalls {$i bunxsysc.inc} // syscalls in system unit. // {$i settimeo.inc} {$endif} @@ -151,4 +155,4 @@ begin end; end; -end. +end.
\ No newline at end of file diff --git a/rtl/haiku/osdefs.inc b/rtl/haiku/osdefs.inc new file mode 100644 index 0000000000..648adfceba --- /dev/null +++ b/rtl/haiku/osdefs.inc @@ -0,0 +1,23 @@ +{ + Copyright (c) 2000-2002 by Marco van de Voort + + Target dependent defines used when compileing the baseunix unit + + 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. + + ****************************************************************************} + +{$define usedomain} // Allow uname with "domain" entry. + // (which is a GNU extension)
\ No newline at end of file diff --git a/rtl/haiku/ostypes.inc b/rtl/haiku/ostypes.inc index 38ba6e44cc..c6c2fe6dff 100644 --- a/rtl/haiku/ostypes.inc +++ b/rtl/haiku/ostypes.inc @@ -363,7 +363,10 @@ const B_SYMBOL_TYPE_ANY = $5; { Constansts for MMAP } const - MAP_ANONYMOUS =$1000; +{$ifdef FPC_IS_SYSTEM} + MAP_PRIVATE =2; +{$endif} + MAP_ANONYMOUS =$08; const POLLIN = $0001; @@ -388,4 +391,3 @@ type tpollfd = pollfd; ppollfd = ^pollfd; - diff --git a/rtl/haiku/pthread.inc b/rtl/haiku/pthread.inc index 341c1fa9ff..8d911c6aa7 100644 --- a/rtl/haiku/pthread.inc +++ b/rtl/haiku/pthread.inc @@ -45,12 +45,10 @@ function pthread_getspecific (t : pthread_key_t):pointer; cdecl; external; function pthread_setspecific (t : pthread_key_t;p:pointer):cint; cdecl; external; function pthread_key_create (p : ppthread_key_t;f: __destr_func_t):cint; cdecl;external; function pthread_attr_init (p : ppthread_attr_t):cint; cdecl; external; -{$ifndef haiku} -function pthread_attr_setinheritsched(p : ppthread_attr_t;i:cint):cint; cdecl; external; +//function pthread_attr_setinheritsched(p : ppthread_attr_t;i:cint):cint; cdecl; external; function pthread_attr_setscope (p : ppthread_attr_t;i:cint):cint;cdecl;external; function pthread_attr_setdetachstate (p : ppthread_attr_t;i:cint):cint;cdecl;external; function pthread_attr_setstacksize(p: ppthread_attr_t; stacksize: size_t):cint;cdecl;external; -{$endif} function pthread_create ( p: ppthread_t;attr : ppthread_attr_t;f:__startroutine_t;arg:pointer):cint;cdecl;external; procedure pthread_exit ( p: pointer); cdecl;external; function pthread_self:pthread_t; cdecl;external; @@ -68,7 +66,6 @@ function pthread_cond_wait(_para1:Ppthread_cond_t;_para2:Ppthread_mutex_t):cint; function pthread_kill(__thread:pthread_t; __signo:cint):cint;cdecl;external; function pthread_sigmask(how: cint; nset: psigset; oset: psigset): cint; cdecl; external; -{$ifndef haiku} function sem_init(__sem:Psem_t; __pshared:cint;__value:dword):cint;cdecl; external; function sem_destroy(__sem:Psem_t):cint;cdecl;external ; function sem_close(__sem:Psem_t):cint;cdecl;external ; @@ -77,7 +74,7 @@ function sem_wait(__sem:Psem_t):cint;cdecl;external ; function sem_trywait(__sem:Psem_t):cint;cdecl;external ; function sem_post(__sem:Psem_t):cint;cdecl;external ; function sem_getvalue(__sem:Psem_t; __sval:Pcint):cint;cdecl;external; -{$endif} + function pthread_mutexattr_init(_para1:Ppthread_mutexattr_t):cint;cdecl;external; function pthread_mutexattr_destroy(_para1:Ppthread_mutexattr_t):cint;cdecl;external; function pthread_mutexattr_gettype(_para1:Ppthread_mutexattr_t; _para2:Pcint):cint;cdecl;external; @@ -85,4 +82,3 @@ function pthread_mutexattr_settype(_para1:Ppthread_mutexattr_t; _para2:cint):cin function pthread_cond_timedwait(__cond:ppthread_cond_t; __mutex:ppthread_mutex_t; __abstime:ptimespec):longint;cdecl;external; - diff --git a/rtl/haiku/signal.inc b/rtl/haiku/signal.inc index 6e7dfaf455..707451ece3 100644 --- a/rtl/haiku/signal.inc +++ b/rtl/haiku/signal.inc @@ -15,31 +15,39 @@ Const { For sending a signal } - SA_NOCLDSTOP = 1; - - // does not exist under BeOS i think ! - SA_ONSTACK = $001; { take signal on signal stack } - SA_RESTART = $002; { restart system call on signal return } - SA_RESETHAND = $004; { reset to SIG_DFL when taking signal } - SA_NODEFER = $010; { don't mask the signal we're delivering } - SA_NOCLDWAIT = $020; { don't keep zombies around } - SA_SIGINFO = $040; { signal handler with SA_SIGINFO args } - SA_USERTRAMP = $100; { SUNOS compat: Do not bounce off kernel's sigtramp } + SA_NOCLDSTOP = $01; + SA_NOCLDWAIT = $02; + SA_RESETHAND = $03; + SA_NODEFER = $08; + SA_RESTART = $10; + SA_ONSTACK = $20; + SA_SIGINFO = $40; + SA_NOMASK = SA_NODEFER; + SA_STACK = SA_ONSTACK; + SA_ONESHOT = SA_RESETHAND; SIG_BLOCK = 1; SIG_UNBLOCK = 2; SIG_SETMASK = 3; - -{BeOS Checked} + +{ values for ss_flags } + SS_ONSTACK = $1; + SS_DISABLE = $2; + + MINSIGSTKSZ = 4096; + SIGSTKSZ = 16384; + +{Haiku Checked} { The numbering of signals for BeOS attempts to maintain some consistency with UN*X conventions so that things like "kill -9" do what you expect. } - SIG_DFL = 0 ; - SIG_IGN = 1 ; - SIG_ERR = -1 ; + SIG_DFL = 0; + SIG_IGN = 1; + SIG_ERR = -1; + SIG_HOLD = 3; SIGHUP = 1; SIGINT = 2; @@ -63,6 +71,14 @@ Const { For sending a signal } SIGWINCH = 20; SIGKILLTHR = 21; SIGTRAP = 22; + SIGPOLL = 23; + SIGPROF = 24; + SIGSYS = 25; + SIGURG = 26; + SIGVTALRM = 27; + SIGXCPU = 28; + SIGXFSZ = 29; + SIGBUS = SIGSEGV; { @@ -283,11 +299,20 @@ type // end; sa_Mask : SigSet; sa_Flags : Longint; - sa_userdaa : pointer + sa_userdata : pointer end; PSigActionRec = ^SigActionRec; + pstack_t = ^stack_t; + stack_t = record + ss_sp: pChar; {* signal stack base *} + ss_size: size_t; {* signal stack length *} + ss_flags: cInt; {* SS_DISABLE and/or SS_ONSTACK *} + end; + TStack = stack_t; + PStack = pstack_t; + { Change action of process upon receipt of a signal. Signum specifies the signal (all except SigKill and SigStop). @@ -296,4 +321,3 @@ type } - diff --git a/rtl/haiku/system.pp b/rtl/haiku/system.pp index 9f1e5f70c8..8476aba3b4 100644 --- a/rtl/haiku/system.pp +++ b/rtl/haiku/system.pp @@ -314,21 +314,52 @@ end; {$i sighnd.inc} +//void set_signal_stack(void *ptr, size_t size); +//int sigaltstack(const stack_t *ss, stack_t *oss); + +procedure set_signal_stack(ptr : pointer; size : size_t); external 'root' name 'set_signal_stack'; +function sigaltstack(const ss : pstack_t; oss : pstack_t) : integer; external 'root' name 'sigaltstack'; + +type + TAlternateSignalStack = record + case Integer of + 0 : (buffer : array[0..SIGSTKSZ] of Char); + 1 : (ld : int64); + 2 : (l : integer); + 3 : (p : pointer); + end; + var act: SigActionRec; + alternate_signal_stack : TAlternateSignalStack; Procedure InstallSignals; +var + oldact: SigActionRec; + r : integer; + st : stack_t; begin + FillChar(st, sizeof(st), 0); + + st.ss_flags := 0; + st.ss_sp := alternate_signal_stack.buffer; + st.ss_size := SizeOf(alternate_signal_stack); + + r := sigaltstack(@st, nil); + + if (r <> 0) then + WriteLn('error sigalstack'); { Initialize the sigaction structure } { all flags and information set to zero } FillChar(act, sizeof(SigActionRec),0); { initialize handler } act.sa_handler := SigActionHandler(@SignalToRunError); - act.sa_flags:=SA_SIGINFO; - FpSigAction(SIGFPE,@act,nil); - FpSigAction(SIGSEGV,@act,nil); - FpSigAction(SIGBUS,@act,nil); - FpSigAction(SIGILL,@act,nil); + act.sa_flags := SA_ONSTACK; + + FpSigAction(SIGFPE,@act,@oldact); + FpSigAction(SIGSEGV,@act,@oldact); + FpSigAction(SIGBUS,@act,@oldact); + FpSigAction(SIGILL,@act,@oldact); end; procedure SysInitStdIO; @@ -352,7 +383,8 @@ begin IsConsole := TRUE; StackLength := CheckInitialStkLen(InitialStkLen); StackBottom := Sptr - StackLength; - + ReturnNilIfGrowHeapFails := False; + SysResetFPU; if not(IsLibrary) then SysInitFPU; @@ -362,11 +394,12 @@ begin SysInitStdIO; { Setup heap } - myheapsize:=4096*1;// $ 20000; - myheaprealsize:=4096*1;// $ 20000; + myheapsize:=4096*100;// $ 20000; + myheaprealsize:=4096*100;// $ 20000; heapstart:=nil; heapstartpointer := nil; - heapstartpointer := Sbrk2(4096*1); +// heapstartpointer := Sbrk2(4096*1); + heapstartpointer := SysOSAlloc(4096*100); {$IFDEF FPC_USE_LIBC} // heap_handle := create_area('fpcheap',heapstart,0,myheaprealsize,0,3);//!! {$ELSE} @@ -421,4 +454,4 @@ begin initunicodestringmanager; {$endif VER2_2} setupexecname; -end. +end.
\ No newline at end of file diff --git a/rtl/haiku/termios.inc b/rtl/haiku/termios.inc index 6ccdc8dc98..b0ccdee823 100644 --- a/rtl/haiku/termios.inc +++ b/rtl/haiku/termios.inc @@ -415,3 +415,9 @@ struct winsize { Chr(VINTR), Chr(VQUIT), Chr(VERASE), Chr(VKILL), Chr(VEOF), Chr(VEOL), Chr(VEOL2), Chr(VSWTCH), Chr(VSTART), Chr(VSTOP), Chr(VSUSP)); +{ + According to posix/sys/ioctl.h + /* these currently work only on sockets */ +} + FIONBIO = $be000000; + FIONREAD = $be000001;
\ No newline at end of file diff --git a/rtl/haiku/tthread.inc b/rtl/haiku/tthread.inc deleted file mode 100644 index d722f24506..0000000000 --- a/rtl/haiku/tthread.inc +++ /dev/null @@ -1,613 +0,0 @@ -{ - This file is part of the Free Component Library (FCL) - Copyright (c) 1999-2000 by Peter Vreman - - BeOS TThread implementation - - See the file COPYING.FPC, included in this distribution, - for details about the copyright. - - 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. - - **********************************************************************} - - -{$IFDEF VER1_0} // leaving the old implementation in for now... -type - PThreadRec=^TThreadRec; - TThreadRec=record - thread : TThread; - next : PThreadRec; - end; - -var - ThreadRoot : PThreadRec; - ThreadsInited : boolean; -// MainThreadID: longint; - -Const - ThreadCount: longint = 0; - -function ThreadSelf:TThread; -var - hp : PThreadRec; - sp : Pointer; -begin - sp:=SPtr; - hp:=ThreadRoot; - while assigned(hp) do - begin - if (sp<=hp^.Thread.FStackPointer) and - (sp>(hp^.Thread.FStackPointer-hp^.Thread.FStackSize)) then - begin - Result:=hp^.Thread; - exit; - end; - hp:=hp^.next; - end; - Result:=nil; -end; - - -//function SIGCHLDHandler(Sig: longint): longint; cdecl;//this is std linux C declaration as function -procedure SIGCHLDHandler(Sig: longint); cdecl; - -begin - fpwaitpid(-1, nil, WNOHANG); -end; - -procedure InitThreads; -var - Act, OldAct: Baseunix.PSigActionRec; -begin - ThreadRoot:=nil; - ThreadsInited:=true; - - -// This will install SIGCHLD signal handler -// signal() installs "one-shot" handler, -// so it is better to install and set up handler with sigaction() - - GetMem(Act, SizeOf(SigActionRec)); - GetMem(OldAct, SizeOf(SigActionRec)); - - Act^.sa_handler := TSigAction(@SIGCHLDHandler); - Act^.sa_flags := SA_NOCLDSTOP {or SA_NOMASK or SA_RESTART}; - Fillchar(Act^.sa_mask,sizeof(Act^.sa_mask),0); //Do not block all signals ??. Don't need if SA_NOMASK in flags - FpSigAction(SIGCHLD, Act, OldAct); - - FreeMem(Act, SizeOf(SigActionRec)); - FreeMem(OldAct, SizeOf(SigActionRec)); -end; - - -procedure DoneThreads; -var - hp : PThreadRec; -begin - while assigned(ThreadRoot) do - begin - ThreadRoot^.Thread.Destroy; - hp:=ThreadRoot; - ThreadRoot:=ThreadRoot^.Next; - dispose(hp); - end; - ThreadsInited:=false; -end; - - -procedure AddThread(t:TThread); -var - hp : PThreadRec; -begin - { Need to initialize threads ? } - if not ThreadsInited then - InitThreads; - - { Put thread in the linked list } - new(hp); - hp^.Thread:=t; - hp^.next:=ThreadRoot; - ThreadRoot:=hp; - - inc(ThreadCount, 1); -end; - - -procedure RemoveThread(t:TThread); -var - lasthp,hp : PThreadRec; -begin - hp:=ThreadRoot; - lasthp:=nil; - while assigned(hp) do - begin - if hp^.Thread=t then - begin - if assigned(lasthp) then - lasthp^.next:=hp^.next - else - ThreadRoot:=hp^.next; - dispose(hp); - exit; - end; - lasthp:=hp; - hp:=hp^.next; - end; - - Dec(ThreadCount, 1); - if ThreadCount = 0 then DoneThreads; -end; - - -{ TThread } -function ThreadProc(args:pointer): Integer;//cdecl; -var - FreeThread: Boolean; - Thread : TThread absolute args; -begin - while Thread.FHandle = 0 do fpsleep(1); - if Thread.FSuspended then Thread.suspend(); - try - Thread.Execute; - except - Thread.FFatalException := TObject(AcquireExceptionObject); - end; - FreeThread := Thread.FFreeOnTerminate; - Result := Thread.FReturnValue; - Thread.FFinished := True; - Thread.DoTerminate; - if FreeThread then - Thread.Free; - fpexit(Result); -end; - - -constructor TThread.Create(CreateSuspended: Boolean); -var - Flags: Integer; -begin - inherited Create; - AddThread(self); - FSuspended := CreateSuspended; - Flags := CLONE_VM + CLONE_FS + CLONE_FILES + CLONE_SIGHAND + SIGCHLD; - { Setup 16k of stack } - FStackSize:=16384; - Getmem(FStackPointer,FStackSize); - inc(FStackPointer,FStackSize); - FCallExitProcess:=false; - { Clone } - FHandle:= Clone(@ThreadProc,FStackPointer,Flags,self); -// if FSuspended then Suspend; - FThreadID := FHandle; - IsMultiThread := TRUE; - FFatalException := nil; -end; - - -destructor TThread.Destroy; -begin - if not FFinished and not Suspended then - begin - Terminate; - WaitFor; - end; - if FHandle <> -1 then - fpkill(FHandle, SIGKILL); - dec(FStackPointer,FStackSize); - Freemem(FStackPointer); - FFatalException.Free; - FFatalException := nil; - inherited Destroy; - RemoveThread(self); -end; - - -procedure TThread.CallOnTerminate; -begin - FOnTerminate(Self); -end; - -procedure TThread.DoTerminate; -begin - if Assigned(FOnTerminate) then - Synchronize(@CallOnTerminate); -end; - - -const -{ I Don't know idle or timecritical, value is also 20, so the largest other - possibility is 19 (PFV) } - Priorities: array [TThreadPriority] of Integer = - (-20,-19,-10,9,10,19,20); - -function TThread.GetPriority: TThreadPriority; -var - P: Integer; - I: TThreadPriority; -begin - P := fpGetPriority(Prio_Process,FHandle); - Result := tpNormal; - for I := Low(TThreadPriority) to High(TThreadPriority) do - if Priorities[I] = P then - Result := I; -end; - - -procedure TThread.SetPriority(Value: TThreadPriority); -begin - fpSetPriority(Prio_Process,FHandle,Priorities[Value]); -end; - - -procedure TThread.Synchronize(Method: TThreadMethod); -begin - FSynchronizeException := nil; - FMethod := Method; -{ SendMessage(ThreadWindow, CM_EXECPROC, 0, Longint(Self)); } - if Assigned(FSynchronizeException) then - raise FSynchronizeException; -end; - - -procedure TThread.SetSuspended(Value: Boolean); -begin - if Value <> FSuspended then - if Value then - Suspend - else - Resume; -end; - - -procedure TThread.Suspend; -begin - FSuspended := true; - fpKill(FHandle, SIGSTOP); -end; - - -procedure TThread.Resume; -begin - fpKill(FHandle, SIGCONT); - FSuspended := False; -end; - - -procedure TThread.Terminate; -begin - FTerminated := True; -end; - -function TThread.WaitFor: Integer; -var - status : longint; -begin - if FThreadID = MainThreadID then - fpwaitpid(0,@status,0) - else - fpwaitpid(FHandle,@status,0); - Result:=status; -end; -{$ELSE} - -{ - What follows, is a short description on my implementation of TThread. - Most information can also be found by reading the source and accompanying - comments. - - A thread is created using BeginThread, which in turn calls - pthread_create. So the threads here are always posix threads. - Posix doesn't define anything for suspending threads as this is - inherintly unsafe. Just don't suspend threads at points they cannot - control. Therefore, I didn't implement .Suspend() if its called from - outside the threads execution flow (except on Linux _without_ NPTL). - - The implementation for .suspend uses a semaphore, which is initialized - at thread creation. If the thread tries to suspend itself, we simply - let it wait on the semaphore until it is unblocked by someone else - who calls .Resume. - - If a thread is supposed to be suspended (from outside its own path of - execution) on a system where the symbol LINUX is defined, two things - are possible. - 1) the system has the LinuxThreads pthread implementation - 2) the system has NPTL as the pthread implementation. - - In the first case, each thread is a process on its own, which as far as - know actually violates posix with respect to signal handling. - But we can detect this case, because getpid(2) will - return a different PID for each thread. In that case, sending SIGSTOP - to the PID associated with a thread will actually stop that thread - only. - In the second case, this is not possible. But getpid(2) returns the same - PID across all threads, which is detected, and TThread.Suspend() does - nothing in that case. This should probably be changed, but I know of - no way to suspend a thread when using NPTL. - - If the symbol LINUX is not defined, then the unimplemented - function SuspendThread is called. - - Johannes Berg <johannes@sipsolutions.de>, Sunday, November 16 2003 -} - -// ========== semaphore stuff ========== -{ - I don't like this. It eats up 2 filedescriptors for each thread, - and those are a limited resource. If you have a server programm - handling client connections (one per thread) it will not be able - to handle many if we use 2 fds already for internal structures. - However, right now I don't see a better option unless some sem_* - functions are added to systhrds. - I encapsulated all used functions here to make it easier to - change them completely. -} - -{BeOS implementation} - -function SemaphoreInit: Pointer; -begin - SemaphoreInit := GetMem(SizeOf(TFilDes)); - fppipe(PFilDes(SemaphoreInit)^); -end; - -procedure SemaphoreWait(const FSem: Pointer); -var - b: byte; -begin - fpread(PFilDes(FSem)^[0], b, 1); -end; - -procedure SemaphorePost(const FSem: Pointer); -var - b : byte; -begin - b := 0; - fpwrite(PFilDes(FSem)^[1], b, 1); -end; - -procedure SemaphoreDestroy(const FSem: Pointer); -begin - fpclose(PFilDes(FSem)^[0]); - fpclose(PFilDes(FSem)^[1]); - FreeMemory(FSem); -end; - -// =========== semaphore end =========== - -var - ThreadsInited: boolean = false; -{$IFDEF LINUX} - GMainPID: LongInt = 0; -{$ENDIF} -const - // stupid, considering its not even implemented... - Priorities: array [TThreadPriority] of Integer = - (-20,-19,-10,0,9,18,19); - -procedure InitThreads; -begin - if not ThreadsInited then begin - ThreadsInited := true; - {$IFDEF LINUX} - GMainPid := fpgetpid(); - {$ENDIF} - end; -end; - -procedure DoneThreads; -begin - ThreadsInited := false; -end; - -{ ok, so this is a hack, but it works nicely. Just never use - a multiline argument with WRITE_DEBUG! } -{$MACRO ON} -{$IFDEF DEBUG_MT} -{$define WRITE_DEBUG := writeln} // actually write something -{$ELSE} -{$define WRITE_DEBUG := //} // just comment out those lines -{$ENDIF} - -function ThreadFunc(parameter: Pointer): LongInt; // cdecl; -var - LThread: TThread; - c: char; -begin - WRITE_DEBUG('ThreadFunc is here...'); - LThread := TThread(parameter); - {$IFDEF LINUX} - // save the PID of the "thread" - // this is different from the PID of the main thread if - // the LinuxThreads implementation is used - LThread.FPid := fpgetpid(); - {$ENDIF} - WRITE_DEBUG('thread initing, parameter = ', LongInt(LThread)); - try - if LThread.FInitialSuspended then begin - SemaphoreWait(LThread.FSem); - if not LThread.FInitialSuspended then begin - WRITE_DEBUG('going into LThread.Execute'); - LThread.Execute; - end; - end else begin - WRITE_DEBUG('going into LThread.Execute'); - LThread.Execute; - end; - except - on e: exception do begin - WRITE_DEBUG('got exception: ',e.message); - LThread.FFatalException := TObject(AcquireExceptionObject); - // not sure if we should really do this... - // but .Destroy was called, so why not try FreeOnTerminate? - if e is EThreadDestroyCalled then LThread.FFreeOnTerminate := true; - end; - end; - WRITE_DEBUG('thread done running'); - Result := LThread.FReturnValue; - WRITE_DEBUG('Result is ',Result); - LThread.FFinished := True; - LThread.DoTerminate; - if LThread.FreeOnTerminate then begin - WRITE_DEBUG('Thread should be freed'); - LThread.Free; - WRITE_DEBUG('Thread freed'); - end; - WRITE_DEBUG('thread func exiting'); -end; - -{ TThread } -constructor TThread.Create(CreateSuspended: Boolean; const StackSize: SizeUInt = DefaultStackSize); -var - data : pointer; -begin - // lets just hope that the user doesn't create a thread - // via BeginThread and creates the first TThread Object in there! - InitThreads; - inherited Create; - FSem := SemaphoreInit; - FSuspended := CreateSuspended; - FSuspendedExternal := false; - FInitialSuspended := CreateSuspended; - FFatalException := nil; - WRITE_DEBUG('creating thread, self = ',longint(self)); - FHandle:= BeginThread(@ThreadFunc, Pointer(Self), FThreadID); - WRITE_DEBUG('TThread.Create done'); -end; - - -destructor TThread.Destroy; -begin - if FThreadID = GetCurrentThreadID then begin - raise EThreadDestroyCalled.Create('A thread cannot destroy itself except by setting FreeOnTerminate and leaving!'); - end; - // if someone calls .Free on a thread with - // FreeOnTerminate, then don't crash! - FFreeOnTerminate := false; - if not FFinished and not FSuspended then begin - Terminate; - WaitFor; - end; - if (FInitialSuspended) then begin - // thread was created suspended but never woken up. - SemaphorePost(FSem); - WaitFor; - end; - FFatalException.Free; - FFatalException := nil; - SemaphoreDestroy(FSem); - inherited Destroy; -end; - -procedure TThread.SetSuspended(Value: Boolean); -begin - if Value <> FSuspended then - if Value then - Suspend - else - Resume; -end; - -procedure TThread.Suspend; -begin - if not FSuspended then begin - if FThreadID = GetCurrentThreadID then begin - FSuspended := true; - SemaphoreWait(FSem); - end else begin - FSuspendedExternal := true; -{$IFDEF LINUX} - // naughty hack if the user doesn't have Linux with NPTL... - // in that case, the PID of threads will not be identical - // to the other threads, which means that our thread is a normal - // process that we can suspend via SIGSTOP... - // this violates POSIX, but is the way it works on the - // LinuxThreads pthread implementation. Not with NPTL, but in that case - // getpid(2) also behaves properly and returns the same PID for - // all threads. Thats actually (FINALLY!) native thread support :-) - if FPid <> GMainPID then begin - FSuspended := true; - fpkill(FPid, SIGSTOP); - end; -{$ELSE} - SuspendThread(FHandle); -{$ENDIF} - end; - end; -end; - - -procedure TThread.Resume; -begin - if (not FSuspendedExternal) then begin - if FSuspended then begin - SemaphorePost(FSem); - FInitialSuspended := false; - FSuspended := False; - end; - end else begin -{$IFDEF LINUX} - // see .Suspend - if FPid <> GMainPID then begin - fpkill(FPid, SIGCONT); - FSuspended := False; - end; -{$ELSE} - ResumeThread(FHandle); -{$ENDIF} - FSuspendedExternal := false; - end; -end; - - -procedure TThread.Terminate; -begin - FTerminated := True; -end; - -function TThread.WaitFor: Integer; -begin - WRITE_DEBUG('waiting for thread ',FHandle); - WaitFor := WaitForThreadTerminate(FHandle, 0); - WRITE_DEBUG('thread terminated'); -end; - -procedure TThread.CallOnTerminate; -begin - // no need to check if FOnTerminate <> nil, because - // thats already done in DoTerminate - FOnTerminate(self); -end; - -procedure TThread.DoTerminate; -begin - if Assigned(FOnTerminate) then - Synchronize(@CallOnTerminate); -end; - -function TThread.GetPriority: TThreadPriority; -var - P: Integer; - I: TThreadPriority; -begin - P := ThreadGetPriority(FHandle); - Result := tpNormal; - for I := Low(TThreadPriority) to High(TThreadPriority) do - if Priorities[I] = P then - Result := I; -end; - -(* -procedure TThread.Synchronize(Method: TThreadMethod); -begin -{$TODO someone with more clue of the GUI stuff will have to do this} -end; -*) -procedure TThread.SetPriority(Value: TThreadPriority); -begin - ThreadSetPriority(FHandle, Priorities[Value]); -end; -{$ENDIF} - diff --git a/rtl/inc/stdsock.inc b/rtl/inc/stdsock.inc index 3ce4d6f243..e0df429134 100644 --- a/rtl/inc/stdsock.inc +++ b/rtl/inc/stdsock.inc @@ -14,7 +14,16 @@ {$define uselibc:=cdecl; external;} -const libname='c'; +const + {$ifdef BEOS} + {$ifdef HAIKU} + libname = 'network'; + {$else} + libname = 'net'; + {$endif} + {$else} + libname='c'; + {$endif} function cfpaccept (s:cint; addrx : psockaddr; addrlen : psocklen):cint; cdecl; external libname name 'accept'; function cfpbind (s:cint; addrx : psockaddr; addrlen : tsocklen):cint; cdecl; external libname name 'bind'; @@ -32,7 +41,12 @@ function cfpsendto (s:cint; msg:pointer; len:size_t; flags:cint; tox :psock function cfpsetsockopt (s:cint; level:cint; optname:cint; optval:pointer; optlen :tsocklen):cint; cdecl; external libname name 'setsockopt'; function cfpshutdown (s:cint; how:cint):cint; cdecl; external libname name 'shutdown'; function cfpsocket (domain:cint; xtype:cint; protocol: cint):cint; cdecl; external libname name 'socket'; + +{$if defined(BEOS) and not defined(HAIKU)} +// function unavailable under BeOS +{$else} function cfpsocketpair (d:cint; xtype:cint; protocol:cint; sv:pcint):cint; cdecl; external libname name 'socketpair'; +{$endif} function fpaccept (s:cint; addrx : psockaddr; addrlen : psocklen):cint; @@ -120,9 +134,16 @@ begin internal_socketerror:=fpgeterrno; end; +{$if defined(BEOS) and not defined(HAIKU)} +// function unavailable under BeOS +function fpsocketpair (d:cint; xtype:cint; protocol:cint; sv:pcint):cint; +begin + internal_socketerror:= -1; // TODO : check if it is an error +end; +{$else} function fpsocketpair (d:cint; xtype:cint; protocol:cint; sv:pcint):cint; begin fpsocketpair:=cfpsocketpair(d,xtype,protocol,sv); internal_socketerror:=fpgeterrno; end; - +{$endif}
\ No newline at end of file diff --git a/rtl/unix/cthreads.pp b/rtl/unix/cthreads.pp index 5371122396..4c9fb2b733 100644 --- a/rtl/unix/cthreads.pp +++ b/rtl/unix/cthreads.pp @@ -47,7 +47,9 @@ interface {$ifndef dynpthreads} // If you have problems compiling this on FreeBSD 5.x {$linklib c} // try adding -Xf {$ifndef Darwin} - {$linklib pthread} + {$ifndef haiku} + {$linklib pthread} + {$endif haiku} {$endif darwin} {$endif} @@ -278,7 +280,9 @@ Type PINTRTLEvent = ^TINTRTLEvent; writeln('Starting new thread'); {$endif DEBUG_MT} pthread_attr_init(@thread_attr); + {$ifndef HAIKU} pthread_attr_setinheritsched(@thread_attr, PTHREAD_EXPLICIT_SCHED); + {$endif} // will fail under linux -- apparently unimplemented pthread_attr_setscope(@thread_attr, PTHREAD_SCOPE_PROCESS); @@ -1092,4 +1096,4 @@ initialization end; SetCThreadManager; finalization -end. +end.
\ No newline at end of file diff --git a/rtl/unix/cwstring.pp b/rtl/unix/cwstring.pp index 860613b9f8..855948102e 100644 --- a/rtl/unix/cwstring.pp +++ b/rtl/unix/cwstring.pp @@ -26,8 +26,12 @@ implementation {$linklib c} -{$if not defined(linux) and not defined(solaris) and not defined(haiku)} // Linux (and maybe glibc platforms in general), have iconv in glibc. - {$linklib iconv} +{$if not defined(linux) and not defined(solaris)} // Linux (and maybe glibc platforms in general), have iconv in glibc. + {$if defined(haiku)} + {$linklib textencoding} + {$else} + {$linklib iconv} + {$endif} {$define useiconv} {$endif linux} @@ -42,7 +46,11 @@ Const {$ifndef useiconv} libiconvname='c'; // is in libc under Linux. {$else} + {$ifdef haiku} + libiconvname='textencoding'; // is in libtextencoding under Haiku + {$else} libiconvname='iconv'; + {$endif} {$endif} { helper functions from libc } @@ -89,7 +97,11 @@ const {$ifdef beos} {$warning check correct value for BeOS} CODESET=49; - LC_ALL = 6; // Checked for BeOS, but 0 under Haiku... + {$ifdef haiku} + LC_ALL = 0; // Checked for Haiku + {$else} + LC_ALL = 6; // Checked for BeOS + {$endif} ESysEILSEQ = EILSEQ; {$else} {$error lookup the value of CODESET in /usr/include/langinfo.h, and the value of LC_ALL in /usr/include/locale.h for your OS } @@ -124,7 +136,7 @@ type function nl_langinfo(__item:nl_item):pchar;cdecl;external libiconvname name 'nl_langinfo'; {$endif} -{$if (not defined(bsd) and not defined(beos)) or defined(darwin) or defined(haiku)} +{$if (not defined(bsd) and not defined(beos)) or defined(darwin)} function iconv_open(__tocode:pchar; __fromcode:pchar):iconv_t;cdecl;external libiconvname name 'iconv_open'; function iconv(__cd:iconv_t; __inbuf:ppchar; __inbytesleft:psize_t; __outbuf:ppchar; __outbytesleft:psize_t):size_t;cdecl;external libiconvname name 'iconv'; function iconv_close(__cd:iconv_t):cint;cdecl;external libiconvname name 'iconv_close'; @@ -759,4 +771,3 @@ finalization { fini conversion tables for main program } FiniThread; end. - diff --git a/rtl/unix/oscdeclh.inc b/rtl/unix/oscdeclh.inc index e6c372cbe4..2ea107f59e 100644 --- a/rtl/unix/oscdeclh.inc +++ b/rtl/unix/oscdeclh.inc @@ -81,10 +81,10 @@ const {$ifdef beos} {$ifdef haiku} Function FPSelect (N:cint;readfds,writefds,exceptfds:pfdSet;TimeOut:PTimeVal):cint; cdecl; external 'network' name 'select'; - Function FpPoll (fds: ppollfd; nfds: cuint; timeout: clong): cint; cdecl; external 'network' name 'poll'; + Function FpPoll (fds: ppollfd; nfds: cuint; timeout: clong): cint; cdecl; external clib name 'poll'; {$else} Function FPSelect (N:cint;readfds,writefds,exceptfds:pfdSet;TimeOut:PTimeVal):cint; cdecl; external 'net' name 'select'; - Function FpPoll (fds: ppollfd; nfds: cuint; timeout: clong): cint; cdecl; external 'net' name 'poll'; + Function FpPoll (fds: ppollfd; nfds: cuint; timeout: clong): cint; cdecl; external clib name 'poll'; {$endif} {$else} Function FPSelect (N:cint;readfds,writefds,exceptfds:pfdSet;TimeOut:PTimeVal):cint; cdecl; external clib name 'select'; @@ -158,4 +158,4 @@ const {$ifdef linux} function FpPrCtl(options : cInt; const args : ptruint) : cint; cdecl; external clib name 'prctl'; -{$endif} +{$endif}
\ No newline at end of file |