diff --git a/rtl/os2/dos.pas b/rtl/os2/dos.pas index bc051207a1..90cbaf5b13 100644 --- a/rtl/os2/dos.pas +++ b/rtl/os2/dos.pas @@ -1,42 +1,42 @@ {**************************************************************************** - FPKPascal Runtime-Library - Copyright (c) 1994,97 by - Florian Klaempfl and Michael Spiegel - OS/2 port by Danil Mantione + FPKPascal Runtime-Library + Copyright (c) 1994,97 by + Florian Klaempfl and Michael Spiegel + OS/2 port by Danil Mantione ****************************************************************************} { History: 2.7.1994: Version 0.2 - Datenstrukturen sind deklariert sowie - 50 % der Unterprogramme sind implementiert + Datenstrukturen sind deklariert sowie + 50 % der Unterprogramme sind implementiert 12.8.1994: exec implemented 14.8.1994: findfirst and findnext implemented 24.8.1994: Version 0.3 28.2.1995: Version 0.31 - some parameter lists with const optimized + some parameter lists with const optimized 3.7.1996: bug in fsplit removed (dir and ext were not intializised) 7.7.1996: packtime and unpacktime implemented 20.9.1996: Version 0.5 - setftime and getftime implemented - some optimizations done (integer -> longint) - procedure fsearch from the LINUX version ported - msdos call implemented + setftime and getftime implemented + some optimizations done (integer -> longint) + procedure fsearch from the LINUX version ported + msdos call implemented 26th november 1996: - better fexpand + better fexpand 29th january 1997: - bug in getftime and setftime removed - setfattr and getfattr added + bug in getftime and setftime removed + setfattr and getfattr added 2th february 1997: Version 0.9 - bug of searchrec corrected + bug of searchrec corrected 2 june 1997: - OS/2 support added. + OS/2 support added. 12 june 1997: - OS/2 port done. + OS/2 port done. 12 November 1997: - Adapted to new DLL stuff. + Adapted to new DLL stuff. } unit dos; @@ -47,15 +47,15 @@ unit dos; interface - uses - strings; + uses + strings; - const - { bit masks for CPU flags} - fcarry = $0001; - fparity = $0004; - fauxiliary = $0010; - fzero = $0040; + const + { bit masks for CPU flags} + fcarry = $0001; + fparity = $0004; + fauxiliary = $0010; + fzero = $0040; fsign = $0080; foverflow = $0800; @@ -73,48 +73,48 @@ unit dos; fminout = $D7B3; type - { some string types } - {$IFDEF OS2} - comstr=string; {Filenames can be long in OS/2.} - pathstr=string; - {$ELSE} - comstr = string[127]; { Kommandozeilenstring } - pathstr = string[79]; { String fuer einen Pfadnamen } - {$ENDIF} - dirstr = string[67]; { String fuer kompletten Pfad } - namestr = string[8]; { Dateinamenstring } - extstr = string[4]; { String fuer Dateinamensuffix } + { some string types } + {$IFDEF OS2} + comstr=string; {Filenames can be long in OS/2.} + pathstr=string; + {$ELSE} + comstr = string[127]; { Kommandozeilenstring } + pathstr = string[79]; { String fuer einen Pfadnamen } + {$ENDIF} + dirstr = string[67]; { String fuer kompletten Pfad } + namestr = string[8]; { Dateinamenstring } + extstr = string[4]; { String fuer Dateinamensuffix } - { search record which is used by findfirst and findnext } + { search record which is used by findfirst and findnext } {$PACKRECORDS 1} - searchrec = record - fill : array[1..21] of byte; - attr : byte; - time : longint; - {$IFNDEF OS2} { A DJGPP strange thing.} - reserved : word; { requires the DOS extender (DJ GNU-C) } - {$ENDIF} - size : longint; - {$IFNDEF OS2} - name : string[15]; { the same size as declared by (DJ GNU C) } - {$ELSE} - name:string; {Filenames can be very long in OS/2!} - {$ENDIF} - end; + searchrec = record + fill : array[1..21] of byte; + attr : byte; + time : longint; + {$IFNDEF OS2} { A DJGPP strange thing.} + reserved : word; { requires the DOS extender (DJ GNU-C) } + {$ENDIF} + size : longint; + {$IFNDEF OS2} + name : string[15]; { the same size as declared by (DJ GNU C) } + {$ELSE} + name:string; {Filenames can be very long in OS/2!} + {$ENDIF} + end; {$PACKRECORDS 2} { file record for untyped files } filerec = record handle : word; mode : word; - recsize : word; + recsize : word; _private : array[1..26] of byte; userdata: array[1..16] of byte; name: array[0..79] of char; - end; + end; { file record for text files } - textbuf = array[0..127] of char; + textbuf = array[0..127] of char; textrec = record handle : word; @@ -123,155 +123,155 @@ unit dos; _private : word; bufpos : word; bufend : word; - bufptr : ^textbuf; + bufptr : ^textbuf; openfunc : pointer; - inoutfunc : pointer; + inoutfunc : pointer; flushfunc : pointer; closefunc : pointer; - userdata : array[1..16] of byte; - name : array[0..79] of char; - buffer : textbuf; + userdata : array[1..16] of byte; + name : array[0..79] of char; + buffer : textbuf; end; - { data structure for the registers needed by msdos and intr } + { data structure for the registers needed by msdos and intr } registers = record - case i : integer of - 0 : (ax,f1,bx,f2,cx,f3,dx,f4,bp,f5,si,f51,di,f6,ds,f7,es,f8,flags,fs,gs : word); - 1 : (al,ah,f9,f10,bl,bh,f11,f12,cl,ch,f13,f14,dl,dh : byte); - 2 : (eax, ebx, ecx, edx, ebp, esi, edi : longint); - end; + case i : integer of + 0 : (ax,f1,bx,f2,cx,f3,dx,f4,bp,f5,si,f51,di,f6,ds,f7,es,f8,flags,fs,gs : word); + 1 : (al,ah,f9,f10,bl,bh,f11,f12,cl,ch,f13,f14,dl,dh : byte); + 2 : (eax, ebx, ecx, edx, ebp, esi, edi : longint); + end; - { record for date and time } - datetime = record - year,month,day,hour,min,sec : word; - end; + { record for date and time } + datetime = record + year,month,day,hour,min,sec : word; + end; - {Flags for the exec procedure: + {Flags for the exec procedure: - Starting the program: - efwait: Wait until program terminates, otherwise the program - continues execution. - efno_wait: ? Function unknown. Not implemented in EMX. - efoverlay: Terminate this program, then execute the requested - program. WARNING: Exit-procedures are not called! - efdebug: Debug program. Details are unknown. - efsession: Do not execute as child of this program. Use a seperate - session instead. - efdetach: Detached. Function unknown. Info wanted! - efpm: Run as presentation manager program. + Starting the program: + efwait: Wait until program terminates, otherwise the program + continues execution. + efno_wait: ? Function unknown. Not implemented in EMX. + efoverlay: Terminate this program, then execute the requested + program. WARNING: Exit-procedures are not called! + efdebug: Debug program. Details are unknown. + efsession: Do not execute as child of this program. Use a seperate + session instead. + efdetach: Detached. Function unknown. Info wanted! + efpm: Run as presentation manager program. - Determining the window state of the program: - efdefault: Run the pm program in it's default situation. - efminimize: Run the pm program minimized. - efmaximize: Run the pm program maximized. - effullscreen: Run the non-pm program fullscreen. - efwindowed: Run the non-pm program in a window. + Determining the window state of the program: + efdefault: Run the pm program in it's default situation. + efminimize: Run the pm program minimized. + efmaximize: Run the pm program maximized. + effullscreen: Run the non-pm program fullscreen. + efwindowed: Run the non-pm program in a window. - Other options are not implemented defined because lack of - knowledge abou what they do.} + Other options are not implemented defined because lack of + knowledge abou what they do.} - type execrunflags=(efwait,efno_wait,efoverlay,efdebug,efsession, - efdetach,efpm); - execwinflags=(efdefault,efminimize,efmaximize,effullscreen, - efwindowed); - execset=set of execrunflags; + type execrunflags=(efwait,efno_wait,efoverlay,efdebug,efsession, + efdetach,efpm); + execwinflags=(efdefault,efminimize,efmaximize,effullscreen, + efwindowed); + execset=set of execrunflags; - var - { error variable } - doserror : integer; + var + { error variable } + doserror : integer; - procedure getdate(var year,month,day,dayofweek : word); - procedure gettime(var hour,minute,second,sec100 : word); - function dosversion : word; - procedure setdate(year,month,day : word); - procedure settime(hour,minute,second,sec100 : word); - procedure getcbreak(var breakvalue : boolean); - procedure setcbreak(breakvalue : boolean); - procedure getverify(var verify : boolean); - procedure setverify(verify : boolean); - function diskfree(drive : byte) : longint; - function disksize(drive : byte) : longint; - procedure findfirst(const path : pathstr;attr : word;var f : searchRec); - procedure findnext(var f : searchRec); + procedure getdate(var year,month,day,dayofweek : word); + procedure gettime(var hour,minute,second,sec100 : word); + function dosversion : word; + procedure setdate(year,month,day : word); + procedure settime(hour,minute,second,sec100 : word); + procedure getcbreak(var breakvalue : boolean); + procedure setcbreak(breakvalue : boolean); + procedure getverify(var verify : boolean); + procedure setverify(verify : boolean); + function diskfree(drive : byte) : longint; + function disksize(drive : byte) : longint; + procedure findfirst(const path : pathstr;attr : word;var f : searchRec); + procedure findnext(var f : searchRec); - { is a dummy } - procedure swapvectors; + { is a dummy } + procedure swapvectors; { not supported: - procedure getintvec(intno : byte;var vector : pointer); - procedure setintvec(intno : byte;vector : pointer); - procedure keep(exitcode : word); + procedure getintvec(intno : byte;var vector : pointer); + procedure setintvec(intno : byte;vector : pointer); + procedure keep(exitcode : word); } - procedure msdos(var regs : registers); - procedure intr(intno : byte;var regs : registers); + procedure msdos(var regs : registers); + procedure intr(intno : byte;var regs : registers); - procedure getfattr(var f;var attr : word); - procedure setfattr(var f;attr : word); + procedure getfattr(var f;var attr : word); + procedure setfattr(var f;attr : word); - function fsearch(const path : pathstr;dirlist : string) : pathstr; - procedure getftime(var f;var time : longint); - procedure setftime(var f;time : longint); - procedure packtime (var d: datetime; var time: longint); - procedure unpacktime (time: longint; var d: datetime); - function fexpand(const path : pathstr) : pathstr; - procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr; - var ext : extstr); - procedure exec(const path : pathstr;const comline : comstr); - {$IFDEF OS2} - function exec(path:pathstr;runflags:execset;winflags:execwinflags; - const comline:comstr):longint; - {$ENDIF} - function dosexitcode : word; + function fsearch(const path : pathstr;dirlist : string) : pathstr; + procedure getftime(var f;var time : longint); + procedure setftime(var f;time : longint); + procedure packtime (var d: datetime; var time: longint); + procedure unpacktime (time: longint; var d: datetime); + function fexpand(const path : pathstr) : pathstr; + procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr; + var ext : extstr); + procedure exec(const path : pathstr;const comline : comstr); + {$IFDEF OS2} + function exec(path:pathstr;runflags:execset;winflags:execwinflags; + const comline:comstr):longint; + {$ENDIF} + function dosexitcode : word; function envcount : longint; - function envstr(index : longint) : string; - function getenv(const envvar : string): string; + function envstr(index : longint) : string; + function getenv(const envvar : string): string; implementation {$ifdef OS2} - type OS2FSAllocate=record - idfilesystem, - csectorunit, - cunit, - cunitavail:longint; - cbsector:word; - end; + type OS2FSAllocate=record + idfilesystem, + csectorunit, + cunit, + cunitavail:longint; + cbsector:word; + end; function dosqueryFSinfo(driveno:word;infolevel:word; - var info;infolen:word):word; - external 'DOSCALLS' index 278; + var info;infolen:word):word; + external 'DOSCALLS' index 278; {$endif OS2} - { this was first written for the LINUX version, } - { by Michael Van Canneyt but it works also } - { for the DOS version (I hope so) } - function fsearch(const path : pathstr;dirlist : string) : pathstr; + { this was first written for the LINUX version, } + { by Michael Van Canneyt but it works also } + { for the DOS version (I hope so) } + function fsearch(const path : pathstr;dirlist : string) : pathstr; - var - newdir : pathstr; - p1 : byte; - s : searchrec; + var + newdir : pathstr; + p1 : byte; + s : searchrec; - begin - if (pos('?',path)<>0) or (pos('*',path)<>0) then - { No wildcards allowed in these things } - fsearch:='' - else - begin - repeat - { get first path } - p1:=pos(';',dirlist); - if p1>0 then - begin - newdir:=copy(dirlist,1,p1-1); - delete(dirlist,1,p1) - end - else - begin - newdir:=dirlist; - dirlist:='' + begin + if (pos('?',path)<>0) or (pos('*',path)<>0) then + { No wildcards allowed in these things } + fsearch:='' + else + begin + repeat + { get first path } + p1:=pos(';',dirlist); + if p1>0 then + begin + newdir:=copy(dirlist,1,p1-1); + delete(dirlist,1,p1) + end + else + begin + newdir:=dirlist; + dirlist:='' end; findfirst(newdir+'\'+path,anyfile,s); if doserror=0 then @@ -281,874 +281,874 @@ unit dos; if pos('.\',newdir)=1 then delete(newdir, 1, 2) { DOS strips off an initial .\ } - } - end - else newdir:=''; - until(dirlist='') or (length(newdir)>0); - fsearch:=newdir; - end; - end; + } + end + else newdir:=''; + until(dirlist='') or (length(newdir)>0); + fsearch:=newdir; + end; + end; - procedure getftime(var f;var time : longint); + procedure getftime(var f;var time : longint); - begin - {$IFNDEF OS2} - asm - { load handle } - movl f,%ebx - movw (%ebx),%bx - { get date } - movw $0x5700,%ax - int $0x21 - shll $16,%edx - movw %cx,%dx - movl time,%ebx - movl %edx,(%ebx) - xorb %ah,%ah - movw %ax,U_DOS_DOSERROR - end; - {$ELSE} - asm - { load handle } - movl f,%ebx - movw (%ebx),%bx - { get date } - movw $0x5700,%ax - call ___SYSCALL - shll $16,%edx - movw %cx,%dx - movl time,%ebx - movl %edx,(%ebx) - xorb %ah,%ah - movw %ax,U_DOS_DOSERROR - end; - {$ENDIF} - end; + begin + {$IFNDEF OS2} + asm + { load handle } + movl f,%ebx + movw (%ebx),%bx + { get date } + movw $0x5700,%ax + int $0x21 + shll $16,%edx + movw %cx,%dx + movl time,%ebx + movl %edx,(%ebx) + xorb %ah,%ah + movw %ax,U_DOS_DOSERROR + end; + {$ELSE} + asm + { load handle } + movl f,%ebx + movw (%ebx),%bx + { get date } + movw $0x5700,%ax + call ___SYSCALL + shll $16,%edx + movw %cx,%dx + movl time,%ebx + movl %edx,(%ebx) + xorb %ah,%ah + movw %ax,U_DOS_DOSERROR + end; + {$ENDIF} + end; procedure setftime(var f;time : longint); - begin - {$IFNDEF OS2} - asm - { load handle } - movl f,%ebx - movw (%ebx),%bx - movl time,%ecx - shldl $16,%ecx,%edx - { set date } - movw $0x5701,%ax - int $0x21 - xorb %ah,%ah - movw %ax,U_DOS_DOSERROR - end; - {$ELSE} - asm - { load handle } - movl f,%ebx - movw (%ebx),%bx - movl time,%ecx - shldl $16,%ecx,%edx - { set date } - movw $0x5701,%ax - call ___SYSCALL - xorb %ah,%ah - movw %ax,U_DOS_DOSERROR - end; - {$ENDIF} - end; - - procedure msdos(var regs : registers); - - { Not recommended for EMX. Only works in DOS mode, not in OS/2 mode.} - - begin - intr($21,regs); - end; - - procedure intr(intno : byte;var regs : registers); - - { Not recommended for EMX. Only works in DOS mode, not in OS/2 mode.} - - begin - asm - .data - int86: - .byte 0xcd - int86_vec: - .byte 0x03 - jmp int86_retjmp - - .text - movl 8(%ebp),%eax - movb %al,int86_vec - - movl 10(%ebp),%eax - {do not use first int} - addl $2,%eax - - movl 4(%eax),%ebx - movl 8(%eax),%ecx - movl 12(%eax),%edx - movl 16(%eax),%ebp - movl 20(%eax),%esi - movl 24(%eax),%edi - movl (%eax),%eax - - jmp int86 - int86_retjmp: - pushf - pushl %ebp - pushl %eax - movl %esp,%ebp - {calc EBP new} - addl $12,%ebp - movl 10(%ebp),%eax - {do not use first int} - addl $2,%eax - - popl (%eax) - movl %ebx,4(%eax) - movl %ecx,8(%eax) - movl %edx,12(%eax) - {restore EBP} - popl %edx - movl %edx,16(%eax) - movl %esi,20(%eax) - movl %edi,24(%eax) - {ignore ES and DS} - popl %ebx /* flags */ - movl %ebx,32(%eax) - {FS and GS too} - end; - end; - - var - lastdosexitcode : word; - - {$IFNDEF OS2} - - procedure exec(const path : pathstr;const comline : comstr); - - procedure do_system(p : pchar); - - begin - asm - movl 12(%ebp),%ebx - movw $0xff07,%ax - int $0x21 - movw %ax,_LASTDOSEXITCODE - end; - end; - - var - execute : string; - b : array[0..255] of char; - - begin - execute:=path+' '+comline; - move(execute[1],b,length(execute)); - b[length(execute)]:=#0; - do_system(b); - end; - {$ELSE} - - procedure exec(const path:pathstr;const comline:comstr); - - {Execute a program.} - - begin - exec(path,[efwait],efdefault,comline); - end; - - function exec(path:pathstr;runflags:execset;winflags:execwinflags; - const comline:comstr):longint; - - {Execute a program. More suitable for OS/2 than the exec above.} - - {512 bytes should be enough to contain the command-line.} - - type bytearray=array[0..8191] of byte; - Pbytearray=^bytearray; - - setarray=array[0..3] of byte; - - execstruc=record - argofs,envofs,nameofs:pointer; - argseg,envseg,nameseg:word; - numarg,sizearg, - numenv,sizeenv:word; - mode1,mode2:byte; - end; - - var args:Pbytearray; - env:Pbytearray; - i,j:word; - es:execstruc; - esadr:pointer; - - begin - getmem(args,512); - getmem(env,8192); - i:=1; - j:=0; - es.numarg:=0; - while i<=length(comline) do - begin - if comline[i]<>' ' then - begin - {Commandline argument found. Copy it.} - inc(es.numarg); - args^[j]:=$80; - inc(j); - while (i<=length(comline)) and (comline[i]<>' ') do - begin - args^[j]:=byte(comline[i]); - inc(j); - inc(i); - end; - args^[j]:=0; - inc(j); - end; - inc(i); - end; - args^[j]:=0; - inc(j); - - {Commandline ready, now build the environment. - - Oh boy, I always had the opinion that executing a program under Dos - was a hard job!} - - asm - movl env,%edi {Setup destination pointer.} - movl _envc,%ecx {Load number of arguments in edx.} - movl _environ,%esi {Load env. strings.} - xorl %edx,%edx {Count environment size.} - exa1: - lodsl {Load a Pchar.} - xchgl %eax,%ebx - exa2: - movb (%ebx),%al {Load a byte.} - incl %ebx {Point to next byte.} - stosb {Store it.} - incl %edx {Increase counter.} - cmpb $0,%al {Ready ?.} - jne exa2 - loop exa1 {Next argument.} - stosb {Store an extra 0 to finish. (AL is now 0).} - incl %edx - movl %edx,(24)es {Store environment size.} - end; - - {Environtment ready, now set-up exec structure.} - es.argofs:=args; - es.envofs:=env; - asm - leal path,%esi - lodsb - movzbl %al,%eax - incl %eax - addl %eax,%esi - movb $0,(%esi) - end; - es.nameofs:=pointer(longint(@path)+1); - asm - movw %ss,(12)es {Compiler doesn't like record elems in asm.} - movw %ss,(14)es - movw %ss,(16)es - end; - es.sizearg:=j; - es.numenv:=0; - {Typecasting of sets in FPK is a bit hard.} - es.mode1:=setarray(runflags)[0]; - es.mode2:=byte(winflags); - - {Now exec the program.} - esadr:=@es; - asm - movl esadr,%edx - mov $0x7f06,%ax - call ___SYSCALL - jnc exprg1 - movl %eax,U_DOS_DOSERROR - xorl %eax,%eax - decl %eax - exprg1: - movl %eax,__RESULT - end; - - freemem(args,512); - freemem(env,8192); - {Phew! That's it. This was the most sophisticated procedure to call - a system function I ever wrote!} - end; - - {$ENDIF} - - function dosexitcode : word; - - begin - dosexitcode:=lastdosexitcode; - end; - - function dosversion : word; - - begin - {$IFNDEF OS2} - asm - movb $0x30,%ah - pushl %ebp - int $0x21 - popl %ebp - leave - ret - end; - {$ELSE} - {Returns DOS version in DOS and OS/2 version in OS/2} - asm - movb $0x30,%ah - call ___SYSCALL - leave - ret - end; - {$ENDIF} - end; - - procedure getdate(var year,month,day,dayofweek : word); - - begin - {$IFNDEF OS2} - asm - movb $0x2a,%ah - pushl %ebp - int $0x21 - popl %ebp - xorb %ah,%ah - movl 20(%ebp),%edi - stosw - movl 16(%ebp),%edi - movb %dl,%al - stosw - movl 12(%ebp),%edi - movb %dh,%al - stosw - movl 8(%ebp),%edi - movw %cx,%ax - stosw - end; - {$ELSE} - asm - movb $0x2a,%ah - call ___SYSCALL - xorb %ah,%ah - movl 20(%ebp),%edi - stosw - movl 16(%ebp),%edi - movb %dl,%al - stosw - movl 12(%ebp),%edi - movb %dh,%al - stosw - movl 8(%ebp),%edi - xchgw %ecx,%eax - stosw - end; - {$ENDIF} - end; - - procedure setdate(year,month,day : word); - - begin - {$IFNDEF OS2} - asm - movw 8(%ebp),%cx - movb 10(%ebp),%dh - movb 12(%ebp),%dl - movb $0x2b,%ah - pushl %ebp - int $0x21 - popl %ebp - xorb %ah,%ah - movw %ax,U_DOS_DOSERROR - end; - {$ELSE} - {DOS only! You cannot change the system date in OS/2!} - asm - movw 8(%ebp),%cx - movb 10(%ebp),%dh - movb 12(%ebp),%dl - movb $0x2b,%ah - call ___SYSCALL - xorb %ah,%ah - movw %ax,U_DOS_DOSERROR - end; - {$ENDIF} - end; - - procedure gettime(var hour,minute,second,sec100 : word); - - begin - {$IFNDEF OS2} - asm - movb $0x2c,%ah - pushl %ebp - int $0x21 - popl %ebp - xorb %ah,%ah - movl 20(%ebp),%edi - movb %dl,%al - stosw - movl 16(%ebp),%edi - movb %dh,%al - stosw - movl 12(%ebp),%edi - movb %cl,%al - stosw - movl 8(%ebp),%edi - movb %ch,%al - stosw - end; - {$ELSE} - asm - movb $0x2c,%ah - call ___SYSCALL - xorb %ah,%ah - movl 20(%ebp),%edi - movb %dl,%al - stosw - movl 16(%ebp),%edi - movb %dh,%al - stosw - movl 12(%ebp),%edi - movb %cl,%al - stosw - movl 8(%ebp),%edi - movb %ch,%al - stosw - end; - {$ENDIF} - end; - - procedure settime(hour,minute,second,sec100 : word); - - begin - {$IFNDEF OS2} - asm - movb 8(%ebp),%ch - movb 10(%ebp),%cl - movb 12(%ebp),%dh - movb 14(%ebp),%dl - movb $0x2d,%ah - pushl %ebp - int $0x21 - popl %ebp - xorb %ah,%ah - movw %ax,U_DOS_DOSERROR - end; - {$ELSE} - asm - movb 8(%ebp),%ch - movb 10(%ebp),%cl - movb 12(%ebp),%dh - movb 14(%ebp),%dl - movb $0x2d,%ah - call ___SYSCALL - xorb %ah,%ah - movw %ax,U_DOS_DOSERROR - end; - {$ENDIF} - end; - - procedure getcbreak(var breakvalue : boolean); - - begin - {$IFNDEF OS2} - asm - movw $0x3300,%ax - pushl %ebp - int $0x21 - popl %ebp - movl 8(%ebp),%eax - movb %dl,(%eax) - end; - {$ELSE} - {! Do not use in OS/2. Also not recommended in DOS. Use - signal handling instead.} - asm - movw $0x3300,%ax - call ___SYSCALL - movl 8(%ebp),%eax - movb %dl,(%eax) - end; - {$ENDIF} - end; - - procedure setcbreak(breakvalue : boolean); - - begin - {$IFNDEF OS2} - asm - movb 8(%ebp),%dl - movl $0x3301,%ax - pushl %ebp - int $0x21 - popl %ebp - end; - {$ELSE} - {! Do not use in OS/2. Also not recommended in DOS. Use - signal handling instead.} - asm - movb 8(%ebp),%dl - movl $0x3301,%ax - call ___SYSCALL - end; - {$ENDIF} - end; - - procedure getverify(var verify : boolean); - - begin - {$IFNDEF OS2} - asm - movb $0x54,%ah - pushl %ebp - int $0x21 - popl %ebp - movl 8(%ebp),%edi - stosb - end; - {$ELSE} - {! Do not use in OS/2.} - asm - movb $0x54,%ah - call ___SYSCALL - movl 8(%ebp),%edi - stosb - end; - {$ENDIF} - end; - - procedure setverify(verify : boolean); - - begin - {$IFNDEF OS2} - asm - movb 8(%ebp),%al - movl $0x2e,%ah - pushl %ebp - int $0x21 - popl %ebp - end; - {$ELSE} - {! Do not use in OS/2.} - asm - movb 8(%ebp),%al - movl $0x2e,%ah - call ___SYSCALL - end; - {$ENDIF} - end; - - function diskfree(drive : byte) : longint; - - var fi:OS2FSallocate; - - begin - {$IFNDEF OS2} - asm - movb 8(%ebp),%dl - movb $0x36,%ah - pushl %ebp - int $0x21 - popl %ebp - cmpw $-1,%ax - je LDISKFREE1 - mulw %cx - mulw %bx - shll $16,%edx - movw %ax,%dx - movl %edx,%eax - leave - ret - LDISKFREE1: - cwde - leave - ret - end; - {$ELSE} - if os_mode=osDOS then - {Function 36 is not supported in OS/2.} - asm - movb 8(%ebp),%dl - movb $0x36,%ah - call ___SYSCALL - cmpw $-1,%ax - je LDISKFREE1 - mulw %cx - mulw %bx - shll $16,%edx - movw %ax,%dx - xchgl %edx,%eax - leave - ret - LDISKFREE1: - cwde - leave - ret - end - else - {In OS/2, we use the filesystem information.} - begin - doserror:=dosqueryFSinfo(drive,1,FI,sizeof(FI)); - if doserror=0 then - diskfree:=FI.cunitavail*FI.csectorunit*FI.cbsector - else - diskfree:=-1; - end; - {$ENDIF} - end; - - function disksize(drive : byte) : longint; - - begin - {$IFNDEF OS/2} - asm - movb 8(%ebp),%dl - movb $0x36,%ah - pushl %ebp - int $0x21 - popl %ebp - movw %dx,%bx - cmpw $-1,%ax - je LDISKSIZE1 - mulw %cx - mulw %bx - shll $16,%edx - movw %ax,%dx - movl %edx,%eax - leave - ret - LDISKSIZE1: - movl $-1,%eax - leave - ret - end; - {$ELSE} - if os_mode=osDOS then - {Function 36 is not supported in OS/2.} - asm - movb 8(%ebp),%dl - movb $0x36,%ah - call ___SYSCALL - movw %dx,%bx - cmpw $-1,%ax - je LDISKSIZE1 - mulw %cx - mulw %bx - shll $16,%edx - movw %ax,%dx - xchgl %edx,%eax - leave - ret - LDISKSIZE1: - cwde - leave - ret - end; - else - {In OS/2, we use the filesystem information.} - begin - doserror:=dosQFSinfo(drive,1,FI,sizeof(FI)); - if doserror=0 then - diskfree:=FI.cunit*FI.csectorunit*FI.cbsector - else - diskfree:=-1; - end; - {$ENDIF} - end; - - procedure searchrec2dossearchrec(var f : searchrec); - - var - l,i : longint; - - {$IFDEF OS2} - const namesize=255; - {$ELSE} - const namesize=12; - {$ENDIF} - - begin - l:=length(f.name); - for i:=1 to namesize do - f.name[i-1]:=f.name[i]; - f.name[l]:=#0; - end; - - procedure dossearchrec2searchrec(var f : searchrec); - - var - l,i : longint; - - {$IFDEF OS2} - const namesize=255; - {$ELSE} - const namesize=12; - {$ENDIF} - - begin - for i:=0 to namesize do - if f.name[i]=#0 then - begin - l:=i; - break; - end; - for i:=namesize-1 downto 0 do - f.name[i+1]:=f.name[i]; - f.name[0]:=chr(l); - end; - - procedure findfirst(const path : pathstr;attr : word;var f : searchRec); - - procedure _findfirst(path : pchar;attr : word;var f : searchrec); - - begin - {$IFNDEF OS2} - asm - movl 18(%ebp),%edx - movb $0x1a,%ah - int $0x21 - movl 12(%esp),%edx - movzwl 16(%esp),%ecx - movb $0x4e,%ah - int $0x21 - jnc LFF - movw %ax,U_DOS_DOSERROR - LFF: - end; - {$ELSE} - asm - movl 12(%esp),%edx - movw 16(%esp),%cx - {No need to set DTA in EMX. Just give a pointer in ESI.} - movl 18(%ebp),%esi - movb $0x4e,%ah - call ___SYSCALL - jnc LFF - movw %ax,U_DOS_DOSERROR - LFF: - end; - {$ENDIF} - end; - - var - path0 : array[0..80] of char; - - begin - { no error } - doserror:=0; - strpcopy(path0,path); - _findfirst(path0,attr,f); - dossearchrec2searchrec(f); - end; - - procedure findnext(var f : searchRec); - - procedure _findnext(var f : searchrec); - - begin - {$IFNDEF OS2} - asm - movl 12(%ebp),%edx - movb $0x1a,%ah - int $0x21 - movb $0x4f,%ah - int $0x21 - jnc LFN - movw %ax,U_DOS_DOSERROR - LFN: - end; - {$ELSE} - asm - movl 12(%ebp),%esi - movb $0x4f,%ah - call ___SYSCALL - jnc LFN - movw %ax,U_DOS_DOSERROR - LFN: - end; - {$ENDIF} - end; - - begin - { no error } - doserror:=0; - searchrec2dossearchrec(f); - _findnext(f); - dossearchrec2searchrec(f); - end; - - procedure swapvectors; - - begin - { tut nichts, DOS-Extender bernimmt das Ntige } - { normalerweise selber } - { nur aus Kompatibilittsgrnden implementiert } - end; - - type - ppchar = ^pchar; - - function envs : ppchar; - - begin - asm - movl _environ,%eax - leave - ret - end ['EAX']; - end; - - function envcount : longint; - - var - hp : ppchar; - - begin - {$IFNDEF OS2} - hp:=envs; - envcount:=0; - while assigned(hp^) do - begin - { not the best solution, but quite understandable } - inc(envcount); - hp:=hp+4; - end; - {$ELSE} - asm - movl _envc,%eax - leave - ret - end ['EAX']; - {$ENDIF} - end; - - function envstr(index : longint) : string; - - var - hp : ppchar; - - begin - if (index<=0) or (index>envcount) then - begin + begin + {$IFNDEF OS2} + asm + { load handle } + movl f,%ebx + movw (%ebx),%bx + movl time,%ecx + shldl $16,%ecx,%edx + { set date } + movw $0x5701,%ax + int $0x21 + xorb %ah,%ah + movw %ax,U_DOS_DOSERROR + end; + {$ELSE} + asm + { load handle } + movl f,%ebx + movw (%ebx),%bx + movl time,%ecx + shldl $16,%ecx,%edx + { set date } + movw $0x5701,%ax + call ___SYSCALL + xorb %ah,%ah + movw %ax,U_DOS_DOSERROR + end; + {$ENDIF} + end; + + procedure msdos(var regs : registers); + + { Not recommended for EMX. Only works in DOS mode, not in OS/2 mode.} + + begin + intr($21,regs); + end; + + procedure intr(intno : byte;var regs : registers); + + { Not recommended for EMX. Only works in DOS mode, not in OS/2 mode.} + + begin + asm + .data + int86: + .byte 0xcd + int86_vec: + .byte 0x03 + jmp int86_retjmp + + .text + movl 8(%ebp),%eax + movb %al,int86_vec + + movl 10(%ebp),%eax + {do not use first int} + addl $2,%eax + + movl 4(%eax),%ebx + movl 8(%eax),%ecx + movl 12(%eax),%edx + movl 16(%eax),%ebp + movl 20(%eax),%esi + movl 24(%eax),%edi + movl (%eax),%eax + + jmp int86 + int86_retjmp: + pushf + pushl %ebp + pushl %eax + movl %esp,%ebp + {calc EBP new} + addl $12,%ebp + movl 10(%ebp),%eax + {do not use first int} + addl $2,%eax + + popl (%eax) + movl %ebx,4(%eax) + movl %ecx,8(%eax) + movl %edx,12(%eax) + {restore EBP} + popl %edx + movl %edx,16(%eax) + movl %esi,20(%eax) + movl %edi,24(%eax) + {ignore ES and DS} + popl %ebx /* flags */ + movl %ebx,32(%eax) + {FS and GS too} + end; + end; + + var + lastdosexitcode : word; + + {$IFNDEF OS2} + + procedure exec(const path : pathstr;const comline : comstr); + + procedure do_system(p : pchar); + + begin + asm + movl 12(%ebp),%ebx + movw $0xff07,%ax + int $0x21 + movw %ax,_LASTDOSEXITCODE + end; + end; + + var + execute : string; + b : array[0..255] of char; + + begin + execute:=path+' '+comline; + move(execute[1],b,length(execute)); + b[length(execute)]:=#0; + do_system(b); + end; + {$ELSE} + + procedure exec(const path:pathstr;const comline:comstr); + + {Execute a program.} + + begin + exec(path,[efwait],efdefault,comline); + end; + + function exec(path:pathstr;runflags:execset;winflags:execwinflags; + const comline:comstr):longint; + + {Execute a program. More suitable for OS/2 than the exec above.} + + {512 bytes should be enough to contain the command-line.} + + type bytearray=array[0..8191] of byte; + Pbytearray=^bytearray; + + setarray=array[0..3] of byte; + + execstruc=record + argofs,envofs,nameofs:pointer; + argseg,envseg,nameseg:word; + numarg,sizearg, + numenv,sizeenv:word; + mode1,mode2:byte; + end; + + var args:Pbytearray; + env:Pbytearray; + i,j:word; + es:execstruc; + esadr:pointer; + + begin + getmem(args,512); + getmem(env,8192); + i:=1; + j:=0; + es.numarg:=0; + while i<=length(comline) do + begin + if comline[i]<>' ' then + begin + {Commandline argument found. Copy it.} + inc(es.numarg); + args^[j]:=$80; + inc(j); + while (i<=length(comline)) and (comline[i]<>' ') do + begin + args^[j]:=byte(comline[i]); + inc(j); + inc(i); + end; + args^[j]:=0; + inc(j); + end; + inc(i); + end; + args^[j]:=0; + inc(j); + + {Commandline ready, now build the environment. + + Oh boy, I always had the opinion that executing a program under Dos + was a hard job!} + + asm + movl env,%edi {Setup destination pointer.} + movl _envc,%ecx {Load number of arguments in edx.} + movl _environ,%esi {Load env. strings.} + xorl %edx,%edx {Count environment size.} + exa1: + lodsl {Load a Pchar.} + xchgl %eax,%ebx + exa2: + movb (%ebx),%al {Load a byte.} + incl %ebx {Point to next byte.} + stosb {Store it.} + incl %edx {Increase counter.} + cmpb $0,%al {Ready ?.} + jne exa2 + loop exa1 {Next argument.} + stosb {Store an extra 0 to finish. (AL is now 0).} + incl %edx + movl %edx,(24)es {Store environment size.} + end; + + {Environtment ready, now set-up exec structure.} + es.argofs:=args; + es.envofs:=env; + asm + leal path,%esi + lodsb + movzbl %al,%eax + incl %eax + addl %eax,%esi + movb $0,(%esi) + end; + es.nameofs:=pointer(longint(@path)+1); + asm + movw %ss,(12)es {Compiler doesn't like record elems in asm.} + movw %ss,(14)es + movw %ss,(16)es + end; + es.sizearg:=j; + es.numenv:=0; + {Typecasting of sets in FPK is a bit hard.} + es.mode1:=setarray(runflags)[0]; + es.mode2:=byte(winflags); + + {Now exec the program.} + esadr:=@es; + asm + movl esadr,%edx + mov $0x7f06,%ax + call ___SYSCALL + jnc exprg1 + movl %eax,U_DOS_DOSERROR + xorl %eax,%eax + decl %eax + exprg1: + movl %eax,__RESULT + end; + + freemem(args,512); + freemem(env,8192); + {Phew! That's it. This was the most sophisticated procedure to call + a system function I ever wrote!} + end; + + {$ENDIF} + + function dosexitcode : word; + + begin + dosexitcode:=lastdosexitcode; + end; + + function dosversion : word; + + begin + {$IFNDEF OS2} + asm + movb $0x30,%ah + pushl %ebp + int $0x21 + popl %ebp + leave + ret + end; + {$ELSE} + {Returns DOS version in DOS and OS/2 version in OS/2} + asm + movb $0x30,%ah + call ___SYSCALL + leave + ret + end; + {$ENDIF} + end; + + procedure getdate(var year,month,day,dayofweek : word); + + begin + {$IFNDEF OS2} + asm + movb $0x2a,%ah + pushl %ebp + int $0x21 + popl %ebp + xorb %ah,%ah + movl 20(%ebp),%edi + stosw + movl 16(%ebp),%edi + movb %dl,%al + stosw + movl 12(%ebp),%edi + movb %dh,%al + stosw + movl 8(%ebp),%edi + movw %cx,%ax + stosw + end; + {$ELSE} + asm + movb $0x2a,%ah + call ___SYSCALL + xorb %ah,%ah + movl 20(%ebp),%edi + stosw + movl 16(%ebp),%edi + movb %dl,%al + stosw + movl 12(%ebp),%edi + movb %dh,%al + stosw + movl 8(%ebp),%edi + xchgw %ecx,%eax + stosw + end; + {$ENDIF} + end; + + procedure setdate(year,month,day : word); + + begin + {$IFNDEF OS2} + asm + movw 8(%ebp),%cx + movb 10(%ebp),%dh + movb 12(%ebp),%dl + movb $0x2b,%ah + pushl %ebp + int $0x21 + popl %ebp + xorb %ah,%ah + movw %ax,U_DOS_DOSERROR + end; + {$ELSE} + {DOS only! You cannot change the system date in OS/2!} + asm + movw 8(%ebp),%cx + movb 10(%ebp),%dh + movb 12(%ebp),%dl + movb $0x2b,%ah + call ___SYSCALL + xorb %ah,%ah + movw %ax,U_DOS_DOSERROR + end; + {$ENDIF} + end; + + procedure gettime(var hour,minute,second,sec100 : word); + + begin + {$IFNDEF OS2} + asm + movb $0x2c,%ah + pushl %ebp + int $0x21 + popl %ebp + xorb %ah,%ah + movl 20(%ebp),%edi + movb %dl,%al + stosw + movl 16(%ebp),%edi + movb %dh,%al + stosw + movl 12(%ebp),%edi + movb %cl,%al + stosw + movl 8(%ebp),%edi + movb %ch,%al + stosw + end; + {$ELSE} + asm + movb $0x2c,%ah + call ___SYSCALL + xorb %ah,%ah + movl 20(%ebp),%edi + movb %dl,%al + stosw + movl 16(%ebp),%edi + movb %dh,%al + stosw + movl 12(%ebp),%edi + movb %cl,%al + stosw + movl 8(%ebp),%edi + movb %ch,%al + stosw + end; + {$ENDIF} + end; + + procedure settime(hour,minute,second,sec100 : word); + + begin + {$IFNDEF OS2} + asm + movb 8(%ebp),%ch + movb 10(%ebp),%cl + movb 12(%ebp),%dh + movb 14(%ebp),%dl + movb $0x2d,%ah + pushl %ebp + int $0x21 + popl %ebp + xorb %ah,%ah + movw %ax,U_DOS_DOSERROR + end; + {$ELSE} + asm + movb 8(%ebp),%ch + movb 10(%ebp),%cl + movb 12(%ebp),%dh + movb 14(%ebp),%dl + movb $0x2d,%ah + call ___SYSCALL + xorb %ah,%ah + movw %ax,U_DOS_DOSERROR + end; + {$ENDIF} + end; + + procedure getcbreak(var breakvalue : boolean); + + begin + {$IFNDEF OS2} + asm + movw $0x3300,%ax + pushl %ebp + int $0x21 + popl %ebp + movl 8(%ebp),%eax + movb %dl,(%eax) + end; + {$ELSE} + {! Do not use in OS/2. Also not recommended in DOS. Use + signal handling instead.} + asm + movw $0x3300,%ax + call ___SYSCALL + movl 8(%ebp),%eax + movb %dl,(%eax) + end; + {$ENDIF} + end; + + procedure setcbreak(breakvalue : boolean); + + begin + {$IFNDEF OS2} + asm + movb 8(%ebp),%dl + movl $0x3301,%ax + pushl %ebp + int $0x21 + popl %ebp + end; + {$ELSE} + {! Do not use in OS/2. Also not recommended in DOS. Use + signal handling instead.} + asm + movb 8(%ebp),%dl + movl $0x3301,%ax + call ___SYSCALL + end; + {$ENDIF} + end; + + procedure getverify(var verify : boolean); + + begin + {$IFNDEF OS2} + asm + movb $0x54,%ah + pushl %ebp + int $0x21 + popl %ebp + movl 8(%ebp),%edi + stosb + end; + {$ELSE} + {! Do not use in OS/2.} + asm + movb $0x54,%ah + call ___SYSCALL + movl 8(%ebp),%edi + stosb + end; + {$ENDIF} + end; + + procedure setverify(verify : boolean); + + begin + {$IFNDEF OS2} + asm + movb 8(%ebp),%al + movb $0x2e,%ah + pushl %ebp + int $0x21 + popl %ebp + end; + {$ELSE} + {! Do not use in OS/2.} + asm + movb 8(%ebp),%al + movb $0x2e,%ah + call ___SYSCALL + end; + {$ENDIF} + end; + + function diskfree(drive : byte) : longint; + + var fi:OS2FSallocate; + + begin + {$IFNDEF OS2} + asm + movb 8(%ebp),%dl + movb $0x36,%ah + pushl %ebp + int $0x21 + popl %ebp + cmpw $-1,%ax + je LDISKFREE1 + mulw %cx + mulw %bx + shll $16,%edx + movw %ax,%dx + movl %edx,%eax + leave + ret + LDISKFREE1: + cwde + leave + ret + end; + {$ELSE} + if os_mode=osDOS then + {Function 36 is not supported in OS/2.} + asm + movb 8(%ebp),%dl + movb $0x36,%ah + call ___SYSCALL + cmpw $-1,%ax + je LDISKFREE1 + mulw %cx + mulw %bx + shll $16,%edx + movw %ax,%dx + xchgl %edx,%eax + leave + ret + LDISKFREE1: + cwde + leave + ret + end + else + {In OS/2, we use the filesystem information.} + begin + doserror:=dosqueryFSinfo(drive,1,FI,sizeof(FI)); + if doserror=0 then + diskfree:=FI.cunitavail*FI.csectorunit*FI.cbsector + else + diskfree:=-1; + end; + {$ENDIF} + end; + + function disksize(drive : byte) : longint; + + begin + {$IFNDEF OS/2} + asm + movb 8(%ebp),%dl + movb $0x36,%ah + pushl %ebp + int $0x21 + popl %ebp + movw %dx,%bx + cmpw $-1,%ax + je LDISKSIZE1 + mulw %cx + mulw %bx + shll $16,%edx + movw %ax,%dx + movl %edx,%eax + leave + ret + LDISKSIZE1: + movl $-1,%eax + leave + ret + end; + {$ELSE} + if os_mode=osDOS then + {Function 36 is not supported in OS/2.} + asm + movb 8(%ebp),%dl + movb $0x36,%ah + call ___SYSCALL + movw %dx,%bx + cmpw $-1,%ax + je LDISKSIZE1 + mulw %cx + mulw %bx + shll $16,%edx + movw %ax,%dx + xchgl %edx,%eax + leave + ret + LDISKSIZE1: + cwde + leave + ret + end; + else + {In OS/2, we use the filesystem information.} + begin + doserror:=dosQFSinfo(drive,1,FI,sizeof(FI)); + if doserror=0 then + diskfree:=FI.cunit*FI.csectorunit*FI.cbsector + else + diskfree:=-1; + end; + {$ENDIF} + end; + + procedure searchrec2dossearchrec(var f : searchrec); + + var + l,i : longint; + + {$IFDEF OS2} + const namesize=255; + {$ELSE} + const namesize=12; + {$ENDIF} + + begin + l:=length(f.name); + for i:=1 to namesize do + f.name[i-1]:=f.name[i]; + f.name[l]:=#0; + end; + + procedure dossearchrec2searchrec(var f : searchrec); + + var + l,i : longint; + + {$IFDEF OS2} + const namesize=255; + {$ELSE} + const namesize=12; + {$ENDIF} + + begin + for i:=0 to namesize do + if f.name[i]=#0 then + begin + l:=i; + break; + end; + for i:=namesize-1 downto 0 do + f.name[i+1]:=f.name[i]; + f.name[0]:=chr(l); + end; + + procedure findfirst(const path : pathstr;attr : word;var f : searchRec); + + procedure _findfirst(path : pchar;attr : word;var f : searchrec); + + begin + {$IFNDEF OS2} + asm + movl 18(%ebp),%edx + movb $0x1a,%ah + int $0x21 + movl 12(%esp),%edx + movzwl 16(%esp),%ecx + movb $0x4e,%ah + int $0x21 + jnc LFF + movw %ax,U_DOS_DOSERROR + LFF: + end; + {$ELSE} + asm + movl 12(%esp),%edx + movw 16(%esp),%cx + {No need to set DTA in EMX. Just give a pointer in ESI.} + movl 18(%ebp),%esi + movb $0x4e,%ah + call ___SYSCALL + jnc LFF + movw %ax,U_DOS_DOSERROR + LFF: + end; + {$ENDIF} + end; + + var + path0 : array[0..80] of char; + + begin + { no error } + doserror:=0; + strpcopy(path0,path); + _findfirst(path0,attr,f); + dossearchrec2searchrec(f); + end; + + procedure findnext(var f : searchRec); + + procedure _findnext(var f : searchrec); + + begin + {$IFNDEF OS2} + asm + movl 12(%ebp),%edx + movb $0x1a,%ah + int $0x21 + movb $0x4f,%ah + int $0x21 + jnc LFN + movw %ax,U_DOS_DOSERROR + LFN: + end; + {$ELSE} + asm + movl 12(%ebp),%esi + movb $0x4f,%ah + call ___SYSCALL + jnc LFN + movw %ax,U_DOS_DOSERROR + LFN: + end; + {$ENDIF} + end; + + begin + { no error } + doserror:=0; + searchrec2dossearchrec(f); + _findnext(f); + dossearchrec2searchrec(f); + end; + + procedure swapvectors; + + begin + { tut nichts, DOS-Extender bernimmt das Ntige } + { normalerweise selber } + { nur aus Kompatibilittsgrnden implementiert } + end; + + type + ppchar = ^pchar; + + function envs : ppchar; + + begin + asm + movl _environ,%eax + leave + ret + end ['EAX']; + end; + + function envcount : longint; + + var + hp : ppchar; + + begin + {$IFNDEF OS2} + hp:=envs; + envcount:=0; + while assigned(hp^) do + begin + { not the best solution, but quite understandable } + inc(envcount); + hp:=hp+4; + end; + {$ELSE} + asm + movl _envc,%eax + leave + ret + end ['EAX']; + {$ENDIF} + end; + + function envstr(index : longint) : string; + + var + hp : ppchar; + + begin + if (index<=0) or (index>envcount) then + begin envstr:=''; exit; end; - hp:=envs+4*(index-1); + hp:=envs+4*(index-1); envstr:=strpas(hp^); - end; + end; - function getenv(const envvar : string) : string; + function getenv(const envvar : string) : string; var hs,_envvar : string; @@ -1157,19 +1157,19 @@ unit dos; begin _envvar:=upcase(envvar); getenv:=''; - for i:=1 to envcount do - begin + for i:=1 to envcount do + begin hs:=envstr(i); eqpos:=pos('=',hs); - if copy(hs,1,eqpos-1)=_envvar then + if copy(hs,1,eqpos-1)=_envvar then begin - getenv:=copy(hs,eqpos+1,length(hs)-eqpos); + getenv:=copy(hs,eqpos+1,length(hs)-eqpos); exit; end; end; end; - procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr; + procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr; var ext : extstr); var @@ -1179,17 +1179,17 @@ unit dos; { try to find out a extension } p1:=pos('.',path); if p1>0 then - begin + begin ext:=copy(path,p1,4); delete(path,p1,length(path)-p1+1); end - else + else ext:=''; - { get drive name } + { get drive name } p1:=pos(':',path); if p1>0 then begin - dir:=path[1]+':'; + dir:=path[1]+':'; delete(path,1,p1); end else @@ -1202,60 +1202,60 @@ unit dos; if p1=0 then break; dir:=dir+copy(path,1,p1); - delete(path,1,p1); - end; + delete(path,1,p1); + end; name:=path; end; function fexpand(const path : pathstr) : pathstr; function get_current_drive : byte; - + var r : registers; - - begin + + begin r.ah:=$19; msdos(r); get_current_drive:=r.al; - end; + end; - var - {$IFDEF DOS} - s,pa : string[79]; - {$ELSE} - s,pa:string; - {$ENDIF} + var + {$IFDEF DOS} + s,pa : string[79]; + {$ELSE} + s,pa:string; + {$ENDIF} - begin - { There are differences between FPKPascal and Turbo Pascal - e.g. for the string 'D:\DEMO\..\HELLO' which isn't handled } - getdir(0,s); - pa:=upcase(path); - if (byte(pa[0])>1) and ((pa[1] in ['A'..'Z']) and (pa[2]=':')) then - begin - if (byte(pa[0])>2) and (pa[3]<>'\') then - if pa[1]=s[1] then - pa:=s+'\'+copy (pa,3,length(pa)) - else - pa:=pa[1]+':\'+copy (pa,3,length(pa)) - end - else - if pa[1]='\' then - pa:=s[1]+':'+pa - else if s[0]=#3 then - pa:=s+pa - else - pa:=s+'\'+pa; - fexpand:=pa; - end; + begin + { There are differences between FPKPascal and Turbo Pascal + e.g. for the string 'D:\DEMO\..\HELLO' which isn't handled } + getdir(0,s); + pa:=upcase(path); + if (byte(pa[0])>1) and ((pa[1] in ['A'..'Z']) and (pa[2]=':')) then + begin + if (byte(pa[0])>2) and (pa[3]<>'\') then + if pa[1]=s[1] then + pa:=s+'\'+copy (pa,3,length(pa)) + else + pa:=pa[1]+':\'+copy (pa,3,length(pa)) + end + else + if pa[1]='\' then + pa:=s[1]+':'+pa + else if s[0]=#3 then + pa:=s+pa + else + pa:=s+'\'+pa; + fexpand:=pa; + end; procedure packtime(var d : datetime;var time : longint); - var + var zs : longint; - begin + begin time:=-1980; time:=time+d.year and 127; time:=time shl 4; @@ -1263,17 +1263,17 @@ unit dos; time:=time shl 5; time:=time+d.day; time:=time shl 16; - zs:=d.hour; + zs:=d.hour; zs:=zs shl 6; zs:=zs+d.min; zs:=zs shl 5; - zs:=zs+d.sec div 2; - time:=time+(zs and $ffff); - end; + zs:=zs+d.sec div 2; + time:=time+(zs and $ffff); + end; procedure unpacktime (time: longint; var d: datetime); - begin + begin d.sec:=(time and 31) * 2; time:=time shr 5; d.min:=time and 63; @@ -1291,54 +1291,54 @@ unit dos; var { to avoid problems } - n : array[0..255] of char; - {$IFNDEF OS2} - r : registers; - {$ENDIF} + n : array[0..255] of char; + {$IFNDEF OS2} + r : registers; + {$ENDIF} - begin - strpcopy(n,filerec(f).name); - {$IFNDEF OS2} - r.ax:=$4300; - r.edx:=longint(@n); - msdos(r); - attr:=r.cx; - {$ELSE} - {Alas, msdos(r) doesn't work when we are running in OS/2.} - asm - movw $0x4300,%ax - leal n,%edx - call ___SYSCALL - movl attr,%ebx - movw %cx,(%ebx) - end; - {$ENDIF} - end; + begin + strpcopy(n,filerec(f).name); + {$IFNDEF OS2} + r.ax:=$4300; + r.edx:=longint(@n); + msdos(r); + attr:=r.cx; + {$ELSE} + {Alas, msdos(r) doesn't work when we are running in OS/2.} + asm + movw $0x4300,%ax + leal n,%edx + call ___SYSCALL + movl attr,%ebx + movw %cx,(%ebx) + end; + {$ENDIF} + end; - procedure setfattr(var f;attr : word); + procedure setfattr(var f;attr : word); - var - { to avoid problems } - n : array[0..255] of char; - {$IFNDEF OS2} - r : registers; - {$ENDIF} + var + { to avoid problems } + n : array[0..255] of char; + {$IFNDEF OS2} + r : registers; + {$ENDIF} - begin - strpcopy(n,filerec(f).name); - {$IFNDEF OS2} - r.ax:=$4301; - r.edx:=longint(@n); - r.cx:=attr; - msdos(r); - {$ELSE} - {Alas, msdos(r) doesn't work when we are running in OS/2.} - asm - movw $0x4301,%ax - leal n,%edx - movw attr,%cx - call ___SYSCALL - end; - {$ENDIF} - end; + begin + strpcopy(n,filerec(f).name); + {$IFNDEF OS2} + r.ax:=$4301; + r.edx:=longint(@n); + r.cx:=attr; + msdos(r); + {$ELSE} + {Alas, msdos(r) doesn't work when we are running in OS/2.} + asm + movw $0x4301,%ax + leal n,%edx + movw attr,%cx + call ___SYSCALL + end; + {$ENDIF} + end; end. diff --git a/rtl/os2/makefile b/rtl/os2/makefile index 7a218e82b7..ddf81988e5 100644 --- a/rtl/os2/makefile +++ b/rtl/os2/makefile @@ -1,23 +1,29 @@ -# makes the SYSTEM-Unit for OS2 # -# Copyright (c) 1996 by Michael Van Canneyt +# $Id$ +# This file is part of the Free Pascal run time library. +# Copyright (c) 1996-98 by Michael van Canneyt +# +# Makefile for the Free Pascal OS/2 Runtime Library +# +# 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. +# ##################################################################### -# Start of configurable section. -# Please note that all these must be set in the main makefile, and +# Start of configurable section. +# Please note that all these must be set in the main makefile, and # should be set there. # Don't remove the indef statements. They serve to avoid conflicts # with the main makefile. ##################################################################### -# set the directory where to install the units. -ifndef LIBINSTALLDIR -LIBINSTALLDIR=c:/pp/bin -endif - -# What is the Operating System -ifndef OS_SRC -OS_SRC=os2 +# What is the Operating System ? +ifndef OS_SOURCE +OS_SOURCE=go32v2 endif # What is the target operating system ? @@ -25,9 +31,15 @@ ifndef OS_TARGET OS_TARGET=os2 endif +# What is the target processor : +ifndef CPU +CPU=i386 +#CPU=m68k +endif + # What compiler to use ? ifndef PP -PP=../../ppc386 +PP=ppc386 endif # What options to pass to the compiler ? @@ -36,19 +48,38 @@ ifndef OPT OPT= endif -ifndef CPU -CPU=i386 -endif +# Where is the PPUMOVE program ? +ifndef PPUMOVE +PPUMOVE=ppumove +endif + +# Set this to 'shared' or 'static' +LIBTYPE=shared + +# AOUT should be defined in main makefile. +# But you can set it here too. +# AOUT = -DAOUT + +# Do you want to link to the C library ? +# Standard it is NO. You can set it to YES to link in th C library. +ifndef LINK_TO_C +LINK_TO_C=NO +endif ##################################################################### -# End of configurable section. +# End of configurable section. # Do not edit after this line. ##################################################################### -# Where are the include files +##################################################################### +# System independent +##################################################################### + +# Where are the include files ? INC=../inc PROCINC=../$(CPU) CFG=../cfg +OBJPASDIR=../objpas # Get some defaults for Programs and OSes. # This will set the following variables : @@ -59,13 +90,13 @@ CFG=../cfg include $(CFG)/makefile.cfg # Get the system independent include file names. -# This will set the following variables : +# This will set the following variables : # SYSINCNAMES include $(INC)/makefile.inc SYSINCDEPS=$(addprefix $(INC)/,$(SYSINCNAMES)) # Get the processor dependent include file names. -# This will set the following variables : +# This will set the following variables : # CPUINCNAMES include $(PROCINC)/makefile.cpu SYSCPUDEPS=$(addprefix $(PROCINC)/,$(CPUINCNAMES)) @@ -77,69 +108,118 @@ SYSDEPS=$(SYSINCDEPS) $(SYSCPUDEPS) # System dependent ##################################################################### +PPUEXT=.ppo +ASMEXT=.so2 +OEXT=.o2 -PPUEXT = .ppu +# Define Linux Units +SYSTEMPPU=sysos2$(PPUEXT) +OBJECTS=strings objpas \ + dos crt -OEXT = .obj +LOADERS=prt0 prt1 +##################################################################### +# System independent Makefile +##################################################################### -.PHONY: all clean install diffs diffclean +# Add Prefix and Suffixes +OBJLOADERS=$(addsuffix $(OEXT), $(LOADERS)) +PPUOBJECTS=$(addsuffix $(PPUEXT), $(OBJECTS)) -all : sysos2$(PPUEXT) prt0$(OEXT) prt1$(OEXT) dosinit$(OEXT) \ - strings$(PPUEXT) dos$(PPUEXT) getopts$(PPUEXT) +.PHONY : all install clean \ + libs libsclean \ + diffs diffclean \ +all : $(OBJLOADERS) $(PPUOBJECTS) -getopts$(PPUEXT) : $(PROCINC)/getopts.pp sysos2$(PPUEXT) - $(COPY) $(PROCINC)/getopts.pp . - $(PP) $(OPT) getopts.pp $(REDIR) - $(DEL) getopts.pp +install : all + $(MKDIR) $(UNITINSTALLDIR) + $(INSTALL) *$(PPUEXT) *$(OEXT) $(UNITINSTALLDIR) -strings$(PPUEXT) : $(PROCINC)/strings.pp sysos2$(PPUEXT) - $(COPY) $(PROCINC)/strings.pp . - $(PP) $(OPT) strings.pp $(REDIR) - $(DEL) strings.pp +clean : + -$(DEL) *$(OEXT) *$(ASMEXT) *$(PPUEXT) log -dos$(PPUEXT) : dos.pas strings$(PPUEXT) sysos2$(PPUEXT) - $(PP) $(OPT) dos.pas $(REDIR) +##################################################################### +# Files +##################################################################### -sysos2$(PPUEXT) : sysos2.pas $(SYSDEPS) - $(PP) $(OPT) -Us sysos2.pas $(REDIR) +# +# Loaders +# -prt0$(OEXT) : prt0.so2 +prt0$(OEXT) : prt0.as as -D -o prt0$(OEXT) prt0.as -prt1$(OEXT) : prt1.so2 +prt1$(OEXT) : prt1.as as -D -o prt1$(OEXT) prt1.as -dosinit$(OEXT) : dosinit.as - as -D -o dosinit$(OEXT) dosinit.as +# +# Base Units (System, strings, os-dependent-base-unit) +# -clean: - -$(DEL) *$(OEXT) - -$(DEL) *$(PPUEXT) - -$(DEL) *.dif - -$(DEL) *.s - -$(DEL) log +$(SYSTEMPPU) : sysos2.pas $(SYSDEPS) + $(PP) $(OPT) -Us -Sg sysos2.pas $(REDIR) -diffclean: - -$(DEL) *.dif +strings$(PPUEXT) : $(PROCINC)/strings.pp $(SYSTEMPPU) + $(COPY) $(PROCINC)/strings.pp . + $(PP) $(OPT) strings $(REDIR) + $(DEL) strings.pp -install: all - $(MKDIR) $(LIBINSTALLDIR)/os2units - $(INSTALL) *$(OEXT) *$(PPUEXT) $(LIBINSTALLDIR)/os2units +# +# Delphi Object Model +# -%.dif : %.pas - -$(DIFF) $(DIFOPTS) $*.pas $(REFPATH)/os2/$*.pas > $*.dif +objpas$(PPUEXT) : $(OBJPASDIR)/objpas.pp $(SYSTEMPPU) + $(COPY) $(OBJPASDIR)/objpas.pp . + $(PP) $(OPT) objpas $(REDIR) + $(DEL) objpas.pp -%.dif : %.inc - -$(DIFF) $(DIFOPTS) $*.inc $(REFPATH)/os2/$*.inc > $*.dif +# +# System Dependent Units +# -%.dif : %.as - -$(DIFF) $(DIFOPTS) $*.as $(REFPATH)/os2/$*.as > $*.dif +# +# TP7 Compatible RTL Units +# -makefile.dif : makefile - -$(DIFF) $(DIFFOPTS) makefile $(REFPATH)/os2/makefile > makefile.dif - +dos$(PPUEXT) : dos.pas $(INC)/filerec.inc $(INC)/textrec.inc strings$(PPUEXT) $(SYSTEMPPU) + $(PP) $(OPT) dos.pas $(REDIR) -diffs: sysos2.dif dos.dif doscalls.dif os.dif prt0.dif prt1.dif dosinit.dif \ - makefile.dif +crt$(PPUEXT) : crt.pas dos$(PPUEXT) + $(PP) $(OPT) crt.pas $(REDIR) + +#objects$(PPUEXT) : $(INC)/objects.pp objinc.inc $(SYSTEMPPU) +# $(COPY) $(INC)/objects.pp . +# $(PP) $(OPT) objects $(REDIR) +# $(DEL) objects.pp + +# +# Other RTL Units +# + +##################################################################### +# Libs +##################################################################### + +libs : all libfpc$(LIBEXT) + +libfpc.so: + $(PPUMOVE) -o fpc *.ppu + +libfpc.a: + $(PPUMOVE) -s -o fpc *.ppu + +libinstall : libs + $(INSTALLEXE) libfpc$(LIBEXT) $(LIBINSTALLDIR) + $(INSTALL) *$(PPLEXT) $(UNITINSTALLDIR) + ldconfig + +libsclean : clean + -$(DEL) *.a *.so *$(PPLEXT) + +##################################################################### +# Default targets +##################################################################### + +include $(CFG)/makefile.def diff --git a/rtl/os2/prt0.so2 b/rtl/os2/prt0.as similarity index 100% rename from rtl/os2/prt0.so2 rename to rtl/os2/prt0.as diff --git a/rtl/os2/prt1.as b/rtl/os2/prt1.as new file mode 100644 index 0000000000..fc3019d2a4 --- /dev/null +++ b/rtl/os2/prt1.as @@ -0,0 +1,60 @@ +/ prt1.s (emx+fpk) -- Made from crt2.s and dos.s, +/ Copyright (c) 1990-1996 by Eberhard Mattes. +/ Changed for FPK-Pascal in 1997 Danil Mantione. +/ This code is _not_ under the Library GNU Public +/ License, because the original is not. See copying.emx +/ for details. You should have received it with this +/ product, write the author if you haven't. + + .globl __entry1 + .globl _environ + .globl _envc + .globl _argv + .globl _argc + + .text + +__entry1: + popl %esi + xorl %ebp, %ebp + leal (%esp), %edi + movl %edi,_environ + call L_ptr_tbl + mov %ecx,_envc + mov %edi,_argv + call L_ptr_tbl + mov %ecx,_argc + jmp *%esi + +L_ptr_tbl: + xorl %eax, %eax + movl $-1, %ecx +1: incl %ecx + scasl + jne 1b + ret + +/ In executables created with emxbind, the call to _dos_init will +/ be fixed up at load time to _emx_init of emx.dll. Under DOS, +/ this dummy is called instead as there is no fixup. This module +/ must be linked statically to avoid having two fixups for the +/ same location. + + .globl __dos_init + .globl __dos_syscall + +__dos_init: + ret $4 + + .align 2, 0x90 + +__dos_syscall: + int $0x21 + ret + + .data + + .comm _environ, 4 + .comm _envc, 4 + .comm _argv, 4 + .comm _argc, 4 diff --git a/rtl/os2/prt1.so2 b/rtl/os2/prt1.so2 deleted file mode 100644 index 091e4335ab..0000000000 --- a/rtl/os2/prt1.so2 +++ /dev/null @@ -1,60 +0,0 @@ -/ prt1.s (emx+fpk) -- Made from crt2.s and dos.s, -/ Copyright (c) 1990-1996 by Eberhard Mattes. -/ Changed for FPK-Pascal in 1997 Danil Mantione. -/ This code is _not_ under the Library GNU Public -/ License, because the original is not. See copying.emx -/ for details. You should have received it with this -/ product, write the author if you haven't. - - .globl __entry1 - .globl _environ - .globl _envc - .globl _argv - .globl _argc - - .text - -__entry1: - popl %esi - xorl %ebp, %ebp - leal (%esp), %edi - movl %edi,_environ - call L_ptr_tbl - mov %ecx,_envc - mov %edi,_argv - call L_ptr_tbl - mov %ecx,_argc - jmp *%esi - -L_ptr_tbl: - xorl %eax, %eax - movl $-1, %ecx -1: incl %ecx - scasl - jne 1b - ret - -/ In executables created with emxbind, the call to _dos_init will -/ be fixed up at load time to _emx_init of emx.dll. Under DOS, -/ this dummy is called instead as there is no fixup. This module -/ must be linked statically to avoid having two fixups for the -/ same location. - - .globl __dos_init - .globl __dos_syscall - -__dos_init: - ret $4 - - .align 2, 0x90 - -__dos_syscall: - int $0x21 - ret - - .data - - .comm _environ, 4 - .comm _envc, 4 - .comm _argv, 4 - .comm _argc, 4 diff --git a/rtl/os2/sysos2.pas b/rtl/os2/sysos2.pas index 266b9f9173..10fdbdedd8 100644 --- a/rtl/os2/sysos2.pas +++ b/rtl/os2/sysos2.pas @@ -1,9 +1,9 @@ {**************************************************************************** - FPK-Pascal -- OS/2 runtime library + FPK-Pascal -- OS/2 runtime library - Copyright (c) 1993,95 by Florian Klmpfl - Copyright (c) 1997 by Danil Mantione + Copyright (c) 1993,95 by Florian Klmpfl + Copyright (c) 1997 by Danil Mantione FPK-Pascal is distributed under the GNU Public License v2. So is this unit. The GNU Public License requires you to distribute the source code of this @@ -32,19 +32,19 @@ unit sysos2; {Changelog: - People: + People: - DM - Danil Mantione + DM - Danil Mantione - Date: Description of change: Changed by: + Date: Description of change: Changed by: - - First released version 0.1. DM + - First released version 0.1. DM Coding style: - My coding style is a bit unusual for Pascal. Nevertheless I friendly ask - you to try to make your changes not look all to different. In general, - set your IDE to use tab characters, optimal fill on and a tabsize of 4.} + My coding style is a bit unusual for Pascal. Nevertheless I friendly ask + you to try to make your changes not look all to different. In general, + set your IDE to use tab characters, optimal fill on and a tabsize of 4.} {$I os.inc} @@ -53,67 +53,67 @@ interface {Link the startup code.} {$l prt1.oo2} -{$I SYSTEMH.INC} -{$I heaph.inc} +{$I SYSTEMH.INC} +{$I heaph.inc} -type Tos=(osDOS,osOS2,osDPMI); +type Tos=(osDOS,osOS2,osDPMI); -var os_mode:Tos; - first_meg:pointer; +var os_mode:Tos; + first_meg:pointer; -type Psysthreadib=^Tsysthreadib; - Pthreadinfoblock=^Tthreadinfoblock; - Pprocessinfoblock=^Tprocessinfoblock; +type Psysthreadib=^Tsysthreadib; + Pthreadinfoblock=^Tthreadinfoblock; + Pprocessinfoblock=^Tprocessinfoblock; - Tbytearray=array[0..$ffff] of byte; - Pbytearray=^Tbytearray; + Tbytearray=array[0..$ffff] of byte; + Pbytearray=^Tbytearray; - Tsysthreadib=record - tid, - priority, - version:longint; - MCcount, - MCforceflag:word; - end; + Tsysthreadib=record + tid, + priority, + version:longint; + MCcount, + MCforceflag:word; + end; - Tthreadinfoblock=record - pexchain, - stack, - stacklimit:pointer; - tib2:Psysthreadib; - version, - ordinal:longint; - end; + Tthreadinfoblock=record + pexchain, + stack, + stacklimit:pointer; + tib2:Psysthreadib; + version, + ordinal:longint; + end; - Tprocessinfoblock=record - pid, - parentpid, - hmte:longint; - cmd, - env:Pbytearray; - flstatus, - ttype:longint; - end; + Tprocessinfoblock=record + pid, + parentpid, + hmte:longint; + cmd, + env:Pbytearray; + flstatus, + ttype:longint; + end; -const UnusedHandle=$ffff; - StdInputHandle=0; - StdOutputHandle=1; - StdErrorHandle=2; +const UnusedHandle=$ffff; + StdInputHandle=0; + StdOutputHandle=1; + StdErrorHandle=2; implementation -{$I SYSTEM.INC} +{$I SYSTEM.INC} procedure dosgetinfoblocks(var Atib:Pthreadinfoblock; - var Apib:Pprocessinfoblock); - external 'DOSCALLS' index 312; + var Apib:Pprocessinfoblock); + external 'DOSCALLS' index 312; {This is the correct way to call external assembler procedures.} procedure syscall;external name '___SYSCALL'; {*************************************************************************** - Runtime error checking related routines. + Runtime error checking related routines. ***************************************************************************} @@ -121,106 +121,106 @@ procedure syscall;external name '___SYSCALL'; procedure st1(stack_size:longint);[public,alias: 'STACKCHECK']; begin - { called when trying to get local stack } - { if the compiler directive $S is set } - asm - movl stack_size,%ebx - movl %esp,%eax - subl %ebx,%eax + { called when trying to get local stack } + { if the compiler directive $S is set } + asm + movl stack_size,%ebx + movl %esp,%eax + subl %ebx,%eax {$ifdef SYSTEMDEBUG} - movl U_SYSOS2_LOWESTSTACK,%ebx - cmpl %eax,%ebx - jb .Lis_not_lowest - movl %eax,U_SYSOS2_LOWESTSTACK - .Lis_not_lowest: + movl U_SYSOS2_LOWESTSTACK,%ebx + cmpl %eax,%ebx + jb .Lis_not_lowest + movl %eax,U_SYSOS2_LOWESTSTACK + .Lis_not_lowest: {$endif SYSTEMDEBUG} - cmpb $2,U_SYSOS2_OS_MODE - jne .Lrunning_in_dos - movl U_SYSOS2_STACKBOTTOM,%ebx - jmp .Lrunning_in_os2 - .Lrunning_in_dos: - movl __heap_brk,%ebx - .Lrunning_in_os2: - cmpl %eax,%ebx - jae .Lshort_on_stack - leave - ret $4 - .Lshort_on_stack: - end ['EAX','EBX']; - { this needs a local variable } - { so the function called itself !! } - { Writeln('low in stack ');} - RunError(202); + cmpb $2,U_SYSOS2_OS_MODE + jne .Lrunning_in_dos + movl U_SYSOS2_STACKBOTTOM,%ebx + jmp .Lrunning_in_os2 + .Lrunning_in_dos: + movl __heap_brk,%ebx + .Lrunning_in_os2: + cmpl %eax,%ebx + jae .Lshort_on_stack + leave + ret $4 + .Lshort_on_stack: + end ['EAX','EBX']; + { this needs a local variable } + { so the function called itself !! } + { Writeln('low in stack ');} + RunError(202); end; {no stack check in system } {**************************************************************************** - Miscelleanious related routines. + Miscelleanious related routines. ****************************************************************************} procedure halt(errnum:byte); begin - asm - movb $0x4c,%ah - movb errnum,%al - call syscall - end; + asm + movb $0x4c,%ah + movb errnum,%al + call syscall + end; end; function paramcount:longint; begin - asm - movl _argc,%eax - decl %eax - leave - ret - end ['EAX']; + asm + movl _argc,%eax + decl %eax + leave + ret + end ['EAX']; end; function paramstr(l:longint):string; - function args:pointer; + function args:pointer; - begin - asm - movl _argv,%eax - leave - ret - end ['EAX']; - end; + begin + asm + movl _argv,%eax + leave + ret + end ['EAX']; + end; -var p:^Pchar; +var p:^Pchar; begin - if (l>=0) and (l<=paramcount) then - begin - p:=args; - paramstr:=strpas(p[l]); - end - else paramstr:=''; + if (l>=0) and (l<=paramcount) then + begin + p:=args; + paramstr:=strpas(p[l]); + end + else paramstr:=''; end; procedure randomize; -var hl:longint; +var hl:longint; begin - asm - movb $0x2c,%ah - call syscall - movw %cx,-4(%ebp) - movw %dx,-2(%ebp) - end; - randseed:=hl; + asm + movb $0x2c,%ah + call syscall + movw %cx,-4(%ebp) + movw %dx,-2(%ebp) + end; + randseed:=hl; end; {**************************************************************************** - Heap management releated routines. + Heap management releated routines. ****************************************************************************} @@ -231,29 +231,29 @@ syscall $7f00 resizes the brk area} function sbrk(size:longint):longint; begin - asm - movl size,%edx - movw $0x7f00,%ax - call syscall - movl %eax,__RESULT - end; + asm + movl size,%edx + movw $0x7f00,%ax + call syscall + movl %eax,__RESULT + end; end; function getheapstart:pointer; begin - asm - movl __heap_base,%eax - leave - ret - end ['EAX']; + asm + movl __heap_base,%eax + leave + ret + end ['EAX']; end; -{$i heap.inc} +{$i heap.inc} {**************************************************************************** - Low Level File Routines + Low Level File Routines ****************************************************************************} @@ -261,169 +261,169 @@ procedure allowslash(p:Pchar); {Allow slash as backslash.} -var i:longint; +var i:longint; begin - for i:=0 to strlen(p) do - if p[i]='/' then p[i]:='\'; + for i:=0 to strlen(p) do + if p[i]='/' then p[i]:='\'; end; procedure do_close(h:longint); begin - asm - movb $0x3e,%ah - mov h,%ebx - call syscall - end; + asm + movb $0x3e,%ah + mov h,%ebx + call syscall + end; end; procedure do_erase(p:Pchar); begin - allowslash(p); - asm - movl 8(%ebp),%edx - movb $0x41,%ah - call syscall - jnc .LERASE1 - movw %ax,inoutres; - .LERASE1: - end; + allowslash(p); + asm + movl 8(%ebp),%edx + movb $0x41,%ah + call syscall + jnc .LERASE1 + movw %ax,inoutres; + .LERASE1: + end; end; procedure do_rename(p1,p2:Pchar); begin - allowslash(p1); - allowslash(p2); - asm - movl 8(%ebp),%edx - movl 12(%ebp),%edi - movb $0x56,%ah - call syscall - jnc .LRENAME1 - movw %ax,inoutres; - .LRENAME1: - end; + allowslash(p1); + allowslash(p2); + asm + movl 8(%ebp),%edx + movl 12(%ebp),%edi + movb $0x56,%ah + call syscall + jnc .LRENAME1 + movw %ax,inoutres; + .LRENAME1: + end; end; function do_read(h,addr,len:longint):longint; begin - asm - movl 16(%ebp),%ecx - movl 12(%ebp),%edx - movl 8(%ebp),%ebx - movb $0x3f,%ah - call syscall - jnc .LDOSREAD1 - movw %ax,inoutres; - xorl %eax,%eax - .LDOSREAD1: - leave - ret $12 - end; + asm + movl 16(%ebp),%ecx + movl 12(%ebp),%edx + movl 8(%ebp),%ebx + movb $0x3f,%ah + call syscall + jnc .LDOSREAD1 + movw %ax,inoutres; + xorl %eax,%eax + .LDOSREAD1: + leave + ret $12 + end; end; function do_write(h,addr,len:longint) : longint; begin - asm - movl 16(%ebp),%ecx - movl 12(%ebp),%edx - movl 8(%ebp),%ebx - movb $0x40,%ah - call syscall - jnc .LDOSWRITE1 - movw %ax,inoutres; - .LDOSWRITE1: - movl %eax,-4(%ebp) - end; + asm + movl 16(%ebp),%ecx + movl 12(%ebp),%edx + movl 8(%ebp),%ebx + movb $0x40,%ah + call syscall + jnc .LDOSWRITE1 + movw %ax,inoutres; + .LDOSWRITE1: + movl %eax,-4(%ebp) + end; end; function do_filepos(handle:longint):longint; begin - asm - movw $0x4201,%ax - movl 8(%ebp),%ebx - xorl %edx,%edx - call syscall - jnc .LDOSFILEPOS - movw %ax,inoutres; - xorl %eax,%eax - .LDOSFILEPOS: - leave - ret $4 - end; + asm + movw $0x4201,%ax + movl 8(%ebp),%ebx + xorl %edx,%edx + call syscall + jnc .LDOSFILEPOS + movw %ax,inoutres; + xorl %eax,%eax + .LDOSFILEPOS: + leave + ret $4 + end; end; procedure do_seek(handle,pos:longint); begin - asm - movw $0x4200,%ax - movl 8(%ebp),%ebx - movl 12(%ebp),%edx - call syscall - jnc .LDOSSEEK1 - movw %ax,inoutres; - .LDOSSEEK1: - leave - ret $8 - end; + asm + movw $0x4200,%ax + movl 8(%ebp),%ebx + movl 12(%ebp),%edx + call syscall + jnc .LDOSSEEK1 + movw %ax,inoutres; + .LDOSSEEK1: + leave + ret $8 + end; end; function do_seekend(handle:longint):longint; begin - asm - movw $0x4202,%ax - movl 8(%ebp),%ebx - xorl %edx,%edx - call syscall - jnc .Lset_at_end1 - movw %ax,inoutres; - xorl %eax,%eax - .Lset_at_end1: - leave - ret $4 - end; + asm + movw $0x4202,%ax + movl 8(%ebp),%ebx + xorl %edx,%edx + call syscall + jnc .Lset_at_end1 + movw %ax,inoutres; + xorl %eax,%eax + .Lset_at_end1: + leave + ret $4 + end; end; function do_filesize(handle:longint):longint; -var aktfilepos:longint; +var aktfilepos:longint; begin - aktfilepos:=do_filepos(handle); - do_filesize:=do_seekend(handle); - do_seek(handle,aktfilepos); + aktfilepos:=do_filepos(handle); + do_filesize:=do_seekend(handle); + do_seek(handle,aktfilepos); end; procedure do_truncate(handle,pos:longint); begin - asm - movl $0x4200,%eax - movl 8(%ebp),%ebx - movl 12(%ebp),%edx - call syscall - jc .LTruncate1 - movl 8(%ebp),%ebx - movl 12(%ebp),%edx - movl %ebp,%edx - xorl %ecx,%ecx - movb $0x40,%ah - call syscall - jnc .LTruncate2 - .LTruncate1: - movw %ax,inoutres; - .LTruncate2: - leave - ret $8 - end; + asm + movl $0x4200,%eax + movl 8(%ebp),%ebx + movl 12(%ebp),%edx + call syscall + jc .LTruncate1 + movl 8(%ebp),%ebx + movl 12(%ebp),%edx + movl %ebp,%edx + xorl %ecx,%ecx + movb $0x40,%ah + call syscall + jnc .LTruncate2 + .LTruncate1: + movw %ax,inoutres; + .LTruncate2: + leave + ret $8 + end; end; procedure do_open(var f;p:pchar;flags:longint); @@ -436,92 +436,92 @@ procedure do_open(var f;p:pchar;flags:longint); when (flags and $1000) there is no check for close (needed for textfiles) } -var oflags:byte; +var oflags:byte; begin - allowslash(p); - { close first if opened } - if ((flags and $1000)=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:=high(word); - oflags:=2; - { convert filemode to filerec modes } - case (flags and 3) of - 0 : begin - filerec(f).mode:=fminput; - oflags:=0; - end; - 1 : filerec(f).mode:=fmoutput; - 2 : filerec(f).mode:=fminout; - end; - if (flags and $100)<>0 then - begin - filerec(f).mode:=fmoutput; - oflags:=2; - end - else - if (flags and $10)<>0 then - begin - filerec(f).mode:=fmoutput; - oflags:=2; - end; - { empty name is special } - if p[0]=#0 then - begin - case filerec(f).mode of - fminput:filerec(f).handle:=StdInputHandle; - fmappend,fmoutput : begin - filerec(f).handle:=StdOutputHandle; - filerec(f).mode:=fmoutput; {fool fmappend} - end; - end; - exit; - end; - if (flags and $100)<>0 then - {Use create function.} - asm - movb $0x3c,%ah - movl p,%edx - xorw %cx,%cx - call syscall - jnc .LOPEN1 - movw %ax,inoutres; - movw $0xffff,%ax - .LOPEN1: - movl f,%edx - movw %ax,(%edx) - end - else - {Use open function.} - asm - movb $0x3d,%ah - movb oflags,%al - movl p,%edx - call syscall - jnc .LOPEN2 - movw %ax,inoutres; - movw $0xffff,%ax - .LOPEN2: - movl f,%edx - movw %ax,(%edx) - end; - if (flags and $10)<>0 then - do_seekend(filerec(f).handle); + allowslash(p); + { close first if opened } + if ((flags and $1000)=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:=high(word); + oflags:=2; + { convert filemode to filerec modes } + case (flags and 3) of + 0 : begin + filerec(f).mode:=fminput; + oflags:=0; + end; + 1 : filerec(f).mode:=fmoutput; + 2 : filerec(f).mode:=fminout; + end; + if (flags and $100)<>0 then + begin + filerec(f).mode:=fmoutput; + oflags:=2; + end + else + if (flags and $10)<>0 then + begin + filerec(f).mode:=fmoutput; + oflags:=2; + end; + { empty name is special } + if p[0]=#0 then + begin + case filerec(f).mode of + fminput:filerec(f).handle:=StdInputHandle; + fmappend,fmoutput : begin + filerec(f).handle:=StdOutputHandle; + filerec(f).mode:=fmoutput; {fool fmappend} + end; + end; + exit; + end; + if (flags and $100)<>0 then + {Use create function.} + asm + movb $0x3c,%ah + movl p,%edx + xorw %cx,%cx + call syscall + jnc .LOPEN1 + movw %ax,inoutres; + movw $0xffff,%ax + .LOPEN1: + movl f,%edx + movw %ax,(%edx) + end + else + {Use open function.} + asm + movb $0x3d,%ah + movb oflags,%al + movl p,%edx + call syscall + jnc .LOPEN2 + movw %ax,inoutres; + movw $0xffff,%ax + .LOPEN2: + movl f,%edx + movw %ax,(%edx) + end; + if (flags and $10)<>0 then + do_seekend(filerec(f).handle); end; {***************************************************************************** - UnTyped File Handling + UnTyped File Handling *****************************************************************************} {$i file.inc} @@ -542,194 +542,194 @@ end; {**************************************************************************** - Directory related routines. + Directory related routines. ****************************************************************************} {***************************************************************************** - Directory Handling + Directory Handling *****************************************************************************} procedure dosdir(func:byte;const s:string); -var buffer:array[0..255] of char; +var buffer:array[0..255] of char; begin - move(s[1],buffer,length(s)); - buffer[length(s)]:=#0; - allowslash(Pchar(@buffer)); - asm - leal buffer,%edx - movb 8(%ebp),%ah - call syscall - jnc .LDOS_DIRS1 - movw %ax,inoutres; - .LDOS_DIRS1: - end; + move(s[1],buffer,length(s)); + buffer[length(s)]:=#0; + allowslash(Pchar(@buffer)); + asm + leal buffer,%edx + movb 8(%ebp),%ah + call syscall + jnc .LDOS_DIRS1 + movw %ax,inoutres; + .LDOS_DIRS1: + end; end; procedure mkdir(const s : string); begin - DosDir($39,s); + DosDir($39,s); end; procedure rmdir(const s : string); begin - DosDir($3a,s); + DosDir($3a,s); end; procedure chdir(const s : string); begin - DosDir($3b,s); + DosDir($3b,s); end; procedure getdir(drivenr : byte;var dir : string); {Written by Michael Van Canneyt.} -var temp:array[0..255] of char; - sof:Pchar; - i:byte; +var temp:array[0..255] of char; + sof:Pchar; + i:byte; begin - sof:=pchar(@dir[4]); - { dir[1..3] will contain '[drivenr]:\', but is not } - { supplied by DOS, so we let dos string start at } - { dir[4] } - { Get dir from drivenr : 0=default, 1=A etc... } - asm - movb drivenr,%dl - movl sof,%esi - mov $0x47,%ah - call syscall - end; - { Now Dir should be filled with directory in ASCIIZ, } - { starting from dir[4] } - dir[0]:=#3; - dir[2]:=':'; - dir[3]:='\'; - i:=4; - {Conversion to Pascal string } - while (dir[i]<>#0) do - begin - { convert path name to DOS } - if dir[i]='/' then - dir[i]:='\'; - dir[0]:=char(i); - inc(i); - end; - { upcase the string (FPKPascal function) } - 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 } - asm - movb $0x19,%ah - call syscall - addb $65,%al - movb %al,i - end; - dir[1]:=char(i); - end; + sof:=pchar(@dir[4]); + { dir[1..3] will contain '[drivenr]:\', but is not } + { supplied by DOS, so we let dos string start at } + { dir[4] } + { Get dir from drivenr : 0=default, 1=A etc... } + asm + movb drivenr,%dl + movl sof,%esi + mov $0x47,%ah + call syscall + end; + { Now Dir should be filled with directory in ASCIIZ, } + { starting from dir[4] } + dir[0]:=#3; + dir[2]:=':'; + dir[3]:='\'; + i:=4; + {Conversion to Pascal string } + while (dir[i]<>#0) do + begin + { convert path name to DOS } + if dir[i]='/' then + dir[i]:='\'; + dir[0]:=char(i); + inc(i); + end; + { upcase the string (FPKPascal function) } + 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 } + asm + movb $0x19,%ah + call syscall + addb $65,%al + movb %al,i + end; + dir[1]:=char(i); + end; end; {**************************************************************************** - System unit initialization. + System unit initialization. ****************************************************************************} procedure OpenStdIO(var f:text;mode:word;hdl:longint); begin - Assign(f,''); - TextRec(f).Handle:=hdl; - TextRec(f).Mode:=mode; - TextRec(f).InOutFunc:=@FileInOutFunc; - TextRec(f).FlushFunc:=@FileInOutFunc; - TextRec(f).Closefunc:=@fileclosefunc; + Assign(f,''); + TextRec(f).Handle:=hdl; + TextRec(f).Mode:=mode; + TextRec(f).InOutFunc:=@FileInOutFunc; + TextRec(f).FlushFunc:=@FileInOutFunc; + TextRec(f).Closefunc:=@fileclosefunc; end; -var pib:Pprocessinfoblock; - tib:Pthreadinfoblock; +var pib:Pprocessinfoblock; + tib:Pthreadinfoblock; begin - {Determine the operating system we are running on.} - asm - movw $0x7f0a,%ax - call syscall - testw $512,%bx {Bit 9 is OS/2 flag.} - setnzl os_mode - testw $4096,%bx - jz .LnoRSX - movl $2,os_mode - .LnoRSX: - end; + {Determine the operating system we are running on.} + asm + movw $0x7f0a,%ax + call syscall + testw $512,%bx {Bit 9 is OS/2 flag.} + setnzl os_mode + testw $4096,%bx + jz .LnoRSX + movl $2,os_mode + .LnoRSX: + end; - {$ASMMODE DIRECT} - {Enable the brk area by initializing it with the initial heap size.} - asm - movw $0x7f01,%ax - movl HEAPSIZE,%edx - addl __heap_base,%edx - call ___SYSCALL - cmpl $-1,%eax - jnz Lheapok - pushl $204 - {call RUNERROR$$WORD} - Lheapok: - end; - {$ASMMODE ATT} + {$ASMMODE DIRECT} + {Enable the brk area by initializing it with the initial heap size.} + asm + movw $0x7f01,%ax + movl HEAPSIZE,%edx + addl __heap_base,%edx + call ___SYSCALL + cmpl $-1,%eax + jnz Lheapok + pushl $204 + {call RUNERROR$$WORD} + Lheapok: + end; + {$ASMMODE ATT} - {Now request, if we are running under DOS, - read-access to the first meg. of memory.} - if os_mode in [osDOS,osDPMI] then - asm - movw $0x7f13,%ax - xorl %ebx,%ebx - movl $0xfff,%ecx - xorl %edx,%edx - call syscall - movl %eax,first_meg - end - else - first_meg:=nil; - {At 0.9.2, case for enumeration does not work.} - case os_mode of - osDOS: - stackbottom:=0; {In DOS mode, heap_brk is also the - stack bottom.} - osOS2: - begin - dosgetinfoblocks(tib,pib); - stackbottom:=longint(tib^.stack); - end; - osDPMI: - stackbottom:=0; {Not sure how to get it, but seems to be - always zero.} - end; - exitproc:=nil; + {Now request, if we are running under DOS, + read-access to the first meg. of memory.} + if os_mode in [osDOS,osDPMI] then + asm + movw $0x7f13,%ax + xorl %ebx,%ebx + movl $0xfff,%ecx + xorl %edx,%edx + call syscall + movl %eax,first_meg + end + else + first_meg:=nil; + {At 0.9.2, case for enumeration does not work.} + case os_mode of + osDOS: + stackbottom:=0; {In DOS mode, heap_brk is also the + stack bottom.} + osOS2: + begin + dosgetinfoblocks(tib,pib); + stackbottom:=longint(tib^.stack); + end; + osDPMI: + stackbottom:=0; {Not sure how to get it, but seems to be + always zero.} + end; + exitproc:=nil; - {Initialize the heap.} - initheap; + {Initialize the heap.} + initheap; - { to test stack depth } - loweststack:=maxlongint; + { to test stack depth } + loweststack:=maxlongint; - OpenStdIO(Input,fmInput,StdInputHandle); - OpenStdIO(Output,fmOutput,StdOutputHandle); - OpenStdIO(StdErr,fmOutput,StdErrorHandle); + OpenStdIO(Input,fmInput,StdInputHandle); + OpenStdIO(Output,fmOutput,StdOutputHandle); + OpenStdIO(StdErr,fmOutput,StdErrorHandle); - { kein Ein- Ausgabefehler } - inoutres:=0; + { kein Ein- Ausgabefehler } + inoutres:=0; end.