crt.tpu{**************************************************************************** Standard CRT unit. Free Pascal runtime library for EMX. Copyright (c) 1997 Daniel Mantione. This file may be reproduced and modified under the same conditions as all other Free Pascal source code.****************************************************************************}unit crt;{$ASMMODE ATT}interface{$i crth.inc}{cemodeset means that the procedure textmode has failed to set up a mode.}type cexxxx=(cenoerror,cemodeset);var crt_error:cexxxx; {Crt-status. RW}{***************************************************************************}implementation{$i textrec.inc}const extkeycode:char=#0;var maxrows,maxcols:word; calibration:longint;type Tkbdkeyinfo=record charcode,scancode:char; fbstatus,bnlsshift:byte; fsstate:word; time:longint; end; {if you have information on the folowing datastructure, please send them to me at [email protected]} {This datastructure is needed when we ask in what video mode we are, or we want to set up a new mode.} viomodeinfo=record cb:word; { length of the entire data structure } fbtype, { bit mask of mode being set} color: byte; { number of colors (power of 2) } col, { number of text columns } row, { number of text rows } hres, { horizontal resolution } vres: word; { vertical resolution } fmt_ID, { attribute format ! more info wanted !} attrib: byte; { number of attributes } buf_addr, { physical address of videobuffer, e.g. $0b800} buf_length, { length of a videopage (bytes)} full_length, { total video-memory on video- card (bytes)} partial_length:longint; { ????? info wanted !} ext_data_addr:pointer; { ????? info wanted !} end; Pviomodeinfo=^viomodeinfo; TVioCursorInfo=record case boolean of false:( yStart:word; {Cursor start (top) scan line (0-based)} cEnd:word; {Cursor end (bottom) scan line} cx:word; {Cursor width (0=default width)} Attr:word); {Cursor colour attribute (-1=hidden)} true:( yStartInt: integer; {integer variants can be used to specify negative} cEndInt:integer; {negative values (interpreted as percentage by OS/2)} cxInt:integer; AttrInt:integer); end; PVioCursorInfo=^TVioCursorInfo;{EMXWRAP.DLL has strange calling conventions: All parameters must have a 4 byte size.}function kbdcharin(var Akeyrec:Tkbdkeyinfo;wait,kbdhandle:longint):word; cdecl; external 'EMXWRAP' index 204;function kbdpeek(var Akeyrec:TkbdkeyInfo;kbdhandle:word):word; cdecl; external 'EMXWRAP' index 222;function dossleep(time:cardinal):cardinal; cdecl; external 'DOSCALLS' index 229;function vioscrollup(top,left,bottom,right,lines:longint; var screl:word;viohandle:longint):word; cdecl; external 'EMXWRAP' index 107;function vioscrolldn(top,left,bottom,right,lines:longint; var screl:word;viohandle:longint):word; cdecl; external 'EMXWRAP' index 147;function viogetcurpos(var row,column:word;viohandle:longint):word; cdecl;

external 'EMXWRAP' index 109;function viosetcurpos(row,column,viohandle:longint):word; cdecl; external 'EMXWRAP' index 115;function viowrtTTY(s:Pchar;len,viohandle:longint):word; cdecl; external 'EMXWRAP' index 119;function viowrtcharstratt(s:Pchar;len,row,col:longint;var attr:byte; viohandle:longint):word; cdecl; external 'EMXWRAP' index 148;function viogetmode(var Amodeinfo:viomodeinfo;viohandle:longint):word; cdecl; external 'EMXWRAP' index 121;function viosetmode(var Amodeinfo:viomodeinfo;viohandle:longint):word; cdecl; external 'EMXWRAP' index 122;function VioSetCurType(var CurData:TVioCursorInfo;VioHandle:word):word; cdecl;external 'EMXWRAP' index 132;{external 'VIOCALLS' index 32;}function VioGetCurType(var CurData:TVioCursorInfo;VioHandle:word):word; cdecl;external 'EMXWRAP' index 127;{external 'VIOCALLS' index 27;}procedure syscall;external name '___SYSCALL';procedure setscreenmode(mode:word);{ This procedure sets a new videomode. Note that the constants passes to this procedure are different than in the dos mode.}const modecols:array[0..2] of word=(40,80,132); moderows:array[0..3] of word=(25,28,43,50);var newmode:viomodeinfo;begin if os_mode=osOS2 then begin newmode.cb:=8; newmode.fbtype:=1; {Non graphics colour mode.} newmode.color:=4; {We want 16 colours, 2^4=16.} newmode.col:=modecols[mode and 15]; newmode.row:=moderows[mode shr 4]; if viosetmode(newmode,0)=0 then crt_error:=cenoerror else crt_error:=cemodeset; maxcols:=newmode.col; maxrows:=newmode.row; end else begin maxcols:=modecols[mode and 15]; maxrows:=moderows[mode shr 4]; crt_error:=cenoerror; {Set correct vertical resolution.} asm movw $0x1202,%ax movw 8(%e
bp
),%bx shrw $4,%bx cmpb $2,%bl jne .L_crtsetmode_a1 decw %ax .L_crtsetmode_a1: mov $0x30,%bl int $0x10 end; {132 column mode in DOS is videocard dependend.} if mode and 15=2 then begin crt_error:=cemodeset; exit; end; {Switch to correct mode.} asm mov 8(%ebp),%bx and $15,%bl mov $1,%ax cmp $1,%bl jne .L_crtsetmode_b1 mov $3,%al .L_crtsetmode_b1: int $0x10 {Use alternate print-screen function.} mov $0x12,%ah mov $0x20,%bl int $0x10 end; {Set correct font.} case mode shr 4 of 1: {Set 8x14 font.} asm mov $0x1111,%ax mov $0,%bl int $0x10 end; 2,3: {Set 8x8 font.} asm mov $0x1112,%ax mov $0,%bl int $0x10 end; end; end;end;procedure getcursor(var y,x:word);{Get the cursor position.}begin if os_mode=osOS2 then viogetcurpos(y,x,0) else asm movb $3,%ah movb $0,%bh int $0x10 movl y,%eax movl x,%ebx movzbl %dh,%edi andw $255,%dx movw %di,(%eax) movw %dx,(%ebx) end;end;{$ASMMODE INTEL}procedure setcursor(y,x:word);{Set the cursor position.}begin if os_mode=osOS2 then viosetcurpos(y,x,0) else asm mov ah, 2 mov bh, 0 mov dh, byte ptr y mov dl, byte ptr x int 10h end;end;procedure scroll_up(top,left,bottom,right,lines:word;var screl:word);

begin if os_mode=osOS2 then vioscrollup(top,left,bottom,right,lines,screl,0) else asm mov ah, 6 mov al, byte ptr lines mov edi, screl mov bh, [edi + 1] mov ch, byte ptr top mov cl, byte ptr left mov dh, byte ptr bottom mov dl, byte ptr right int 10h end;end;procedure scroll_dn(top,left,bottom,right,lines:word;var screl:word);begin if os_mode=osOS2 then vioscrolldn(top,left,bottom,right,lines,screl,0) else asm mov ah, 7 mov al, byte ptr lines mov edi, screl mov bh, [edi + 1] mov ch, byte ptr top mov cl, byte ptr left mov dh, byte ptr bottom mov dl, byte ptr right int 10h end;end;{$ASMMODE ATT}function keypressed:boolean;{Checks if a key is pressed.}var Akeyrec:Tkbdkeyinfo;begin if os_mode=osOS2 then begin kbdpeek(Akeyrec,0); keypressed:=(extkeycode<>#0) or ((Akeyrec.fbstatus and $40)<>0); end else begin if extkeycode<>#0 then begin keypressed:=true; exit end else asm movb $1,%ah int $0x16 setnz %al movb %al,__RESULT end; end;end;function readkey:char;{Reads the next character from the keyboard.}var Akeyrec:Tkbdkeyinfo; c,s:char;begin if extkeycode<>#0 then begin readkey:=extkeycode; extkeycode:=#0 end else begin if os_mode=osOS2 then begin kbdcharin(Akeyrec,0,0); c:=Akeyrec.charcode; s:=Akeyrec.scancode; if (c=
#224) and (s<>#
0) then c:=#0; end else begin asm movb $0,%ah int $0x16 movb %al,c movb %ah,s end; end; if c=#0 then extkeycode:=s; readkey:=c; end;end;procedure clrscr;{Clears the current window.}var screl:word;begin screl:=$20+textattr shl 8; scroll_up(hi(windmin),lo(windmin), hi(windmax),lo(windmax), hi(windmax)-hi(windmin)+1, screl); gotoXY(1,1);end;procedure gotoXY(x,y:byte);{Positions the cursor on (x,y) relative to the window origin.}begin if x<1 then x:=1; if y<1 then y:=1; if y+hi(windmin)-2>=hi(windmax) then y:=hi(windmax)-hi(windmin)+1; if x+lo(windmin)-2>=lo(windmax) then x:=lo(windmax)-lo(windmin)+1; setcursor(y+hi(windmin)-1,x+lo(windmin)-1);end;function whereX:byte;{Returns the x position of the cursor.}var x,y:word;begin getcursor(y,x); whereX:=x-lo(windmin)+1;end;function whereY:byte;{Returns the y position of the cursor.}var x,y:word;begin getcursor(y,x); whereY:=y-hi(windmin)+1;end;procedure clreol;{Clear from current position to end of line.Contributed by Michail A. Baikov}var i:byte;begin {not fastest, but compatible} for i:=wherex to lo(windmax) do write(' '); gotoxy(1,wherey); {may be not}end;procedure delline;{Deletes the line at the cursor.}var row,left,right,bot:longint; fil:word;begin row:=whereY; left:=lo(windmin); right:=lo(windmax); bot:=hi(windmax)+1; fil:=$20 or (textattr shl 8); scroll_up(row+1,left,bot,right,1,fil);end;procedure insline;{Inserts a line at the cursor position.}var row,left,right,bot:longint;

fil:word;begin row:=whereY; left:=lo(windmin); right:=lo(windmax); bot:=hi(windmax); fil:=$20 or (textattr shl 8); scroll_dn(row,left,bot,right,1,fil);end;procedure TextMode (Mode: word);{ Use this procedure to set-up a specific text-mode.}begin textattr:=$07; lastmode:=mode; mode:=mode and $ff; setscreenmode(mode); windmin:=0; windmax:=(maxcols-1) or ((maxrows-1) shl 8); clrscr;end;procedure textcolor(color:byte);{All text written after calling this will have color as foreground colour.}begin textattr:=(textattr and $70) or (color and $f)+color and 128;end;procedure textbackground(color:byte);{All text written after calling this will have colour as background colour.}begin textattr:=(textattr and $8f) or ((color and $7) shl 4);end;procedure normvideo;{Changes the text-background to black and the foreground to white.}begin textattr:=$7;end;procedure lowvideo;{All text written after this will have low intensity.}begin textattr:=textattr and $f7;end;procedure highvideo;{All text written after this will have high intensity.}begin textattr:=textattr or $8;end;procedure delay(ms:word);var i,j:longint;{Waits ms microseconds. The DOS code is copied from the DOS rtl.}begin {Under OS/2 we could also calibrate like under DOS. But this is unreliable, because OS/2 can hold our programs while calibrating, if it needs the processor for other things.} if os_mode=osOS2 then dossleep(ms) else begin for i:=1 to ms do for j:=1 to calibration do begin end; end;end;procedure window(X1,Y1,X2,Y2:byte);{Change the write window to the given coordinates.}begin if (X1<1) or (Y1<1) or (X2>maxcols) or (Y2>maxrows) or (X1>X2) or (Y1>Y2) then exit; windmin:=(X1-1) or ((Y1-1) shl 8); windmax:=(X2-1) or ((Y2-1) shl 8); gotoXY(1,1);end;{$ASMMODE INTEL}procedure writePchar(s:Pchar;len:word);{Write a series of characters to the screen. Not very fast, but is just text-mode isn't it?}var x,y:word; c:char; i,n:integer; screl:word; ca:Pchar;begin i:=0; getcursor(y,x); while i<=len-1 do begin case s[i] of #7: asm mov dl, 7 mov ah, 2 call syscall end; #8: if X > Succ (Lo (WindMin)) then Dec (X); { #9: x:=(x-lo(windmin)) and $fff8+8+lo(windmin);} #10: inc(y); #13: x:=lo(windmin); else begin ca:=@s[i]; n:=1; while not(s[i+1] in [#7,
#8,#
10,#13]) and{ (x+n<=lo(windmax)+1) and (i
lo(windmax) then begin x:=lo(windmin); inc(y); end; if y>hi(windmax) then begin screl:=$20+textattr shl 8; scroll_up(hi(windmin),lo(windmin), hi(windmax),lo(windmax),

with I do begin yStartInt := -90; cEndInt := -100; Attr := 15; end; VioSetCurType (I, 0); end else asm push es push bp mov ax, 1130h mov bh, 0 mov ecx, 0 int 10h pop bp pop es or ecx, ecx jnz @COnOld mov cx, 0707h jmp @COnAll@COnOld: dec cx mov ch, cl dec ch@COnAll: mov ah, 1 int 10h end;end;procedure CursorOff;var I: TVioCursorInfo;begin if Os_Mode = osOS2 then begin VioGetCurType (I, 0); I.AttrInt := -1; VioSetCurType (I, 0); end else asm mov ah, 1 mov cx, 0FFFFh int 10h end;end;procedure CursorBig;var I: TVioCursorInfo;begin if Os_Mode = osOS2 then begin VioGetCurType (I, 0); with I do begin yStart := 0; cEndInt := -100; Attr := 15; end; VioSetCurType (I, 0); end else asm mov ah, 1 mov cx, 1Fh int 10h end;end;{$ASMMODE DEFAULT}{Initialization.}type Pbyte=^byte;var curmode:viomodeinfo; mode:byte;begin textattr:=lightgray; if os_mode=osOS2 then begin curmode.cb:=sizeof(curmode); viogetmode(curmode,0); maxcols:=curmode.col; maxrows:=curmode.row; lastmode:=0; case maxcols of 40: lastmode:=0; 80: lastmode:=1; 132: lastmode:=2; end; case maxrows of 25:; 28: lastmode:=lastmode+16; 43: lastmode:=lastmode
+3
2; 50: lastmode:=lastmode+48; end end else begin {Request video mode to determine columns.} asm mov $0x0f,%ah int $0x10{ mov %al,_MODE } mov %al,MODE end; case mode of 0,1: begin lastmode:=0; maxcols:=40; end; else begin lastmode:=1; maxcols:=80; end; end; {Get number of rows from realmode $0040:$0084.} maxrows:=Pbyte(longint(first_meg)+$484)^; case maxrows of 25:; 28: lastmode:=lastmode+16; 43: lastmode:=lastmode+32; 50: lastmode:=lastmode+48; end end; windmin:=0; windmax:=((maxrows-1) shl 8) or (maxcols-1); if os_mode <> osOS2 then initdelay; crt_error:=cenoerror; assigncrt(input); textrec(input).mode:=fminput; assigncrt(output); textrec(output).mode:=fmoutput;end.dos.tpu{**************************************************************************** Free Pascal Runtime-Library DOS unit for EMX Copyright (c) 1997,1999-2000 by Daniel Mantione, member of the Free Pascal development team 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. ****************************************************************************}unit dos;{$ASMMODE ATT}{***************************************************************************}interface{***************************************************************************}{$PACKRECORDS 1}uses Strings, DosCalls;Type {Search record which is used by findfirst and findnext:} searchrec=record case boolean of false: (handle:THandle; {Used in os_OS2 mode}

FStat:PFileFindBuf3; fill2:array[1..21-SizeOf(THandle)-SizeOf(pointer)] of byte; attr2:byte; time2:longint; size2:longint; name2:string); {Filenames can be long in OS/2!} true: (fill:array[1..21] of byte; attr:byte; time:longint; size:longint; name:string); {Filenames can be long in OS/2!} end;{$i dosh.inc} {Flags for the exec procedure: Starting the program: efwait: Wait until program terminates. efno_wait: Don't wait until the program terminates. Does not work in dos, as DOS cannot multitask. 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. Not found info about execwinflags 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.}const efWait = 0; (* Spawn child, wait until terminated *) efNo_Wait = 1; (* Not implemented according to EMX documentation! *) efOverlay = 2; (* Exec child, kill current process *) efDebug = 3; (* Debug child - use with ptrace syscall *) efSession = 4; (* Run in a separate session *) efDetach = 5; (* Run detached *) efPM = 6; (* Run as a PM program *) efDefault = 0; efMinimize = $100; efMaximize = $200; efFullScreen = $300; efWindowed = $400; efBackground = $1000; efNoClose = $2000; efNoSession = $4000; efMoreFlags = $8000; (* Needed if any flags > $FFFF are supplied *) efQuote = $10000; efTilde = $20000; efDebugDesc = $40000;{OS/2 specific functions}function GetEnvPChar (EnvVar: string): PChar;threadvar(* For compatibility with VP/2, used for runflags in Exec procedure. *) ExecFlags: cardinal;implementation{$DEFINE HAS_INTR}{$DEFINE HAS_SETVERIFY}{$DEFINE HAS_GETVERIFY}{$DEFINE FPC_FEXPAND_UNC} (* UNC paths are supported *){$DEFINE FPC_FEXPAND_DRIVES} (* Full paths begin with drive specification *)const LFNSupport = true;{$I dos.inc}threadvar LastSR: SearchRec;var EnvC: longint; external name '_envc'; EnvP: ppchar; external name '_environ';type TBA = array [1..SizeOf (SearchRec)] of byte; PBA = ^TBA;const FindResvdMask = $00003737; {Allowed bits in attribute specification for DosFindFirst call.}{Import syscall to call it nicely from assembler procedures.}procedure syscall;external name '___SYSCALL';function fsearch(path:pathstr;dirlist:string):pathstr;var i,p1:longint; newdir:pathstr;{$ASMMODE INTEL}function CheckFile (FN: ShortString):boolean; assembler;asm{$IFDEF REGCALL} mov edx, eax{$ELSE REGCALL} mov edx, FN { get pointer to string }{$ENDIF REGCALL}

inc edx { avoid length byte } mov ax, 4300h call syscall mov ax, 0 jc @LCFstop test cx, 18h jnz @LCFstop inc ax@LCFstop:end ['eax', 'ecx', 'edx'];{$ASMMODE ATT}begin{ check if the file specified exists } if CheckFile (Path + #0) then FSearch := Path else begin {No wildcards allowed in these things:} if (pos('?',path)<>0) or (pos('*',path)<>0) then fsearch:='' else begin { allow slash as backslash } for i:=1 to length(dirlist) do if dirlist[i]='/' then dirlist[i]:='\'; repeat 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; if (newdir<>'') and not (newdir[length(newdir)] in ['\',':']) then newdir:=newdir+'\'; if CheckFile (NewDir + Path + #0) then NewDir := NewDir + Path else NewDir := ''; until (DirList = '') or (NewDir <> ''); FSearch := NewDir; end; end;end;procedure GetFTime (var F; var Time: longint); assembler;asm pushl %ebx {Load handle}{$IFDEF REGCALL} movl %eax,%ebx pushl %edx{$ELSE REGCALL} movl F,%ebx{$ENDIF REGCALL} movl (%ebx),%ebx {Get date} movw $0x5700,%ax call syscall shll $16,%edx movw %cx,%dx{$IFDEF REGCALL} popl %ebx{$ELSE REGCALL} movl Time,%ebx{$ENDIF REGCALL} movl %edx,(%ebx) movw %ax,DosError popl %ebxend {['eax', 'ecx', 'edx']};procedure SetFTime (var F; Time: longint);var FStat: TFileStatus3; RC: cardinal;begin if os_mode = osOS2 then begin RC := DosQueryFileInfo (FileRec (F).Handle, ilStandard, @FStat, SizeOf (FStat)); if RC = 0 then begin FStat.DateLastAccess := Hi (Time); FStat.DateLastWrite := Hi (Time); FStat.TimeLastAccess := Lo (Time); FStat.TimeLastWrite := Lo (Time); RC := DosSetFileInfo (FileRec (F).Handle, ilStandard, @FStat, SizeOf (FStat)); end; DosError := integer (RC); end else asm pushl %ebx {Load handle} movl f,%ebx movl (%ebx),%ebx movl time,%ecx shldl $16,%ecx,%edx {Set date} movw $0x5701,%ax call syscall movw %ax,doserror popl %ebx end ['eax', 'ecx', 'edx'];end;procedure Intr (IntNo: byte; var Regs: Registers);{Not recommended for EMX. Only works in DOS mode, not in OS/2 mode.}begin if os_mode = osos2 then exit; asm jmp .Lstart{ .data}.Lint86: .byte 0xcd.Lint86_vec: .byte 0x03 jmp .Lint86_retjmp{ .text}.Lstart: movb intno,%al movb %al,.Lint86_vec{ movl 10(%ebp),%eax incl %eax incl %eax} movl regs,%eax {Do not use first int} 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 .Lint86.Lint86_retjmp: pushf pushl %ebp pushl %eax movl %esp,%ebp {Calc EBP new} addl $12,%ebp{ movl 10(%ebp),%eax incl %eax incl %eax} {Do not use first int} movl regs,%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 ['eax','ebx','ecx','edx','esi','edi'];end;procedure exec(const path:pathstr;const comline:comstr);{Execute a program.}type bytearray=array[0..8191] of byte; Pbytearray=^bytearray; execstruc=packed record argofs : pointer; { pointer to arguments (offset) } envofs : pointer; { pointer to environment (offset) } nameofs: pointer; { pointer to file name (offset) } argseg : word; { pointer to arguments (selector) } envseg : word; { pointer to environment (selector} nameseg: word; { pointer to file name (selector) } numarg : word; { number of arguments } sizearg : word; { size of arguments } numenv : word; { number of env strings } sizeenv:word; { size of environment } mode:word; { mode word } end;var args:Pbytearray; env:Pbytearray; Path2:PByteArray; i,argsize:word; es:execstruc; esadr:pointer; d:dirstr; n:namestr; e:extstr; p : ppchar; j : integer;const ArgsSize = 2048; (* Amount of memory reserved for arguments in bytes. *)begin getmem(args,ArgsSize); GetMem(env, envc*sizeof(pchar)+16384); GetMem (Path2, 260); {Now setup the arguments. The first argument should be the program name without directory and extension.} fsplit(path,d,n,e); es.numarg:=1; args^[0]:=$80; argsize:=1; for i:=1 to length(n) do begin args^[argsize]:=byte(n[i]); inc(argsize); end; args^[argsize]:=0; inc(argsize); {Now do the real arguments.} i:=1; while i<=length(comline) do begin if comline[i]<>' ' then begin {Commandline argument found. Copy it.} inc(es.numarg); args^[argsize]:=$80; inc(argsize); while (i<=length(comline)) and (comline[i]<>' ') do begin args^[argsize]:=byte(comline[i]); inc(argsize); inc(i); end; args^[argsize]:=0; inc(argsize); end; inc(i); end; args^[argsize]:=0; inc(argsize); {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 envp,%esi {Load env. strings.} xorl %edx,%edx {Count environment size.}.Lexa1: lodsl {Load a Pchar.} xchgl %eax,%ebx.Lexa2: movb (%ebx),%al {Load a byte.} incl %ebx {Point to next byte.} stosb {Store it.} incl %edx {Increase counter.} cmpb $0,%al {Ready ?.} jne .Lexa2 loop .Lexa1 {Next argument.} stosb {Store an extra 0 to finish. (AL is now 0).} incl %edx movw %dx,ES.SizeEnv {Store environment size.} end ['eax','ebx','ecx','edx','esi','edi']; {Environment ready, now set-up exec structure.} es.argofs:=args; es.envofs:=env; es.numenv:=envc; Move (Path [1], Path2^, Length (Path)); Path2^ [Length (Path)] := 0; es.nameofs := Path2; asm movw %ss,es.argseg movw %ss,es.envseg movw %ss,es.nameseg end; es.sizearg:=argsize; es.mode := word (ExecFlags); {Now exec the program.} asm leal es,%edx

movw $0x7f06,%ax call syscall movl $0,%edi jnc .Lexprg1 xchgl %eax,%edi xorl %eax,%eax .Lexprg1: movw %di,doserror movl %eax, LastDosExitCode end ['eax', 'ebx', 'ecx', 'edx', 'esi', 'edi']; FreeMem (Path2, 260); FreeMem(env, envc*sizeof(pchar)+16384); freemem(args,ArgsSize); {Phew! That's it. This was the most sophisticated procedure to call a system function I ever wrote!}end;function dosversion:word;assembler;{Returns DOS version in DOS and OS/2 version in OS/2}asm movb $0x30,%ah call syscallend ['eax'];procedure GetDate (var Year, Month, MDay, WDay: word);begin asm movb $0x2a, %ah call syscall xorb %ah, %ah movl WDay, %edi stosw movl MDay, %edi movb %dl, %al stosw movl Month, %edi movb %dh, %al stosw movl Year, %edi xchgw %ecx, %eax stosw end ['eax', 'ecx', 'edx'];end;{$asmmode intel}procedure SetDate (Year, Month, Day: word);var DT: TDateTime;begin if os_mode = osOS2 then begin DosGetDateTime (DT); DT.Year := Year; DT.Month := byte (Month); DT.Day := byte (Day); DosSetDateTime (DT); end else asm mov cx, Year mov dh, byte ptr Month mov dl, byte ptr Day mov ah, 2Bh call syscall end ['eax', 'ecx', 'edx'];end;{$asmmode att}procedure GetTime (var Hour, Minute, Second, Sec100: word);{$IFDEF REGCALL}begin{$ELSE REGCALL} assembler;{$ENDIF REGCALL}asm movb $0x2c, %ah call syscall xorb %ah, %ah movl Sec100, %edi movb %dl, %al stosw movl Second, %edi movb %dh,%al stosw movl Minute, %edi movb %cl,%al stosw movl Hour, %edi movb %ch,%al stosw{$IFDEF REGCALL} end ['eax', 'ecx', 'edx'];end;{$ELSE REGCALL}end {['eax', 'ecx', 'edx']};{$ENDIF REGCALL}{$asmmode intel}procedure SetTime (Hour, Minute, Second, Sec100: word);var DT: TDateTime;begin if os_mode = osOS2 thenbegin DosGetDateTime (DT); DT.Hour := byte (Hour); DT.Minute := byte (Minute); DT.Second := byte (Second); DT.Sec100 := byte (Sec100); DosSetDateTime (DT); end else asm mov ch, byte ptr Hour mov cl, byte ptr Minute mov dh, byte ptr Second mov dl, byte ptr Sec100 mov ah, 2Dh call syscall end ['eax', 'ecx', 'edx'];end;{$asmmode att}procedure getverify(var verify:boolean);begin {! Do not use in OS/2.} if os_mode in [osDOS,osDPMI] then asm movb $0x54,%ah call syscall movl verify,%edi stosb end ['eax', 'edi'] else verify := true;end;procedure setverify(verify:boolean);begin {! Do not use in OS/2!} if os_mode in [osDOS,osDPMI] then asm movb verify,%al movb $0x2e,%ah call syscall end ['eax']; end;function DiskFree (Drive: byte): int64;var FI: TFSinfo; RC: cardinal;begin if (os_mode = osDOS) or (os_mode = osDPMI) then {Function 36 is not supported in OS/2.} asm pushl %ebx movb Drive,%dl movb $0x36,%ah call syscall cmpw $-1,%ax je .LDISKFREE1 mulw %cx mulw %bx shll $16,%edx movw %ax,%dx movl $0,%eax xchgl %edx,%eax jmp .LDISKFREE2

.LDISKFREE1: cltd .LDISKFREE2: popl %ebx leave ret end ['eax', 'ecx', 'edx'] else {In OS/2, we use the filesystem information.} begin RC := DosQueryFSInfo (Drive, 1, FI, SizeOf (FI)); if RC = 0 then DiskFree := int64 (FI.Free_Clusters) * int64 (FI.Sectors_Per_Cluster) * int64 (FI.Bytes_Per_Sector) else DiskFree := -1;end;end;function DiskSize (Drive: byte): int64;var FI: TFSinfo; RC: cardinal;begin if (os_mode = osDOS) or (os_mode = osDPMI) then {Function 36 is not supported in OS/2.} asm pushl %ebx movb Drive,%dl movb $0x36,%ah call syscall movw %dx,%bx cmpw $-1,%ax je .LDISKSIZE1 mulw %cx mulw %bx shll $16,%edx movw %ax,%dx movl $0,%eax xchgl %edx,%eax jmp .LDISKSIZE2 .LDISKSIZE1: cltd .LDISKSIZE2: popl %ebx leave ret end ['eax', 'ecx', 'edx'] else {In OS/2, we use the filesystem information.}begin RC := DosQueryFSinfo (Drive, 1, FI, SizeOf (FI)); if RC = 0 then DiskSize := int64 (FI.Total_Clusters) * int64 (FI.Sectors_Per_Cluster) * int64 (FI.Bytes_Per_Sector) else DiskSize := -1;end;end;procedure SearchRec2DosSearchRec (var F: SearchRec);const NameSize = 255;var L, I: longint;begin if os_mode <> osOS2 then begin I := 1; while (I <= SizeOf (LastSR)) and (PBA (@F)^ [I] = PBA (@LastSR)^ [I]) do Inc (I);{ Raise "Invalid file handle" RTE if nested FindFirst calls were used. } if I <= SizeOf (LastSR) then RunError (6); l:=length(f.name); for i:=1 to namesize do f.name[i-1]:=f.name[i]; f.name[l]:=#0; end;end;procedure DosSearchRec2SearchRec (var F: SearchRec);const NameSize=255;var L, I: longint;type TRec = record T, D: word; end;begin if os_mode = osOS2 then with F do begin Name := FStat^.Name; Size := FStat^.FileSize; Attr := byte(FStat^.AttrFile and $FF); TRec (Time).T := FStat^.TimeLastWrite; TRec (Time).D := FStat^.DateLastWrite; end else 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]:=char(l); Move (F, LastSR, SizeOf (LastSR)); end;end; procedure _findfirst(path:pchar;attr:word;var f:searchrec); begin asm pushl %esi movl path,%edx movw attr,%cx {No need to set DTA in EMX. Just give a pointer in ESI.} movl f,%esi movb $0x4e,%ah call syscall jnc .LFF movw %ax,doserror .LFF: popl %esi end ['eax', 'ecx', 'edx']; end;procedure FindFirst (const Path: PathStr; Attr: word; var F: SearchRec);var path0: array[0..255] of char; Count: cardinal;begin {No error.} DosError := 0; if os_mode = osOS2 then begin New (F.FStat); F.Handle := THandle ($FFFFFFFF); Count := 1; DosError := integer (DosFindFirst (Path, F.Handle, Attr and FindResvdMask, F.FStat, SizeOf (F.FStat^), Count, ilStandard)); if (DosError = 0) and (Count = 0) then DosError := 18; end else begin strPcopy(path0,path); _findfirst(path0,attr,f); end; DosSearchRec2SearchRec (F);

end; procedure _findnext(var f : searchrec); begin asm pushl %esi movl f,%esi movb $0x4f,%ah call syscall jnc .LFN movw %ax,doserror .LFN: popl %esi end ['eax']; end;procedure FindNext (var F: SearchRec);var Count: cardinal;begin {No error} DosError := 0; SearchRec2DosSearchRec (F); if os_mode = osOS2 then begin Count := 1; DosError := integer (DosFindNext (F.Handle, F.FStat, SizeOf (F.FStat^), Count)); if (DosError = 0) and (Count = 0) then DosError := 18; end else _findnext (F); DosSearchRec2SearchRec (F);end;procedure FindClose (var F: SearchRec);begin if os_mode = osOS2 then begin if F.Handle <> THandle ($FFFFFFFF) then DosError := DosFindClose (F.Handle); Dispose (F.FStat);end;end;function envcount:longint;assembler;asm movl envc,%eaxend ['EAX'];function envstr(index : longint) : string;var hp:Pchar;begin if (index<=0) or (index>envcount) then begin envstr:=''; exit; end; hp:=EnvP[index-1]; envstr:=strpas(hp);end;function GetEnvPChar (EnvVar: string): PChar;(* The assembler version is more than three times as fast as Pascal. *)var P: PChar;begin EnvVar := UpCase (EnvVar);{$ASMMODE INTEL} asm cld mov edi, Environment lea esi, EnvVar xor eax, eax lodsb@NewVar: cmp byte ptr [edi], 0 jz @Stop push eax { eax contains length of searched variable name } push esi { esi points to the beginning of the variable name } mov ecx, -1 { our character ('=' - see below) _must_ be found } mov edx, edi { pointer to beginning of variable name saved in edx } mov al, '=' { searching until '=' (end of variable name) } repne scasb { scan until '=' not found } neg ecx { what was the name length? } dec ecx { corrected } dec ecx { exclude the '=' character } pop esi { restore pointer to beginning of variable name } pop eax { restore length of searched variable name } push eax { and save both of them again for later use } push esi cmp ecx, eax { compare length of searched variable name with name } jnz @NotEqual { ... of currently found variable, jump if different } xchg edx, edi { pointer to current variable name restored in edi } repe cmpsb { compare till the end of variable name } xchg edx, edi { pointer to beginning of variable contents in edi } jz @Equal { finish if they're equal }@NotEqual: xor eax, eax { look for 00h } mov ecx, -1 { it _must_ be found } repne scasb { scan until found } pop esi { restore pointer to beginning of variable name } pop eax { restore length of searched variable name } jmp @NewVar { ... or continue with new variable otherwise }@Stop: xor eax, eax mov P, eax { Not found - return nil } jmp @End@Equal: pop esi { restore the stack position } pop eax mov P, edi { place pointer to variable contents in P }@End: end ['eax','ecx','edx','esi','edi']; GetEnvPChar := P;end;{$ASMMODE ATT}function GetEnv (EnvVar: string): string;begin GetEnv := StrPas (GetEnvPChar (EnvVar));

end;procedure getfattr(var f;var attr : word); { Under EMX, this routine requires } { the expanded path specification } { otherwise it will not function } { properly (CEC) }var path: pathstr; buffer:array[0..255] of char;begin DosError := 0; path:=''; path := StrPas(filerec(f).Name); { Takes care of slash and backslash support } path:=FExpand(path); move(path[1],buffer,length(path)); buffer[length(path)]:=#0; asm pushl %ebx movw $0x4300,%ax leal buffer,%edx call syscall jnc .Lnoerror { is there an error ? } movw %ax,doserror .Lnoerror: movl attr,%ebx movw %cx,(%ebx) popl %ebx end ['eax', 'ecx', 'edx'];end;procedure setfattr(var f;attr : word); { Under EMX, this routine requires } { the expanded path specification } { otherwise it will not function } { properly (CEC) }var path: pathstr; buffer:array[0..255] of char;begin path:=''; DosError := 0; path := StrPas(filerec(f).Name); { Takes care of slash and backslash support } path:=FExpand(path); move(path[1],buffer,length(path)); buffer[length(path)]:=#0; asm movw $0x4301,%ax leal buffer,%edx movw attr,%cx call syscall jnc .Lnoerror movw %ax,doserror .Lnoerror: end ['eax', 'ecx', 'edx'];end;procedure InitEnvironment;var cnt : integer; ptr : pchar; base : pchar; i: integer; PIB: PProcessInfoBlock; TIB: PThreadInfoBlock;begin { We need to setup the environment } { only in the case of OS/2 } { otherwise everything is in the stack } if os_Mode in [OsDOS,osDPMI] then exit; cnt := 0; { count number of environment pointers } DosGetInfoBlocks (PPThreadInfoBlock (@TIB), PPProcessInfoBlock (@PIB)); ptr := pchar(PIB^.env); { stringz,stringz...,#0 } i := 0; repeat repeat (inc(i)); until (ptr[i] = #0); inc(i); { here, it may be a double null, end of environment } if ptr[i] <> #0 then inc(cnt); until (ptr[i] = #0); { save environment count } envc := cnt; { got count of environment strings } GetMem(envp, cnt*sizeof(pchar)+16384); cnt := 0; ptr := pchar(PIB^.env); i:=0; repeat envp[cnt] := ptr; Inc(cnt); { go to next string ... } repeat inc(ptr); until (ptr^ =
#0); inc(ptr); until ptr^ = #
0; envp[cnt] := #0;end;procedure DoneEnvironment;begin { it is allocated on the stack for DOS/DPMI } if os_mode = osOs2 then FreeMem(envp, envc*sizeof(pchar)+16384);end;var oldexit : pointer;{****************************************************************************** --- Not Supported ---******************************************************************************}begin oldexit:=exitproc; exitproc:=@doneenvironment; InitEnvironment; LastDosExitCode := 0; ExecFlags := 0;end.

{ This file is part of the Free Pascal run time library. Copyright (c) 1999-2000 by Carl Eric Codere member of the Free Pascal development team 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. **********************************************************************}{$define ATARI}unit system;{--------------------------------------------------------------------}{ LEFT TO DO: }{--------------------------------------------------------------------}{ o SBrk }{ o Implement truncate }{ o Implement paramstr(0) }{--------------------------------------------------------------------}{$I os.inc} interface {$I systemh.inc}type THandle = longint; {$I heaph.inc}{Platform specific information}const LineEnding = #10; LFNSupport = true; CtrlZMarksEOF: boolean = false; (* #26 not considered as end of file *) DirectorySeparator = '/'; DriveSeparator = ':'; PathSeparator = ';'; FileNameCaseSensitive = false; maxExitCode = 255; MaxPathLen = 255; sLineBreak: string [1] = LineEnding; { used for single computations } const BIAS4 = $7f-1;const UnusedHandle = $ffff; StdInputHandle = 0; StdOutputHandle = 1; StdErrorHandle = $ffff; implementation {$I system.inc} {$I lowmath.inc}function GetProcessID:SizeUInt;begin{$WARNING To be checked by platform maintainer} GetProcessID := 1;end; const argc : longint = 0; var errno : integer;{$S-} procedure Stack_Check; assembler; { Check for local variable allocation } { On Entry -> d0 : size of local stack we are trying to allocate } asm XDEF STACKCHECK move.l sp,d1 { get value of stack pointer } sub.l d0,d1 { sp - stack_size } sub.l #2048,d1 cmp.l __BREAK,d1 bgt @st1nosweat move.l #202,d0 jsr HALT_ERROR @st1nosweat: end; Procedure Error2InOut; Begin if (errno <= -2) and (errno >= -11) then InOutRes:=150-errno { 150+errno } else Begin case errno of -32 : InOutRes:=1; -33 : InOutRes:=2; -34 : InOutRes:=3; -35 : InOutRes:=4; -36 : InOutRes:=5; -37 : InOutRes:=8; -39 : InOutRes:=8; -40 : InOutRes:=9; -46 : InOutRes:=15; -67..-64 : InOutRes:=153; -15 : InOutRes:=151; -13 : InOutRes:=150; else InOutres := word(errno); end; end; errno:=0; end; procedure halt(errnum : byte); begin do_exit; flush(stderr); asm clr.l d0 move.b errnum,d0 move.w d0,-(sp) move.w
#$4c,-(sp) trap #
1 end; end; function args : pointer; assembler; asm move.l __ARGS,d0 end; Function GetParamCount(const p: pchar): longint; var i: word; count: word; Begin i:=0; count:=0; while p[count] <> #0 do Begin if (p[count] <> ' ') and (p[count] <> #9) and (p[count] <> #0) then Begin i:=i+1; while (p[count] <> ' ') and (p[count] <> #9) and (p[count] <> #0) do

count:=count+1; end; if p[count] = #0 then break; count:=count+1; end; GetParamCount:=longint(i); end; Function GetParam(index: word; const p : pchar): string; { On Entry: index = string index to correct parameter } { On exit: = correct character index into pchar array } { Returns correct index to command line argument } var count: word; localindex: word; l: byte; temp: string; Begin temp:=''; count := 0; { first index is one } localindex := 1; l:=0; While p[count] <> #0 do Begin if (p[count] <> ' ') and (p[count] <> #9) then Begin if localindex = index then Begin while (p[count] <> #0) and (p[count] <> ' ') and (p[count] <> #9) and (l < 256) do Begin temp:=temp+p[count]; l:=l+1; count:=count+1; end; temp[0]:=char(l); GetParam:=temp; exit; end; { Point to next argument in list } while (p[count] <> #0) and (p[count] <> ' ') and (p[count] <> #9) do Begin count:=count+1; end; localindex:=localindex+1; end; if p[count] = #0 then break; count:=count+1; end; GetParam:=temp; end; function paramstr(l : longint) : string; var p : pchar; s1 : string; begin if l = 0 then Begin s1 := ''; end else if (l>0) and (l<=paramcount) then begin p:=args; paramstr:=GetParam(word(l),p); end else paramstr:=''; end; function paramcount : longint; Begin paramcount := argc; end; procedure randomize; var hl : longint; begin asm movem.l d2/d3/a2/a3, -(sp) { save OS registers } move.w
#17,-(sp) trap #
14 { call xbios - random number } add.l #2,sp movem.l (sp)+,d2/d3/a2/a3 move.l d0,hl { result in d0 } end; randseed:=hl; end;function getheapstart:pointer;assembler;asm lea.l HEAP,a0 move.l a0,d0end;function getheapsize:longint;assembler;asm move.l HEAP_SIZE,d0end ['D0']; { This routine is used to grow the heap. } { But here we do a trick, we say that the } { heap cannot be regrown! } function sbrk( size: longint): pointer; { on exit nil = if fails. } Begin sbrk:=nil; end;{$I heap.inc}{**************************************************************************** Low Level File Routines ****************************************************************************}procedure AllowSlash(p:pchar);var i : longint;begin{ allow slash as backslash } for i:=0 to strlen(p) do if p[i]='/' then p[i]:='\';end;procedure do_close(h : longint);begin asm movem.l d2/d3/a2/a3,-(sp) move.l h,d0 move.w d0,-(sp) move.w #$3e,-(sp) trap
#1 add.l #
4,sp { restore stack ... } movem.l (sp)+,d2/d3/a2/a3 end;end;procedure do_erase(p : pchar);begin AllowSlash(p); asm move.l d2,d6 { save d2 } movem.l d3/a2/a3,-(sp) { save regs } move.l p,-(sp) move.w #$41,-(sp) trap
#1 add.l #
6,sp move.l d6,d2 { restore d2 } movem.l (sp)+,d3/a2/a3 tst.w d0 beq @doserend move.w d0,errno @doserend: end; if errno <> 0 then Error2InOut;end;procedure do_rename(p1,p2 : pchar);

begin AllowSlash(p1); AllowSlash(p2); asm move.l d2,d6 { save d2 } movem.l d3/a2/a3,-(sp) move.l p1,-(sp) move.l p2,-(sp) clr.w -(sp) move.w
#$56,-(sp) trap #
1 lea 12(sp),sp move.l d6,d2 { restore d2 } movem.l (sp)+,d3/a2/a3 tst.w d0 beq @dosreend move.w d0,errno { error ... } @dosreend: end; if errno <> 0 then Error2InOut;end;function do_isdevice(handle:word):boolean;begin if (handle=stdoutputhandle) or (handle=stdinputhandle) or (handle=stderrorhandle) then do_isdevice:=FALSE else do_isdevice:=TRUE;end;function do_write(h,addr,len : longint) : longint;begin asm move.l d2,d6 { save d2 } movem.l d3/a2/a3,-(sp) move.l addr,-(sp) move.l len,-(sp) move.l h,d0 move.w d0,-(sp) move.w
#$40,-(sp) trap #
1 lea 12(sp),sp move.l d6,d2 { restore d2 } movem.l (sp)+,d3/a2/a3 tst.l d0 bpl @doswrend move.w d0,errno { error ... } @doswrend: move.l d0,@RESULT end; if errno <> 0 then Error2InOut;end;function do_read(h,addr,len : longint) : longint;begin asm move.l d2,d6 { save d2 } movem.l d3/a2/a3,-(sp) move.l addr,-(sp) move.l len,-(sp) move.l h,d0 move.w d0,-(sp) move.w
#$3f,-(sp) trap #
1 lea 12(sp),sp move.l d6,d2 { restore d2 } movem.l (sp)+,d3/a2/a3 tst.l d0 bpl @dosrdend move.w d0,errno { error ... } @dosrdend: move.l d0,@Result end; if errno <> 0 then Error2InOut;end;function do_filepos(handle : longint) : longint;begin asm move.l d2,d6 { save d2 } movem.l d3/a2/a3,-(sp) move.w #1,-(sp) { seek from current position } move.l handle,d0 move.w d0,-(sp) move.l #0,-(sp) { with a seek offset of zero } move.w
#$42,-(sp) trap #
1 lea 10(sp),sp move.l d6,d2 { restore d2 } movem.l (sp)+,d3/a2/a3 move.l d0,@Result end;end;procedure do_seek(handle,pos : longint);begin asm move.l d2,d6 { save d2 } movem.l d3/a2/a3,-(sp) move.w #0,-(sp) { seek from start of file } move.l handle,d0 move.w d0,-(sp) move.l pos,-(sp) move.w
#$42,-(sp) trap #
1 lea 10(sp),sp move.l d6,d2 { restore d2 } movem.l (sp)+,d3/a2/a3 end;end;function do_seekend(handle:longint):longint;var t: longint;begin asm move.l d2,d6 { save d2 } movem.l d3/a2/a3,-(sp) move.w #2,-(sp) { seek from end of file } move.l handle,d0 move.w d0,-(sp) move.l #0,-(sp) { with an offset of 0 from end } move.w
#$42,-(sp) trap #
1 lea 10(sp),sp move.l d6,d2 { restore d2 } movem.l (sp)+,d3/a2/a3 move.l d0,t end; do_seekend:=t;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;procedure do_truncate (handle,pos:longint);begin do_seek(handle,pos); {!!!!!!!!!!!!}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 i : word; oflags: longint;begin AllowSlash(p); { 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; oflags:=$02; { read/write mode }{ convert filemode to filerec modes } case (flags and 3) of 0 : begin filerec(f).mode:=fminput; oflags:=$00; { read mode only } end; 1 : filerec(f).mode:=fmoutput; 2 : filerec(f).mode:=fminout; end; if (flags and $1000)<>0 then begin filerec(f).mode:=fmoutput; oflags:=$04; { read/write with create } end else if (flags and $100)<>0 then begin filerec(f).mode:=fmoutput; oflags:=$02; { read/write } 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; asm movem.l d2/d3/a2/a3,-(sp) { save used registers } cmp.l #4,oflags { check if rewrite mode ... } bne @opencont2 { rewrite mode - create new file } move.w #0,-(sp) move.l p,-(sp) move.w #$3c,-(sp) trap
#1 add.l #
8,sp { restore stack of os call } bra @end { reset - open existing files } @opencont2: move.l oflags,d0 { use flag as source ... } @opencont1: move.w d0,-(sp) move.l p,-(sp) move.w #$3d,-(sp) trap
#1 add.l #
8,sp { restore stack of os call } @end: movem.l (sp)+,d2/d3/a2/a3 tst.w d0 bpl @opennoerr { if positive return values then ok } cmp.w #-1,d0 { if handle is -1 CON: } beq @opennoerr cmp.w #-2,d0 { if handle is -2 AUX: } beq @opennoerr cmp.w #-3,d0 { if handle is -3 PRN: } beq @opennoerr move.w d0,errno { otherwise normal error } @opennoerr: move.w d0,i { get handle as SIGNED VALUE... } end; if errno <> 0 then Error2InOut; filerec(f).handle:=i; if ((flags and $100) <> 0) and (FileRec (F).Handle <> UnusedHandle) then do_seekend(filerec(f).handle);end;{***************************************************************************** UnTyped File Handling*****************************************************************************}{$i file.inc}{***************************************************************************** Typed File Handling*****************************************************************************}{$i typefile.inc}{***************************************************************************** Text File Handling*****************************************************************************}{$i text.inc}{***************************************************************************** Directory Handling*****************************************************************************}

procedure DosDir(func:byte;const s:string);var buffer : array[0..255] of char; c : word;begin move(s[1],buffer,length(s)); buffer[length(s)]:=#0; AllowSlash(pchar(@buffer)); c:=word(func); asm move.l d2,d6 { save d2 } movem.l d3/a2/a3,-(sp) pea buffer move.w c,-(sp) trap
#1 add.l #
6,sp move.l d6,d2 { restore d2 } movem.l (sp)+,d3/a2/a3 tst.w d0 beq @dosdirend move.w d0,errno @dosdirend: end; if errno <> 0 then Error2InOut;end;procedure mkdir(const s : string);[IOCheck];begin If InOutRes <> 0 then exit; DosDir($39,s);end;procedure rmdir(const s : string);[IOCheck];begin If InOutRes <> 0 then exit; DosDir($3a,s);end;procedure chdir(const s : string);[IOCheck];begin If InOutRes <> 0 then exit; DosDir($3b,s);end;function GetDirIO (DriveNr: byte; var Dir: ShortString): word; [public, alias: 'FPC_GETDIRIO'];var temp : array[0..255] of char; i : longint; j: byte; drv: word;begin GetDirIO := 0; drv:=word(drivenr); asm move.l d2,d6 { save d2 } movem.l d3/a2/a3,-(sp) { Get dir from drivenr : 0=default, 1=A etc... } move.w drv,-(sp) { put (previously saved) offset in si }{ move.l temp,-(sp)} pea temp { call attos function 47H : Get dir } move.w #$47,-(sp) { make the call } trap
#1 add.l #
8,sp move.l d6,d2 { restore d2 } movem.l (sp)+,d3/a2/a3 end; { conversion to pascal string } i:=0; while (temp[i]<>#0) do begin if temp[i]='/' then temp[i]:='\'; dir[i+3]:=temp[i]; inc(i); end; dir[2]:=':'; dir[3]:='\'; dir[0]:=char(i+2);{ upcase the string (FPC Pascal function) } dir:=upcase(dir); if drivenr<>0 then { Drive was supplied. We know it } dir[1]:=chr(65+drivenr-1) else begin asm move.l d2,d6 { save d2 } movem.l d3/a2/a3,-(sp) move.w #$19,-(sp) trap
#1 add.l #
2,sp move.w d0,drv move.l d6,d2 { restore d2 } movem.l (sp)+,d3/a2/a3 end; dir[1]:=chr(byte(drv)+ord('A')); end;end;procedure GetDir (DriveNr: byte; var Dir: ShortString);begin InOutRes := GetDirIO (DriveNr, Dir);end;{***************************************************************************** System Dependent Exit code*****************************************************************************}Procedure system_exit;beginend;{***************************************************************************** SystemUnit Initialization*****************************************************************************}begin{ Initialize ExitProc } ExitProc:=Nil;{ Setup heap } InitHeap;{ Setup stdin, stdout and stderr } OpenStdIO(Input,fmInput,StdInputHandle); OpenStdIO(Output,fmOutput,StdOutputHandle); OpenStdIO(StdOut,fmOutput,StdOutputHandle); OpenStdIO(StdErr,fmOutput,StdErrorHandle);{ Reset IO Error } InOutRes:=0;(* This should be changed to a real value during *)(* thread driver initialization if appropriate. *) ThreadID := 1; errno := 0;{ Setup command line arguments } argc:=GetParamCount(args); InitVariantManager;{$ifdef HASWIDESTRING} InitWideStringManager;{$endif HASWIDESTRING}end.

是原创的？

在一个编译器里找的