paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-12-05 04:07:13 +01:00
Code Issues Packages Projects Releases Wiki Activity

* fixed more properties, I still wonder how this could be commited

Browse Source 
git-svn-id: trunk@13543 -
This commit is contained in:
florian 2009-08-16 10:57:52 +00:00
parent 212da45205
commit 6ea40be296
22 changed files with 1533 additions and 1533 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

150
.gitattributes vendored
View File

@ -673,7 +673,7 @@ ide/fpcygwin.pas svneol=native#text/plain
ide/fpdebug.pas svneol=native#text/plain
ide/fpdesk.pas svneol=native#text/plain
ide/fpdpansi.pas svneol=native#text/plain
ide/fpevalw.pas svneol=native#text/x-pascal
ide/fpevalw.pas svneol=native#text/plain
ide/fphelp.pas svneol=native#text/plain
ide/fpide.pas svneol=native#text/plain
ide/fpini.pas svneol=native#text/plain
@ -5440,7 +5440,7 @@ rtl/amiga/timerd.inc svneol=native#text/plain
rtl/amiga/tthread.inc svneol=native#text/plain
rtl/amiga/varutils.pp svneol=native#text/plain
rtl/arm/arm.inc svneol=native#text/plain
rtl/arm/divide.inc svneol=native#text/x-pascal
rtl/arm/divide.inc svneol=native#text/plain
rtl/arm/int64p.inc svneol=native#text/plain
rtl/arm/makefile.cpu svneol=native#text/plain
rtl/arm/math.inc svneol=native#text/plain
@ -5500,7 +5500,7 @@ rtl/beos/unixsock.inc svneol=native#text/plain
rtl/beos/unxconst.inc svneol=native#text/plain
rtl/beos/unxfunc.inc svneol=native#text/plain
rtl/beos/unxsockh.inc svneol=native#text/plain
rtl/bsd/bsd.pas -text
rtl/bsd/bsd.pas -text svneol=unset#text/plain
rtl/bsd/bunxfunch.inc svneol=native#text/plain
rtl/bsd/bunxsysc.inc svneol=native#text/plain
rtl/bsd/clocale.inc svneol=native#text/plain
@ -5528,7 +5528,7 @@ rtl/darwin/Makefile.fpc svneol=native#text/plain
rtl/darwin/arm/sighnd.inc svneol=native#text/plain
rtl/darwin/console.pp svneol=native#text/plain
rtl/darwin/errno.inc svneol=native#text/plain
rtl/darwin/errnostr.inc -text
rtl/darwin/errnostr.inc svneol=native#text/plain
rtl/darwin/extres_multiarch.inc svneol=native#text/plain
rtl/darwin/i386/sig_cpu.inc svneol=native#text/plain
rtl/darwin/i386/sighnd.inc svneol=native#text/plain
@ -5594,8 +5594,8 @@ rtl/freebsd/buildrtl.lpi svneol=native#text/plain
rtl/freebsd/buildrtl.pp svneol=native#text/plain
rtl/freebsd/console.pp svneol=native#text/plain
rtl/freebsd/errno.inc svneol=native#text/plain
rtl/freebsd/errnostr.inc -text
rtl/freebsd/freebsd.pas -text
rtl/freebsd/errnostr.inc svneol=native#text/plain
rtl/freebsd/freebsd.pas -text svneol=unset#text/plain
rtl/freebsd/i386/bsyscall.inc svneol=native#text/plain
rtl/freebsd/i386/cprt0.as svneol=native#text/plain
rtl/freebsd/i386/gprt0.as svneol=native#text/plain
@ -5617,7 +5617,7 @@ rtl/freebsd/sysnr.inc svneol=native#text/plain
rtl/freebsd/termio.pp svneol=native#text/plain
rtl/freebsd/termios.inc svneol=native#text/plain
rtl/freebsd/termiosproc.inc svneol=native#text/plain
rtl/freebsd/ucontexth.inc -text svneol=unset#text/plain
rtl/freebsd/ucontexth.inc svneol=native#text/plain
rtl/freebsd/unixsock.inc svneol=native#text/plain
rtl/freebsd/unxconst.inc svneol=native#text/plain
rtl/freebsd/unxfunc.inc svneol=native#text/plain
@ -5851,7 +5851,7 @@ rtl/linux/buildrtl.lpi svneol=native#text/plain
rtl/linux/buildrtl.pp svneol=native#text/plain
rtl/linux/bunxsysc.inc svneol=native#text/plain
rtl/linux/errno.inc svneol=native#text/plain
rtl/linux/errnostr.inc -text
rtl/linux/errnostr.inc svneol=native#text/plain
rtl/linux/fpcylix.pp svneol=native#text/plain
rtl/linux/fpmake.inc svneol=native#text/plain
rtl/linux/gpm.pp svneol=native#text/plain
@ -5878,7 +5878,7 @@ rtl/linux/i386/sysnr.inc svneol=native#text/plain
rtl/linux/ipccall.inc svneol=native#text/plain
rtl/linux/ipcsys.inc svneol=native#text/plain
rtl/linux/linux.pp svneol=native#text/plain
rtl/linux/linuxvcs.pp -text
rtl/linux/linuxvcs.pp svneol=native#text/plain
rtl/linux/m68k/bsyscall.inc svneol=native#text/plain
rtl/linux/m68k/cprt0.as svneol=native#text/plain
rtl/linux/m68k/cprt21.as svneol=native#text/plain
@ -5970,7 +5970,7 @@ rtl/linux/x86_64/stat.inc svneol=native#text/plain
rtl/linux/x86_64/syscall.inc svneol=native#text/plain
rtl/linux/x86_64/syscallh.inc svneol=native#text/plain
rtl/linux/x86_64/sysnr.inc svneol=native#text/plain
rtl/m68k/int64p.inc -text
rtl/m68k/int64p.inc svneol=native#text/plain
rtl/m68k/lowmath.inc svneol=native#text/plain
rtl/m68k/m68k.inc svneol=native#text/plain
rtl/m68k/makefile.cpu svneol=native#text/plain
@ -6000,12 +6000,12 @@ rtl/macos/system.pp svneol=native#text/plain
rtl/macos/sysutils.pp svneol=native#text/plain
rtl/morphos/Makefile svneol=native#text/plain
rtl/morphos/Makefile.fpc svneol=native#text/plain
rtl/morphos/aboxlib.pas -text
rtl/morphos/aboxlib.pas -text svneol=unset#text/plain
rtl/morphos/ahi.pas svneol=native#text/plain
rtl/morphos/asl.pas svneol=native#text/plain
rtl/morphos/classes.pp svneol=native#text/plain
rtl/morphos/clipboard.pas svneol=native#text/plain
rtl/morphos/datatypes.pas -text
rtl/morphos/datatypes.pas -text svneol=unset#text/plain
rtl/morphos/dos.pp svneol=native#text/plain
rtl/morphos/doslib.pp svneol=native#text/plain
rtl/morphos/doslibd.inc svneol=native#text/plain
@ -6024,8 +6024,8 @@ rtl/morphos/keymap.pas svneol=native#text/plain
rtl/morphos/kvm.pp svneol=native#text/plain
rtl/morphos/layers.pas svneol=native#text/plain
rtl/morphos/mouse.pp svneol=native#text/plain
rtl/morphos/mui.pas -text
rtl/morphos/muihelper.pas -text
rtl/morphos/mui.pas -text svneol=unset#text/plain
rtl/morphos/muihelper.pas -text svneol=unset#text/plain
rtl/morphos/prt0.as svneol=native#text/plain
rtl/morphos/sockets.pp svneol=native#text/plain
rtl/morphos/sysdir.inc svneol=native#text/plain
@ -6038,7 +6038,7 @@ rtl/morphos/sysutils.pp svneol=native#text/plain
rtl/morphos/timer.pp svneol=native#text/plain
rtl/morphos/timerd.inc svneol=native#text/plain
rtl/morphos/timerf.inc svneol=native#text/plain
rtl/morphos/tinygl.pp -text
rtl/morphos/tinygl.pp svneol=native#text/plain
rtl/morphos/tthread.inc svneol=native#text/plain
rtl/morphos/utild1.inc svneol=native#text/plain
rtl/morphos/utild2.inc svneol=native#text/plain
@ -6061,7 +6061,7 @@ rtl/nds/prt07.as svneol=native#text/plain
rtl/nds/prt09.as svneol=native#text/plain
rtl/nds/sysdir.inc svneol=native#text/plain
rtl/nds/sysfile.inc svneol=native#text/plain
rtl/nds/sysheap.inc svneol=native#text/x-pascal
rtl/nds/sysheap.inc svneol=native#text/plain
rtl/nds/sysos.inc svneol=native#text/plain
rtl/nds/sysosh.inc svneol=native#text/plain
rtl/nds/system.pp svneol=native#text/plain
@ -6072,7 +6072,7 @@ rtl/nds/varutils.pp svneol=native#text/plain
rtl/netbsd/Makefile svneol=native#text/plain
rtl/netbsd/Makefile.fpc svneol=native#text/plain
rtl/netbsd/errno.inc svneol=native#text/plain
rtl/netbsd/errnostr.inc -text
rtl/netbsd/errnostr.inc svneol=native#text/plain
rtl/netbsd/i386/bsyscall.inc svneol=native#text/plain
rtl/netbsd/i386/cprt0.as svneol=native#text/plain
rtl/netbsd/i386/prt0.as svneol=native#text/plain
@ -6473,7 +6473,7 @@ rtl/symbian/Makefile svneol=native#text/plain
rtl/symbian/Makefile.fpc svneol=native#text/plain
rtl/symbian/bindings/pbeexe.cpp -text
rtl/symbian/buildrtl.pp svneol=native#text/plain
rtl/symbian/symbian.pas -text
rtl/symbian/symbian.pas -text svneol=unset#text/plain
rtl/symbian/symbianinc/e32def.inc svneol=native#text/plain
rtl/symbian/symbianinc/e32err.inc svneol=native#text/plain
rtl/symbian/symbianinc/e32std.inc svneol=native#text/plain
@ -6483,8 +6483,8 @@ rtl/symbian/sysheap.inc svneol=native#text/plain
rtl/symbian/sysos.inc svneol=native#text/plain
rtl/symbian/sysosh.inc svneol=native#text/plain
rtl/symbian/system.pp svneol=native#text/plain
rtl/symbian/uiq.pas -text
rtl/symbian/uiqclasses.pas -text
rtl/symbian/uiq.pas -text svneol=unset#text/plain
rtl/symbian/uiqclasses.pas -text svneol=unset#text/plain
rtl/symbian/uiqinc/qikapplication.inc svneol=native#text/plain
rtl/symbian/uiqinc/qikapplicationoo.inc svneol=native#text/plain
rtl/ucmaps/8859-1.txt svneol=native#text/plain
@ -6535,7 +6535,7 @@ rtl/unix/bunxovl.inc svneol=native#text/plain
rtl/unix/bunxovlh.inc svneol=native#text/plain
rtl/unix/classes.pp svneol=native#text/plain
rtl/unix/clocale.pp svneol=native#text/plain
rtl/unix/convert.inc -text
rtl/unix/convert.inc svneol=native#text/plain
rtl/unix/crt.pp svneol=native#text/plain
rtl/unix/cthreads.pp svneol=native#text/plain
rtl/unix/ctypes.inc svneol=native#text/plain
@ -6588,11 +6588,11 @@ rtl/watcom/classes.pp svneol=native#text/plain
rtl/watcom/crt.pp svneol=native#text/plain
rtl/watcom/dos.pp svneol=native#text/plain
rtl/watcom/prt0.as -text
rtl/watcom/sysdir.inc -text
rtl/watcom/sysfile.inc -text
rtl/watcom/sysheap.inc -text
rtl/watcom/sysos.inc -text
rtl/watcom/sysosh.inc -text
rtl/watcom/sysdir.inc svneol=native#text/plain
rtl/watcom/sysfile.inc svneol=native#text/plain
rtl/watcom/sysheap.inc svneol=native#text/plain
rtl/watcom/sysos.inc svneol=native#text/plain
rtl/watcom/sysosh.inc svneol=native#text/plain
rtl/watcom/system.pp svneol=native#text/plain
rtl/watcom/sysutils.pp svneol=native#text/plain
rtl/watcom/varutils.pp svneol=native#text/plain
@ -6682,7 +6682,7 @@ rtl/wince/wininc/makefile.inc svneol=native#text/plain
rtl/wince/wininc/messages.inc svneol=native#text/plain
rtl/wince/wininc/redef.inc svneol=native#text/plain
rtl/wince/wininc/struct.inc svneol=native#text/plain
rtl/wince/winres.inc -text
rtl/wince/winres.inc svneol=native#text/plain
rtl/wince/winsock.pp svneol=native#text/plain
rtl/wince/winsock2.pp svneol=native#text/plain
rtl/x86_64/int64p.inc svneol=native#text/plain
@ -6701,7 +6701,7 @@ tests/MPWMake -text
tests/Makefile svneol=native#text/plain
tests/Makefile.fpc svneol=native#text/plain
tests/bench/bansi1.inc svneol=native#text/plain
tests/bench/bansi1.pp -text
tests/bench/bansi1.pp svneol=native#text/plain
tests/bench/bansi1mt.pp svneol=native#text/plain
tests/bench/blists1.inc svneol=native#text/plain
tests/bench/blists1.pp svneol=native#text/plain
@ -6772,7 +6772,7 @@ tests/bench/shootout/src/knucleotide.lpi svneol=native#text/plain
tests/bench/shootout/src/knucleotide.pp svneol=native#text/plain
tests/bench/shootout/src/mandelbrot.pp svneol=native#text/plain
tests/bench/shootout/src/message.pp svneol=native#text/plain
tests/bench/shootout/src/meteorshower.pp svneol=native#text/x-pascal
tests/bench/shootout/src/meteorshower.pp svneol=native#text/plain
tests/bench/shootout/src/n_body.pp svneol=native#text/plain
tests/bench/shootout/src/nsieve.pp svneol=native#text/plain
tests/bench/shootout/src/partialsums.pp svneol=native#text/plain
@ -6782,9 +6782,9 @@ tests/bench/shootout/src/regexdna.pp svneol=native#text/plain
tests/bench/shootout/src/simple_hash.pp svneol=native#text/plain
tests/bench/shootout/src/spectralnorm.pp svneol=native#text/plain
tests/bench/shootout/src/sumcol.pp svneol=native#text/plain
tests/bench/shootout/src/thread_ring.pp svneol=native#text/pascal
tests/bench/shootout/src/thread_ring.pp svneol=native#text/plain
tests/bench/shortbench.pp svneol=native#text/plain
tests/bench/stream.pp svneol=native#text/x-pascal
tests/bench/stream.pp svneol=native#text/plain
tests/bench/timer.pas svneol=native#text/plain
tests/bench/whet.pas svneol=native#text/plain
tests/dbdigest.cfg.example -text
@ -6988,9 +6988,9 @@ tests/tbf/tb0195.pp svneol=native#text/plain
tests/tbf/tb0196.pp svneol=native#text/plain
tests/tbf/tb0197.pp svneol=native#text/plain
tests/tbf/tb0198.pp svneol=native#text/plain
tests/tbf/tb0199.pp -text
tests/tbf/tb0199a.pp -text
tests/tbf/tb0200.pp svneol=native#text/x-pascal
tests/tbf/tb0199.pp svneol=native#text/plain
tests/tbf/tb0199a.pp svneol=native#text/plain
tests/tbf/tb0200.pp svneol=native#text/plain
tests/tbf/tb0201.pp svneol=native#text/plain
tests/tbf/tb0202.pp svneol=native#text/plain
tests/tbf/tb0203.pp svneol=native#text/plain
@ -7533,15 +7533,15 @@ tests/tbs/tb0520.pp svneol=native#text/plain
tests/tbs/tb0521.pp svneol=native#text/plain
tests/tbs/tb0522.pp svneol=native#text/plain
tests/tbs/tb0523.pp svneol=native#text/plain
tests/tbs/tb0524.pp svneol=native#text/x-pascal
tests/tbs/tb0524.pp svneol=native#text/plain
tests/tbs/tb0525.pp svneol=native#text/plain
tests/tbs/tb0526.pp svneol=native#text/plain
tests/tbs/tb0527.pp svneol=native#text/plain
tests/tbs/tb0528.pp svneol=native#text/x-pascal
tests/tbs/tb0528.pp svneol=native#text/plain
tests/tbs/tb0529.pp svneol=native#text/plain
tests/tbs/tb0530.pp svneol=native#text/plain
tests/tbs/tb0531.pp svneol=native#text/plain
tests/tbs/tb0532.pp svneol=native#text/x-pascal
tests/tbs/tb0532.pp svneol=native#text/plain
tests/tbs/tb0533.pp svneol=native#text/plain
tests/tbs/tb0534.pp svneol=native#text/plain
tests/tbs/tb0535.pp svneol=native#text/plain
@ -7549,7 +7549,7 @@ tests/tbs/tb0536.pp svneol=native#text/plain
tests/tbs/tb0537.pp svneol=native#text/plain
tests/tbs/tb0538.pp svneol=native#text/plain
tests/tbs/tb0539.pp svneol=native#text/plain
tests/tbs/tb0540.pp svneol=native#text/x-pascal
tests/tbs/tb0540.pp svneol=native#text/plain
tests/tbs/tb0541.pp svneol=native#text/plain
tests/tbs/tb0542.pp svneol=native#text/plain
tests/tbs/tb0543.pp svneol=native#text/plain
@ -7728,7 +7728,7 @@ tests/test/cg/taddset4.pp svneol=native#text/plain
tests/test/cg/tadint64.pp svneol=native#text/plain
tests/test/cg/tassign1.pp svneol=native#text/plain
tests/test/cg/tassign2.pp svneol=native#text/plain
tests/test/cg/tautom.pp svneol=native#text/x-pascal
tests/test/cg/tautom.pp svneol=native#text/plain
tests/test/cg/tcalcla1.pp svneol=native#text/plain
tests/test/cg/tcalcon1.pp svneol=native#text/plain
tests/test/cg/tcalcst1.pp svneol=native#text/plain
@ -7742,8 +7742,8 @@ tests/test/cg/tcalcst8.pp svneol=native#text/plain
tests/test/cg/tcalcst9.pp svneol=native#text/plain
tests/test/cg/tcalext.pp svneol=native#text/plain
tests/test/cg/tcalext2.pp svneol=native#text/plain
tests/test/cg/tcalext3.pp -text
tests/test/cg/tcalext4.pp -text
tests/test/cg/tcalext3.pp svneol=native#text/plain
tests/test/cg/tcalext4.pp svneol=native#text/plain
tests/test/cg/tcalext5.pp svneol=native#text/plain
tests/test/cg/tcalfun1.pp svneol=native#text/plain
tests/test/cg/tcalfun2.pp svneol=native#text/plain
@ -7770,7 +7770,7 @@ tests/test/cg/tcalpvr6.pp svneol=native#text/plain
tests/test/cg/tcalpvr7.pp svneol=native#text/plain
tests/test/cg/tcalpvr8.pp svneol=native#text/plain
tests/test/cg/tcalval1.pp svneol=native#text/plain
tests/test/cg/tcalval10.pp -text
tests/test/cg/tcalval10.pp svneol=native#text/plain
tests/test/cg/tcalval2.pp svneol=native#text/plain
tests/test/cg/tcalval3.pp svneol=native#text/plain
tests/test/cg/tcalval4.pp svneol=native#text/plain
@ -7808,7 +7808,7 @@ tests/test/cg/tdivz1.pp svneol=native#text/plain
tests/test/cg/tdivz2.pp svneol=native#text/plain
tests/test/cg/texit.pp svneol=native#text/plain
tests/test/cg/tfor.pp svneol=native#text/plain
tests/test/cg/tformfnc.pp -text
tests/test/cg/tformfnc.pp svneol=native#text/plain
tests/test/cg/tfuncret.pp svneol=native#text/plain
tests/test/cg/tin.pp svneol=native#text/plain
tests/test/cg/tincdec.pp svneol=native#text/plain
@ -8081,15 +8081,15 @@ tests/test/taddstr1.pp svneol=native#text/plain
tests/test/talign.pp svneol=native#text/plain
tests/test/talign1.pp svneol=native#text/plain
tests/test/talign2.pp svneol=native#text/plain
tests/test/targ1a.pp -text
tests/test/targ1b.pp -text
tests/test/targ1a.pp svneol=native#text/plain
tests/test/targ1b.pp svneol=native#text/plain
tests/test/tarray1.pp svneol=native#text/plain
tests/test/tarray2.pp svneol=native#text/plain
tests/test/tarray3.pp svneol=native#text/plain
tests/test/tarray4.pp svneol=native#text/plain
tests/test/tarray5.pp svneol=native#text/plain
tests/test/tarray6.pp svneol=native#text/plain
tests/test/tarray7.pp svneol=native#text/x-pascal
tests/test/tarray7.pp svneol=native#text/plain
tests/test/tasmread.pp svneol=native#text/plain
tests/test/tasout.pp svneol=native#text/plain
tests/test/tbopr.pp svneol=native#text/plain
@ -8184,7 +8184,7 @@ tests/test/tinline10.pp svneol=native#text/plain
tests/test/tinline2.pp svneol=native#text/plain
tests/test/tinline3.pp svneol=native#text/plain
tests/test/tinline4.pp svneol=native#text/plain
tests/test/tinline5.pp -text
tests/test/tinline5.pp svneol=native#text/plain
tests/test/tinline6.pp svneol=native#text/plain
tests/test/tinline7.pp svneol=native#text/plain
tests/test/tinline8.pp svneol=native#text/plain
@ -8311,9 +8311,9 @@ tests/test/trange3.pp svneol=native#text/plain
tests/test/trange4.pp svneol=native#text/plain
tests/test/trange5.pp svneol=native#text/plain
tests/test/trangeob.pp svneol=native#text/plain
tests/test/trecreg.pp -text
tests/test/trecreg.pp svneol=native#text/plain
tests/test/trecreg2.pp svneol=native#text/plain
tests/test/trecreg3.pp -text
tests/test/trecreg3.pp svneol=native#text/plain
tests/test/trecreg4.pp svneol=native#text/plain
tests/test/tresstr.pp svneol=native#text/plain
tests/test/trox1.pp svneol=native#text/plain
@ -8360,7 +8360,7 @@ tests/test/tstring8.pp svneol=native#text/plain
tests/test/tstring9.pp svneol=native#text/plain
tests/test/tstrreal1.pp svneol=native#text/plain
tests/test/tstrreal2.pp svneol=native#text/plain
tests/test/tstrreal3.pp -text
tests/test/tstrreal3.pp svneol=native#text/plain
tests/test/tsubdecl.pp svneol=native#text/plain
tests/test/tunaligned1.pp svneol=native#text/plain
tests/test/tunistr1.pp svneol=native#text/plain
@ -8373,8 +8373,8 @@ tests/test/tunit1.pp svneol=native#text/plain
tests/test/tunit2.pp svneol=native#text/plain
tests/test/tunit3.pp svneol=native#text/plain
tests/test/tunroll1.pp svneol=native#text/plain
tests/test/tutf81.pp svneol=native#text/plain%3Bcharset%3Dutf-8
tests/test/tutf82.pp svneol=native#text/plain%3Bcharset%3Dutf-8
tests/test/tutf81.pp svneol=native#text/plain
tests/test/tutf82.pp svneol=native#text/plain
tests/test/tvarset1.pp svneol=native#text/plain
tests/test/tweaklib1.pp svneol=native#text/plain
tests/test/tweaklib2.pp svneol=native#text/plain
@ -8498,7 +8498,7 @@ tests/test/units/system/trandom.pp svneol=native#text/plain
tests/test/units/system/trdtxt01.pp svneol=native#text/plain
tests/test/units/system/trdtxt02.pp svneol=native#text/plain
tests/test/units/system/trdtxt03.pp svneol=native#text/plain
tests/test/units/system/tres.pp -text
tests/test/units/system/tres.pp svneol=native#text/plain
tests/test/units/system/tres1.rc -text
tests/test/units/system/tres1.res -text
tests/test/units/system/tres1.txt -text
@ -8523,13 +8523,13 @@ tests/test/units/system/tstring.pp svneol=native#text/plain
tests/test/units/system/ttrig.pas svneol=native#text/plain
tests/test/units/system/ttrunc.pp svneol=native#text/plain
tests/test/units/system/tval.inc svneol=native#text/plain
tests/test/units/system/tval.pp -text
tests/test/units/system/tval1.pp -text
tests/test/units/system/tval2.pp -text
tests/test/units/system/tval3.pp -text
tests/test/units/system/tval4.pp -text
tests/test/units/system/tval.pp svneol=native#text/plain
tests/test/units/system/tval1.pp svneol=native#text/plain
tests/test/units/system/tval2.pp svneol=native#text/plain
tests/test/units/system/tval3.pp svneol=native#text/plain
tests/test/units/system/tval4.pp svneol=native#text/plain
tests/test/units/system/tval5.pp svneol=native#text/plain
tests/test/units/system/tvalc.pp -text
tests/test/units/system/tvalc.pp svneol=native#text/plain
tests/test/units/sysutils/tastrcmp.pp svneol=native#text/plain
tests/test/units/sysutils/tastrcmp1.pp svneol=native#text/plain
tests/test/units/sysutils/texec1.pp svneol=native#text/plain
@ -8538,7 +8538,7 @@ tests/test/units/sysutils/textractquote.pp svneol=native#text/plain
tests/test/units/sysutils/tfile1.pp svneol=native#text/plain
tests/test/units/sysutils/tfile2.pp svneol=native#text/plain
tests/test/units/sysutils/tfilename.pp svneol=native#text/plain
tests/test/units/sysutils/tfloattostr.pp -text
tests/test/units/sysutils/tfloattostr.pp svneol=native#text/plain
tests/test/units/sysutils/tlocale.pp svneol=native#text/plain
tests/test/units/sysutils/tsscanf.pp svneol=native#text/plain
tests/test/units/sysutils/tstrtobool.pp svneol=native#text/plain
@ -8776,7 +8776,7 @@ tests/webtbf/tw4554c.pp svneol=native#text/plain
tests/webtbf/tw4554d.pp svneol=native#text/plain
tests/webtbf/tw4569a.pp svneol=native#text/plain
tests/webtbf/tw4569b.pp svneol=native#text/plain
tests/webtbf/tw4619a.pp -text svneol=unset#text/plain
tests/webtbf/tw4619a.pp svneol=native#text/plain
tests/webtbf/tw4619b.pp svneol=native#text/plain
tests/webtbf/tw4647.pp svneol=native#text/plain
tests/webtbf/tw4651.pp svneol=native#text/plain
@ -8792,7 +8792,7 @@ tests/webtbf/tw4781b.pp svneol=native#text/plain
tests/webtbf/tw4893d.pp svneol=native#text/plain
tests/webtbf/tw4893e.pp svneol=native#text/plain
tests/webtbf/tw4911.pp svneol=native#text/plain
tests/webtbf/tw4913.pp -text
tests/webtbf/tw4913.pp svneol=native#text/plain
tests/webtbf/tw5896a.pp svneol=native#text/plain
tests/webtbf/tw6036b.pp svneol=native#text/plain
tests/webtbf/tw6420.pp svneol=native#text/plain
@ -8802,7 +8802,7 @@ tests/webtbf/tw6796.pp svneol=native#text/plain
tests/webtbf/tw6797a.pp svneol=native#text/plain
tests/webtbf/tw6797b.pp svneol=native#text/plain
tests/webtbf/tw6922.pp svneol=native#text/plain
tests/webtbf/tw6957.pp -text
tests/webtbf/tw6957.pp svneol=native#text/plain
tests/webtbf/tw6970.pp svneol=native#text/plain
tests/webtbf/tw7070.pp svneol=native#text/plain
tests/webtbf/tw7322.pp svneol=native#text/plain
@ -8832,7 +8832,7 @@ tests/webtbf/tw8465a.pp svneol=native#text/plain
tests/webtbf/tw8528.pp svneol=native#text/plain
tests/webtbf/tw8583.pp svneol=native#text/plain
tests/webtbf/tw8588.pp svneol=native#text/plain
tests/webtbf/tw8591.pp -text
tests/webtbf/tw8591.pp svneol=native#text/plain
tests/webtbf/tw8717.pp svneol=native#text/plain
tests/webtbf/tw8738.pas svneol=native#text/plain
tests/webtbf/tw8777a.pp svneol=native#text/plain
@ -9838,7 +9838,7 @@ tests/webtbs/tw5001.pp svneol=native#text/plain
tests/webtbs/tw5015.pp svneol=native#text/plain
tests/webtbs/tw5023.pp svneol=native#text/plain
tests/webtbs/tw5036.pp svneol=native#text/plain
tests/webtbs/tw5082.pp -text svneol=unset#text/plain
tests/webtbs/tw5082.pp svneol=native#text/plain
tests/webtbs/tw5086.pp svneol=native#text/plain
tests/webtbs/tw5094.pp svneol=native#text/plain
tests/webtbs/tw5100.pp svneol=native#text/plain
@ -9857,7 +9857,7 @@ tests/webtbs/tw6451a.pp svneol=native#text/plain
tests/webtbs/tw6451b.pp svneol=native#text/plain
tests/webtbs/tw6491.pp svneol=native#text/plain
tests/webtbs/tw6493.pp svneol=native#text/plain
tests/webtbs/tw6525.pp -text
tests/webtbs/tw6525.pp svneol=native#text/plain
tests/webtbs/tw6543.pp svneol=native#text/plain
tests/webtbs/tw6586a.pp svneol=native#text/plain
tests/webtbs/tw6586b.pp svneol=native#text/plain
@ -9870,7 +9870,7 @@ tests/webtbs/tw6690.pp svneol=native#text/plain
tests/webtbs/tw6700.pp svneol=native#text/plain
tests/webtbs/tw6727.pp svneol=native#text/plain
tests/webtbs/tw6735.pp svneol=native#text/plain
tests/webtbs/tw6737.pp -text
tests/webtbs/tw6737.pp svneol=native#text/plain
tests/webtbs/tw6742.pp svneol=native#text/plain
tests/webtbs/tw6767.pp svneol=native#text/plain
tests/webtbs/tw6769.pp svneol=native#text/plain
@ -9961,7 +9961,7 @@ tests/webtbs/tw8156.pp svneol=native#text/plain
tests/webtbs/tw8171.pp svneol=native#text/plain
tests/webtbs/tw8172.pp svneol=native#text/plain
tests/webtbs/tw8177.pp svneol=native#text/plain
tests/webtbs/tw8177a.pp -text
tests/webtbs/tw8177a.pp svneol=native#text/plain
tests/webtbs/tw8180.pp svneol=native#text/plain
tests/webtbs/tw8183.pp svneol=native#text/plain
tests/webtbs/tw8187.pp svneol=native#text/plain
@ -10062,12 +10062,12 @@ tests/webtbs/tw9190.pp svneol=native#text/plain
tests/webtbs/tw9209.pp svneol=native#text/plain
tests/webtbs/tw9221.pp svneol=native#text/plain
tests/webtbs/tw9233.pp svneol=native#text/plain
tests/webtbs/tw9261.pp svneol=native#text/x-pascal
tests/webtbs/tw9261.pp svneol=native#text/plain
tests/webtbs/tw9278.pp svneol=native#text/plain
tests/webtbs/tw9299.pp -text
tests/webtbs/tw9306a.pp -text
tests/webtbs/tw9306b.pp -text
tests/webtbs/tw9309.pp -text
tests/webtbs/tw9299.pp svneol=native#text/plain
tests/webtbs/tw9306a.pp svneol=native#text/plain
tests/webtbs/tw9306b.pp svneol=native#text/plain
tests/webtbs/tw9309.pp svneol=native#text/plain
tests/webtbs/tw9327.pp svneol=native#text/plain
tests/webtbs/tw9347.pp svneol=native#text/plain
tests/webtbs/tw9347a.pp svneol=native#text/plain
@ -10083,7 +10083,7 @@ tests/webtbs/tw9551a.pp svneol=native#text/plain
tests/webtbs/tw9601.pp svneol=native#text/plain
tests/webtbs/tw9667.pp svneol=native#text/plain
tests/webtbs/tw9672.pp svneol=native#text/plain
tests/webtbs/tw9673.pp -text
tests/webtbs/tw9673.pp svneol=native#text/plain
tests/webtbs/tw9695.pp svneol=native#text/plain
tests/webtbs/tw9704.pp svneol=native#text/plain
tests/webtbs/tw9766.pp svneol=native#text/plain
@ -10092,7 +10092,7 @@ tests/webtbs/tw9894.pp svneol=native#text/plain
tests/webtbs/tw9894a.pp svneol=native#text/plain
tests/webtbs/tw9897.pp svneol=native#text/plain
tests/webtbs/tw9918.pp svneol=native#text/plain
tests/webtbs/tw9919.pp -text
tests/webtbs/tw9919.pp svneol=native#text/plain
tests/webtbs/tw9985.pp svneol=native#text/plain
tests/webtbs/tw9985a.pp svneol=native#text/plain
tests/webtbs/ub1873.pp svneol=native#text/plain

246
rtl/netbsd/errnostr.inc
View File

@ -1,123 +1,123 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2005 by Ales Katona
Contains BSD specific errors for error.pp in rtl/unix
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.
**********************************************************************}
{$warning FIX ME, I'am from FreeBSD }
const
sys_errn=93;
sys_errlist:array[0..sys_errn-1] of pchar = (
'Success', { 0 }
'Operation not permitted', { EPERM }
'No such file or directory', { ENOENT }
'No such process', { ESRCH }
'Interrupted system call', { EINTR }
'I/O error', { EIO }
'No such device or address', { ENXIO }
'Arg list too long', { E2BIG }
'Exec format error', { ENOEXEC }
'Bad file number', { EBADF }
'No child processes', { ECHILD }
'Resource deadlock avoided', { EDEADLK was EAGAIN }
'Out of memory', { ENOMEM }
'Permission denied', { EACCES }
'Bad address', { EFAULT }
'Block device required', { ENOTBLK }
'Device or resource busy', { EBUSY }
'File exists', { EEXIST }
'Cross-device link', { EXDEV }
'No such device', { ENODEV }
'Not a directory', { ENOTDIR }
'Is a directory', { EISDIR }
'Invalid argument', { EINVAL }
'File table overflow', { ENFILE }
'Too many open files', { EMFILE }
'Not a typewriter', { ENOTTY }
'Text (code segment) file busy', { ETXTBSY Text file busy. The new process was
a pure procedure (shared text) file which was
open for writing by another process, or file
which was open for writing by another process,
or while the pure procedure file was being
executed an open(2) call requested write access
requested write access.}
'File too large', { EFBIG }
'No space left on device', { ENOSPC }
'Illegal seek', { ESPIPE }
'Read-only file system', { EROFS }
'Too many links', { EMLINK }
'Broken pipe', { EPIPE }
'Math argument out of domain of func', { EDOM }
'Math result not representable', { ERANGE }
'Resource temporarily unavailable', { EAGAIN }
'Operation now in progress', { EINPROGRESS }
'Operation already in progress', { EALREADY }
// ipc/network software -- argument errors
'Socket operation on non-socket', { ENOTSOCK }
'Destination address required', { EDESTADDRREQ }
'Message too long', { EMSGSIZE }
'Protocol wrong type for socket', { EPROTOTYPE }
'Protocol not available', { ENOPROTOOPT }
'Protocol not supported', { EPROTONOSUPPORT }
'Socket type not supported', { ESOCKTNOSUPPORT }
'Operation not supported', { EOPNOTSUPP }
'Protocol family not supported', { EPFNOSUPPORT }
'Address family not supported by protocol family', { EAFNOSUPPORT }
'Address already in use', { EADDRINUSE }
'Can''t assign requested address', { EADDRNOTAVAIL }
// ipc/network software -- operational errors
'Network is down', { ENETDOWN }
'Network is unreachable', { ENETUNREACH }
'Network dropped connection on reset', { ENETRESET }
'Software caused connection abort', { ECONNABORTED }
'Connection reset by peer', { ECONNRESET }
'No buffer space available', { ENOBUFS }
'Socket is already connected', { EISCONN }
'Socket is not connected', { ENOTCONN }
'Can''t send after socket shutdown', { ESHUTDOWN }
'Too many references: can''t splice', { ETOOMANYREFS }
'Operation timed out', { ETIMEDOUT }
'Connection refused', { ECONNREFUSED }
'Too many levels of symbolic links', { ELOOP }
'File name too long', { ENAMETOOLONG }
'Host is down', { EHOSTDOWN }
'No route to host', { EHOSTUNREACH }
'Directory not empty', { ENOTEMPTY }
'Too many processes', { EPROCLIM }
'Too many users', { EUSERS }
'Disc quota exceeded', { EDQUOT }
// Network File System
'Stale NFS file handle', { ESTALE }
'Too many levels of remote in path', { EREMOTE }
'RPC struct is bad', { EBADRPC }
'RPC version wrong', { ERPCMISMATCH }
'RPC prog. not avail', { EPROGUNAVAIL }
'Program version wrong', { EPROGMISMATCH }
'Bad procedure for program', { EPROCUNAVAIL }
'No locks available', { ENOLCK }
'Function not implemented', { ENOSYS }
'Inappropriate file type or format', { EFTYPE }
'Authentication error', { EAUTH }
'Need authenticator', { ENEEDAUTH }
'Identifier removed', { EIDRM }
'No message of desired type', { ENOMSG }
'Value too large to be stored in data type', { EOVERFLOW }
'Operation canceled', { ECANCELED }
'Illegal byte sequence', { EILSEQ }
'Attribute not found', { ENOATTR }
'Programming error', { EDOOFUS }
'Bad message', { EBADMSG }
'Multihop attempted', { EMULTIHOP }
'Link has been severed', { ENOLINK }
'Protocol error' { EPROTO }
);
{
This file is part of the Free Pascal run time library.
Copyright (c) 2005 by Ales Katona
Contains BSD specific errors for error.pp in rtl/unix
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.
**********************************************************************}
{$warning FIX ME, I'am from FreeBSD }
const
sys_errn=93;
sys_errlist:array[0..sys_errn-1] of pchar = (
'Success', { 0 }
'Operation not permitted', { EPERM }
'No such file or directory', { ENOENT }
'No such process', { ESRCH }
'Interrupted system call', { EINTR }
'I/O error', { EIO }
'No such device or address', { ENXIO }
'Arg list too long', { E2BIG }
'Exec format error', { ENOEXEC }
'Bad file number', { EBADF }
'No child processes', { ECHILD }
'Resource deadlock avoided', { EDEADLK was EAGAIN }
'Out of memory', { ENOMEM }
'Permission denied', { EACCES }
'Bad address', { EFAULT }
'Block device required', { ENOTBLK }
'Device or resource busy', { EBUSY }
'File exists', { EEXIST }
'Cross-device link', { EXDEV }
'No such device', { ENODEV }
'Not a directory', { ENOTDIR }
'Is a directory', { EISDIR }
'Invalid argument', { EINVAL }
'File table overflow', { ENFILE }
'Too many open files', { EMFILE }
'Not a typewriter', { ENOTTY }
'Text (code segment) file busy', { ETXTBSY Text file busy. The new process was
a pure procedure (shared text) file which was
open for writing by another process, or file
which was open for writing by another process,
or while the pure procedure file was being
executed an open(2) call requested write access
requested write access.}
'File too large', { EFBIG }
'No space left on device', { ENOSPC }
'Illegal seek', { ESPIPE }
'Read-only file system', { EROFS }
'Too many links', { EMLINK }
'Broken pipe', { EPIPE }
'Math argument out of domain of func', { EDOM }
'Math result not representable', { ERANGE }
'Resource temporarily unavailable', { EAGAIN }
'Operation now in progress', { EINPROGRESS }
'Operation already in progress', { EALREADY }
// ipc/network software -- argument errors
'Socket operation on non-socket', { ENOTSOCK }
'Destination address required', { EDESTADDRREQ }
'Message too long', { EMSGSIZE }
'Protocol wrong type for socket', { EPROTOTYPE }
'Protocol not available', { ENOPROTOOPT }
'Protocol not supported', { EPROTONOSUPPORT }
'Socket type not supported', { ESOCKTNOSUPPORT }
'Operation not supported', { EOPNOTSUPP }
'Protocol family not supported', { EPFNOSUPPORT }
'Address family not supported by protocol family', { EAFNOSUPPORT }
'Address already in use', { EADDRINUSE }
'Can''t assign requested address', { EADDRNOTAVAIL }
// ipc/network software -- operational errors
'Network is down', { ENETDOWN }
'Network is unreachable', { ENETUNREACH }
'Network dropped connection on reset', { ENETRESET }
'Software caused connection abort', { ECONNABORTED }
'Connection reset by peer', { ECONNRESET }
'No buffer space available', { ENOBUFS }
'Socket is already connected', { EISCONN }
'Socket is not connected', { ENOTCONN }
'Can''t send after socket shutdown', { ESHUTDOWN }
'Too many references: can''t splice', { ETOOMANYREFS }
'Operation timed out', { ETIMEDOUT }
'Connection refused', { ECONNREFUSED }
'Too many levels of symbolic links', { ELOOP }
'File name too long', { ENAMETOOLONG }
'Host is down', { EHOSTDOWN }
'No route to host', { EHOSTUNREACH }
'Directory not empty', { ENOTEMPTY }
'Too many processes', { EPROCLIM }
'Too many users', { EUSERS }
'Disc quota exceeded', { EDQUOT }
// Network File System
'Stale NFS file handle', { ESTALE }
'Too many levels of remote in path', { EREMOTE }
'RPC struct is bad', { EBADRPC }
'RPC version wrong', { ERPCMISMATCH }
'RPC prog. not avail', { EPROGUNAVAIL }
'Program version wrong', { EPROGMISMATCH }
'Bad procedure for program', { EPROCUNAVAIL }
'No locks available', { ENOLCK }
'Function not implemented', { ENOSYS }
'Inappropriate file type or format', { EFTYPE }
'Authentication error', { EAUTH }
'Need authenticator', { ENEEDAUTH }
'Identifier removed', { EIDRM }
'No message of desired type', { ENOMSG }
'Value too large to be stored in data type', { EOVERFLOW }
'Operation canceled', { ECANCELED }
'Illegal byte sequence', { EILSEQ }
'Attribute not found', { ENOATTR }
'Programming error', { EDOOFUS }
'Bad message', { EBADMSG }
'Multihop attempted', { EMULTIHOP }
'Link has been severed', { ENOLINK }
'Protocol error' { EPROTO }
);

256
rtl/watcom/sysdir.inc
View File

@ -1,128 +1,128 @@
{*****************************************************************************
Directory Handling
*****************************************************************************}
procedure DosDir(func:byte;const s:string);
var
buffer : array[0..255] of char;
regs : trealregs;
begin
move(s[1],buffer,length(s));
buffer[length(s)]:=#0;
DoDirSeparators(pchar(@buffer));
{ True DOS does not like backslashes at end
Win95 DOS accepts this !!
but "\" and "c:\" should still be kept and accepted hopefully PM }
if (length(s)>0) and (buffer[length(s)-1]='\') and
Not ((length(s)=1) or ((length(s)=3) and (s[2]=':'))) then
buffer[length(s)-1]:=#0;
syscopytodos(longint(@buffer),length(s)+1);
regs.realedx:=tb_offset;
regs.realds:=tb_segment;
if LFNSupport then
regs.realeax:=$7100+func
else
regs.realeax:=func shl 8;
sysrealintr($21,regs);
if (regs.realflags and carryflag) <> 0 then
GetInOutRes(lo(regs.realeax));
end;
procedure mkdir(const s : string);[IOCheck];
begin
If (s='') or (InOutRes <> 0) then
exit;
DosDir($39,s);
end;
procedure rmdir(const s : string);[IOCheck];
begin
if (s = '.' ) then
InOutRes := 16;
If (s='') or (InOutRes <> 0) then
exit;
DosDir($3a,s);
end;
procedure chdir(const s : string);[IOCheck];
var
regs : trealregs;
begin
If (s='') or (InOutRes <> 0) then
exit;
{ First handle Drive changes }
if (length(s)>=2) and (s[2]=':') then
begin
regs.realedx:=(ord(s[1]) and (not 32))-ord('A');
regs.realeax:=$0e00;
sysrealintr($21,regs);
regs.realeax:=$1900;
sysrealintr($21,regs);
if byte(regs.realeax)<>byte(regs.realedx) then
begin
Inoutres:=15;
exit;
end;
{ DosDir($3b,'c:') give Path not found error on
pure DOS PM }
if length(s)=2 then
exit;
end;
{ do the normal dos chdir }
DosDir($3b,s);
end;
procedure getdir(drivenr : byte;var dir : shortstring);
var
temp : array[0..255] of char;
i : longint;
regs : trealregs;
begin
regs.realedx:=drivenr;
regs.realesi:=tb_offset;
regs.realds:=tb_segment;
if LFNSupport then
regs.realeax:=$7147
else
regs.realeax:=$4700;
sysrealintr($21,regs);
if (regs.realflags and carryflag) <> 0 then
Begin
GetInOutRes(lo(regs.realeax));
Dir := char (DriveNr + 64) + ':\';
exit;
end
else
syscopyfromdos(longint(@temp),251);
{ conversion to Pascal string including slash conversion }
i:=0;
while (temp[i]<>#0) do
begin
if temp[i] in AllowDirectorySeparators then
temp[i]:=DirectorySeparator;
dir[i+4]:=temp[i];
inc(i);
end;
dir[2]:=':';
dir[3]:='\';
dir[0]:=char(i+3);
{ upcase the string }
if not FileNameCaseSensitive then
dir:=upcase(dir);
if drivenr<>0 then { Drive was supplied. We know it }
dir[1]:=char(65+drivenr-1)
else
begin
{ We need to get the current drive from DOS function 19H }
{ because the drive was the default, which can be unknown }
regs.realeax:=$1900;
sysrealintr($21,regs);
i:= (regs.realeax and $ff) + ord('A');
dir[1]:=chr(i);
end;
end;
{*****************************************************************************
Directory Handling
*****************************************************************************}
procedure DosDir(func:byte;const s:string);
var
buffer : array[0..255] of char;
regs : trealregs;
begin
move(s[1],buffer,length(s));
buffer[length(s)]:=#0;
DoDirSeparators(pchar(@buffer));
{ True DOS does not like backslashes at end
Win95 DOS accepts this !!
but "\" and "c:\" should still be kept and accepted hopefully PM }
if (length(s)>0) and (buffer[length(s)-1]='\') and
Not ((length(s)=1) or ((length(s)=3) and (s[2]=':'))) then
buffer[length(s)-1]:=#0;
syscopytodos(longint(@buffer),length(s)+1);
regs.realedx:=tb_offset;
regs.realds:=tb_segment;
if LFNSupport then
regs.realeax:=$7100+func
else
regs.realeax:=func shl 8;
sysrealintr($21,regs);
if (regs.realflags and carryflag) <> 0 then
GetInOutRes(lo(regs.realeax));
end;
procedure mkdir(const s : string);[IOCheck];
begin
If (s='') or (InOutRes <> 0) then
exit;
DosDir($39,s);
end;
procedure rmdir(const s : string);[IOCheck];
begin
if (s = '.' ) then
InOutRes := 16;
If (s='') or (InOutRes <> 0) then
exit;
DosDir($3a,s);
end;
procedure chdir(const s : string);[IOCheck];
var
regs : trealregs;
begin
If (s='') or (InOutRes <> 0) then
exit;
{ First handle Drive changes }
if (length(s)>=2) and (s[2]=':') then
begin
regs.realedx:=(ord(s[1]) and (not 32))-ord('A');
regs.realeax:=$0e00;
sysrealintr($21,regs);
regs.realeax:=$1900;
sysrealintr($21,regs);
if byte(regs.realeax)<>byte(regs.realedx) then
begin
Inoutres:=15;
exit;
end;
{ DosDir($3b,'c:') give Path not found error on
pure DOS PM }
if length(s)=2 then
exit;
end;
{ do the normal dos chdir }
DosDir($3b,s);
end;
procedure getdir(drivenr : byte;var dir : shortstring);
var
temp : array[0..255] of char;
i : longint;
regs : trealregs;
begin
regs.realedx:=drivenr;
regs.realesi:=tb_offset;
regs.realds:=tb_segment;
if LFNSupport then
regs.realeax:=$7147
else
regs.realeax:=$4700;
sysrealintr($21,regs);
if (regs.realflags and carryflag) <> 0 then
Begin
GetInOutRes(lo(regs.realeax));
Dir := char (DriveNr + 64) + ':\';
exit;
end
else
syscopyfromdos(longint(@temp),251);
{ conversion to Pascal string including slash conversion }
i:=0;
while (temp[i]<>#0) do
begin
if temp[i] in AllowDirectorySeparators then
temp[i]:=DirectorySeparator;
dir[i+4]:=temp[i];
inc(i);
end;
dir[2]:=':';
dir[3]:='\';
dir[0]:=char(i+3);
{ upcase the string }
if not FileNameCaseSensitive then
dir:=upcase(dir);
if drivenr<>0 then { Drive was supplied. We know it }
dir[1]:=char(65+drivenr-1)
else
begin
{ We need to get the current drive from DOS function 19H }
{ because the drive was the default, which can be unknown }
regs.realeax:=$1900;
sysrealintr($21,regs);
i:= (regs.realeax and $ff) + ord('A');
dir[1]:=chr(i);
end;
end;

858
rtl/watcom/sysfile.inc
View File

@ -1,429 +1,429 @@
{ Keep Track of open files }
const
max_files = 50;
var
openfiles : array [0..max_files-1] of boolean;
{$ifdef SYSTEMDEBUG}
opennames : array [0..max_files-1] of pchar;
const
free_closed_names : boolean = true;
{$endif SYSTEMDEBUG}
{****************************************************************************
Low level File Routines
****************************************************************************}
procedure do_close(handle : longint);
var
regs : trealregs;
begin
if Handle<=4 then
exit;
regs.realebx:=handle;
if handle<max_files then
begin
openfiles[handle]:=false;
{$ifdef SYSTEMDEBUG}
if assigned(opennames[handle]) and free_closed_names then
begin
sysfreememsize(opennames[handle],strlen(opennames[handle])+1);
opennames[handle]:=nil;
end;
{$endif SYSTEMDEBUG}
end;
regs.realeax:=$3e00;
sysrealintr($21,regs);
if (regs.realflags and carryflag) <> 0 then
GetInOutRes(lo(regs.realeax));
end;
procedure do_erase(p : pchar);
var
regs : trealregs;
begin
DoDirSeparators(p);
syscopytodos(longint(p),strlen(p)+1);
regs.realedx:=tb_offset;
regs.realds:=tb_segment;
if LFNSupport then
regs.realeax:=$7141
else
regs.realeax:=$4100;
regs.realesi:=0;
regs.realecx:=0;
sysrealintr($21,regs);
if (regs.realflags and carryflag) <> 0 then
GetInOutRes(lo(regs.realeax));
end;
procedure do_rename(p1,p2 : pchar);
var
regs : trealregs;
begin
DoDirSeparators(p1);
DoDirSeparators(p2);
if strlen(p1)+strlen(p2)+3>tb_size then
HandleError(217);
sysseg_move(get_ds,sizeuint(p2),dos_selector,tb,strlen(p2)+1);
sysseg_move(get_ds,sizeuint(p1),dos_selector,tb+strlen(p2)+2,strlen(p1)+1);
regs.realedi:=tb_offset;
regs.realedx:=tb_offset + strlen(p2)+2;
regs.realds:=tb_segment;
regs.reales:=tb_segment;
if LFNSupport then
regs.realeax:=$7156
else
regs.realeax:=$5600;
regs.realecx:=$ff; { attribute problem here ! }
sysrealintr($21,regs);
if (regs.realflags and carryflag) <> 0 then
GetInOutRes(lo(regs.realeax));
end;
function do_write(h:longint;addr:pointer;len : longint) : longint;
var
regs : trealregs;
size,
writesize : longint;
begin
writesize:=0;
while len > 0 do
begin
if len>tb_size then
size:=tb_size
else
size:=len;
syscopytodos(ptrint(addr)+writesize,size);
regs.realecx:=size;
regs.realedx:=tb_offset;
regs.realds:=tb_segment;
regs.realebx:=h;
regs.realeax:=$4000;
sysrealintr($21,regs);
if (regs.realflags and carryflag) <> 0 then
begin
GetInOutRes(lo(regs.realeax));
exit(writesize);
end;
inc(writesize,lo(regs.realeax));
dec(len,lo(regs.realeax));
{ stop when not the specified size is written }
if lo(regs.realeax)<size then
break;
end;
Do_Write:=WriteSize;
end;
function do_read(h:longint;addr:pointer;len : longint) : longint;
var
regs : trealregs;
size,
readsize : longint;
begin
readsize:=0;
while len > 0 do
begin
if len>tb_size then
size:=tb_size
else
size:=len;
regs.realecx:=size;
regs.realedx:=tb_offset;
regs.realds:=tb_segment;
regs.realebx:=h;
regs.realeax:=$3f00;
sysrealintr($21,regs);
if (regs.realflags and carryflag) <> 0 then
begin
GetInOutRes(lo(regs.realeax));
do_read:=0;
exit;
end;
syscopyfromdos(ptrint(addr)+readsize,lo(regs.realeax));
inc(readsize,lo(regs.realeax));
dec(len,lo(regs.realeax));
{ stop when not the specified size is read }
if lo(regs.realeax)<size then
break;
end;
do_read:=readsize;
end;
function do_filepos(handle : longint) : longint;
var
regs : trealregs;
begin
regs.realebx:=handle;
regs.realecx:=0;
regs.realedx:=0;
regs.realeax:=$4201;
sysrealintr($21,regs);
if (regs.realflags and carryflag) <> 0 then
Begin
GetInOutRes(lo(regs.realeax));
do_filepos:=0;
end
else
do_filepos:=lo(regs.realedx) shl 16+lo(regs.realeax);
end;
procedure do_seek(handle,pos : longint);
var
regs : trealregs;
begin
regs.realebx:=handle;
regs.realecx:=pos shr 16;
regs.realedx:=pos and $ffff;
regs.realeax:=$4200;
sysrealintr($21,regs);
if (regs.realflags and carryflag) <> 0 then
GetInOutRes(lo(regs.realeax));
end;
function do_seekend(handle:longint):longint;
var
regs : trealregs;
begin
regs.realebx:=handle;
regs.realecx:=0;
regs.realedx:=0;
regs.realeax:=$4202;
sysrealintr($21,regs);
if (regs.realflags and carryflag) <> 0 then
Begin
GetInOutRes(lo(regs.realeax));
do_seekend:=0;
end
else
do_seekend:=lo(regs.realedx) shl 16+lo(regs.realeax);
end;
function do_filesize(handle : longint) : longint;
var
aktfilepos : longint;
begin
aktfilepos:=do_filepos(handle);
do_filesize:=do_seekend(handle);
do_seek(handle,aktfilepos);
end;
{ truncate at a given position }
procedure do_truncate (handle,pos:longint);
var
regs : trealregs;
begin
do_seek(handle,pos);
regs.realecx:=0;
regs.realedx:=tb_offset;
regs.realds:=tb_segment;
regs.realebx:=handle;
regs.realeax:=$4000;
sysrealintr($21,regs);
if (regs.realflags and carryflag) <> 0 then
GetInOutRes(lo(regs.realeax));
end;
const
FileHandleCount : longint = 20;
function Increase_file_handle_count : boolean;
var
regs : trealregs;
begin
Inc(FileHandleCount,10);
regs.realebx:=FileHandleCount;
regs.realeax:=$6700;
sysrealintr($21,regs);
if (regs.realflags and carryflag) <> 0 then
begin
Increase_file_handle_count:=false;
Dec (FileHandleCount, 10);
end
else
Increase_file_handle_count:=true;
end;
function dos_version : word;
var
regs : trealregs;
begin
regs.realeax := $3000;
sysrealintr($21,regs);
dos_version := regs.realeax
end;
procedure do_open(var f;p:pchar;flags:longint);
{
filerec and textrec have both handle and mode as the first items so
they could use the same routine for opening/creating.
when (flags and $100) the file will be append
when (flags and $1000) the file will be truncate/rewritten
when (flags and $10000) there is no check for close (needed for textfiles)
}
var
regs : trealregs;
action : longint;
Avoid6c00 : boolean;
begin
DoDirSeparators(p);
{ check if Extended Open/Create API is safe to use }
Avoid6c00 := lo(dos_version) < 7;
{ close first if opened }
if ((flags and $10000)=0) then
begin
case filerec(f).mode of
fminput,fmoutput,fminout : Do_Close(filerec(f).handle);
fmclosed : ;
else
begin
inoutres:=102; {not assigned}
exit;
end;
end;
end;
{ reset file handle }
filerec(f).handle:=UnusedHandle;
action:=$1;
{ convert filemode to filerec modes }
case (flags and 3) of
0 : filerec(f).mode:=fminput;
1 : filerec(f).mode:=fmoutput;
2 : filerec(f).mode:=fminout;
end;
if (flags and $1000)<>0 then
action:=$12; {create file function}
{ empty name is special }
if p[0]=#0 then
begin
case FileRec(f).mode of
fminput :
FileRec(f).Handle:=StdInputHandle;
fminout, { this is set by rewrite }
fmoutput :
FileRec(f).Handle:=StdOutputHandle;
fmappend :
begin
FileRec(f).Handle:=StdOutputHandle;
FileRec(f).mode:=fmoutput; {fool fmappend}
end;
end;
exit;
end;
{ real dos call }
syscopytodos(longint(p),strlen(p)+1);
{$ifndef RTLLITE}
if LFNSupport then
regs.realeax := $716c { Use LFN Open/Create API }
else
regs.realeax:=$6c00;
{$endif RTLLITE}
if Avoid6c00 then
regs.realeax := $3d00 + (flags and $ff) { For now, map to Open API }
else
regs.realeax := $6c00; { Use Extended Open/Create API }
if byte(regs.realeax shr 8) = $3d then
begin { Using the older Open or Create API's }
if (action and $00f0) <> 0 then
regs.realeax := $3c00; { Map to Create/Replace API }
regs.realds := tb_segment;
regs.realedx := tb_offset;
end
else
begin { Using LFN or Extended Open/Create API }
regs.realedx := action; { action if file does/doesn't exist }
regs.realds := tb_segment;
regs.realesi := tb_offset;
regs.realebx := $2000 + (flags and $ff); { file open mode }
end;
regs.realecx := $20; { file attributes }
sysrealintr($21,regs);
{$ifndef RTLLITE}
if (regs.realflags and carryflag) <> 0 then
if lo(regs.realeax)=4 then
if Increase_file_handle_count then
begin
{ Try again }
if LFNSupport then
regs.realeax := $716c {Use LFN Open/Create API}
else
if Avoid6c00 then
regs.realeax := $3d00+(flags and $ff) {For now, map to Open API}
else
regs.realeax := $6c00; {Use Extended Open/Create API}
if byte(regs.realeax shr 8) = $3d then
begin { Using the older Open or Create API's }
if (action and $00f0) <> 0 then
regs.realeax := $3c00; {Map to Create/Replace API}
regs.realds := tb_segment;
regs.realedx := tb_offset;
end
else
begin { Using LFN or Extended Open/Create API }
regs.realedx := action; {action if file does/doesn't exist}
regs.realds := tb_segment;
regs.realesi := tb_offset;
regs.realebx := $2000+(flags and $ff); {file open mode}
end;
regs.realecx := $20; {file attributes}
sysrealintr($21,regs);
end;
{$endif RTLLITE}
if (regs.realflags and carryflag) <> 0 then
begin
GetInOutRes(lo(regs.realeax));
exit;
end
else
begin
filerec(f).handle:=lo(regs.realeax);
{$ifndef RTLLITE}
{ for systems that have more then 20 by default ! }
if lo(regs.realeax)>FileHandleCount then
FileHandleCount:=lo(regs.realeax);
{$endif RTLLITE}
end;
if lo(regs.realeax)<max_files then
begin
{$ifdef SYSTEMDEBUG}
if openfiles[lo(regs.realeax)] and
assigned(opennames[lo(regs.realeax)]) then
begin
Writeln(stderr,'file ',opennames[lo(regs.realeax)],'(',lo(regs.realeax),') not closed but handle reused!');
sysfreememsize(opennames[lo(regs.realeax)],strlen(opennames[lo(regs.realeax)])+1);
end;
{$endif SYSTEMDEBUG}
openfiles[lo(regs.realeax)]:=true;
{$ifdef SYSTEMDEBUG}
opennames[lo(regs.realeax)] := sysgetmem(strlen(p)+1);
move(p^,opennames[lo(regs.realeax)]^,strlen(p)+1);
{$endif SYSTEMDEBUG}
end;
{ append mode }
if ((flags and $100) <> 0) and
(FileRec (F).Handle <> UnusedHandle) then
begin
do_seekend(filerec(f).handle);
filerec(f).mode:=fmoutput; {fool fmappend}
end;
end;
function do_isdevice(handle:THandle):boolean;
var
regs : trealregs;
begin
regs.realebx:=handle;
regs.realeax:=$4400;
sysrealintr($21,regs);
do_isdevice:=(regs.realedx and $80)<>0;
if (regs.realflags and carryflag) <> 0 then
GetInOutRes(lo(regs.realeax));
end;
{ Keep Track of open files }
const
max_files = 50;
var
openfiles : array [0..max_files-1] of boolean;
{$ifdef SYSTEMDEBUG}
opennames : array [0..max_files-1] of pchar;
const
free_closed_names : boolean = true;
{$endif SYSTEMDEBUG}
{****************************************************************************
Low level File Routines
****************************************************************************}
procedure do_close(handle : longint);
var
regs : trealregs;
begin
if Handle<=4 then
exit;
regs.realebx:=handle;
if handle<max_files then
begin
openfiles[handle]:=false;
{$ifdef SYSTEMDEBUG}
if assigned(opennames[handle]) and free_closed_names then
begin
sysfreememsize(opennames[handle],strlen(opennames[handle])+1);
opennames[handle]:=nil;
end;
{$endif SYSTEMDEBUG}
end;
regs.realeax:=$3e00;
sysrealintr($21,regs);
if (regs.realflags and carryflag) <> 0 then
GetInOutRes(lo(regs.realeax));
end;
procedure do_erase(p : pchar);
var
regs : trealregs;
begin
DoDirSeparators(p);
syscopytodos(longint(p),strlen(p)+1);
regs.realedx:=tb_offset;
regs.realds:=tb_segment;
if LFNSupport then
regs.realeax:=$7141
else
regs.realeax:=$4100;
regs.realesi:=0;
regs.realecx:=0;
sysrealintr($21,regs);
if (regs.realflags and carryflag) <> 0 then
GetInOutRes(lo(regs.realeax));
end;
procedure do_rename(p1,p2 : pchar);
var
regs : trealregs;
begin
DoDirSeparators(p1);
DoDirSeparators(p2);
if strlen(p1)+strlen(p2)+3>tb_size then
HandleError(217);
sysseg_move(get_ds,sizeuint(p2),dos_selector,tb,strlen(p2)+1);
sysseg_move(get_ds,sizeuint(p1),dos_selector,tb+strlen(p2)+2,strlen(p1)+1);
regs.realedi:=tb_offset;
regs.realedx:=tb_offset + strlen(p2)+2;
regs.realds:=tb_segment;
regs.reales:=tb_segment;
if LFNSupport then
regs.realeax:=$7156
else
regs.realeax:=$5600;
regs.realecx:=$ff; { attribute problem here ! }
sysrealintr($21,regs);
if (regs.realflags and carryflag) <> 0 then
GetInOutRes(lo(regs.realeax));
end;
function do_write(h:longint;addr:pointer;len : longint) : longint;
var
regs : trealregs;
size,
writesize : longint;
begin
writesize:=0;
while len > 0 do
begin
if len>tb_size then
size:=tb_size
else
size:=len;
syscopytodos(ptrint(addr)+writesize,size);
regs.realecx:=size;
regs.realedx:=tb_offset;
regs.realds:=tb_segment;
regs.realebx:=h;
regs.realeax:=$4000;
sysrealintr($21,regs);
if (regs.realflags and carryflag) <> 0 then
begin
GetInOutRes(lo(regs.realeax));
exit(writesize);
end;
inc(writesize,lo(regs.realeax));
dec(len,lo(regs.realeax));
{ stop when not the specified size is written }
if lo(regs.realeax)<size then
break;
end;
Do_Write:=WriteSize;
end;
function do_read(h:longint;addr:pointer;len : longint) : longint;
var
regs : trealregs;
size,
readsize : longint;
begin
readsize:=0;
while len > 0 do
begin
if len>tb_size then
size:=tb_size
else
size:=len;
regs.realecx:=size;
regs.realedx:=tb_offset;
regs.realds:=tb_segment;
regs.realebx:=h;
regs.realeax:=$3f00;
sysrealintr($21,regs);
if (regs.realflags and carryflag) <> 0 then
begin
GetInOutRes(lo(regs.realeax));
do_read:=0;
exit;
end;
syscopyfromdos(ptrint(addr)+readsize,lo(regs.realeax));
inc(readsize,lo(regs.realeax));
dec(len,lo(regs.realeax));
{ stop when not the specified size is read }
if lo(regs.realeax)<size then
break;
end;
do_read:=readsize;
end;
function do_filepos(handle : longint) : longint;
var
regs : trealregs;
begin
regs.realebx:=handle;
regs.realecx:=0;
regs.realedx:=0;
regs.realeax:=$4201;
sysrealintr($21,regs);
if (regs.realflags and carryflag) <> 0 then
Begin
GetInOutRes(lo(regs.realeax));
do_filepos:=0;
end
else
do_filepos:=lo(regs.realedx) shl 16+lo(regs.realeax);
end;
procedure do_seek(handle,pos : longint);
var
regs : trealregs;
begin
regs.realebx:=handle;
regs.realecx:=pos shr 16;
regs.realedx:=pos and $ffff;
regs.realeax:=$4200;
sysrealintr($21,regs);
if (regs.realflags and carryflag) <> 0 then
GetInOutRes(lo(regs.realeax));
end;
function do_seekend(handle:longint):longint;
var
regs : trealregs;
begin
regs.realebx:=handle;
regs.realecx:=0;
regs.realedx:=0;
regs.realeax:=$4202;
sysrealintr($21,regs);
if (regs.realflags and carryflag) <> 0 then
Begin
GetInOutRes(lo(regs.realeax));
do_seekend:=0;
end
else
do_seekend:=lo(regs.realedx) shl 16+lo(regs.realeax);
end;
function do_filesize(handle : longint) : longint;
var
aktfilepos : longint;
begin
aktfilepos:=do_filepos(handle);
do_filesize:=do_seekend(handle);
do_seek(handle,aktfilepos);
end;
{ truncate at a given position }
procedure do_truncate (handle,pos:longint);
var
regs : trealregs;
begin
do_seek(handle,pos);
regs.realecx:=0;
regs.realedx:=tb_offset;
regs.realds:=tb_segment;
regs.realebx:=handle;
regs.realeax:=$4000;
sysrealintr($21,regs);
if (regs.realflags and carryflag) <> 0 then
GetInOutRes(lo(regs.realeax));
end;
const
FileHandleCount : longint = 20;
function Increase_file_handle_count : boolean;
var
regs : trealregs;
begin
Inc(FileHandleCount,10);
regs.realebx:=FileHandleCount;
regs.realeax:=$6700;
sysrealintr($21,regs);
if (regs.realflags and carryflag) <> 0 then
begin
Increase_file_handle_count:=false;
Dec (FileHandleCount, 10);
end
else
Increase_file_handle_count:=true;
end;
function dos_version : word;
var
regs : trealregs;
begin
regs.realeax := $3000;
sysrealintr($21,regs);
dos_version := regs.realeax
end;
procedure do_open(var f;p:pchar;flags:longint);
{
filerec and textrec have both handle and mode as the first items so
they could use the same routine for opening/creating.
when (flags and $100) the file will be append
when (flags and $1000) the file will be truncate/rewritten
when (flags and $10000) there is no check for close (needed for textfiles)
}
var
regs : trealregs;
action : longint;
Avoid6c00 : boolean;
begin
DoDirSeparators(p);
{ check if Extended Open/Create API is safe to use }
Avoid6c00 := lo(dos_version) < 7;
{ close first if opened }
if ((flags and $10000)=0) then
begin
case filerec(f).mode of
fminput,fmoutput,fminout : Do_Close(filerec(f).handle);
fmclosed : ;
else
begin
inoutres:=102; {not assigned}
exit;
end;
end;
end;
{ reset file handle }
filerec(f).handle:=UnusedHandle;
action:=$1;
{ convert filemode to filerec modes }
case (flags and 3) of
0 : filerec(f).mode:=fminput;
1 : filerec(f).mode:=fmoutput;
2 : filerec(f).mode:=fminout;
end;
if (flags and $1000)<>0 then
action:=$12; {create file function}
{ empty name is special }
if p[0]=#0 then
begin
case FileRec(f).mode of
fminput :
FileRec(f).Handle:=StdInputHandle;
fminout, { this is set by rewrite }
fmoutput :
FileRec(f).Handle:=StdOutputHandle;
fmappend :
begin
FileRec(f).Handle:=StdOutputHandle;
FileRec(f).mode:=fmoutput; {fool fmappend}
end;
end;
exit;
end;
{ real dos call }
syscopytodos(longint(p),strlen(p)+1);
{$ifndef RTLLITE}
if LFNSupport then
regs.realeax := $716c { Use LFN Open/Create API }
else
regs.realeax:=$6c00;
{$endif RTLLITE}
if Avoid6c00 then
regs.realeax := $3d00 + (flags and $ff) { For now, map to Open API }
else
regs.realeax := $6c00; { Use Extended Open/Create API }
if byte(regs.realeax shr 8) = $3d then
begin { Using the older Open or Create API's }
if (action and $00f0) <> 0 then
regs.realeax := $3c00; { Map to Create/Replace API }
regs.realds := tb_segment;
regs.realedx := tb_offset;
end
else
begin { Using LFN or Extended Open/Create API }
regs.realedx := action; { action if file does/doesn't exist }
regs.realds := tb_segment;
regs.realesi := tb_offset;
regs.realebx := $2000 + (flags and $ff); { file open mode }
end;
regs.realecx := $20; { file attributes }
sysrealintr($21,regs);
{$ifndef RTLLITE}
if (regs.realflags and carryflag) <> 0 then
if lo(regs.realeax)=4 then
if Increase_file_handle_count then
begin
{ Try again }
if LFNSupport then
regs.realeax := $716c {Use LFN Open/Create API}
else
if Avoid6c00 then
regs.realeax := $3d00+(flags and $ff) {For now, map to Open API}
else
regs.realeax := $6c00; {Use Extended Open/Create API}
if byte(regs.realeax shr 8) = $3d then
begin { Using the older Open or Create API's }
if (action and $00f0) <> 0 then
regs.realeax := $3c00; {Map to Create/Replace API}
regs.realds := tb_segment;
regs.realedx := tb_offset;
end
else
begin { Using LFN or Extended Open/Create API }
regs.realedx := action; {action if file does/doesn't exist}
regs.realds := tb_segment;
regs.realesi := tb_offset;
regs.realebx := $2000+(flags and $ff); {file open mode}
end;
regs.realecx := $20; {file attributes}
sysrealintr($21,regs);
end;
{$endif RTLLITE}
if (regs.realflags and carryflag) <> 0 then
begin
GetInOutRes(lo(regs.realeax));
exit;
end
else
begin
filerec(f).handle:=lo(regs.realeax);
{$ifndef RTLLITE}
{ for systems that have more then 20 by default ! }
if lo(regs.realeax)>FileHandleCount then
FileHandleCount:=lo(regs.realeax);
{$endif RTLLITE}
end;
if lo(regs.realeax)<max_files then
begin
{$ifdef SYSTEMDEBUG}
if openfiles[lo(regs.realeax)] and
assigned(opennames[lo(regs.realeax)]) then
begin
Writeln(stderr,'file ',opennames[lo(regs.realeax)],'(',lo(regs.realeax),') not closed but handle reused!');
sysfreememsize(opennames[lo(regs.realeax)],strlen(opennames[lo(regs.realeax)])+1);
end;
{$endif SYSTEMDEBUG}
openfiles[lo(regs.realeax)]:=true;
{$ifdef SYSTEMDEBUG}
opennames[lo(regs.realeax)] := sysgetmem(strlen(p)+1);
move(p^,opennames[lo(regs.realeax)]^,strlen(p)+1);
{$endif SYSTEMDEBUG}
end;
{ append mode }
if ((flags and $100) <> 0) and
(FileRec (F).Handle <> UnusedHandle) then
begin
do_seekend(filerec(f).handle);
filerec(f).mode:=fmoutput; {fool fmappend}
end;
end;
function do_isdevice(handle:THandle):boolean;
var
regs : trealregs;
begin
regs.realebx:=handle;
regs.realeax:=$4400;
sysrealintr($21,regs);
do_isdevice:=(regs.realedx and $80)<>0;
if (regs.realflags and carryflag) <> 0 then
GetInOutRes(lo(regs.realeax));
end;

60
rtl/watcom/sysheap.inc
View File

@ -1,30 +1,30 @@
{*****************************************************************************
OS Memory allocation / deallocation
****************************************************************************}
function ___sbrk(size:longint):pointer;cdecl; external name '___sbrk';
function SysOSAlloc(size: ptrint): pointer;assembler;
asm
{$ifdef SYSTEMDEBUG}
cmpb $1,accept_sbrk
je .Lsbrk
movl $0,%eax
jmp .Lsbrk_fail
.Lsbrk:
{$endif}
movl size,%eax
pushl %eax
call ___sbrk
addl $4,%esp
{$ifdef SYSTEMDEBUG}
.Lsbrk_fail:
{$endif}
end;
{ define HAS_SYSOSFREE}
procedure SysOSFree(p: pointer; size: ptrint);
begin
end;
{*****************************************************************************
OS Memory allocation / deallocation
****************************************************************************}
function ___sbrk(size:longint):pointer;cdecl; external name '___sbrk';
function SysOSAlloc(size: ptrint): pointer;assembler;
asm
{$ifdef SYSTEMDEBUG}
cmpb $1,accept_sbrk
je .Lsbrk
movl $0,%eax
jmp .Lsbrk_fail
.Lsbrk:
{$endif}
movl size,%eax
pushl %eax
call ___sbrk
addl $4,%esp
{$ifdef SYSTEMDEBUG}
.Lsbrk_fail:
{$endif}
end;
{ define HAS_SYSOSFREE}
procedure SysOSFree(p: pointer; size: ptrint);
begin
end;

314
rtl/watcom/sysos.inc
View File

@ -1,157 +1,157 @@
{*****************************************************************************
Watcom Helpers
*****************************************************************************}
const
carryflag = 1;
type
tseginfo=packed record
offset : pointer;
segment : word;
end;
var
old_int00 : tseginfo;cvar;
old_int75 : tseginfo;cvar;
procedure getinoutres(def : word);
var
regs : trealregs;
begin
regs.realeax:=$5900;
regs.realebx:=$0;
sysrealintr($21,regs);
InOutRes:=lo(regs.realeax);
case InOutRes of
19 : InOutRes:=150;
21 : InOutRes:=152;
32 : InOutRes:=5;
end;
if InOutRes=0 then
InOutRes:=Def;
end;
function far_strlen(selector : word;linear_address : sizeuint) : longint;assembler;
asm
movl linear_address,%edx
movl %edx,%ecx
movw selector,%gs
.Larg19:
movb %gs:(%edx),%al
testb %al,%al
je .Larg20
incl %edx
jmp .Larg19
.Larg20:
movl %edx,%eax
subl %ecx,%eax
end;
function get_ds : word;assembler;
asm
movw %ds,%ax
end;
function get_cs : word;assembler;
asm
movw %cs,%ax
end;
function dos_selector : word; assembler;
asm
movw %ds,%ax { no separate selector needed }
end;
procedure alloc_tb; assembler;
{ allocate 8kB real mode transfer buffer }
asm
pushl %ebx
movw $0x100,%ax
movw $512,%bx
int $0x31
movw %ax,tb_segment
shll $16,%eax
shrl $12,%eax
movl %eax,tb
popl %ebx
end;
procedure sysseg_move(sseg : word;source : sizeuint;dseg : word;dest : sizeuint;count : longint);
begin
if count=0 then
exit;
if (sseg<>dseg) or ((sseg=dseg) and (source>dest)) then
asm
pushl %esi
pushl %edi
pushw %es
pushw %ds
cld
movl count,%ecx
movl source,%esi
movl dest,%edi
movw dseg,%ax
movw %ax,%es
movw sseg,%ax
movw %ax,%ds
movl %ecx,%eax
shrl $2,%ecx
rep
movsl
movl %eax,%ecx
andl $3,%ecx
rep
movsb
popw %ds
popw %es
popl %edi
popl %esi
end
else if (source<dest) then
{ copy backward for overlapping }
asm
pushl %esi
pushl %edi
pushw %es
pushw %ds
std
movl count,%ecx
movl source,%esi
movl dest,%edi
movw dseg,%ax
movw %ax,%es
movw sseg,%ax
movw %ax,%ds
addl %ecx,%esi
addl %ecx,%edi
movl %ecx,%eax
andl $3,%ecx
orl %ecx,%ecx
jz .LSEG_MOVE1
{ calculate esi and edi}
decl %esi
decl %edi
rep
movsb
incl %esi
incl %edi
.LSEG_MOVE1:
subl $4,%esi
subl $4,%edi
movl %eax,%ecx
shrl $2,%ecx
rep
movsl
cld
popw %ds
popw %es
popl %edi
popl %esi
end;
end;
{*****************************************************************************
Watcom Helpers
*****************************************************************************}
const
carryflag = 1;
type
tseginfo=packed record
offset : pointer;
segment : word;
end;
var
old_int00 : tseginfo;cvar;
old_int75 : tseginfo;cvar;
procedure getinoutres(def : word);
var
regs : trealregs;
begin
regs.realeax:=$5900;
regs.realebx:=$0;
sysrealintr($21,regs);
InOutRes:=lo(regs.realeax);
case InOutRes of
19 : InOutRes:=150;
21 : InOutRes:=152;
32 : InOutRes:=5;
end;
if InOutRes=0 then
InOutRes:=Def;
end;
function far_strlen(selector : word;linear_address : sizeuint) : longint;assembler;
asm
movl linear_address,%edx
movl %edx,%ecx
movw selector,%gs
.Larg19:
movb %gs:(%edx),%al
testb %al,%al
je .Larg20
incl %edx
jmp .Larg19
.Larg20:
movl %edx,%eax
subl %ecx,%eax
end;
function get_ds : word;assembler;
asm
movw %ds,%ax
end;
function get_cs : word;assembler;
asm
movw %cs,%ax
end;
function dos_selector : word; assembler;
asm
movw %ds,%ax { no separate selector needed }
end;
procedure alloc_tb; assembler;
{ allocate 8kB real mode transfer buffer }
asm
pushl %ebx
movw $0x100,%ax
movw $512,%bx
int $0x31
movw %ax,tb_segment
shll $16,%eax
shrl $12,%eax
movl %eax,tb
popl %ebx
end;
procedure sysseg_move(sseg : word;source : sizeuint;dseg : word;dest : sizeuint;count : longint);
begin
if count=0 then
exit;
if (sseg<>dseg) or ((sseg=dseg) and (source>dest)) then
asm
pushl %esi
pushl %edi
pushw %es
pushw %ds
cld
movl count,%ecx
movl source,%esi
movl dest,%edi
movw dseg,%ax
movw %ax,%es
movw sseg,%ax
movw %ax,%ds
movl %ecx,%eax
shrl $2,%ecx
rep
movsl
movl %eax,%ecx
andl $3,%ecx
rep
movsb
popw %ds
popw %es
popl %edi
popl %esi
end
else if (source<dest) then
{ copy backward for overlapping }
asm
pushl %esi
pushl %edi
pushw %es
pushw %ds
std
movl count,%ecx
movl source,%esi
movl dest,%edi
movw dseg,%ax
movw %ax,%es
movw sseg,%ax
movw %ax,%ds
addl %ecx,%esi
addl %ecx,%edi
movl %ecx,%eax
andl $3,%ecx
orl %ecx,%ecx
jz .LSEG_MOVE1
{ calculate esi and edi}
decl %esi
decl %edi
rep
movsb
incl %esi
incl %edi
.LSEG_MOVE1:
subl $4,%esi
subl $4,%edi
movl %eax,%ecx
shrl $2,%ecx
rep
movsl
cld
popw %ds
popw %es
popl %edi
popl %esi
end;
end;

58
rtl/watcom/sysosh.inc
View File

@ -1,29 +1,29 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2001 by Free Pascal development team
This file implements all the base types and limits required
for a minimal POSIX compliant subset required to port the compiler
to a new OS.
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.
**********************************************************************}
{Platform specific information}
type
THandle = Longint;
TThreadID = THandle;
PRTLCriticalSection = ^TRTLCriticalSection;
TRTLCriticalSection = record
Locked: boolean
end;
{
This file is part of the Free Pascal run time library.
Copyright (c) 2001 by Free Pascal development team
This file implements all the base types and limits required
for a minimal POSIX compliant subset required to port the compiler
to a new OS.
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.
**********************************************************************}
{Platform specific information}
type
THandle = Longint;
TThreadID = THandle;
PRTLCriticalSection = ^TRTLCriticalSection;
TRTLCriticalSection = record
Locked: boolean
end;

18
tests/tbf/tb0199.pp
View File

@ -1,9 +1,9 @@
{%NORUN}
{%FAIL}
type
test = record
f3,,,f5,,, : Boolean;
end;
begin
end.
{%NORUN}
{%FAIL}
type
test = record
f3,,,f5,,, : Boolean;
end;
begin
end.

18
tests/tbf/tb0199a.pp
View File

@ -1,9 +1,9 @@
{%NORUN}
{%FAIL}
type
test = record
f3,f5, : Boolean;
end;
begin
end.
{%NORUN}
{%FAIL}
type
test = record
f3,f5, : Boolean;
end;
begin
end.

62
tests/test/targ1a.pp
View File

@ -1,31 +1,31 @@
program go32v2_crash;
const
MAX_SIZE = 256;
SIZE_INC = 8;
type
TMemArray = array [0..MAX_SIZE div SIZE_INC] of pointer;
var
i : longint;
MemArray : TMemArray;
function Size(i: longint) : longint;
begin
Size:=1+SIZE_INC*i;
end;
begin
FillChar(MemArray,Sizeof(MemArray),#0);
for i:=0 to MAX_SIZE div SIZE_INC do
begin
GetMem(MemArray[i],Size(i));
end;
for i:=1 to MAX_SIZE div SIZE_INC do
begin
FreeMem(MemArray[i],Size(i));
end;
Writeln(stderr,'Everthing is fine');
end.
program go32v2_crash;
const
MAX_SIZE = 256;
SIZE_INC = 8;
type
TMemArray = array [0..MAX_SIZE div SIZE_INC] of pointer;
var
i : longint;
MemArray : TMemArray;
function Size(i: longint) : longint;
begin
Size:=1+SIZE_INC*i;
end;
begin
FillChar(MemArray,Sizeof(MemArray),#0);
for i:=0 to MAX_SIZE div SIZE_INC do
begin
GetMem(MemArray[i],Size(i));
end;
for i:=1 to MAX_SIZE div SIZE_INC do
begin
FreeMem(MemArray[i],Size(i));
end;
Writeln(stderr,'Everthing is fine');
end.

188
tests/test/targ1b.pp
View File

@ -1,94 +1,94 @@
{%skiptarget=wince}
{ This file is to check if there is some memory corruption
due to startup code with argument loading
go32v2 target had this problem
close to 2.2 release 2007-03-27 pierre }
program create_startup_test_crash;
{$ifdef go32v2}
{$define HasExeSuffix}
{$endif}
{$ifdef win32}
{$define HasExeSuffix}
{$endif}
{$ifdef win64}
{$define HasExeSuffix}
{$endif}
{$ifdef wince}
{$define HasExeSuffix}
{$endif}
{$ifdef os2}
{$define HasExeSuffix}
{$endif}
{$ifdef emx}
{$define HasExeSuffix}
{$endif}
{$ifdef wdosx}
{$define HasExeSuffix}
{$endif}
{$ifdef netware}
{$define HasNlmSuffix}
{$endif}
{$ifdef netwlibc}
{$define HasNlmSuffix}
{$endif}
uses
dos;
const
ExeSuffix =
{$ifdef HasExeSuffix}
'.exe'
{$else}
{$ifdef HasNlmSuffix}
'.nlm'
{$else}
''
{$endif}
{$endif}
;
const
MAX = 255;
var
cmd,
arg : string;
i, first_wrong : longint;
const
Everything_ok : boolean = true;
begin
cmd:='targ1a'+ExeSuffix;
arg:='';
first_wrong:=-1;
for i:=0 to MAX do
begin
Writeln(stderr,'Going to call "',cmd,'" with arg = "',arg,'"');
Writeln(stderr,'arg length =',length(arg));
Exec(cmd,arg);
if (DosExitCode<>0) or (DosError<>0) then
begin
Writeln(stderr,'Crash detected');
if first_wrong=-1 then
first_wrong:=i;
Everything_ok := false;
end;
arg:=arg+'a';
end;
if Everything_ok then
begin
Writeln(stderr,'Test successful: no memory corruption occurs');
end
else
begin
Writeln(stderr,'Test fails: Memory corruption occurs');
Writeln(stderr,'First arg length where error appears is ',first_wrong);
if first_wrong<100 then
RunError(1)
else
Writeln(stderr,'Warning: when using Dos.Exec, arg length must be smaller than ',first_wrong);
end;
end.
{%skiptarget=wince}
{ This file is to check if there is some memory corruption
due to startup code with argument loading
go32v2 target had this problem
close to 2.2 release 2007-03-27 pierre }
program create_startup_test_crash;
{$ifdef go32v2}
{$define HasExeSuffix}
{$endif}
{$ifdef win32}
{$define HasExeSuffix}
{$endif}
{$ifdef win64}
{$define HasExeSuffix}
{$endif}
{$ifdef wince}
{$define HasExeSuffix}
{$endif}
{$ifdef os2}
{$define HasExeSuffix}
{$endif}
{$ifdef emx}
{$define HasExeSuffix}
{$endif}
{$ifdef wdosx}
{$define HasExeSuffix}
{$endif}
{$ifdef netware}
{$define HasNlmSuffix}
{$endif}
{$ifdef netwlibc}
{$define HasNlmSuffix}
{$endif}
uses
dos;
const
ExeSuffix =
{$ifdef HasExeSuffix}
'.exe'
{$else}
{$ifdef HasNlmSuffix}
'.nlm'
{$else}
''
{$endif}
{$endif}
;
const
MAX = 255;
var
cmd,
arg : string;
i, first_wrong : longint;
const
Everything_ok : boolean = true;
begin
cmd:='targ1a'+ExeSuffix;
arg:='';
first_wrong:=-1;
for i:=0 to MAX do
begin
Writeln(stderr,'Going to call "',cmd,'" with arg = "',arg,'"');
Writeln(stderr,'arg length =',length(arg));
Exec(cmd,arg);
if (DosExitCode<>0) or (DosError<>0) then
begin
Writeln(stderr,'Crash detected');
if first_wrong=-1 then
first_wrong:=i;
Everything_ok := false;
end;
arg:=arg+'a';
end;
if Everything_ok then
begin
Writeln(stderr,'Test successful: no memory corruption occurs');
end
else
begin
Writeln(stderr,'Test fails: Memory corruption occurs');
Writeln(stderr,'First arg length where error appears is ',first_wrong);
if first_wrong<100 then
RunError(1)
else
Writeln(stderr,'Warning: when using Dos.Exec, arg length must be smaller than ',first_wrong);
end;
end.

118
tests/test/units/system/tres.pp
View File

@ -1,59 +1,59 @@
{ Test for resources support. }
{%TARGET=win32,win64,wince,linux,freebsd,darwin,netbsd,openbsd,solaris}
{$mode objfpc}
{$R tres1.res}
procedure Fail(const Msg: string);
begin
writeln(Msg);
Halt(1);
end;
function GetResource(ResourceName, ResourceType: PChar; PResSize: PLongInt = nil): pointer;
var
hRes: TFPResourceHandle;
gRes: TFPResourceHGLOBAL;
begin
hRes:=FindResource(HINSTANCE, ResourceName, ResourceType);
if hRes = 0 then
Fail('FindResource failed.');
gRes:=LoadResource(HINSTANCE, hRes);
if gRes = 0 then
Fail('LoadResource failed.');
if PResSize <> nil then begin
PResSize^:=SizeofResource(HINSTANCE, hRes);
if PResSize^ = 0 then
Fail('SizeofResource failed.');
end;
Result:=LockResource(gRes);
if Result = nil then
Fail('LockResource failed.');
end;
procedure DoTest;
var
s: string;
p: PChar;
sz: longint;
begin
p:=GetResource('TestFile', 'FILE', @sz);
SetString(s, p, sz);
if s <> 'test file.' then
Fail('Invalid resource loaded.');
writeln(s);
p:=GetResource('Test', 'TEXT', @sz);
SetString(s, p, sz);
if s <> 'Another test file.' then
Fail('Invalid resource loaded.');
writeln(s);
end;
begin
writeln('Resources test.');
DoTest;
writeln('Done.');
end.
{ Test for resources support. }
{%TARGET=win32,win64,wince,linux,freebsd,darwin,netbsd,openbsd,solaris}
{$mode objfpc}
{$R tres1.res}
procedure Fail(const Msg: string);
begin
writeln(Msg);
Halt(1);
end;
function GetResource(ResourceName, ResourceType: PChar; PResSize: PLongInt = nil): pointer;
var
hRes: TFPResourceHandle;
gRes: TFPResourceHGLOBAL;
begin
hRes:=FindResource(HINSTANCE, ResourceName, ResourceType);
if hRes = 0 then
Fail('FindResource failed.');
gRes:=LoadResource(HINSTANCE, hRes);
if gRes = 0 then
Fail('LoadResource failed.');
if PResSize <> nil then begin
PResSize^:=SizeofResource(HINSTANCE, hRes);
if PResSize^ = 0 then
Fail('SizeofResource failed.');
end;
Result:=LockResource(gRes);
if Result = nil then
Fail('LockResource failed.');
end;
procedure DoTest;
var
s: string;
p: PChar;
sz: longint;
begin
p:=GetResource('TestFile', 'FILE', @sz);
SetString(s, p, sz);
if s <> 'test file.' then
Fail('Invalid resource loaded.');
writeln(s);
p:=GetResource('Test', 'TEXT', @sz);
SetString(s, p, sz);
if s <> 'Another test file.' then
Fail('Invalid resource loaded.');
writeln(s);
end;
begin
writeln('Resources test.');
DoTest;
writeln('Done.');
end.

62
tests/test/units/system/tval.pp
View File

@ -1,31 +1,31 @@
program TestVal;
uses
{ longint type, short string }
tval1,
{ dword type, short string }
tval2,
{ int64 type, short string }
tval3,
{ uint64 type, short string }
tval4,
{ common variables and functions }
tvalc;
begin
if (paramcount>0) and
(paramstr(1)='verbose') then
silent:=false;
TestAllVal1;
TestAllVal2;
TestAllVal3;
TestAllVal4;
if HasErrors then
begin
Writeln('Test tval failed');
Halt(1);
end;
end.
program TestVal;
uses
{ longint type, short string }
tval1,
{ dword type, short string }
tval2,
{ int64 type, short string }
tval3,
{ uint64 type, short string }
tval4,
{ common variables and functions }
tvalc;
begin
if (paramcount>0) and
(paramstr(1)='verbose') then
silent:=false;
TestAllVal1;
TestAllVal2;
TestAllVal3;
TestAllVal4;
if HasErrors then
begin
Writeln('Test tval failed');
Halt(1);
end;
end.

54
tests/test/units/system/tval1.pp
View File

@ -1,27 +1,27 @@
unit tval1;
{$mode fpc}
interface
function TestAllVal1 : boolean;
implementation
uses
tvalc;
type
IntegerType = longint;
{$i tval.inc}
function TestAllVal1 : boolean;
begin
Writeln('Test val for longint type');
TestAllVal1:=TestAll;
end;
end.
unit tval1;
{$mode fpc}
interface
function TestAllVal1 : boolean;
implementation
uses
tvalc;
type
IntegerType = longint;
{$i tval.inc}
function TestAllVal1 : boolean;
begin
Writeln('Test val for longint type');
TestAllVal1:=TestAll;
end;
end.

54
tests/test/units/system/tval2.pp
View File

@ -1,27 +1,27 @@
unit tval2;
{$mode fpc}
interface
function TestAllval2 : boolean;
implementation
uses
tvalc;
type
IntegerType = dword;
{$i tval.inc}
function TestAllval2 : boolean;
begin
Writeln('Test val for dword type');
TestAllval2:=TestAll;
end;
end.
unit tval2;
{$mode fpc}
interface
function TestAllval2 : boolean;
implementation
uses
tvalc;
type
IntegerType = dword;
{$i tval.inc}
function TestAllval2 : boolean;
begin
Writeln('Test val for dword type');
TestAllval2:=TestAll;
end;
end.

54
tests/test/units/system/tval3.pp
View File

@ -1,27 +1,27 @@
unit tval3;
{$mode fpc}
interface
function TestAllval3 : boolean;
implementation
uses
tvalc;
type
IntegerType = int64;
{$i tval.inc}
function TestAllval3 : boolean;
begin
Writeln('Test val for int64 type');
TestAllval3:=TestAll;
end;
end.
unit tval3;
{$mode fpc}
interface
function TestAllval3 : boolean;
implementation
uses
tvalc;
type
IntegerType = int64;
{$i tval.inc}
function TestAllval3 : boolean;
begin
Writeln('Test val for int64 type');
TestAllval3:=TestAll;
end;
end.

54
tests/test/units/system/tval4.pp
View File

@ -1,27 +1,27 @@
unit tval4;
{$mode fpc}
interface
function TestAllval4 : boolean;
implementation
uses
tvalc;
type
IntegerType = qword;
{$i tval.inc}
function TestAllval4 : boolean;
begin
Writeln('Test val for qword type');
TestAllval4:=TestAll;
end;
end.
unit tval4;
{$mode fpc}
interface
function TestAllval4 : boolean;
implementation
uses
tvalc;
type
IntegerType = qword;
{$i tval.inc}
function TestAllval4 : boolean;
begin
Writeln('Test val for qword type');
TestAllval4:=TestAll;
end;
end.

126
tests/test/units/system/tvalc.pp
View File

@ -1,63 +1,63 @@
unit tvalc;
interface
const
HasErrors : boolean = false;
Silent : boolean = true;
CheckVal : boolean = true;
SuccessCount : longint = 0;
FailCount : longint = 0;
type
TCharSet = set of char;
const
ValidNumeralsBase2 : TCHarSet = ['0'..'1'];
ValidNumeralsBase8 : TCHarSet = ['0'..'7'];
ValidNumeralsBase10 : TCHarSet = ['0'..'9'];
ValidNumeralsBase16 : TCHarSet = ['0'..'9','a'..'f','A'..'F'];
SpecialCharsFirst : TCharSet = [' ',#9,'x','X','$','&','%','+','-'];
SpecialCharsSecond : TCharSet = [#0];
type
ValTestType =
(ValShouldFail,
ValShouldSucceed,
ValShouldSucceedAfterRemovingTrail);
function Display(const s : string) : string;
implementation
function Display(const s : string) : string;
var
res,ordval : string;
i : longint;
quoted : boolean;
begin
res:='"';
quoted:=false;
for i:=1 to length(s) do
if ord(s[i])<32 then
begin
if quoted then
res:=res+'''';
str(ord(s[i]),ordval);
res:=res+'#'+ordval;
quoted:=false;
end
else
begin
if not quoted then
res:=res+'''';
quoted:=true;
res:=res+s[i];
end;
if quoted then
res:=res+'''';
res:=res+'"';
Display:=res;
end;
end.
unit tvalc;
interface
const
HasErrors : boolean = false;
Silent : boolean = true;
CheckVal : boolean = true;
SuccessCount : longint = 0;
FailCount : longint = 0;
type
TCharSet = set of char;
const
ValidNumeralsBase2 : TCHarSet = ['0'..'1'];
ValidNumeralsBase8 : TCHarSet = ['0'..'7'];
ValidNumeralsBase10 : TCHarSet = ['0'..'9'];
ValidNumeralsBase16 : TCHarSet = ['0'..'9','a'..'f','A'..'F'];
SpecialCharsFirst : TCharSet = [' ',#9,'x','X','$','&','%','+','-'];
SpecialCharsSecond : TCharSet = [#0];
type
ValTestType =
(ValShouldFail,
ValShouldSucceed,
ValShouldSucceedAfterRemovingTrail);
function Display(const s : string) : string;
implementation
function Display(const s : string) : string;
var
res,ordval : string;
i : longint;
quoted : boolean;
begin
res:='"';
quoted:=false;
for i:=1 to length(s) do
if ord(s[i])<32 then
begin
if quoted then
res:=res+'''';
str(ord(s[i]),ordval);
res:=res+'#'+ordval;
quoted:=false;
end
else
begin
if not quoted then
res:=res+'''';
quoted:=true;
res:=res+s[i];
end;
if quoted then
res:=res+'''';
res:=res+'"';
Display:=res;
end;
end.

112
tests/test/units/sysutils/tfloattostr.pp
View File

@ -1,56 +1,56 @@
{ Test for FloatToStr and CurrToStr functions. }
uses sysutils;
const
MaxCurrency : currency = 922337203685477.5807;
MinCurrency : currency = -922337203685477.5807;
var
ErrCount: longint;
procedure CheckResult(const s, ref: string);
begin
if s <> ref then
begin
writeln('Got : ', s);
writeln('Should be: ', ref);
Inc(ErrCount);
end;
end;
var
e: extended;
d: double;
s: single;
c: currency;
begin
e:=1234567890123.4;
d:=12345.12345;
s:=12345.12;
c:=12345.1234;
CheckResult(FloatToStrF(e,ffExponent,15,1), '1'+DecimalSeparator+'23456789012340E+12');
CheckResult(FloatToStrF(d,ffExponent,11,0), '1'+DecimalSeparator+'2345123450E+4');
CheckResult(FloatToStrF(s,ffExponent,8,0), '1'+DecimalSeparator+'2345120E+4');
CheckResult(FloatToStrF(s,ffExponent,8,7), '1'+DecimalSeparator+'2345120E+0004');
CheckResult(FloatToStrF(e,ffExponent,8,3), '1'+DecimalSeparator+'2345679E+012');
CheckResult(FloatToStrF(c,ffExponent,10,0), '1'+DecimalSeparator+'234512340E+4');
CheckResult(FloatToStrF(c,ffExponent,11,2), '1'+DecimalSeparator+'2345123400E+04');
CheckResult(FloatToStrF(c,ffExponent,10,4), '1'+DecimalSeparator+'234512340E+0004');
CheckResult(FloatToStrF(-12345.12345,ffExponent,11,0), '-1'+DecimalSeparator+'2345123450E+4');
CheckResult(FloatToStrF(-0.00000123,ffGeneral,15,0), '-1'+DecimalSeparator+'23E-6');
CheckResult(FloatToStrF(-12345.12345,ffGeneral,7,0), '-12345'+DecimalSeparator+'12');
CheckResult(CurrToStr(-12345.1234), '-12345'+DecimalSeparator+'1234');
CheckResult(CurrToStr(MaxCurrency), '922337203685477'+DecimalSeparator+'5807');
CheckResult(CurrToStr(MinCurrency), '-922337203685477'+DecimalSeparator+'5807');
NegCurrFormat:=8;
CheckResult(FloatToStrF(-12345.1234,ffCurrency,19,4), '-12' + ThousandSeparator + '345'+DecimalSeparator+'1234 ' + CurrencyString);
CheckResult(FloatToStrF(MinCurrency,ffCurrency,19,4), '-922' + ThousandSeparator + '337' + ThousandSeparator + '203' + ThousandSeparator + '685' + ThousandSeparator + '477'+DecimalSeparator+'5807 ' + CurrencyString);
if ErrCount > 0 then
begin
writeln('Test failed. Errors: ', ErrCount);
Halt(1);
end
else
writeln('Test completed.');
end.
{ Test for FloatToStr and CurrToStr functions. }
uses sysutils;
const
MaxCurrency : currency = 922337203685477.5807;
MinCurrency : currency = -922337203685477.5807;
var
ErrCount: longint;
procedure CheckResult(const s, ref: string);
begin
if s <> ref then
begin
writeln('Got : ', s);
writeln('Should be: ', ref);
Inc(ErrCount);
end;
end;
var
e: extended;
d: double;
s: single;
c: currency;
begin
e:=1234567890123.4;
d:=12345.12345;
s:=12345.12;
c:=12345.1234;
CheckResult(FloatToStrF(e,ffExponent,15,1), '1'+DecimalSeparator+'23456789012340E+12');
CheckResult(FloatToStrF(d,ffExponent,11,0), '1'+DecimalSeparator+'2345123450E+4');
CheckResult(FloatToStrF(s,ffExponent,8,0), '1'+DecimalSeparator+'2345120E+4');
CheckResult(FloatToStrF(s,ffExponent,8,7), '1'+DecimalSeparator+'2345120E+0004');
CheckResult(FloatToStrF(e,ffExponent,8,3), '1'+DecimalSeparator+'2345679E+012');
CheckResult(FloatToStrF(c,ffExponent,10,0), '1'+DecimalSeparator+'234512340E+4');
CheckResult(FloatToStrF(c,ffExponent,11,2), '1'+DecimalSeparator+'2345123400E+04');
CheckResult(FloatToStrF(c,ffExponent,10,4), '1'+DecimalSeparator+'234512340E+0004');
CheckResult(FloatToStrF(-12345.12345,ffExponent,11,0), '-1'+DecimalSeparator+'2345123450E+4');
CheckResult(FloatToStrF(-0.00000123,ffGeneral,15,0), '-1'+DecimalSeparator+'23E-6');
CheckResult(FloatToStrF(-12345.12345,ffGeneral,7,0), '-12345'+DecimalSeparator+'12');
CheckResult(CurrToStr(-12345.1234), '-12345'+DecimalSeparator+'1234');
CheckResult(CurrToStr(MaxCurrency), '922337203685477'+DecimalSeparator+'5807');
CheckResult(CurrToStr(MinCurrency), '-922337203685477'+DecimalSeparator+'5807');
NegCurrFormat:=8;
CheckResult(FloatToStrF(-12345.1234,ffCurrency,19,4), '-12' + ThousandSeparator + '345'+DecimalSeparator+'1234 ' + CurrencyString);
CheckResult(FloatToStrF(MinCurrency,ffCurrency,19,4), '-922' + ThousandSeparator + '337' + ThousandSeparator + '203' + ThousandSeparator + '685' + ThousandSeparator + '477'+DecimalSeparator+'5807 ' + CurrencyString);
if ErrCount > 0 then
begin
writeln('Test failed. Errors: ', ErrCount);
Halt(1);
end
else
writeln('Test completed.');
end.

38
tests/webtbf/tw6957.pp
View File

@ -1,19 +1,19 @@
{ %fail }
{$IFDEF FPC}
{$MODE TP}
{$ENDIF FPC}
unit tw6957;
interface
function tw6957: boolean;
implementation
function tw6957: boolean;
begin
tw6957 := true;
end;
end.
{ %fail }
{$IFDEF FPC}
{$MODE TP}
{$ENDIF FPC}
unit tw6957;
interface
function tw6957: boolean;
implementation
function tw6957: boolean;
begin
tw6957 := true;
end;
end.

108
tests/webtbs/tw5082.pp
View File

@ -1,54 +1,54 @@
{ Source provided for Free Pascal Bug Report 5082 }
{ Submitted by "Martin Schreiber" on 2006-05-01 }
{ e-mail: }
program storedfalse;
{$ifdef FPC}{$mode objfpc}{$h+}{$INTERFACES CORBA}{$endif}
{$ifdef mswindows}{$apptype console}{$endif}
uses
{$ifdef FPC}{$ifdef linux}cthreads,{$endif}{$endif}
sysutils,classes;
type
ttestclass1 = class(tcomponent)
private
fprop1: real;
public
property prop1: real read fprop1 write fprop1 stored false;
end;
ttestclass2 = class(ttestclass1)
published
property prop1;
end;
var
testclass2: ttestclass2;
stream1,stream2: tmemorystream;
str1: string;
begin
testclass2:= ttestclass2.create(nil);
testclass2.prop1:= 1;
stream1:= tmemorystream.create;
try
stream1.writecomponent(testclass2);
stream2:= tmemorystream.create;
try
stream1.position:= 0;
objectbinarytotext(stream1,stream2);
stream2.position:= 0;
setlength(str1,stream2.size);
move(stream2.memory^,str1[1],length(str1));
write(str1);
finally
stream2.free;
end;
finally
stream1.free;
end;
if pos('prop1',str1)<>0 then
begin
writeln('error');
halt(1);
end;
end.
{ Source provided for Free Pascal Bug Report 5082 }
{ Submitted by "Martin Schreiber" on 2006-05-01 }
{ e-mail: }
program storedfalse;
{$ifdef FPC}{$mode objfpc}{$h+}{$INTERFACES CORBA}{$endif}
{$ifdef mswindows}{$apptype console}{$endif}
uses
{$ifdef FPC}{$ifdef linux}cthreads,{$endif}{$endif}
sysutils,classes;
type
ttestclass1 = class(tcomponent)
private
fprop1: real;
public
property prop1: real read fprop1 write fprop1 stored false;
end;
ttestclass2 = class(ttestclass1)
published
property prop1;
end;
var
testclass2: ttestclass2;
stream1,stream2: tmemorystream;
str1: string;
begin
testclass2:= ttestclass2.create(nil);
testclass2.prop1:= 1;
stream1:= tmemorystream.create;
try
stream1.writecomponent(testclass2);
stream2:= tmemorystream.create;
try
stream1.position:= 0;
objectbinarytotext(stream1,stream2);
stream2.position:= 0;
setlength(str1,stream2.size);
move(stream2.memory^,str1[1],length(str1));
write(str1);
finally
stream2.free;
end;
finally
stream1.free;
end;
if pos('prop1',str1)<>0 then
begin
writeln('error');
halt(1);
end;
end.

58
tests/webtbs/tw8177a.pp
View File

@ -1,30 +1,30 @@
var
S : string;
i : longint;
err : word;
begin
S:='';
val(S,i,err);
if err=0 then
begin
Writeln('Error: empty string is a valid input for val function');
Halt(1);
end
else
begin
Writeln('Correct: empty string is a not valid input for val function');
end;
S:=#0;
val(S,i,err);
if err=0 then
begin
Writeln('Error: #0 string is a valid input for val function');
Halt(1);
end
else
begin
Writeln('Correct: #0 string is a not valid input for val function');
end;
var
S : string;
i : longint;
err : word;
begin
S:='';
val(S,i,err);
if err=0 then
begin
Writeln('Error: empty string is a valid input for val function');
Halt(1);
end
else
begin
Writeln('Correct: empty string is a not valid input for val function');
end;
S:=#0;
val(S,i,err);
if err=0 then
begin
Writeln('Error: #0 string is a valid input for val function');
Halt(1);
end
else
begin
Writeln('Correct: #0 string is a not valid input for val function');
end;
end.