diff --git a/CPDrv.pas b/CPDrv.pas new file mode 100644 index 0000000..3318881 --- /dev/null +++ b/CPDrv.pas @@ -0,0 +1,1136 @@ +//------------------------------------------------------------------------ +// UNIT : CPDrv.pas +// CONTENTS : TCommPortDriver component +// VERSION : 2.1 +// TARGET : (Inprise's) Borland Delphi 4.0 +// AUTHOR : Marco Cocco +// STATUS : Freeware +// INFOS : Implementation of TCommPortDriver component: +// - non multithreaded serial I/O +// KNOWN BUGS : none +// COMPATIBILITY : Windows 95/98/NT/2000 +// REPLACES : TCommPortDriver v2.00 (Delphi 4.0) +// TCommPortDriver v1.08/16 (Delphi 1.0) +// TCommPortDriver v1.08/32 (Delphi 2.0/3.0) +// BACK/COMPAT. : partial - a lot of properties have been renamed +// RELEASE DATE : 06/06/2000 +// (Replaces v2.0 released on 30/NOV/1998) +//------------------------------------------------------------------------ +// FOR UPDATES : - sorry, no home page - +// BUGS REPORT : mail to : mcocco@libero.it +// or: ditrek@tiscalinet.it +//------------------------------------------------------------------------ +// +// Copyright (c) 1996-2000 by Marco Cocco. All rights reseved. +// Copyright (c) 1996-2000 by d3k Software Company. All rights reserved. +// +//****************************************************************************** +//* Permission to use, copy, modify, and distribute this software and its * +//* documentation without fee for any purpose is hereby granted, * +//* provided that the above copyright notice appears on all copies and that * +//* both that copyright notice and this permission notice appear in all * +//* supporting documentation. * +//* * +//* NO REPRESENTATIONS ARE MADE ABOUT THE SUITABILITY OF THIS SOFTWARE FOR ANY * +//* PURPOSE. IT IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED WARRANTY. * +//* NEITHER MARCO COCCO OR D3K SHALL BE LIABLE FOR ANY DAMAGES SUFFERED BY * +//* THE USE OF THIS SOFTWARE. * +//****************************************************************************** + +unit CPDrv; + +interface + +uses + // Delphi units + Windows, Messages, SysUtils, Classes, Forms + // ComDrv32 units + ; + +//------------------------------------------------------------------------ +// Property types +//------------------------------------------------------------------------ + +type + // Baud Rates (custom or 110...256k bauds) + TBaudRate = ( brCustom, + br110, br300, br600, br1200, br2400, br4800, + br9600, br14400, br19200, br38400, br56000, + br57600, br115200, br128000, br256000 ); + // Port Numbers ( custom or COM1..COM16 ) + TPortNumber = ( pnCustom, + pnCOM1, pnCOM2, pnCOM3, pnCOM4, pnCOM5, pnCOM6, pnCOM7, + pnCOM8, pnCOM9, pnCOM10, pnCOM11, pnCOM12, pnCOM13, + pnCOM14, pnCOM15, pnCOM16 ); + // Data bits ( 5, 6, 7, 8 ) + TDataBits = ( db5BITS, db6BITS, db7BITS, db8BITS ); + // Stop bits ( 1, 1.5, 2 ) + TStopBits = ( sb1BITS, sb1HALFBITS, sb2BITS ); + // Parity ( None, odd, even, mark, space ) + TParity = ( ptNONE, ptODD, ptEVEN, ptMARK, ptSPACE ); + // Hardware Flow Control ( None, None + RTS always on, RTS/CTS ) + THwFlowControl = ( hfNONE, hfNONERTSON, hfRTSCTS ); + // Software Flow Control ( None, XON/XOFF ) + TSwFlowControl = ( sfNONE, sfXONXOFF ); + // What to do with incomplete (incoming) packets ( Discard, Pass ) + TPacketMode = ( pmDiscard, pmPass ); + +//------------------------------------------------------------------------ +// Event types +//------------------------------------------------------------------------ + +type + // RX event ( packet mode disabled ) + TReceiveDataEvent = procedure( Sender: TObject; DataPtr: pointer; DataSize: DWORD ) of object; + // RX event ( packed mode enabled ) + TReceivePacketEvent = procedure( Sender: TObject; Packet: pointer; DataSize: DWORD ) of object; + +//------------------------------------------------------------------------ +// Other types +//------------------------------------------------------------------------ + +type + // Line status ( Clear To Send, Data Set Ready, Ring, Carrier Detect ) + TLineStatus = ( lsCTS, lsDSR, lsRING, lsCD ); + // Set of line status + TLineStatusSet = set of TLineStatus; + +//------------------------------------------------------------------------ +// Constants +//------------------------------------------------------------------------ + +const + RELEASE_NOCLOSE_PORT = HFILE(INVALID_HANDLE_VALUE-1); + +//------------------------------------------------------------------------ +// TCommPortDriver component +//------------------------------------------------------------------------ + +type + TCommPortDriver = class( TComponent ) + protected + // Device Handle ( File Handle ) + FHandle : HFILE; + // # of the COM port to use, or pnCustom to use custom port name + FPort : TPortNumber; + // Custom port name ( usually '\\.\COMn', with n = 1..x ) + FPortName : string; + // COM Port speed (brXXX) + FBaudRate : TBaudRate; + // Baud rate ( actual numeric value ) + FBaudRateValue : DWORD; + // Data bits size (dbXXX) + FDataBits : TDataBits; + // How many stop bits to use (sbXXX) + FStopBits : TStopBits; + // Type of parity to use (ptXXX) + FParity : TParity; + // Type of hw handshaking (hw flow control) to use (hfXXX) + FHwFlow : THwFlowControl; + // Type of sw handshaking (sw flow control) to use (sFXXX) + FSwFlow : TSwFlowControl; + // Size of the input buffer + FInBufSize : DWORD; + // Size of the output buffer + FOutBufSize : DWORD; + // Size of a data packet + FPacketSize : smallint; + // ms to wait for a complete packet (<=0 = disabled) + FPacketTimeout : integer; + // What to do with incomplete packets (pmXXX) + FPacketMode : TPacketMode; + // Event to raise on data reception (asynchronous) + FOnReceiveData : TReceiveDataEvent; + // Event to raise on packet reception (asynchronous) + FOnReceivePacket : TReceivePacketEvent; + // ms of delay between COM port pollings + FPollingDelay : word; + // Specifies if the DTR line must be enabled/disabled on connect + FEnableDTROnOpen : boolean; + // Output timeout - milliseconds + FOutputTimeout : word; + // Timeout for ReadData + FInputTimeout : DWORD; + // Set to TRUE to prevent hangs when no device connected or + // device is OFF + FCkLineStatus : boolean; + // This is used for the timer + FNotifyWnd : HWND; + // Temporary buffer (RX) - used internally + FTempInBuffer : pointer; + // Time of the first byte of current RX packet + FFirstByteOfPacketTime : DWORD; + // Number of RX polling timer pauses + FRXPollingPauses : integer; + + // Sets the COM port handle + procedure SetHandle( Value: HFILE ); + // Selects the COM port to use + procedure SetPort( Value: TPortNumber ); + // Sets the port name + procedure SetPortName( Value: string ); + // Selects the baud rate + procedure SetBaudRate( Value: TBaudRate ); + // Selects the baud rate ( actual baud rate value ) + procedure SetBaudRateValue( Value: DWORD ); + // Selects the number of data bits + procedure SetDataBits( Value: TDataBits ); + // Selects the number of stop bits + procedure SetStopBits( Value: TStopBits ); + // Selects the kind of parity + procedure SetParity( Value: TParity ); + // Selects the kind of hardware flow control + procedure SetHwFlowControl( Value: THwFlowControl ); + // Selects the kind of software flow control + procedure SetSwFlowControl( Value: TSwFlowControl ); + // Sets the RX buffer size + procedure SetInBufSize( Value: DWORD ); + // Sets the TX buffer size + procedure SetOutBufSize( Value: DWORD ); + // Sets the size of incoming packets + procedure SetPacketSize( Value: smallint ); + // Sets the timeout for incoming packets + procedure SetPacketTimeout( Value: integer ); + // Sets the delay between polling checks + procedure SetPollingDelay( Value: word ); + // Applies current settings to open COM port + function ApplyCOMSettings: boolean; + // Polling proc + procedure TimerWndProc( var msg: TMessage ); + public + // Constructor + constructor Create( AOwner: TComponent ); override; + // Destructor + destructor Destroy; override; + + // Opens the COM port and takes of it. Returns false if something + // goes wrong. + function Connect: boolean; + // Closes the COM port and releases control of it + procedure Disconnect; + // Returns true if COM port has been opened + function Connected: boolean; + // Returns the current state of CTS, DSR, RING and RLSD (CD) lines. + // The function fails if the hardware does not support the control-register + // values (that is, returned set is always empty). + function GetLineStatus: TLineStatusSet; + // Returns true if polling has not been paused + function IsPolling: boolean; + // Pauses polling + procedure PausePolling; + // Re-starts polling (after pause) + procedure ContinuePolling; + // Flushes the rx/tx buffers + function FlushBuffers( inBuf, outBuf: boolean ): boolean; + // Returns number of received bytes in the RX buffer + function CountRX: integer; + // Returns the output buffer free space or 65535 if not connected + function OutFreeSpace: word; + // Sends binary data + function SendData( DataPtr: pointer; DataSize: DWORD ): DWORD; + // Sends binary data. Returns number of bytes sent. Timeout overrides + // the value specifiend in the OutputTimeout property + function SendDataEx( DataPtr: pchar; DataSize, Timeout: DWORD ): DWORD; + // Sends a byte. Returns true if the byte has been sent + function SendByte( Value: byte ): boolean; + // Sends a char. Returns true if the char has been sent + function SendChar( Value: char ): boolean; + // Sends a pascal string (NULL terminated if $H+ (default)) + function SendString( s: string ): boolean; + // Sends a C-style strings (NULL terminated) + function SendZString( s: pchar ): boolean; + // Reads binary data. Returns number of bytes read + function ReadData( DataPtr: pchar; MaxDataSize: DWORD ): DWORD; + // Reads a byte. Returns true if the byte has been read + function ReadByte( var Value: byte ): boolean; + // Reads a char. Returns true if char has been read + function ReadChar( var Value: char ): boolean; + // Set DTR line high (onOff=TRUE) or low (onOff=FALSE). + // You must not use HW handshaking. + procedure ToggleDTR( onOff: boolean ); + // Set RTS line high (onOff=TRUE) or low (onOff=FALSE). + // You must not use HW handshaking. + procedure ToggleRTS( onOff: boolean ); + + // Make the Handle of the COM port public (for TAPI...) [read/write] + property Handle: HFILE read FHandle write SetHandle; + published + // # of the COM Port to use ( or pnCustom for port by name ) + property Port: TPortNumber read FPort write SetPort default pnCOM2; + // Name of COM port + property PortName: string read FPortName write SetPortName; + // Speed ( Baud Rate ) + property BaudRate: TBaudRate read FBaudRate write SetBaudRate default br9600; + // Speed ( Actual Baud Rate value ) + property BaudRateValue: DWORD read FBaudRateValue write SetBaudRateValue default 9600; + // Data bits to use (5..8, for the 8250 the use of 5 data bits with 2 stop + // bits is an invalid combination, as is 6, 7, or 8 data bits with 1.5 stop + // bits) + property DataBits: TDataBits read FDataBits write SetDataBits default db8BITS; + // Stop bits to use (1, 1.5, 2) + property StopBits: TStopBits read FStopBits write SetStopBits default sb1BITS; + // Kind of Parity to use (none,odd,even,mark,space) + property Parity: TParity read FParity write SetParity default ptNONE; + // Kind of Hardware Flow Control to use: + // hfNONE none + // hfNONERTSON no flow control but keep RTS line on + // hfRTSCTS Request-To-Send/Clear-To-Send + property HwFlow: THwFlowControl read FHwFlow write SetHwFlowControl default hfNONERTSON; + // Kind of Software Flow Control to use: + // sfNONE none + // sfXONXOFF XON/XOFF + property SwFlow: TSwFlowControl read FSwFlow write SetSwFlowControl default sfNONE; + // Input Buffer size ( suggested - driver might ignore this setting ! ) + property InBufSize: DWORD read FInBufSize write SetInBufSize default 2048; + // Output Buffer size ( suggested - driver usually ignores this setting ! ) + property OutBufSize: DWORD read FOutBufSize write SetOutBufSize default 2048; + // RX packet size ( this value must be less than InBufSize ) + // A value <= 0 means "no packet mode" ( i.e. standard mode enabled ) + property PacketSize: smallint read FPacketSize write SetPacketSize default -1; + // Timeout (ms) for a complete packet (in RX) + property PacketTimeout: integer read FPacketTimeout write SetPacketTimeout default -1; + // What to do with incomplete packets (in RX) + property PacketMode: TPacketMode read FPacketMode write FPacketMode default pmDiscard; + // ms of delay between COM port pollings + property PollingDelay: word read FPollingDelay write SetPollingDelay default 50; + // Set to TRUE to enable DTR line on connect and to leave it on until disconnect. + // Set to FALSE to disable DTR line on connect. + property EnableDTROnOpen: boolean read FEnableDTROnOpen write FEnableDTROnOpen default true; + // Output timeout (milliseconds) + property OutputTimeout: word read FOutputTimeOut write FOutputTimeout default 500; + // Input timeout (milliseconds) + property InputTimeout: DWORD read FInputTimeOut write FInputTimeout default 200; + // Set to TRUE to prevent hangs when no device connected or device is OFF + property CheckLineStatus: boolean read FCkLineStatus write FCkLineStatus default false; + // Event to raise when there is data available (input buffer has data) + // (called only if PacketSize <= 0) + property OnReceiveData: TReceiveDataEvent read FOnReceiveData write FOnReceiveData; + // Event to raise when there is data packet available (called only if PacketSize > 0) + property OnReceivePacket: TReceivePacketEvent read FOnReceivePacket write FOnReceivePacket; + end; + +function BaudRateOf( bRate: TBaudRate ): DWORD; +function DelayForRX( bRate: TBaudRate; DataSize: DWORD ): DWORD; + +implementation + +const + Win32BaudRates: array[br110..br256000] of DWORD = + ( CBR_110, CBR_300, CBR_600, CBR_1200, CBR_2400, CBR_4800, CBR_9600, + CBR_14400, CBR_19200, CBR_38400, CBR_56000, CBR_57600, CBR_115200, + CBR_128000, CBR_256000 ); + +const + dcb_Binary = $00000001; + dcb_ParityCheck = $00000002; + dcb_OutxCtsFlow = $00000004; + dcb_OutxDsrFlow = $00000008; + dcb_DtrControlMask = $00000030; + dcb_DtrControlDisable = $00000000; + dcb_DtrControlEnable = $00000010; + dcb_DtrControlHandshake = $00000020; + dcb_DsrSensivity = $00000040; + dcb_TXContinueOnXoff = $00000080; + dcb_OutX = $00000100; + dcb_InX = $00000200; + dcb_ErrorChar = $00000400; + dcb_NullStrip = $00000800; + dcb_RtsControlMask = $00003000; + dcb_RtsControlDisable = $00000000; + dcb_RtsControlEnable = $00001000; + dcb_RtsControlHandshake = $00002000; + dcb_RtsControlToggle = $00003000; + dcb_AbortOnError = $00004000; + dcb_Reserveds = $FFFF8000; + +function GetWinPlatform: string; +var ov: TOSVERSIONINFO; +begin + ov.dwOSVersionInfoSize := sizeof(ov); + if GetVersionEx( ov ) then + begin + case ov.dwPlatformId of + VER_PLATFORM_WIN32s: // Win32s on Windows 3.1 + Result := 'W32S'; + VER_PLATFORM_WIN32_WINDOWS: // Win32 on Windows 95/98 + Result := 'W95'; + VER_PLATFORM_WIN32_NT: // Windows NT + Result := 'WNT'; + end; + end + else + Result := '??'; +end; + +function GetWinVersion: DWORD; +var ov: TOSVERSIONINFO; +begin + ov.dwOSVersionInfoSize := sizeof(ov); + if GetVersionEx( ov ) then + Result := MAKELONG( ov.dwMinorVersion, ov.dwMajorVersion ) + else + Result := $00000000; +end; + +function BaudRateOf( bRate: TBaudRate ): DWORD; +begin + if bRate = brCustom then + Result := 0 + else + Result := Win32BaudRates[ bRate ]; +end; + +function DelayForRX( bRate: TBaudRate; DataSize: DWORD ): DWORD; +begin + Result := round( DataSize / (BaudRateOf(bRate) / 10) * 1000 ); +end; + +constructor TCommPortDriver.Create( AOwner: TComponent ); +begin + inherited Create( AOwner ); + // Initialize to default values ----------------------- + // Not connected + FHandle := INVALID_HANDLE_VALUE; + // COM 2 + FPort := pnCOM2; + FPortName := '\\.\COM2'; + // 9600 bauds + FBaudRate := br9600; + FBaudRateValue := BaudRateOf( br9600 ); + // 8 data bits + FDataBits := db8BITS; + // 1 stop bit + FStopBits := sb1BITS; + // no parity + FParity := ptNONE; + // No hardware flow control but RTS on + FHwFlow := hfNONERTSON; + // No software flow control + FSwFlow := sfNONE; + // Input buffer of 2048 bytes + FInBufSize := 2048; + // Output buffer of 2048 bytes + FOutBufSize := 2048; + // Don't pack data + FPacketSize := -1; + // Packet timeout disabled + FPacketTimeout := -1; + // Discard incomplete packets + FPacketMode := pmDiscard; + // Poll COM port every 50ms + FPollingDelay := 50; + // Output timeout of 500ms + FOutputTimeout := 500; + // Timeout for ReadData(), 200ms + FInputTimeout := 200; + // DTR high on connect + FEnableDTROnOpen := true; + // Time not valid ( used by the packing routines ) + FFirstByteOfPacketTime := DWORD(-1); + // Don't check of off-line devices + FCkLineStatus := false; + // Init number of RX polling timer pauses - not paused + FRXPollingPauses := 0; + // Temporary buffer for received data + FTempInBuffer := AllocMem( FInBufSize ); + // Allocate a window handle to catch timer's notification messages + if not (csDesigning in ComponentState) then + FNotifyWnd := AllocateHWnd( TimerWndProc ); +end; + +destructor TCommPortDriver.Destroy; +begin + // Be sure to release the COM port + Disconnect; + // Free the temporary buffer + FreeMem( FTempInBuffer, FInBufSize ); + // Destroy the timer's window + if not (csDesigning in ComponentState) then + DeallocateHWnd( FNotifyWnd ); + // Call inherited destructor + inherited Destroy; +end; + +// The COM port handle made public and writeable. +// This lets you connect to external opened com port. +// Setting ComPortHandle to INVALID_PORT_HANDLE acts as Disconnect. +procedure TCommPortDriver.SetHandle( Value: HFILE ); +begin + // If same COM port then do nothing + if FHandle = Value then + exit; + // If value is RELEASE_NOCLOSE_PORT then stop controlling the COM port + // without closing in + if Value = RELEASE_NOCLOSE_PORT then + begin + // Stop the timer + if Connected then + KillTimer( FNotifyWnd, 1 ); + // No more connected + FHandle := INVALID_HANDLE_VALUE; + end + else + begin + // Disconnect + Disconnect; + // If Value is INVALID_HANDLE_VALUE then exit now + if Value = INVALID_HANDLE_VALUE then + exit; + // Set COM port handle + FHandle := Value; + // Start the timer ( used for polling ) + SetTimer( FNotifyWnd, 1, FPollingDelay, nil ); + end; +end; + +// Selects the COM port to use +procedure TCommPortDriver.SetPort( Value: TPortNumber ); +begin + // Be sure we are not using any COM port + if Connected then + exit; + // Change COM port + FPort := Value; + // Update the port name + if FPort <> pnCustom then + FPortName := Format( '\\.\COM%d', [ord(FPort)] ); +end; + +// Sets the port name +procedure TCommPortDriver.SetPortName( Value: string ); +begin + // Be sure we are not using any COM port + if Connected then + exit; + // Change COM port + FPort := pnCustom; + // Update the port name + FPortName := Value; +end; + +// Selects the baud rate +procedure TCommPortDriver.SetBaudRate( Value: TBaudRate ); +begin + // Set new COM speed + FBaudRate := Value; + if FBaudRate <> brCustom then + FBaudRateValue := BaudRateOf( FBaudRate ); + // Apply changes + if Connected then + ApplyCOMSettings; +end; + +// Selects the baud rate ( actual baud rate value ) +procedure TCommPortDriver.SetBaudRateValue( Value: DWORD ); +begin + // Set new COM speed + FBaudRate := brCustom; + FBaudRateValue := Value; + // Apply changes + if Connected then + ApplyCOMSettings; +end; + +// Selects the number of data bits +procedure TCommPortDriver.SetDataBits( Value: TDataBits ); +begin + // Set new data bits + FDataBits := Value; + // Apply changes + if Connected then + ApplyCOMSettings; +end; + +// Selects the number of stop bits +procedure TCommPortDriver.SetStopBits( Value: TStopBits ); +begin + // Set new stop bits + FStopBits := Value; + // Apply changes + if Connected then + ApplyCOMSettings; +end; + +// Selects the kind of parity +procedure TCommPortDriver.SetParity( Value: TParity ); +begin + // Set new parity + FParity := Value; + // Apply changes + if Connected then + ApplyCOMSettings; +end; + +// Selects the kind of hardware flow control +procedure TCommPortDriver.SetHwFlowControl( Value: THwFlowControl ); +begin + // Set new hardware flow control + FHwFlow := Value; + // Apply changes + if Connected then + ApplyCOMSettings; +end; + +// Selects the kind of software flow control +procedure TCommPortDriver.SetSwFlowControl( Value: TSwFlowControl ); +begin + // Set new software flow control + FSwFlow := Value; + // Apply changes + if Connected then + ApplyCOMSettings; +end; + +// Sets the RX buffer size +procedure TCommPortDriver.SetInBufSize( Value: DWORD ); +begin + // Do nothing if connected + if Connected then + exit; + // Free the temporary input buffer + FreeMem( FTempInBuffer, FInBufSize ); + // Set new input buffer size + if Value > 8192 then + Value := 8192 + else if Value < 128 then + Value := 128; + FInBufSize := Value; + // Allocate the temporary input buffer + FTempInBuffer := AllocMem( FInBufSize ); + // Adjust the RX packet size + SetPacketSize( FPacketSize ); +end; + +// Sets the TX buffer size +procedure TCommPortDriver.SetOutBufSize( Value: DWORD ); +begin + // Do nothing if connected + if Connected then + exit; + // Set new output buffer size + if Value > 8192 then + Value := 8192 + else if Value < 128 then + Value := 128; + FOutBufSize := Value; +end; + +// Sets the size of incoming packets +procedure TCommPortDriver.SetPacketSize( Value: smallint ); +begin + // PackeSize <= 0 if data isn't to be 'packetized' + if Value <= 0 then + FPacketSize := -1 + // If the PacketSize if greater than then RX buffer size then + // increase the RX buffer size + else if DWORD(Value) > FInBufSize then + begin + FPacketSize := Value; + SetInBufSize( FPacketSize ); + end; +end; + +// Sets the timeout for incoming packets +procedure TCommPortDriver.SetPacketTimeout( Value: integer ); +begin + // PacketTimeout <= 0 if packet timeout is to be disabled + if Value < 1 then + FPacketTimeout := -1 + // PacketTimeout cannot be less than polling delay + some extra ms + else if Value < FPollingDelay then + FPacketTimeout := FPollingDelay + (FPollingDelay*40) div 100; +end; + +// Sets the delay between polling checks +procedure TCommPortDriver.SetPollingDelay( Value: word ); +begin + // Make it greater than 4 ms + if Value < 5 then + Value := 5; + // If new delay is not equal to previous value... + if Value <> FPollingDelay then + begin + // Stop the timer + if Connected then + KillTimer( FNotifyWnd, 1 ); + // Store new delay value + FPollingDelay := Value; + // Restart the timer + if Connected then + SetTimer( FNotifyWnd, 1, FPollingDelay, nil ); + // Adjust the packet timeout + SetPacketTimeout( FPacketTimeout ); + end; +end; + +// Apply COM settings +function TCommPortDriver.ApplyCOMSettings: boolean; +var dcb: TDCB; +begin + // Do nothing if not connected + Result := false; + if not Connected then + exit; + + // ** Setup DCB (Device Control Block) fields ****************************** + + // Clear all + fillchar( dcb, sizeof(dcb), 0 ); + // DCB structure size + dcb.DCBLength := sizeof(dcb); + // Baud rate + dcb.BaudRate := FBaudRateValue; + // Set fBinary: Win32 does not support non binary mode transfers + // (also disable EOF check) + dcb.Flags := dcb_Binary; + // Enables the DTR line when the device is opened and leaves it on + if EnableDTROnOpen then + dcb.Flags := dcb.Flags or dcb_DtrControlEnable; + // Kind of hw flow control to use + case FHwFlow of + // No hw flow control + hfNONE:; + // No hw flow control but set RTS high and leave it high + hfNONERTSON: + dcb.Flags := dcb.Flags or dcb_RtsControlEnable; + // RTS/CTS (request-to-send/clear-to-send) flow control + hfRTSCTS: + dcb.Flags := dcb.Flags or dcb_OutxCtsFlow or dcb_RtsControlHandshake; + end; + // Kind of sw flow control to use + case FSwFlow of + // No sw flow control + sfNONE:; + // XON/XOFF sw flow control + sfXONXOFF: + dcb.Flags := dcb.Flags or dcb_OutX or dcb_InX; + end; + // Set XONLim: specifies the minimum number of bytes allowed in the input + // buffer before the XON character is sent (or CTS is set). + if (GetWinPlatform = 'WNT') and (GetWinVersion >= $00040000) then + begin + // WinNT 4.0 + Service Pack 3 needs XONLim to be less than or + // equal to 4096 bytes. Win95/98 doesn't have such limit. + if FInBufSize div 4 > 4096 then + dcb.XONLim := 4096 + else + dcb.XONLim := FInBufSize div 4; + end + else + dcb.XONLim := FInBufSize div 4; + // Specifies the maximum number of bytes allowed in the input buffer before + // the XOFF character is sent (or CTS is set low). The maximum number of bytes + // allowed is calculated by subtracting this value from the size, in bytes, of + // the input buffer. + dcb.XOFFLim := dcb.XONLim; + // How many data bits to use + dcb.ByteSize := 5 + ord(FDataBits); + // Kind of parity to use + dcb.Parity := ord(FParity); + // How many stop bits to use + dcb.StopBits := ord(FStopbits); + // XON ASCII char - DC1, Ctrl-Q, ASCII 17 + dcb.XONChar := #17; + // XOFF ASCII char - DC3, Ctrl-S, ASCII 19 + dcb.XOFFChar := #19; + + // Apply new settings + Result := SetCommState( FHandle, dcb ); + if not Result then + exit; + // Flush buffers + Result := FlushBuffers( true, true ); + if not Result then + exit; + // Setup buffers size + Result := SetupComm( FHandle, FInBufSize, FOutBufSize ); +end; + +function TCommPortDriver.Connect: boolean; +var tms: TCOMMTIMEOUTS; +begin + // Do nothing if already connected + Result := Connected; + if Result then + exit; + // Open the COM port + FHandle := CreateFile( pchar(FPortName), + GENERIC_READ or GENERIC_WRITE, + 0, // Not shared + nil, // No security attributes + OPEN_EXISTING, + FILE_ATTRIBUTE_NORMAL, + 0 // No template + ) ; + Result := Connected; + if not Result then + exit; + // Apply settings + Result := ApplyCOMSettings; + if not Result then + begin + Disconnect; + exit; + end; + // Set ReadIntervalTimeout: Specifies the maximum time, in milliseconds, + // allowed to elapse between the arrival of two characters on the + // communications line. + // We disable timeouts because we are polling the com port! + tms.ReadIntervalTimeout := 1; + // Set ReadTotalTimeoutMultiplier: Specifies the multiplier, in milliseconds, + // used to calculate the total time-out period for read operations. + tms.ReadTotalTimeoutMultiplier := 0; + // Set ReadTotalTimeoutConstant: Specifies the constant, in milliseconds, + // used to calculate the total time-out period for read operations. + tms.ReadTotalTimeoutConstant := 1; + // Set WriteTotalTimeoutMultiplier: Specifies the multiplier, in milliseconds, + // used to calculate the total time-out period for write operations. + tms.WriteTotalTimeoutMultiplier := 0; + // Set WriteTotalTimeoutConstant: Specifies the constant, in milliseconds, + // used to calculate the total time-out period for write operations. + tms.WriteTotalTimeoutConstant := 10; + // Apply timeouts + SetCommTimeOuts( FHandle, tms ); + // Start the timer (used for polling) + SetTimer( FNotifyWnd, 1, FPollingDelay, nil ); +end; + +procedure TCommPortDriver.Disconnect; +begin + if Connected then + begin + // Stop the timer (used for polling) + KillTimer( FNotifyWnd, 1 ); + // Release the COM port + CloseHandle( FHandle ); + // No more connected + FHandle := INVALID_HANDLE_VALUE; + end; +end; + +// Returns true if connected +function TCommPortDriver.Connected: boolean; +begin + Result := FHandle <> INVALID_HANDLE_VALUE; +end; + +// Returns CTS, DSR, RING and RLSD (CD) signals status +function TCommPortDriver.GetLineStatus: TLineStatusSet; +var dwS: DWORD; +begin + Result := []; + if not Connected then + exit; + // Retrieves modem control-register values. + // The function fails if the hardware does not support the control-register + // values. + if not GetCommModemStatus( FHandle, dwS ) then + exit; + if dwS and MS_CTS_ON <> 0 then Result := Result + [lsCTS]; + if dwS and MS_DSR_ON <> 0 then Result := Result + [lsDSR]; + if dwS and MS_RING_ON <> 0 then Result := Result + [lsRING]; + if dwS and MS_RLSD_ON <> 0 then Result := Result + [lsCD]; +end; + +// Returns true if polling has not been paused +function TCommPortDriver.IsPolling: boolean; +begin + Result := FRXPollingPauses <= 0; +end; + +// Pauses polling +procedure TCommPortDriver.PausePolling; +begin + // Inc. RX polling pauses counter + inc( FRXPollingPauses ); +end; + +// Re-starts polling (after pause) +procedure TCommPortDriver.ContinuePolling; +begin + // Dec. RX polling pauses counter + dec( FRXPollingPauses ); +end; + +// Flush rx/tx buffers +function TCommPortDriver.FlushBuffers( inBuf, outBuf: boolean ): boolean; +var dwAction: DWORD; +begin + // Do nothing if not connected + Result := false; + if not Connected then + exit; + // Flush the RX data buffer + dwAction := 0; + if outBuf then + dwAction := dwAction or PURGE_TXABORT or PURGE_TXCLEAR; + // Flush the TX data buffer + if inBuf then + dwAction := dwAction or PURGE_RXABORT or PURGE_RXCLEAR; + Result := PurgeComm( FHandle, dwAction ); + // Used by the RX packet mechanism + if Result then + FFirstByteOfPacketTime := DWORD(-1); +end; + +// Returns number of received bytes in the RX buffer +function TCommPortDriver.CountRX: integer; +var stat: TCOMSTAT; + errs: DWORD; +begin + // Do nothing if port has not been opened + Result := 65535; + if not Connected then + exit; + // Get count + ClearCommError( FHandle, errs, @stat ); + Result := stat.cbInQue; +end; + +// Returns the output buffer free space or 65535 if not connected +function TCommPortDriver.OutFreeSpace: word; +var stat: TCOMSTAT; + errs: DWORD; +begin + if not Connected then + Result := 65535 + else + begin + ClearCommError( FHandle, errs, @stat ); + Result := FOutBufSize - stat.cbOutQue; + end; +end; + +// Sends binary data. Returns number of bytes sent. Timeout overrides +// the value specifiend in the OutputTimeout property +function TCommPortDriver.SendDataEx( DataPtr: pchar; DataSize, Timeout: DWORD ): DWORD; +var nToSend, nSent, t1: DWORD; +begin + // Do nothing if port has not been opened + Result := 0; + if not Connected then + exit; + // Current time + t1 := GetTickCount; + // Loop until all data sent or timeout occurred + while DataSize > 0 do + begin + // Get TX buffer free space + nToSend := OutFreeSpace; + // If output buffer has some free space... + if nToSend > 0 then + begin + // Check signals + if FCkLineStatus and (GetLineStatus = []) then + exit; + // Don't send more bytes than we actually have to send + if nToSend > DataSize then + nToSend := DataSize; + // Send + WriteFile( FHandle, DataPtr^, nToSend, nSent, nil ); + nSent := abs( nSent ); + if nSent > 0 then + begin + // Update number of bytes sent + Result := Result + nSent; + // Decrease the count of bytes to send + DataSize := DataSize - nSent; + // Inc. data pointer + DataPtr := DataPtr + nSent; + // Get current time + t1 := GetTickCount; + // Continue. This skips the time check below (don't stop + // trasmitting if the Timeout is set too low) + continue; + end; + end; + // Buffer is full. If we are waiting too long then exit + if DWORD(GetTickCount-t1) > Timeout then + exit; + end; +end; + +// Send data (breaks the data in small packets if it doesn't fit in the output +// buffer) +function TCommPortDriver.SendData( DataPtr: pointer; DataSize: DWORD ): DWORD; +begin + Result := SendDataEx( DataPtr, DataSize, FOutputTimeout ); +end; + +// Sends a byte. Returns true if the byte has been sent +function TCommPortDriver.SendByte( Value: byte ): boolean; +begin + Result := SendData( @Value, 1 ) = 1; +end; + +// Sends a char. Returns true if the char has been sent +function TCommPortDriver.SendChar( Value: char ): boolean; +begin + Result := SendData( @Value, 1 ) = 1; +end; + +// Sends a pascal string (NULL terminated if $H+ (default)) +function TCommPortDriver.SendString( s: string ): boolean; +var len: DWORD; +begin + len := length( s ); + {$IFOPT H+} // New syle pascal string (NULL terminated) + Result := SendData( pchar(s), len ) = len; + {$ELSE} // Old style pascal string (s[0] = length) + Result := SendData( pchar(@s[1]), len ) = len; + {$ENDIF} +end; + +// Sends a C-style string (NULL terminated) +function TCommPortDriver.SendZString( s: pchar ): boolean; +var len: DWORD; +begin + len := strlen( s ); + Result := SendData( s, len ) = len; +end; + +// Reads binary data. Returns number of bytes read +function TCommPortDriver.ReadData( DataPtr: pchar; MaxDataSize: DWORD ): DWORD; +var nToRead, nRead, t1: DWORD; +begin + // Do nothing if port has not been opened + Result := 0; + if not Connected then + exit; + // Pause polling + PausePolling; + // Current time + t1 := GetTickCount; + // Loop until all requested data read or timeout occurred + while MaxDataSize > 0 do + begin + // Get data bytes count in RX buffer + nToRead := CountRX; + // If input buffer has some data... + if nToRead > 0 then + begin + // Don't read more bytes than we actually have to read + if nToRead > MaxDataSize then + nToRead := MaxDataSize; + // Read + ReadFile( FHandle, DataPtr^, nToRead, nRead, nil ); + // Update number of bytes read + Result := Result + nRead; + // Decrease the count of bytes to read + MaxDataSize := MaxDataSize - nRead; + // Inc. data pointer + DataPtr := DataPtr + nRead; + // Get current time + t1 := GetTickCount; + // Continue. This skips the time check below (don't stop + // reading if the FInputTimeout is set too low) + continue; + end; + // Buffer is empty. If we are waiting too long then exit + if (GetTickCount-t1) > FInputTimeout then + break; + end; + // Continue polling + ContinuePolling; +end; + +// Reads a byte. Returns true if the byte has been read +function TCommPortDriver.ReadByte( var Value: byte ): boolean; +begin + Result := ReadData( @Value, 1 ) = 1; +end; + +// Reads a char. Returns true if char has been read +function TCommPortDriver.ReadChar( var Value: char ): boolean; +begin + Result := ReadData( @Value, 1 ) = 1; +end; + +// Set DTR line high (onOff=TRUE) or low (onOff=FALSE). +// You must not use HW handshaking. +procedure TCommPortDriver.ToggleDTR( onOff: boolean ); +const funcs: array[boolean] of integer = (CLRDTR,SETDTR); +begin + if Connected then + EscapeCommFunction( FHandle, funcs[onOff] ); +end; + +// Set RTS line high (onOff=TRUE) or low (onOff=FALSE). +// You must not use HW handshaking. +procedure TCommPortDriver.ToggleRTS( onOff: boolean ); +const funcs: array[boolean] of integer = (CLRRTS,SETRTS); +begin + if Connected then + EscapeCommFunction( FHandle, funcs[onOff] ); +end; + +// COM port polling proc +procedure TCommPortDriver.TimerWndProc( var msg: TMessage ); +var nRead, nToRead, dummy: DWORD; + comStat: TCOMSTAT; +begin + if (msg.Msg = WM_TIMER) and Connected then + begin + // Do nothing if RX polling has been paused + if FRXPollingPauses > 0 then + exit; + // If PacketSize is > 0 then raise the OnReceiveData event only if the RX + // buffer has at least PacketSize bytes in it. + ClearCommError( FHandle, dummy, @comStat ); + if FPacketSize > 0 then + begin + // Complete packet received ? + if DWORD(comStat.cbInQue) >= DWORD(FPacketSize) then + begin + repeat + // Read the packet and pass it to the app + nRead := 0; + if ReadFile( FHandle, FTempInBuffer^, FPacketSize, nRead, nil ) then + if (nRead <> 0) and Assigned(FOnReceivePacket) then + FOnReceivePacket( Self, FTempInBuffer, nRead ); + // Adjust time + //if comStat.cbInQue >= FPacketSize then + FFirstByteOfPacketTime := FFirstByteOfPacketTime + + DelayForRX( FBaudRate, FPacketSize ); + comStat.cbInQue := comStat.cbInQue - WORD(FPacketSize); + if comStat.cbInQue = 0 then + FFirstByteOfPacketTime := DWORD(-1); + until DWORD(comStat.cbInQue) < DWORD(FPacketSize); + // Done + exit; + end; + // Handle packet timeouts + if (FPacketTimeout > 0) and (FFirstByteOfPacketTime <> DWORD(-1)) and + (GetTickCount - FFirstByteOfPacketTime > DWORD(FPacketTimeout)) then + begin + nRead := 0; + // Read the "incomplete" packet + if ReadFile( FHandle, FTempInBuffer^, comStat.cbInQue, nRead, nil ) then + // If PacketMode is not pmDiscard then pass the packet to the app + if (FPacketMode <> pmDiscard) and (nRead <> 0) and Assigned(FOnReceivePacket) then + FOnReceivePacket( Self, FTempInBuffer, nRead ); + // Restart waiting for a packet + FFirstByteOfPacketTime := DWORD(-1); + // Done + exit; + end; + // Start time + if (comStat.cbInQue > 0) and (FFirstByteOfPacketTime = DWORD(-1)) then + FFirstByteOfPacketTime := GetTickCount; + // Done + exit; + end; + + // Standard data handling + nRead := 0; + nToRead := comStat.cbInQue; + if (nToRead > 0) and ReadFile( FHandle, FTempInBuffer^, nToRead, nRead, nil ) then + if (nRead <> 0) and Assigned(FOnReceiveData) then + FOnReceiveData( Self, FTempInBuffer, nRead ); + end + // Let Windows handle other messages + else + Msg.Result := DefWindowProc( FNotifyWnd, Msg.Msg, Msg.wParam, Msg.lParam ) ; +end; + +end. diff --git a/EthThrd.pas b/EthThrd.pas new file mode 100644 index 0000000..a4621fb --- /dev/null +++ b/EthThrd.pas @@ -0,0 +1,788 @@ +///////////////////////////////////////////////////////////////////////// +// // +// Orion/Z (Orion-128 + Z80-CARD-II) emulator, version 1.9 // +// // +// Author: Sergey A. // +// // +// Copyright (C) 2006-2016 Sergey A. // +// // +// This program is free software; you can redistribute it and/or // +// modify it in any ways. // +// This program is distributed "AS IS" 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. // +// // +///////////////////////////////////////////////////////////////////////// + + +{***************************************************************** + + EtherNet Layer2 emulation with destination TAP virtual adapter + + *****************************************************************} + +unit EthThrd; + +interface + +{$I 'OrionZEm.inc'} + +Uses Windows, Messages, SysUtils, Classes, Registry; + +const + ETH_P_IP = $0800; // IPv4 protocol + ETH_P_IP6 = $86dd; // IPv6 protocol + ETH_P_ARP = $0806; // ARP protocol + ETH_HLEN = 14; + ETH_MTU = 1500; + FRAME_SIZE = 1518; + MAXFRAMEF_SZ = 1638; + FRAME_SIZE_FIELD = 1634; + + ETH_HEADER_LEN = ETH_HLEN; + ETHTYPE_ARP = ETH_P_ARP; + ETHTYPE_IP = ETH_P_IP; + ETHTYPE_IP6 = ETH_P_IP6; + + MAC_ADDR_TYPE = $0001; + ARP_REQUEST = $0001; + ARP_REPLY = $0002; + ARP_OPCODE_REQUEST = ARP_REQUEST; + ARP_OPCODE_REPLY = ARP_REPLY; + + IP_HEADER_LEN = 20; + IP_PROTO_ICMP = 1; + IP_PROTO_TCP = 6; + IP_PROTO_UDP = 17; + + UDP_HEADER_LEN = 8; + + ICMP_HEADER_LEN = 8; + ICMP_TYPE_ECHOREPLY= 0; + ICMP_TYPE_ECHOREQUEST = 8; + +{ + TAP_IOCTL_GET_VERSION = TAP_CONTROL_CODE CTL_CODE (FILE_DEVICE_UNKNOWN, 2, METHOD_BUFFERED, FILE_ANY_ACCESS) + + TAP_IOCTL_SET_MEDIA_STATUS = CTL_CODE (FILE_DEVICE_UNKNOWN, 6, METHOD_BUFFERED, FILE_ANY_ACCESS) + +#define CTL_CODE(DeviceType, Function, Method, Access) ( + ((DeviceType) << 16) | ((Access) << 14) | ((Function) << 2) | (Method) +) +} + FILE_DEVICE_UNKNOWN = $00000022; + METHOD_BUFFERED = 0; + FILE_ANY_ACCESS = 0; + + TAP_IOCTL_SET_MEDIA_STATUS = (FILE_DEVICE_UNKNOWN shl 16) or (FILE_ANY_ACCESS shl 14) or (6 shl 2) or (METHOD_BUFFERED); + TAP_IOCTL_GET_VERSION = (FILE_DEVICE_UNKNOWN shl 16) or (FILE_ANY_ACCESS shl 14) or (2 shl 2) or (METHOD_BUFFERED); + +type + TMacAddr = array [0..5] of char; + +const + MacBroadcast: TMacAddr = (#$FF, #$FF, #$FF, #$FF, #$FF, #$FF); + +type + TIPAddr = DWORD; + +//---------------- +// Ethernet header +//---------------- + + TEthHeader = packed record + dest:TMacAddr; // destination eth addr + src:TMacAddr; // source ether addr + proto:word; // packet type ID field + end; + PEthHeader = ^TEthHeader; + +//---------------- +// ARP packet +//---------------- + + TArpHeader = packed record +// dest:TMacAddr; // Reverse these two +0 +// src:TMacAddr; // to answer ARP requests +6 +// proto:word; // 0x0806 +0C + hwtype:word; // 0x0001 +0E + protocol:word; // 0x0800 +10 + hwlen:byte; // 0x06 +12 + protolen:byte; // 0x04 +13 + opcode:word; // 0x0001 for ARP request, 0x0002 for ARP reply +14 + shwaddr:TMacAddr; // +16 + sipaddr:TIPAddr; // +1C + dhwaddr:TMacAddr; // +20 + dipaddr:TIPAddr; // +26 + end; + PArpHeader = ^TArpHeader; + + TEthArpHeader = packed record // sizeof(TEthArpHeader)=$2A=42 + eth: TEthHeader; + arp: TArpHeader; + end; + PEthArpHeader= ^TEthArpHeader; + + TNetIpHeader = packed record + vhl: BYTE; + tos: BYTE; + len: WORD; + ipid: WORD; + ipoffset: WORD; + ttl: BYTE; + proto: BYTE; + ipchksum: WORD; + srcipaddr: DWORD; + destipaddr: DWORD; + end; + PNetIpHeader = ^TNetIpHeader; + + TNetIcmpHeader = packed record + itype: BYTE; + icode: BYTE; + icmpchksum:WORD; + id: WORD; + seqno: WORD; + end; + PNetIcmpHeader = ^TNetIcmpHeader; + + TNetUdpHeader = packed record + srcport: WORD; + destport: WORD; + udplen: WORD; + udpchksum: WORD; + end; + PNetUdpHeader = ^TNetUdpHeader; + + TNetTcpHeader = packed record + srcport: WORD; + destport: WORD; + seqno: DWORD; + ackno: DWORD; + tcpoffset: BYTE; + flags: BYTE; + wnd: WORD; + tcpchksum: WORD; + urgp: WORD; +// optdata[4]: BYTE ; + end; + PNetTcpHeader = ^TNetTcpHeader; + +// Ethernet/IP header + TNetEthIpHeader = packed record + eth: TEthHeader; + ip: TNetIpHeader; + end; + PNetEthIpHeader = ^TNetEthIpHeader; + +// The IP header + ip_hdr = TNetIpHeader; + +// The IP/TCP headers + tcpip_hdr = packed record + ip: TNetIpHeader; + tcp: TNetTcpHeader; + end; + +// The IP/ICMP headers + icmpip_hdr = packed record + ip: TNetIpHeader; + icmp: TNetIcmpHeader; + end; + PICMPip_hdr = ^icmpip_hdr; + +// The UDP and IP headers + udpip_hdr = packed record + ip: TNetIpHeader; + udp: TNetUdpHeader; + end; + + TFrame = array[0..MAXFRAMEF_SZ] of Byte; + PFrame = ^TFrame; + + TEthThread = class(TThread) + private + FVersion: packed record + major: DWORD; + minor: DWORD; + debug: DWORD; + end; + FMACAddr: TMacAddr; + FTAPguid: string; + FTAPHandle: THANDLE; + FOverRead: TOverlapped; + FOverWrite: TOverlapped; + FReadEvent: THandle; + FWriteEvent: THandle; + FBufferSize: integer; + FBufferUsed: integer; + FFramesList: TThreadList; + FFreeList: TList; + FFreeMax: integer; + FFreeBuf: array of TFrame; + FInpCh: char; + FOutCh: char; + FDisCh: char; + FInpFrames: integer; + FOutFrames: integer; + FDisFrames: integer; + FPrevInpFrames: integer; + FPrevOutFrames: integer; + FPrevDisFrames: integer; + FPromiscuous: boolean; + FAcceptRunt: boolean; + FBroadcast: boolean; + FMulticast: boolean; + procedure SetMacAddr(Value: PChar); + procedure SetTAPguid(const Value: string); + procedure OpenTAP(); + procedure CloseTAP(); + function GetFreeBuf:PFrame; + procedure DisposeBuf(ptr:PFrame); + function GetActive: boolean; + procedure SetActive(const Value: boolean); + procedure SetBufSize(const Value: integer); + function GetMacAddr: PChar; + function MacEqual(mac1, mac2: PChar):boolean; + function IsBroadcast(mac: PChar):boolean; + function IsMulticast(mac: PChar):boolean; + procedure SetPromiscuous(const Value: boolean); + procedure SetAcceptRunt(const Value: boolean); + procedure SetBroadcast(const Value: boolean); + procedure SetMulticast(const Value: boolean); + protected + procedure Execute; override; + public + constructor Create(); + destructor Destroy; override; + procedure Start; + procedure Stop; + procedure Reset; + function FrameLen(const Buffer: TFrame):integer; + function GetPacket(var Buffer:TFrame):WORD; + function PutPacket(const Buffer; WrSize:integer):boolean; + function GetStat: string; + function IsPhysical(mac: PChar):boolean; + property VersionMajor: DWORD read FVersion.major; // TAP driver version + property VersionMinor: DWORD read FVersion.minor; + property Active: boolean read GetActive write SetActive; + property BufSize: integer read FBufferSize write SetBufSize; + property MACAddr: PChar read GetMacAddr write SetMacAddr; + property TAPguid: string read FTAPguid write SetTAPguid; + property Promiscuous: boolean read FPromiscuous write SetPromiscuous; + property AcceptMulticast: boolean read FMulticast write SetMulticast; + property AcceptBroadcast: boolean read FBroadcast write SetBroadcast; + property AcceptRunt: boolean read FAcceptRunt write SetAcceptRunt; + property InpFramesList: TThreadList read FFramesList; + property InpFrames: integer read FInpFrames; + property OutFrames: integer read FOutFrames; + property DisFrames: integer read FDisFrames; // discarded due free buffer not ready + end; + + function htons(val:WORD):WORD; + function htonl(val:DWORD): DWORD; + function netChecksum(data:PBYTE; len:WORD): WORD; + procedure GetConnectionInfo(Names, Guids: TStrings); + procedure CreateEthThread; + procedure DestroyEthThread; + +var + EthThread: TEthThread; + +implementation + +function StrWinError(Err:DWORD): string; +var lpMsgBuf: PChar; +begin + FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER or + FORMAT_MESSAGE_FROM_SYSTEM, + nil, Err, 0, + @lpMsgBuf, 0, nil); + Result:=string(lpMsgBuf); + LocalFree( HLOCAL(lpMsgBuf) ); +end; + +function LastWinError: string; +begin + StrWinError(GetLastError); +end; + +function htons(val:WORD):WORD; +begin + result:=(val shl 8) or (val shr 8); +end; + +function htonl(val:DWORD): DWORD; +begin + result:=(htons(val shr 16) or DWORD(htons(val and $0000FFFF) shl 16)); +end; + +function netChecksum(data:PBYTE; len:WORD): WORD; +var sum: DWORD; +begin + sum := 0; + while (len>=2) do begin + sum:=sum+(PWORD(data))^; + inc(data); inc(data); + len:=len-2; + end; + if (len>0) then + sum:=sum+(PBYTE(data))^; + + while ( (sum shr 16) <> 0 ) do + sum := WORD(sum) + WORD(sum shr 16); + + result:= WORD(sum xor $FFFF); +end; + +procedure GetConnectionInfo(Names, Guids: TStrings); +const + StartKey = '\SYSTEM\CurrentControlSet\Control\Network'; + SubKeyNetName = 'Class'; + SubKeyNetValue = 'Net'; + NameValueName = 'Name'; + ShowIconValueName = 'ShowIcon'; +var + Reg: TRegistry; + KeyNames : TStringList; + i : Integer; + KeyFound : Boolean; + Key : string; +begin + Names.Clear; + Guids.Clear; + + // Access the registry in read only mode + Reg := TRegistry.Create(HKEY_LOCAL_MACHINE); + KeyNames := TStringList.Create; + try + Reg.RootKey := HKEY_LOCAL_MACHINE; + Reg.OpenKeyReadOnly(StartKey); + + // Need to find the child that has a value named + // 'Class' which value is 'Net' + Reg.GetKeyNames(KeyNames); + i := 0; + KeyFound := False; + Key := StartKey; + while (i < KeyNames.Count) and not KeyFound do + begin + Reg.OpenKeyReadOnly(Key+'\'+KeyNames[i]); + if Reg.ReadString(SubKeyNetName) = SubKeyNetValue then + KeyFound := True; + Inc(i); + end; + + // Found a key, open it and read its subkeys + // which in turn contain the names we are looking for + // in their Connection subkey + if KeyFound then + begin + Key := '\'+Reg.CurrentPath; + Reg.OpenKeyReadOnly(KeyNames[i-1]); + Reg.GetKeyNames(KeyNames); + for i := 0 to KeyNames.Count - 1 do + begin + Reg.OpenKeyReadOnly(Key+'\'+KeyNames[i]+'\Connection'); + if Reg.ValueExists(NameValueName) then + begin + Names.Add(Reg.ReadString(NameValueName)); + Guids.Add(KeyNames[i]); + end; + end; + end; + finally + Reg.Free; + KeyNames.Free; + end; +end; + +procedure CreateEthThread; +begin + if not Assigned(EthThread) then + begin + EthThread:=TEthThread.Create; { create suspended } + EthThread.Priority := tpLower; { set the priority to normal } + end; +end; + +procedure DestroyEthThread; +begin + if Assigned(EthThread) then with EthThread do begin + if Suspended then Resume; + Terminate; + WaitFor; + Active:=False; // CloseTAP + Free; + end; + EthThread:=nil; +end; + +{ TEthThread } + +procedure TEthThread.Reset; +begin + Stop; + FInpCh:='I'; + FOutCh:='O'; + FDisCh:='D'; + FInpFrames:=0; + FOutFrames:=0; + FDisFrames:=0; + FPrevInpFrames:=0; + FPrevOutFrames:=0; + FPrevDisFrames:=0; + with FFramesList.LockList do + try + while (Count>0) do begin + DisposeBuf(Items[0]); + Delete(0); + end; + finally + FFramesList.UnlockList; + end; +end; + +constructor TEthThread.Create(); +var RandInt: Integer; +begin + FBroadcast:=True; + FMulticast:=False; + FAcceptRunt:=False; // False => ignore (skip) runt packets (packet length < 64 bytes) + FPromiscuous:=False; + Randomize(); + FFramesList:=TThreadList.Create; + FFreeList:=TList.Create; + Reset; + FTAPguid:=''; + FTAPHandle:=INVALID_HANDLE_VALUE; + FBufferUsed:=0; + RandInt:=Random(MaxInt); + FMACAddr[0]:=chr(0); + FMACAddr[1]:=chr(255); + FMACAddr[2]:=chr(lo(RandInt shr 24)); + FMACAddr[3]:=chr(lo(RandInt shr 16)); + FMACAddr[4]:=chr(lo(RandInt shr 8)); + FMACAddr[5]:=chr(lo(RandInt)); + FReadEvent:=CreateEvent(nil, False {True}, False, nil); + FOverRead.Offset:=0; + FOverRead.OffsetHigh:=0; + FOverRead.hEvent := FReadEvent; + if FOverRead.hEvent = 0 then + raise Exception.Create('Error creating TAP read event'); + FWriteEvent:=CreateEvent(nil, False {True}, False, nil); + FOverWrite.Offset:=0; + FOverWrite.OffsetHigh:=0; + FOverWrite.hEvent := FWriteEvent; + if FOverRead.hEvent = 0 then + raise Exception.Create('Error creating TAP write event'); + inherited Create(True); // Create Suspended +end; + +destructor TEthThread.Destroy; +begin + CloseHandle(FWriteEvent); + CloseHandle(FReadEvent); + FFramesList.Free; + FFreeList.Free; + inherited; +end; + +procedure TEthThread.Start; +begin + if not Active then + Active:=True; // OpenTap + Resume; { now run the thread } +end; + +procedure TEthThread.Stop; +begin + Suspend; { pause the thread } +end; + +function TEthThread.MacEqual(mac1, mac2: PChar):boolean; +begin + Result:=False; + if mac1[0]<>mac2[0] then exit; + if mac1[1]<>mac2[1] then exit; + if mac1[2]<>mac2[2] then exit; + if mac1[3]<>mac2[3] then exit; + if mac1[4]<>mac2[4] then exit; + Result:=mac1[5]=mac2[5]; +end; + +function TEthThread.FrameLen(const Buffer: TFrame):integer; +begin + Result:=PDWORD(@Buffer[FRAME_SIZE_FIELD])^; +end; + +function TEthThread.GetPacket(var Buffer:TFrame):WORD; + var PFrameBuf: PFrame; + function min(a,b:integer):integer; begin if a0) then begin + PFrameBuf:=Items[0]; + Delete(0); + Result:=WORD(FrameLen(PFrameBuf^)); + end; + finally + FFramesList.UnlockList; + end; + if Result<>0 then + CopyMemory(@Buffer[0], PFrameBuf, min(Result, sizeof(TFrame))); + if Assigned(PFrameBuf) then + DisposeBuf(PFrameBuf); +end; + +function TEthThread.PutPacket(const Buffer; WrSize:integer):boolean; +var dwWrited: DWORD; + error: DWORD; + res: LongBool; +begin + Result:=False; + if not Active then exit; + res:=GetOverlappedResult(FTAPHandle, FOverWrite, dwWrited, FALSE); + if (not res) and (GetLastError=ERROR_IO_INCOMPLETE) then + WaitForSingleObject(FWriteEvent, INFINITE); + + res:=WriteFile(FTAPHandle, Buffer, WrSize, dwWrited, @FOverWrite); + if (not res) then begin + error:=GetLastError; + if (error=ERROR_IO_PENDING) then + begin + WaitForSingleObject(FWriteEvent, INFINITE); + if not GetOverlappedResult(FTAPHandle, FOverWrite, dwWrited, FALSE) then + raise Exception.CreateFmt('Error reading TAP-adapter, phase 0: %s', [LastWinError()]); + end + else + raise Exception.CreateFmt('Error writing TAP-adapter: write failed: %s', [StrWinError(error)]); + end; + FOutFrames:=FOutFrames+1; + Result:=True; +end; + +procedure TEthThread.Execute; +var + dwError: DWORD; + PFrameBuf: PFrame; + TmpFrameBuf: TFrame; + dwRead: DWORD; +begin + PFrameBuf:=nil; + FreeOnTerminate := False; + while not Terminated do + if FTAPHandle=INVALID_HANDLE_VALUE then sleep(1) else + begin + dwRead:=0; + if not Assigned(PFrameBuf) then begin + PFrameBuf:=GetFreeBuf(); + if not Assigned(PFrameBuf) then PFrameBuf:=@TmpFrameBuf; + end; + if not ReadFile(FTAPHandle, PFrameBuf^, sizeof(TFrame), dwRead, @FOverRead) then + begin + dwError := GetLastError; + if dwError = ERROR_IO_PENDING then begin + WaitForSingleObject(FReadEvent, INFINITE); + if not GetOverlappedResult(FTAPHandle, FOverRead, dwRead, False) then + raise Exception.CreateFmt('Error reading TAP-adapter, phase 0: %s', [LastWinError()]); + end + else + raise Exception.CreateFmt('Error waiting TAP adapter event: %s', [StrWinError(dwError)]); + end; + if (dwRead>=42) or ((dwRead>0)and FAcceptRunt) then // PRE+42+CRC=64 + begin + with FFramesList.LockList do + try + if (PFrameBuf=@TmpFrameBuf) then + FDisFrames:=FDisFrames+1 + else + if MacEqual(pointer(PFrameBuf), @FMACAddr[0]) // we are destination + or (IsBroadcast(pointer(PFrameBuf)) and FBroadcast) // or broadcast accepted + or (IsMulticast(pointer(PFrameBuf)) and FMulticast) // or multicast accepted + or (IsPhysical(pointer(PFrameBuf)) and FPromiscuous) then // or Promiscuous node on + begin + PDWORD(@(PFrameBuf^[FRAME_SIZE_FIELD]))^:=dwRead; + Add(PFrameBuf); + FInpFrames:=FInpFrames+1; + end; + PFrameBuf:=nil; + finally + FFramesList.UnlockList; + end; + end + end; +end; + +procedure TEthThread.OpenTAP; +var len, val: DWORD; + hndl: THANDLE; +begin + if (FTAPHandle<>INVALID_HANDLE_VALUE) then + CloseTap(); + hndl:=CreateFile(PChar('\\.\Global\'+FTAPguid+'.tap'), GENERIC_READ or GENERIC_WRITE, {FILE_SHARE_READ or FILE_SHARE_WRITE}0, nil, + OPEN_EXISTING, FILE_ATTRIBUTE_SYSTEM or FILE_FLAG_OVERLAPPED, 0); + if (hndl=INVALID_HANDLE_VALUE) then + raise Exception.CreateFmt('Error opening TAP adapter: %s', [LastWinError()]); + if not (DeviceIoControl(hndl, TAP_IOCTL_GET_VERSION, + @FVersion, sizeof (FVersion), + @FVersion, sizeof (FVersion), len, nil)) then + begin + CloseHandle(hndl); + raise Exception.CreateFmt('Error TAP adapter - DeviceIoControl (1): %s', [LastWinError()]); + end; + val:=1; + if (not DeviceIoControl(hndl, TAP_IOCTL_SET_MEDIA_STATUS, + @val, sizeof(val), @val, sizeof(val), len, nil)) then + begin + CloseHandle(hndl); + raise Exception.CreateFmt('Error TAP adapter - DeviceIoControl (2): %s', [LastWinError()]); + end; + FTAPHandle:=hndl; +end; + +procedure TEthThread.CloseTAP; +var len, val: DWORD; +begin + if (FTAPHandle<>INVALID_HANDLE_VALUE) then + begin + val:=0; + if (not DeviceIoControl(FTAPHandle, TAP_IOCTL_SET_MEDIA_STATUS, + @val, sizeof(val), @val, sizeof(val), len, nil)) then + raise Exception.CreateFmt('Error TAP adapter - DeviceIoControl: %s', [LastWinError()]); + CloseHandle(FTAPHandle); + end; + FTAPHandle:=INVALID_HANDLE_VALUE; +end; + + +procedure TEthThread.SetMacAddr(Value: PChar); +begin + FMACAddr[0]:=Value[0]; + FMACAddr[1]:=Value[1]; + FMACAddr[2]:=Value[2]; + FMACAddr[3]:=Value[3]; + FMACAddr[4]:=Value[4]; + FMACAddr[5]:=Value[5]; +end; + +procedure TEthThread.SetPromiscuous(const Value: boolean); +begin + FPromiscuous := Value; +end; + +procedure TEthThread.SetTAPguid(const Value: string); +begin + if (trim(FTAPguid)=trim(Value)) then exit; + if (FTAPguid<>'') then + begin + CloseTAP; + FTAPguid:=''; + end; + FTAPguid := trim(Value); +end; + +function TEthThread.GetActive: boolean; +begin + Result:=FTAPHandle<>INVALID_HANDLE_VALUE; +end; + +procedure TEthThread.SetActive(const Value: boolean); +begin + If (Value) then + begin + if (not Active) then OpenTAP; + end + else CloseTAP; +end; + +procedure TEthThread.SetBufSize(const Value: integer); +var i: integer; +begin + FBufferSize:=Value; + FFreeMax:=FBufferSize div MAXFRAMEF_SZ; + SetLength(FFreeBuf, FFreeMax); + FFreeList.Clear; + for i:=0 to FFreeMax-1 do FFreeList.Add(@FFreeBuf[i][0]); +end; + +procedure TEthThread.DisposeBuf(ptr:PFrame); +begin + FFreeList.Add(ptr); +end; + +function TEthThread.GetFreeBuf: PFrame; +begin + if (FFreeList.Count=0) then + Result:=nil + else begin + Result:=FFreeList.Items[0]; + FFreeList.Delete(0); + end; +end; + +function TEthThread.GetMacAddr: PChar; +begin + Result:=@FMACAddr[0]; +end; + +function TEthThread.GetStat: string; + function hsize(Actual: integer; var Prev:integer; var ch:char):string; + begin + if Actual<>Prev then + begin + Prev:=Actual; + ch:=chr(ord(ch) xor $20); + end; + if Actual>=1024*1024 then + result:=ch+format(':%dМ', [Actual div (1024*1024)]) + else if Actual>=1024 then + result:=ch+format(':%dK', [Actual div 1024]) + else + result:=ch+format(':%d', [Actual]); + end; +begin + Result:=format('%s, %s, %s', [hsize(FInpFrames, FPrevInpFrames, FInpCh), + hsize(FOutFrames, FPrevOutFrames, FOutCh), + hsize(FDisFrames, FPrevDisFrames, FDisCh)]); +end; + +procedure TEthThread.SetAcceptRunt(const Value: boolean); +begin + FAcceptRunt := Value; +end; + +procedure TEthThread.SetBroadcast(const Value: boolean); +begin + FBroadcast := Value; +end; + +procedure TEthThread.SetMulticast(const Value: boolean); +begin + FMulticast := Value; +end; + +function TEthThread.IsBroadcast(mac: PChar): boolean; +begin + Result:=MacEqual(mac, @MacBroadcast[0]); +end; + +function TEthThread.IsMulticast(mac: PChar): boolean; +begin + Result:=(ord(mac^) and 1 <> 0) and (mac^ <> #$FF); +end; + +function TEthThread.IsPhysical(mac: PChar): boolean; +begin + Result:=(not IsMulticast(mac)) and (not IsBroadcast(mac)); +end; + +initialization + EthThread:=nil; + +end. + diff --git a/F600common.pas b/F600common.pas new file mode 100644 index 0000000..14a5a42 --- /dev/null +++ b/F600common.pas @@ -0,0 +1,127 @@ +///////////////////////////////////////////////////////////////////////// +// // +// Orion/Z (Orion-128 + Z80-CARD-II) emulator, version 1.9 // +// // +// Author: Sergey A. // +// // +// Copyright (C) 2006-2016 Sergey A. // +// // +// This program is free software; you can redistribute it and/or // +// modify it in any ways. // +// This program is distributed "AS IS" 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 F600common; + +interface + +Uses Windows, Messages, SysUtils; + +const + stSectionName = 'F600Plugin'; + stPrnFileKey = 'PrnFile'; + stPrnFNewKey = 'PrnFNew'; + stPrnCPKey = 'PrnCP'; + stPrnModeKey = 'PrnScheme'; + stPrnFontKey = 'PrnFont'; + stPrnFtSzKey = 'PrnFontSize'; + stPrnPrnKey = 'PrnPrn'; + stPrnBrdTop = 'BorderTop'; + stPrnBrdLeft = 'BorderLeft'; + stPrnBrdRight = 'BorderRight'; + stPrnBrdBot = 'BorderBottom'; + MAX_BUF = 2048; + + koi866: array[$80..$ff] of byte = + ($C4, $B3, $DA, $BF, $C0, $D9, $C3, $B4, $C2, $C1, $C5, $DF, $DC, $DB, $DD, $DE, + $B0, $B1, $B2, $F4, $FE, $F9, $FB, $F7, $F3, $F2, $FF, $F5, $F8, $FD, $FA, $F6, + $CD, $BA, $D5, $F1, $D6, $C9, $B8, $B7, $BB, $D4, $D3, $C8, $BE, $BD, $BC, $C6, + $C7, $CC, $B5, $F0, $B6, $B9, $D1, $D2, $CB, $CF, $D0, $CA, $D8, $D7, $CE, $FC, + $EE, $A0, $A1, $E6, $A4, $A5, $E4, $A3, $E5, $A8, $A9, $AA, $AB, $AC, $AD, $AE, + $AF, $EF, $E0, $E1, $E2, $E3, $A6, $A2, $EC, $EB, $A7, $E8, $ED, $E9, $E7, $EA, + $9E, $80, $81, $96, $84, $85, $94, $83, $95, $88, $89, $8A, $8B, $8C, $8D, $8E, + $8F, $9F, $90, $91, $92, $93, $86, $82, $9C, $9B, $87, $98, $9D, $99, $97, $9A +); + +type + TPrnBuffer = array[0..MAX_BUF] of byte; + +function Koi8to866(inp: byte):byte; +Function GetPrivateString(SectionName,KeyName,DefaultString:string):string; +Function GetPrivateInt(SectionName,KeyName:string;DefaultInt:Integer):integer; +procedure WritePrivateString(SectionName,KeyName,Str:string); +procedure WritePrivateInt(SectionName,KeyName:string;Int:Integer); +procedure GetIniSettings; + +var IniName: string; +var PrnBuffer: TPrnBuffer; + PrnFile, PrnFont: string; + PrnMode, PrnFNew, PrnCP, PrnPrn, PrnFontSize: integer; + BufCount: integer; + prev_pC: byte; + strobe_phase: integer; // {00000111122222} + +implementation + +Uses F600printer; + +function Koi8to866(inp: byte):byte; +begin + if inp<$80 then + Result:=inp + else Result:=koi866[inp]; +end; + +Function GetPrivateString(SectionName,KeyName,DefaultString:string):string; +var buf:array[0..MAX_PATH] of char; +begin + GetPrivateProfileString(PChar(SectionName),PChar(KeyName),PChar(DefaultString),buf,sizeof(buf)-1,PChar(IniName)); + Result:=trim(StrPas(buf)); +end; + +Function GetPrivateInt(SectionName,KeyName:string;DefaultInt:Integer):integer; +begin + Result:=GetPrivateProfileInt(PChar(SectionName),PChar(KeyName),DefaultInt,PChar(IniName)); +end; + +procedure WritePrivateString(SectionName,KeyName,Str:string); +begin + WritePrivateProfileString(PChar(SectionName),PChar(KeyName),PChar(Str),PChar(IniName)); +end; + +procedure WritePrivateInt(SectionName,KeyName:string;Int:Integer); +begin + WritePrivateProfileString(PChar(SectionName),PChar(KeyName),PChar(IntToStr(Int)),PChar(IniName)); +end; + +procedure GetIniSettings; +begin + IniName:=ChangeFileExt(System.ParamStr(0),'.INI'); + If not FileExists(IniName) then IniName:=ExtractFileName(IniName); + PrnFile:=GetPrivateString(stSectionName, stPrnFileKey, 'c:\prn_out.txt'); + PrnFNew:=GetPrivateInt(stSectionName, stPrnFNewKey, 0); + PrnMode:=GetPrivateInt(stSectionName, stPrnModeKey, 0); + PrnCP:=GetPrivateInt(stSectionName, stPrnCPKey, 0); + PrnFont:=GetPrivateString(stSectionName, stPrnFontKey, 'Courier'); + PrnFontSize:=GetPrivateInt(stSectionName, stPrnFtSzKey, 10); + PrnPrn:=GetPrivateInt(stSectionName, stPrnPrnKey, 0); + BorderTop := GetPrivateInt(stSectionName, stPrnBrdTop, 50); + BorderLeft := GetPrivateInt(stSectionName, stPrnBrdLeft, 50); + BorderRight:= GetPrivateInt(stSectionName, stPrnBrdRight, 50); + BorderBottom:=GetPrivateInt(stSectionName, stPrnBrdBot, 50); +end; + +initialization + PrnPrn:=0; + PrnMode:=0; + PrnFNew:=0; + PrnFontSize:=8; + Strobe_phase:=0; + BufCount:=0; + prev_pC:=0; + +end. diff --git a/F600printer.pas b/F600printer.pas new file mode 100644 index 0000000..a520e19 --- /dev/null +++ b/F600printer.pas @@ -0,0 +1,425 @@ +///////////////////////////////////////////////////////////////////////// +// // +// Orion/Z (Orion-128 + Z80-CARD-II) emulator, version 1.9 // +// // +// Author: Sergey A. // +// // +// Copyright (C) 2006-2016 Sergey A. // +// // +// This program is free software; you can redistribute it and/or // +// modify it in any ways. // +// This program is distributed "AS IS" 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 F600printer; + +interface + +uses + Windows, SysUtils, CommDlg, winspool; + +const PRINTER_DIALOG = $1; + PRINT_OUT_FILE = $2; + OUT_FILE_EXIST = $4; + NO_INIT = $8; + APPEND_OUT_FILE = $10; + MATRIX_PRINTER = $20; + LASER_PRINTER = $40; + PREVIEW_OUT_FILE= $80; + PaperWidth: integer = 80; // 80 символов в строке + ParerHeight: integer = 60;// 60 строк на листе + LaserWrap: integer = 0; + FontWidth: integer = 0; + FontHeight: integer = 0; + FontWeight: integer = FW_DONTCARE; + FontName: string = 'Courier'; + Leading: double = 1; + BorderTop: integer = 40; + BorderLeft: integer = 40; + BorderRight: integer = 40; + BorderBottom: integer = 40; + UsePrnPortName: boolean = True; + WndOwner: HWND = 0; + +var DocName: String; + PrinterName: String; + +procedure ShowLastError; +procedure SetPrinterParams(PrintName, DocumName, LaserFontNm: string; LaserFontSz: integer); +procedure GetPrinterParams(var PName:string; var DName: string; var HPrinter:THandle; var PrnDC:HDC); +function PrnStart(Mode:LongInt):boolean; +function PrnString(Text:PChar; Len:integer):boolean; +function PrnStartPage:boolean; +function PrnEndPage:boolean; +function PrnStop:boolean; + +implementation + +type + PrnRec = record + Cur: TPoint; + Finish: TPoint; { End of the printable area } + Height: Integer; { Height of the current line } + end; +const + MagicLaserValue=300; {dpi} + FHPrinter: THandle = 0; + PrinterDC: HDC = 0; // IFDEF TEdit + _hFont: HFONT = 0; + +var + RecPrn: PrnRec; + MatrixPrinter: boolean; + +procedure ShowLastError; +var lpMsgBuf: PChar; +begin + FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER or + FORMAT_MESSAGE_FROM_SYSTEM, + nil, GetLastError, 0, + @lpMsgBuf, 0, nil); + MessageBox(WndOwner, lpMsgBuf, 'System Error', MB_OK+MB_ICONSTOP); + LocalFree( HLOCAL(lpMsgBuf) ); +end; + +procedure FormatReportError(st:PChar); +begin + MessageBox(WndOwner,st,'FormatReport Error',MB_OK+MB_ICONSTOP); +end; + +procedure SetLaserFont; +begin + if PrinterDC<>0 then + begin + _hfont:=CreateFont(-MulDiv(FontHeight, GetDeviceCaps(PrinterDC, LOGPIXELSY), 72), + -MulDiv(FontWidth, GetDeviceCaps(PrinterDC, LOGPIXELSX), 72), + 0, 0, (FontWeight mod 10)*1000, 0, 0, 0, + {DEFAULT}RUSSIAN_CHARSET, OUT_DEFAULT_PRECIS, + CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, + FIXED_PITCH or FF_DONTCARE, PChar(FontName)); + SelectObject(PrinterDC,_hfont); + SetBkMode(PrinterDC, TRANSPARENT); + end; +end; + +procedure SetPrinterParams(PrintName, DocumName, LaserFontNm: string; LaserFontSz: integer); +begin + if PrintName<>'' then + begin + PrinterName:=PrintName; + FHPrinter:=0; + PrinterDC:=0; + end; + DocName:=DocumName; + if LaserFontNm<>'' then FontName:=LaserFontNm; + if LaserFontSz<>0 then FontHeight:=LaserFontSz; + if FontHeight=0 then FontHeight:=10; + if FontName='' then FontName:='Courier'; + FontWidth:=(FontHeight div 3)*2; + FontWeight:=4; + SetLaserFont; +end; + +procedure GetPrinterParams(var PName:string; var DName: string; + var HPrinter:THandle; var PrnDC:HDC); +begin + PName:=PrinterName; + DName:=DocName; + HPrinter:=FHprinter; + PrnDC:=PrinterDC; +end; + +procedure NewPage(var Prn: PrnRec); +begin + with Prn do + begin + Cur.X := BorderLeft {0}; + Cur.Y := BorderTop {0}; + EndPage(PrinterDC); + StartPage(PrinterDC); + end; +end; + +procedure NewLine(var Prn: PrnRec); + function CharHeight: Word; + var + Metrics: TTextMetric; + begin + GetTextMetrics(PrinterDC, Metrics); + Result := Metrics.tmHeight; + end; +begin + with Prn do + begin + Cur.X := BorderLeft {0}; + if Height = 0 then + Inc(Cur.Y, trunc(CharHeight*Leading)) else + Inc(Cur.Y, trunc(Height*Leading)); + if Cur.Y > (Finish.Y - (trunc(Height*Leading) * 2)) then NewPage(Prn); + Height := 0; + end; +end; + +procedure PrnOutStr(var Prn: PrnRec; Text: PChar; Len: Integer); +var + Extent: TSize; + L: Integer; +begin + with Prn do + begin + while Len > 0 do + begin + L := Len; + GetTextExtentPoint32(PrinterDC, Text, L, Extent); + while (L > 0) and (Extent.cX + (Cur.X + BorderLeft) > Finish.X) do + begin + L := CharPrev(Text, Text+L) - Text; + GetTextExtentPoint32(PrinterDC, Text, L, Extent); + end; + if Extent.cY > Height then Height := Extent.cY + 2; + Windows.TextOut(PrinterDC, Cur.X, Cur.Y, Text, L); + Dec(Len, L); + Inc(Text, L); + if Len > 0 then NewLine(Prn) + else Inc(Cur.X, Extent.cX); + end; + end; +end; + +function PrnString(Text:PChar; Len:integer):boolean; +var + L: Integer; + TabWidth: Word; + a: boolean; + n: DWORD; + procedure Flush; + begin + if L <> 0 then PrnOutStr(RecPrn, Text, L); + Inc(Text, L + 1); + Dec(Len, L + 1); + L := 0; + end; + function AvgCharWidth: Word; + var + Metrics: TTextMetric; + begin + GetTextMetrics(PrinterDC, Metrics); + Result := Metrics.tmAveCharWidth; + end; +begin + PrnString:=False; + if (FHPrinter or PrinterDC)=0 then + FormatReportError('Попытка печатать без начала документа.') + else + begin + if (Len=0) and (Text<>nil) and (Text^<>#0) then + Len:=StrLen(Text); + If MatrixPrinter then + begin + a:=WritePrinter(FHPrinter, Text, Len, n); + PrnString:=a and (n=Len); + end + else + begin + PrnString:=True; + OemToAnsiBuff( Text, Text, Len ); + L := 0; + with RecPrn do + begin + while L < Len do + begin + case Text[L] of + #9: + begin + Flush; + TabWidth := AvgCharWidth * 8; + Inc(Cur.X, TabWidth - ((Cur.X + TabWidth + 1) + mod TabWidth) + 1); + if Cur.X > Finish.X then NewLine(RecPrn); + end; + #13: Flush; + #10: + begin + Flush; + NewLine(RecPrn); + end; + ^L: + begin + Flush; + NewPage(RecPrn); + end; + else + Inc(L); + end; + end; + end; + Flush; + end; + end; +end; + +function PrnStartPage:boolean; +begin + PrnStartPage:=False; + if (FHPrinter or PrinterDC)=0 then + FormatReportError('Попытка начать страницу без начала документа.') + else + begin + If MatrixPrinter then PrnStartPage:=StartPagePrinter(FHPrinter) + else PrnStartPage:=boolean(StartPage(PrinterDC)); + end; +end; + +function PrnEndPage:boolean; +var n: DWORD {integer}; + a: boolean; +begin + PrnEndPage:=False; + if (FHPrinter or PrinterDC) = 0 then + FormatReportError('Попытка завершить страницу без начала документа.') + else + begin + If MatrixPrinter then + begin + a:=True; + n:=1; + if (GetVersion and $80000000)<>0 then {IF WIN95} + a:=WritePrinter(FHPrinter, PChar(#12), 1, n); + PrnEndPage:=(n=1) and a and EndPagePrinter(FHPrinter); + end + else PrnEndPage:=(EndPage(PrinterDC)>0); + end; +end; + +function PrnStart(Mode:LongInt):boolean; +var DocInf: TDocInfo; + DocInfo: TDocInfo1; + a: boolean; + xDevMode: PDeviceMode; + DevNames: PDevNames; + PrnDlg: TPrintDlg; +begin + a:=False; + PrnStart:=False; + if (FHPrinter or PrinterDC)<> 0 then + FormatReportError('Предыдущий сеанс печати не завершен.') + else + begin + if (NO_INIT and mode)=0 then SetPrinterParams('','','',0); + with PrnDlg do + begin + lStructSize:=sizeof(PrnDlg); + hWndOwner:=WndOwner; + hDevMode:=0; + hDevNames:=0; + hDC:=0; + Flags:=PD_HIDEPRINTTOFILE or PD_NOPAGENUMS or PD_RETURNDC or PD_USEDEVMODECOPIESANDCOLLATE or PD_NOSELECTION; + if (PRINTER_DIALOG and mode)=0 then Flags:=Flags or PD_RETURNDEFAULT; + nMinPage:=1; + nMaxPage:=9999; + nFromPage:=1; + nToPage:=1; + nCopies:=1; + hInstance:=0; + lCustData:=0; + lpPrintTemplateName:=nil; + lpSetupTemplateName:=nil; + hPrintTemplate:=0; + hSetupTemplate:=0; + end; + if PrintDlg(PrnDlg) then + begin + if (NO_INIT and mode)=0 then + begin + PrinterDC:=PrnDlg.hDC; + try + xDevMode:=GlobalLock(PrnDlg.hDevMode); + PrinterName:=StrPas(xDevMode^.dmDeviceName); + case (MATRIX_PRINTER or LASER_PRINTER) and mode of + MATRIX_PRINTER: MatrixPrinter:=True; + LASER_PRINTER: MatrixPrinter:=False + else MatrixPrinter:=(xDevMode.dmPrintQuality0); + end; + end + else + begin + SetLaserFont; + with RecPrn do + begin + Cur.X := 0; + Cur.Y := 0; + Finish.X := GetDeviceCaps(PrinterDC, HorzRes)-BorderRight; + Finish.Y := GetDeviceCaps(PrinterDC, VertRes)-BorderBottom; + Height := 0; + end; + with DocInf do + begin + cbSize:=sizeof(DocInf); + lpszDocName:=PChar('Orion/Z emulator: '+DocName); + lpszOutput:=nil; + lpszDatatype:='EMF'; + fwType:=0; + end; + a:=(StartDoc(PrinterDC,DocInf)>0) + end; + PrnStart:=a and PrnStartPage; + end; + end; +end; + +function PrnStop:boolean; +var a,b:boolean; +begin + PrnStop:=False; + if (FHPrinter or PrinterDC) = 0 then + FormatReportError('Попытка завершить печать без начала документа.') + else + begin + a:=PrnEndPage; + If MatrixPrinter then + begin + b:=EndDocPrinter(FHPrinter); + PrnStop:=a and b and ClosePrinter(FHPrinter); + end + else + begin + PrnStop:=a and (EndDoc(PrinterDC)>0); + if _hfont<>0 then DeleteObject(_hfont); + end; + FHPrinter:=0; + PrinterDC:=0; + end; +end; + +end. diff --git a/F600prn.cfg b/F600prn.cfg new file mode 100644 index 0000000..5079b08 --- /dev/null +++ b/F600prn.cfg @@ -0,0 +1,35 @@ +-$A+ +-$B- +-$C+ +-$D+ +-$E- +-$F- +-$G+ +-$H+ +-$I+ +-$J+ +-$K- +-$L+ +-$M- +-$N+ +-$O+ +-$P+ +-$Q- +-$R- +-$S- +-$T- +-$U- +-$V+ +-$W- +-$X+ +-$YD +-$Z1 +-cg +-AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +-H+ +-W+ +-M +-$M16384,1048576 +-K$00400000 +-LE"c:\borland\delphi5\Projects\Bpl" +-LN"c:\borland\delphi5\Projects\Bpl" diff --git a/F600prn.dll b/F600prn.dll new file mode 100644 index 0000000..4f30597 Binary files /dev/null and b/F600prn.dll differ diff --git a/F600prn.dof b/F600prn.dof new file mode 100644 index 0000000..bd857a9 --- /dev/null +++ b/F600prn.dof @@ -0,0 +1,89 @@ +[Compiler] +A=1 +B=0 +C=1 +D=1 +E=0 +F=0 +G=1 +H=1 +I=1 +J=1 +K=0 +L=1 +M=0 +N=1 +O=1 +P=1 +Q=0 +R=0 +S=0 +T=0 +U=0 +V=1 +W=0 +X=1 +Y=1 +Z=1 +ShowHints=1 +ShowWarnings=1 +UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +[Linker] +MapFile=0 +OutputObjs=0 +ConsoleApp=1 +DebugInfo=0 +RemoteSymbols=0 +MinStackSize=16384 +MaxStackSize=1048576 +ImageBase=4194304 +ExeDescription= +[Directories] +OutputDir= +UnitOutputDir= +PackageDLLOutputDir= +PackageDCPOutputDir= +SearchPath= +Packages=Vcl50;Vclx50;VclSmp50;Vcldb50;vclado50;ibevnt50;Vclbde50;vcldbx50;Qrpt50;TeeUI50;TeeDB50;Tee50;Dss50;TeeQR50;VCLIB50;Vclmid50;vclie50;Inetdb50;Inet50;NMFast50;webmid50;dclocx50;dclaxserver50 +Conditionals= +DebugSourceDirs= +UsePackages=0 +[Parameters] +RunParams= +HostApplication=C:\Borland\Delphi5\Projects\_OriZEmu\OrionZEm.exe +[Language] +ActiveLang= +ProjectLang=$00000419 +RootDir= +[Version Info] +IncludeVerInfo=1 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1049 +CodePage=1251 +[Version Info Keys] +CompanyName= +FileDescription=Orion/Z emulator port F600 printer plugin +FileVersion=1.0.0.0 +InternalName= +LegalCopyright=(c) 2007 Sergey M. Akimov +LegalTrademarks= +OriginalFilename= +ProductName=Orion/Z emulator +ProductVersion=1.0.0.0 +Comments=FREEWARE +[HistoryLists\hlConditionals] +Count=2 +Item0=ORIONZEM +Item1=USE_SOUND +[HistoryLists\hlUnitAliases] +Count=1 +Item0=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; diff --git a/F600prn.dpr b/F600prn.dpr new file mode 100644 index 0000000..829f279 --- /dev/null +++ b/F600prn.dpr @@ -0,0 +1,98 @@ +///////////////////////////////////////////////////////////////////////// +// // +// Printer Plugin for Orion/Z (Orion-128 + Z80-CARD-II) emulator, // +// version 1.0 // +// // +// // +// Author: Sergey A. // +// // +// Copyright (C)2006-2016 Sergey A. // +// // +// This program is free software; you can redistribute it and/or // +// modify it in any ways. // +// This program is distributed "AS IS" 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. // +// // +///////////////////////////////////////////////////////////////////////// + +library F600prn; + +//{$DEFINE ENTIRE_APP} + +uses + Windows, + Messages, + SysUtils, +{$IFDEF ENTIRE_APP} + Forms, +{$ENDIF} + modF600, + F600prnf in 'F600prnf.pas' {frmF600prnf}, + F600prnp in 'F600prnp.pas' {frmF600prnp}, + F600common in 'F600common.pas'; + +// print to prn functions + +{$R *.RES} + +const + DllFunctions:string='"Port F600 Printer","0","Port F600 print to file","1"'#0; + DllFuncCount=2; + +{$IFDEF ENTIRE_APP} +var OldApp:Tapplication; +{$ENDIF} + +function MainFunc(fIndex:LongInt; fType:LongInt; var fDataPtr: pointer): LongInt; stdcall; +begin + Result:=0; + case fType of + F600Func_Load: begin // when module loaded + GetIniSettings; + end; + F600Func_Flush, + F600Func_UnLoad: begin // when module unloaded + case fIndex of + 0: Result:=flush_prnp; + 1: Result:=flush_prnf + else result:=0; + end; + end; + F600Func_Configure: with PApplicationParams(fDataPtr)^ do + begin // when user press 'configure plugin' button +{$IFDEF ENTIRE_APP} + OldApp:=Application; + Application.Handle:=AppHandle; + Application.Icon.Handle:=aIcon; +{$ENDIF} + case fIndex of + 0: Result:=pConfigure; + 1: Result:=fConfigure + else result:=0; + end; +{$IFDEF ENTIRE_APP} + Application:=OldApp; +{$ENDIF} + end; + F600Func_Enumerate: begin // when OrionZEm read plugin for content (functions list - comma separated pairs "Title","index",...) + fDataPtr:=@DllFunctions[1]; + Result:=DllFuncCount; + end; + else case fIndex of // when printing via parallel port 8255 + 0: Result:=prnbuf(fType, fDataPtr, flush_prnp); + 1: Result:=prnbuf(fType, fDataPtr, flush_prnf) + else result:=0; + end; + end; +end; + +exports + MainFunc index 1; + +begin + frmF600prnp:=nil; + frmF600prnf:=nil; +end. + + diff --git a/F600prn.res b/F600prn.res new file mode 100644 index 0000000..8fe87f9 Binary files /dev/null and b/F600prn.res differ diff --git a/F600prnf.dfm b/F600prnf.dfm new file mode 100644 index 0000000..17e068b --- /dev/null +++ b/F600prnf.dfm @@ -0,0 +1,97 @@ +object frmF600prnf: TfrmF600prnf + Left = 580 + Top = 296 + BorderIcons = [biSystemMenu] + BorderStyle = bsSingle + Caption = 'Configure port F600 printer - print to file' + ClientHeight = 295 + ClientWidth = 515 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + Position = poScreenCenter + OnActivate = FormActivate + PixelsPerInch = 96 + TextHeight = 13 + object edtFileName: TEdit + Left = 208 + Top = 18 + Width = 293 + Height = 21 + TabOrder = 1 + end + object btnFileName: TButton + Left = 16 + Top = 18 + Width = 177 + Height = 25 + Caption = 'Output File name' + TabOrder = 0 + OnClick = btnFileNameClick + end + object btnOk: TButton + Left = 72 + Top = 261 + Width = 129 + Height = 26 + Caption = 'OK' + TabOrder = 4 + OnClick = btnOkClick + end + object btnCancel: TButton + Left = 320 + Top = 261 + Width = 129 + Height = 26 + Cancel = True + Caption = 'Cancel' + ModalResult = 2 + TabOrder = 5 + end + object rgMode: TRadioGroup + Left = 16 + Top = 173 + Width = 485 + Height = 74 + Caption = ' Centronix printer connection ' + Items.Strings = ( + 'B0..B7 - data, C0 - strobe, C7 - ready' + 'A0..A7 - data, C7 - strobe, C3 - ready ') + TabOrder = 3 + end + object rgFNew: TRadioGroup + Left = 16 + Top = 56 + Width = 485 + Height = 48 + Caption = ' File open mode ' + Columns = 2 + Items.Strings = ( + 'Append file' + 'Overwrite file') + TabOrder = 2 + end + object rgCodePage: TRadioGroup + Left = 16 + Top = 112 + Width = 485 + Height = 52 + Caption = ' source text CodePage ' + Columns = 2 + Items.Strings = ( + 'cp866' + 'koi8-r') + TabOrder = 6 + end + object SaveDialog: TSaveDialog + DefaultExt = 'prn' + Filter = + 'any file (*.*)|*.*|output files (*.prn)|*.prn|text files (*.txt)' + + '|*.txt' + Title = 'Select file for printer output' + end +end diff --git a/F600prnf.pas b/F600prnf.pas new file mode 100644 index 0000000..a0cafd4 --- /dev/null +++ b/F600prnf.pas @@ -0,0 +1,217 @@ +///////////////////////////////////////////////////////////////////////// +// // +// Orion/Z (Orion-128 + Z80-CARD-II) emulator, version 1.07 // +// // +// http://www.orion-z.hoter.ru // +// // +// Author: Sergey A. // +// // +// Copyright (C)2006-2011 Sergey A. // +// // +// This program is free software; you can redistribute it and/or // +// modify it in any ways. // +// This program is distributed "AS IS" 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 F600prnf; + +interface + +uses + Windows, Messages, SysUtils, Forms, + Classes, Controls, Dialogs, ExtCtrls, StdCtrls; + +type + TfrmF600prnf = class(TForm) + edtFileName: TEdit; + btnFileName: TButton; + btnOk: TButton; + btnCancel: TButton; + SaveDialog: TSaveDialog; + rgMode: TRadioGroup; + rgFNew: TRadioGroup; + rgCodePage: TRadioGroup; + procedure btnFileNameClick(Sender: TObject); + procedure FormActivate(Sender: TObject); + procedure btnOkClick(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + + TFlushCallback=function: LongInt; + +var + frmF600prnf: TfrmF600prnf; + + function fConfigure: LongInt; + function flush_prnf: LongInt; + function prnbuf(fType:LongInt; var fDataPtr: pointer; flush_buf: TFlushCallback): LongInt; + +implementation + +{$R *.DFM} + +Uses F600common, modF600; + +var NextFront: boolean; + FlushCount: integer=0; + +// Вариант 1: +// pB0...pB7 out - printer data (inverted) +// pC0 out - data strobe (active=1) +// pC7 in - printer ready (Active=1) + +// Вариант 2: +// PA0..PA7 out - DATA +// PC7 - STROBE - strob (inwersnyj) // PC3 - BUSY - gotownostx{ + ; + ; drajwer "LPT" ; "CENTRONICS" (irpr-m) ; ;====================== ; ORG 0A800H ; PPB:EQU 0F601H PPC:EQU 0F602H PPU:EQU 0F603H ; PRINT:JMP PRNT ; whod dr."wywod simwola" STATUS:JMP STR0 ; whod dr."gotownostx" ; STR0:MVI A,98H ; programmirowanie porta STA PPU XRA A STA PPC ; ust.ishod.sost.signalow STR1:DCR A ; zadervka JNZ STR1 CALL STTS ; printer -- gotow? RZ ; esli net - wyhod PUSH H LXI H,STTS ; wykl.ustanowo~nu` ~astx SHLD STR0+1 ; programmy STATUS POP H STTS:LDA PPC ; osnow.~astx progr. STATUS ANI 80H ; prwer. _BUSY RET ; PRNT:PUSH H PUSH D PUSH B PUSH PSW PRT0:JMP PRN ; PRN:MVI A,98H ; po primeru podprog. STA PPU ; STATUS programmiru`aq XRA A ; ~astx podrogr. print STA PPC PRN1:DCR A JNZ PRN1 CALL STTS JZ PRT3 PUSH H LXI H,PRT1 SHLD PRT0+1 POP H ; osnownaq ~astx podprogrm. ; wywoda simwola na printer PRT1:CALL STTS ; ovidatx gotownosti printera JZ PRT1 ; do priema simwola MOV A,C CMA ; inwertirowatx bajt simwola STA PPB ; wywesti na printer MVI A,1 ; \ STA PPC ; formirowanie impulxsa XRA A ; _STROBE STA PPC ;/ PRT2:CALL STTS ; ovidatx gotownosti printera JZ PRT2 ; posle priema simwola PRT3:POP PSW POP B POP D POP H RET ; END uproщennaq shema podkl`~eniq printera s interfejsom "CENTRONICS". port obozn. razxem LX-800 B1 >------------- D0 -------------- 2 DATA 1 B2 >------------- D1 -------------- 3 DATA 2 B3 >------------- D2 -------------- 4 DATA 3 B4 >------------- D3 -------------- 5 DATA 4 B5 >------------- D4 -------------- 6 DATA 5 B6 >------------- D5 -------------- 7 DATA 6 B7 >------------- D6 -------------- 8 DATA 7 B8 >------------- D7 -------------- 9 DATA 8 * C1 >------------ _STROBE -- SC ---- 1 _STROBE C2 >----------------------- S0 ---- C7 <----------------------- A0 ---- C8 <------------ BUSY ---- AC ---- 11 BUSY } + +function flush_prnf: LongInt; +var ii: integer; +{$IFDEF USE_FILESTREAM} + fs: TFileStream; + ss: string; +{$ELSE} + ff: file of byte; + bb: byte; +{$ENDIF} +begin + Result:=0; + if (BufCount=0) or (trim(PrnFile)='') then + begin + inc(FlushCount); + exit; + end; +{$IFDEF USE_FILESTREAM} + fs:=nil; + try + if (not FileExists(PrnFile)) or ((PrnFNew<>0) and (FlushCount>2)) then + begin + fs:=TFileStream.Create(PrnFile, fmCreate); + fs.Free; + end; + fs:=TFileStream.Create(PrnFile, fmOpenReadWrite or fmShareDenyNone); + ss:=''; + for ii:=0 to BufCount-1 do + ss:=ss+chr(PrnBuffer[ii]); + fs.Seek(0, soFromEnd); + fs.Write(PrnBuffer, BufCount); + finally + if Assigned(fs) then fs.Free; + end; +{$ELSE} + AssignFile(ff, PrnFile); + if (not FileExists(PrnFile)) or ((PrnFNew<>0) and (FlushCount>2)) then + Rewrite(ff) + else + begin + Reset(ff); + Seek(ff, FileSize(ff)); + end; + for ii:=0 to BufCount-1 do + case PrnCP of + 1: begin + bb:=Koi8to866(PrnBuffer[ii]); + write(ff, bb); + end + else write(ff, PrnBuffer[ii]); + end; + CloseFile(ff); +{$ENDIF} + FlushCount:=0; + BufCount:=0; +end; + +function prnbuf(fType:LongInt; var fDataPtr: pointer; flush_buf: TFlushCallback): LongInt; +begin + Result:=0; + if BufCount=MAX_BUF then flush_buf; + case fType of + F600Func_PA_out: begin + case PrnMode of + 0: ; + 1: PrnBuffer[BufCount]:=PByte(fDataPtr)^; + end; + end; + F600Func_PB_out: begin + case PrnMode of + 0: PrnBuffer[BufCount]:=not PByte(fDataPtr)^; // in this scheme incoming data is inverted + 1: ; + end; + end; + F600Func_PC_in: begin + case PrnMode of + 0: Result:=$80; // printer allready ready + 1: Result:=not 8; + end; + end; + F600Func_PC_out: begin + case PrnMode of + 0: if (PByte(fDataPtr)^ and 1 = 0) and (prev_pC and 1 <> 0) then // строб по спаду импульса + begin + inc(BufCount); + end; + 1: if (PByte(fDataPtr)^ and $80 <> 0) and (prev_pC and $80 = 0) then // строб по фронту (инверсно) + begin + if NextFront then inc(BufCount); // block first front (inializing of inv. high level carrier) + NextFront:=True; + end; + end; + prev_pC:=PByte(fDataPtr)^; + end; + end; +end; + +function fConfigure: LongInt; +begin + Result:=0; + frmF600prnf:=nil; + try + frmF600prnf:=TfrmF600prnf.Create(Application); + frmF600prnf.ShowModal; + finally + if Assigned(frmF600prnf) then + frmF600prnf.Free; + end; +end; + +procedure TfrmF600prnf.btnFileNameClick(Sender: TObject); +begin + if SaveDialog.Execute then + edtFileName.Text:=SaveDialog.FileName; +end; + +procedure TfrmF600prnf.FormActivate(Sender: TObject); +begin + OnActivate:=nil; + GetIniSettings; + edtFileName.Text:=trim(PrnFile); + rgMode.ItemIndex:=PrnMode; + rgCodePage.ItemIndex:=PrnCP; + rgFNew.ItemIndex:=PrnFNew; +end; + +procedure TfrmF600prnf.btnOkClick(Sender: TObject); +begin + PrnFile:=trim(edtFileName.Text); + PrnMode:=rgMode.ItemIndex; + PrnFNew:=rgFNew.ItemIndex; + PrnCP:=rgCodePage.ItemIndex; + WritePrivateString(stSectionName, stPrnFileKey, PrnFile); + WritePrivateInt(stSectionName, stPrnModeKey, PrnMode); + WritePrivateInt(stSectionName, stPrnCPKey, PrnCP); + WritePrivateInt(stSectionName, stPrnFNewKey, PrnFNew); + ModalResult:=mrOk; +end; + +initialization + NextFront:=False; + FlushCount:=0; + +end. diff --git a/F600prnp.dfm b/F600prnp.dfm new file mode 100644 index 0000000..3fd0bd0 --- /dev/null +++ b/F600prnp.dfm @@ -0,0 +1,163 @@ +object frmF600prnp: TfrmF600prnp + Left = 331 + Top = 293 + BorderIcons = [biSystemMenu] + BorderStyle = bsSingle + Caption = 'Configure port F600 printer' + ClientHeight = 338 + ClientWidth = 495 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + Position = poScreenCenter + OnActivate = FormActivate + PixelsPerInch = 96 + TextHeight = 13 + object Label1: TLabel + Left = 80 + Top = 123 + Width = 65 + Height = 13 + Caption = 'BORDERS ->' + end + object Label2: TLabel + Left = 344 + Top = 123 + Width = 75 + Height = 13 + Caption = '(for laser printer)' + end + object btnFont: TButton + Left = 16 + Top = 12 + Width = 161 + Height = 25 + Caption = 'Printer Font' + TabOrder = 0 + OnClick = btnFontClick + end + object edtFontName: TEdit + Left = 192 + Top = 14 + Width = 225 + Height = 21 + TabOrder = 1 + end + object btnOK: TButton + Left = 48 + Top = 305 + Width = 145 + Height = 25 + Caption = 'OK' + TabOrder = 10 + OnClick = btnOKClick + end + object btnCancel: TButton + Left = 280 + Top = 305 + Width = 145 + Height = 25 + Cancel = True + Caption = 'Cancel' + ModalResult = 2 + TabOrder = 11 + end + object rgMode: TRadioGroup + Left = 8 + Top = 221 + Width = 481 + Height = 73 + Caption = ' Centronix printer connection ' + Items.Strings = ( + 'B0..B7 - data, C0 - strobe, C7 - ready' + 'A0..A7 - data, C7 - strobe, C3 - ready ') + TabOrder = 9 + end + object rgPrinter: TRadioGroup + Left = 8 + Top = 51 + Width = 481 + Height = 50 + Caption = ' Printer ' + Columns = 2 + Items.Strings = ( + 'Windows default printer' + 'select printer before printing') + TabOrder = 3 + end + object meFontSize: TMaskEdit + Left = 440 + Top = 14 + Width = 34 + Height = 21 + EditMask = '!99;1; ' + MaxLength = 2 + TabOrder = 2 + Text = ' ' + end + object rgCodePage: TRadioGroup + Left = 8 + Top = 158 + Width = 481 + Height = 52 + Caption = ' source text CodePage ' + Columns = 2 + Items.Strings = ( + 'cp866 (don`t decode)' + 'koi8-r') + TabOrder = 8 + end + object meBorderTop: TMaskEdit + Left = 232 + Top = 110 + Width = 34 + Height = 19 + EditMask = '!99;1; ' + MaxLength = 2 + TabOrder = 4 + Text = ' ' + end + object meBorderBottom: TMaskEdit + Left = 232 + Top = 134 + Width = 34 + Height = 19 + EditMask = '!99;1; ' + MaxLength = 2 + TabOrder = 7 + Text = ' ' + end + object meBorderLeft: TMaskEdit + Left = 176 + Top = 121 + Width = 34 + Height = 19 + EditMask = '!99;1; ' + MaxLength = 2 + TabOrder = 5 + Text = ' ' + end + object meBorderRight: TMaskEdit + Left = 288 + Top = 121 + Width = 34 + Height = 19 + EditMask = '!99;1; ' + MaxLength = 2 + TabOrder = 6 + Text = ' ' + end + object FontDialog: TFontDialog + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + MinFontSize = 0 + MaxFontSize = 0 + end +end diff --git a/F600prnp.pas b/F600prnp.pas new file mode 100644 index 0000000..d193834 --- /dev/null +++ b/F600prnp.pas @@ -0,0 +1,282 @@ +///////////////////////////////////////////////////////////////////////// +// // +// Orion/Z (Orion-128 + Z80-CARD-II) emulator, version 1.9 // +// // +// Author: Sergey A. // +// // +// Copyright (C) 2006-2016 Sergey A. // +// // +// This program is free software; you can redistribute it and/or // +// modify it in any ways. // +// This program is distributed "AS IS" 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 F600prnp; + +interface + +uses + Windows, Messages, SysUtils, Forms, + Mask, Classes, Controls, Dialogs, ExtCtrls, StdCtrls; + +type + TfrmF600prnp = class(TForm) + btnFont: TButton; + edtFontName: TEdit; + FontDialog: TFontDialog; + btnOK: TButton; + btnCancel: TButton; + rgMode: TRadioGroup; + rgPrinter: TRadioGroup; + meFontSize: TMaskEdit; + rgCodePage: TRadioGroup; + Label1: TLabel; + meBorderTop: TMaskEdit; + meBorderBottom: TMaskEdit; + meBorderLeft: TMaskEdit; + meBorderRight: TMaskEdit; + Label2: TLabel; + procedure btnOKClick(Sender: TObject); + procedure btnFontClick(Sender: TObject); + procedure FormActivate(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + frmF600prnp: TfrmF600prnp; + + function pConfigure: LongInt; + function flush_prnp: LongInt; + +implementation + +{$R *.DFM} + +Uses F600common, modF600, F600printer; + +// Вариант1: +// pB0...pB7 out - printer data (inverted) +// pC0 out - data strobe (active=1) +// pC7 in - printer ready (Active=1) + +// Вариант2: +// PA0..PA7 out - DATA +// PC7 - STROBE - strob (inwersnyj) +// PC3 - BUSY - gotownostx{ + ; + ; drajwer "LPT" + ; "CENTRONICS" (irpr-m) + ; + ;====================== + ; + ORG 0A800H + ; + PPB:EQU 0F601H + PPC:EQU 0F602H + PPU:EQU 0F603H + ; + PRINT:JMP PRNT ; whod dr."wywod simwola" + STATUS:JMP STR0 ; whod dr."gotownostx" + ; + STR0:MVI A,98H ; programmirowanie porta + STA PPU + XRA A + STA PPC ; ust.ishod.sost.signalow + STR1:DCR A ; zadervka + JNZ STR1 + CALL STTS ; printer -- gotow? + RZ ; esli net - wyhod + PUSH H + LXI H,STTS ; wykl.ustanowo~nu` ~astx + SHLD STR0+1 ; programmy STATUS + POP H + STTS:LDA PPC ; osnow.~astx progr. STATUS + ANI 80H ; prwer. _BUSY + RET + ; + PRNT:PUSH H + PUSH D + PUSH B + PUSH PSW + PRT0:JMP PRN + ; + PRN:MVI A,98H ; po primeru podprog. + STA PPU ; STATUS programmiru`aq + XRA A ; ~astx podrogr. print + STA PPC + PRN1:DCR A + JNZ PRN1 + CALL STTS + JZ PRT3 + PUSH H + LXI H,PRT1 + SHLD PRT0+1 + POP H + ; osnownaq ~astx podprogrm. + ; wywoda simwola na printer + PRT1:CALL STTS ; ovidatx gotownosti printera + JZ PRT1 ; do priema simwola + MOV A,C + CMA ; inwertirowatx bajt simwola + STA PPB ; wywesti na printer + MVI A,1 ; \ + STA PPC ; formirowanie impulxsa + XRA A ; _STROBE + STA PPC ;/ + PRT2:CALL STTS ; ovidatx gotownosti printera + JZ PRT2 ; posle priema simwola + PRT3:POP PSW + POP B + POP D + POP H + RET + ; + END + + uproщennaq shema podkl`~eniq printera s interfejsom + "CENTRONICS". + + port obozn. razxem LX-800 + + B1 >------------- D0 -------------- 2 DATA 1 + B2 >------------- D1 -------------- 3 DATA 2 + B3 >------------- D2 -------------- 4 DATA 3 + B4 >------------- D3 -------------- 5 DATA 4 + B5 >------------- D4 -------------- 6 DATA 5 + B6 >------------- D5 -------------- 7 DATA 6 + B7 >------------- D6 -------------- 8 DATA 7 + B8 >------------- D7 -------------- 9 DATA 8 + * + C1 >------------ _STROBE -- SC ---- 1 _STROBE + C2 >----------------------- S0 ---- + + C7 <----------------------- A0 ---- + C8 <------------ BUSY ---- AC ---- 11 BUSY + } + +var + SelectFont: boolean; + SelectPrinter: boolean; + PrnStarted: boolean; + FlushCount: integer; + +function flush_prnp: LongInt; +var mode, ii: integer; + tmpbuf: TPrnBuffer; + procedure PStop; + begin + FlushCount:=0; + if PrnStarted then PrnStop; + PrnStarted:=False; + end; +begin + mode:=0; + Result:=0; + if (BufCount=0) or (trim(PrnFile)='') then + begin + if FlushCount>2 then // close printer (end job) if 3 seconds idle (end of printing) + PStop + else inc(FlushCount); + exit; + end; + if SelectFont then begin + SetPrinterParams('','Orion/Z emulator printing', PrnFont, PrnFontSize); + SelectFont:=False; + end; + if SelectPrinter then begin + if PrnPrn<>0 then mode:=PRINTER_DIALOG; + SelectPrinter:=False; + PStop; + end; + if not PrnStarted then + PrnStarted:=PrnStart(mode); + if PrnStarted then begin + for ii:=0 to BufCount-1 do + case PrnCP of + 1: begin + tmpbuf[ii]:=Koi8to866(PrnBuffer[ii]); + end + end; + PrnString(PChar(@tmpbuf[0]), BufCount); + end; + FlushCount:=0; + BufCount:=0; +end; + +function pConfigure: LongInt; +begin + Result:=0; + frmF600prnp:=nil; + try + frmF600prnp:=TfrmF600prnp.Create(Application); + frmF600prnp.ShowModal; + finally + if Assigned(frmF600prnp) then + frmF600prnp.Free; + end; +end; + +procedure TfrmF600prnp.btnOKClick(Sender: TObject); +begin + SelectFont:=(AnsiUpperCase(PrnFont)<>AnsiUpperCase(trim(edtFontName.Text)))or + (PrnFontSize<>StrToIntDef(trim(meFontSize.Text), 8)); + SelectPrinter:=(PrnPrn<>rgPrinter.ItemIndex); + PrnFont:=trim(edtFontName.Text); + PrnFontSize:=StrToIntDef(trim(meFontSize.Text), 8); + PrnPrn:=rgPrinter.ItemIndex; + PrnMode:=rgMode.ItemIndex; + PrnCP:=rgCodePage.ItemIndex; + BorderTop := StrToIntDef(meBorderTop.Text, 50); + BorderLeft := StrToIntDef(meBorderLeft.Text, 50); + BorderRight := StrToIntDef(meBorderRight.Text, 50); + BorderBottom:= StrToIntDef(meBorderBottom.Text, 50); + WritePrivateString(stSectionName, stPrnFontKey, PrnFont); + WritePrivateInt(stSectionName, stPrnFtSzKey, PrnFontSize); + WritePrivateInt(stSectionName, stPrnModeKey, PrnMode); + WritePrivateInt(stSectionName, stPrnCPKey, PrnCP); + WritePrivateInt(stSectionName, stPrnPrnKey, PrnPrn); + WritePrivateInt(stSectionName, stPrnBrdTop, BorderTop ); + WritePrivateInt(stSectionName, stPrnBrdLeft, BorderLeft ); + WritePrivateInt(stSectionName, stPrnBrdRight, BorderRight ); + WritePrivateInt(stSectionName, stPrnBrdBot, BorderBottom ); + ModalResult:=mrOk; +end; + +procedure TfrmF600prnp.btnFontClick(Sender: TObject); +begin + if FontDialog.Execute then + begin + edtFontName.Text:=FontDialog.Font.Name; + meFontSize.Text:=IntToStr(FontDialog.Font.Size); + end; +end; + +procedure TfrmF600prnp.FormActivate(Sender: TObject); +begin + OnActivate:=nil; + GetIniSettings; + edtFontName.Text:=PrnFont; + meFontSize.Text:=IntToStr(PrnFontSize); + rgPrinter.ItemIndex:=PrnPrn; + rgMode.ItemIndex:=PrnMode; + rgCodePage.ItemIndex:=PrnCP; + meBorderTop.Text := IntToStr(BorderTop); + meBorderLeft.Text := IntToStr(BorderLeft); + meBorderRight.Text := IntToStr(BorderRight); + meBorderBottom.Text:= IntToStr(BorderBottom); +end; + +initialization + SelectPrinter:=True; + SelectFont:=True; + PrnStarted:=False; + FlushCount:=0; + +end. diff --git a/HDDUtils.pas b/HDDUtils.pas new file mode 100644 index 0000000..934ed97 --- /dev/null +++ b/HDDUtils.pas @@ -0,0 +1,377 @@ +///////////////////////////////////////////////////////////////////////// +// // +// Orion/Z (Orion-128 + Z80-CARD-II) emulator, version 1.9 // +// // +// Author: Sergey A. // +// // +// Copyright (C) 2006-2016 Sergey A. // +// // +// This program is free software; you can redistribute it and/or // +// modify it in any ways. // +// This program is distributed "AS IS" 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 HDDUtils; + +interface + +uses + Windows, + SysUtils; + +const + IDE_MAX_SERIAL = 20; + IDE_MAX_FIRMWARE = 8; + IDE_MAX_MODEL = 40; + +type + TSrbIoControl = packed record + HeaderLength : ULONG; + Signature : Array[0..7] of Char; + Timeout : ULONG; + ControlCode : ULONG; + ReturnCode : ULONG; + Length : ULONG; + end; + SRB_IO_CONTROL = TSrbIoControl; + PSrbIoControl = ^TSrbIoControl; + + TIDERegs = packed record + bFeaturesReg : Byte; // Used for specifying SMART "commands". + bSectorCountReg : Byte; // IDE sector count register + bSectorNumberReg : Byte; // IDE sector number register + bCylLowReg : Byte; // IDE low order cylinder value + bCylHighReg : Byte; // IDE high order cylinder value + bDriveHeadReg : Byte; // IDE drive/head register + bCommandReg : Byte; // Actual IDE command. + bReserved : Byte; // reserved. Must be zero. + end; + IDEREGS = TIDERegs; + PIDERegs = ^TIDERegs; + + TSendCmdInParams = packed record + cBufferSize : DWORD; + irDriveRegs : TIDERegs; + bDriveNumber : Byte; + bReserved : Array[0..2] of Byte; + dwReserved : Array[0..3] of DWORD; + bBuffer : Array[0..0] of Byte; + end; + SENDCMDINPARAMS = TSendCmdInParams; + PSendCmdInParams = ^TSendCmdInParams; + + TIdSector = packed record + wGenConfig : Word; + wNumCyls : Word; + wReserved : Word; + wNumHeads : Word; + wBytesPerTrack : Word; + wBytesPerSector : Word; + wSectorsPerTrack : Word; + wVendorUnique : Array[0..2] of Word; + sSerialNumber : Array[0..IDE_MAX_SERIAL-1] of Char; // w 10-19 + wBufferType : Word; + wBufferSize : Word; + wECCSize : Word; + sFirmwareRev : Array[0..IDE_MAX_FIRMWARE-1] of Char; + sModelNumber : Array[0..IDE_MAX_MODEL-1] of Char; + wMoreVendorUnique : Word; + wDoubleWordIO : Word; // w48 + wCapabilities : Word; + wReserved1 : Word; + wPIOTiming : Word; + wDMATiming : Word; + wBS : Word; + wNumCurrentCyls : Word; // w 54 + wNumCurrentHeads : Word; + wNumCurrentSectorsPerTrack : Word; + ulCurrentCapacity : ULONG; + wMultSectorStuff : Word; + ulTotalAddressableSectors : ULONG; // w 60-61 + wSingleWordDMA : Word; + wMultiWordDMA : Word; + bReserved : Array[0..127] of Byte; + end; + PIdSector = ^TIdSector; + + TDISKGEOMETRY = record + Cylinders: int64; + MediaType: Integer; + TracksPerCylinder: DWORD; + SectorsPerTrack: DWORD; + BytesPerSector: DWORD; + end; + PDISKGEOMETRY = ^TDISKGEOMETRY; + +const + IOCTL_DISK_GET_DRIVE_GEOMETRY = 458752; + BLOCK_SIZE = 512; + EXIT_FAILURE = 1; + IDE_ID_FUNCTION = $EC; + IDENTIFY_BUFFER_SIZE = 512; + DFP_RECEIVE_DRIVE_DATA = $0007c088; + IOCTL_SCSI_MINIPORT = $0004d008; + IOCTL_SCSI_MINIPORT_IDENTIFY = $001b0501; + DataSize = sizeof(TSendCmdInParams)-1+IDENTIFY_BUFFER_SIZE; + BufferSize = SizeOf(SRB_IO_CONTROL)+DataSize; + W9xBufferSize = IDENTIFY_BUFFER_SIZE+16; + +function GetIdeDiskIdentify(Drive: char; IdSector: PIdSector): boolean; +function MIN(x,y: int64):int64; +function DiskFileSeek(hf: THANDLE; distance: int64; MoveMethod: DWORD):boolean; +function DiskFileSeekAbs(hf: THANDLE; distance: int64; MoveMethod: DWORD):boolean; +function GetDiskSize(hDisk: THandle; var DiskSize: int64; Geometry: PDISKGEOMETRY): boolean; +function HDDOpen(cDrive: char; IsReadOnly: boolean; var hDevice: THANDLE; + var phis:boolean; var DiskSize, FreeSize: int64; Geometry: PDISKGEOMETRY): boolean; +function OpenImage (pcsz_: PChar; fWrite_: boolean; var h: THANDLE): boolean; +function LastError: string; +function IsDrive(pcsz_: string; pnDrive_:PChar): boolean; +procedure ChangeByteOrder(ptr : PChar; Size : Integer ); + +implementation + +function MIN(x,y: int64):int64; +begin + if x>y then Result:=y else Result:=x; +end; + +//--------------------------------------------------------------------- +// DiskFileSeek: Allow seeking through large files (a disk opened as a +// file). Addressed by LBA-number (512bytes record number) +//--------------------------------------------------------------------- +function DiskFileSeek(hf: THANDLE; distance: int64; MoveMethod: DWORD):boolean; +var seekDistance:int64; + li: LARGE_INTEGER; +begin + Result:=True; + seekDistance := distance*512; + li.QuadPart := seekDistance; + li.LowPart := SetFilePointer(hf, li.LowPart, @li.HighPart, MoveMethod); + if (li.LowPart = $FFFFFFFF) then + Result:=GetLastError()=NO_ERROR; +end; + +// Addressed by absolute filepointer (byte-positioned) +function DiskFileSeekAbs(hf: THANDLE; distance: int64; MoveMethod: DWORD):boolean; +var li: LARGE_INTEGER; +begin + Result:=True; + li.QuadPart := distance; + li.LowPart := SetFilePointer(hf, li.LowPart, @li.HighPart, MoveMethod); + if (li.LowPart = $FFFFFFFF) then + Result:=GetLastError()=NO_ERROR; +end; + +function GetDiskSize(hDisk: THandle; var DiskSize: int64; Geometry: PDISKGEOMETRY): boolean; +var + Returned: DWORD; + i64: int64; +begin + Result:=False; + if hDisk <> INVALID_HANDLE_VALUE then + begin + FillChar(Geometry^, Sizeof(TDISKGEOMETRY),0); + Result:=DeviceIoControl(hDisk,IOCTL_DISK_GET_DRIVE_GEOMETRY,nil,0,Geometry, + sizeof(TDISKGEOMETRY),Returned,nil); + if Result then + with Geometry^ do + begin + i64:=Cylinders; + DiskSize:=i64*TracksPerCylinder*SectorsPerTrack*BytesPerSector; + end; + end; +end; + +function HDDOpen(cDrive: char; IsReadOnly: boolean; var hDevice: THANDLE; + var phis:boolean; var DiskSize, FreeSize: int64; Geometry: PDISKGEOMETRY): boolean; +var + _devicename: array[0..255] of char; + TotalFree: int64; + Access: Cardinal; +begin + if IsReadOnly then + Access:=GENERIC_READ + else + Access:=GENERIC_READ or GENERIC_WRITE; + Result:=False; + DiskSize:=0; + hDevice:=INVALID_HANDLE_VALUE; + case cDrive of + '0'..'9': begin + StrPCopy(_devicename, '\\.\PhysicalDrive0'); + _devicename[17] := cDrive; + phis:=True; + end; + 'A'..'Z': begin + StrPCopy(_devicename, '\\.\A:'); + _devicename[4] := cDrive; + phis:=False; + end + else exit; + end; + hDevice := CreateFile(_devicename, // drive to open + Access, // access type + FILE_SHARE_READ or // share mode + FILE_SHARE_WRITE, + nil, // default security attributes + OPEN_EXISTING, // disposition + 0, // file attributes + 0); // do not copy file attributes + Result := hDevice <> INVALID_HANDLE_VALUE; + if Result then + begin + if phis then + begin + Result:=GetDiskSize(hDevice, DiskSize, Geometry); + FreeSize:=DiskSize div 2; + end + else + Result:=GetDiskFreeSpaceEx(@_devicename[4], FreeSize, DiskSize, @TotalFree); + end; +end; + +function OpenImage (pcsz_: PChar; fWrite_: boolean; var h: THANDLE): boolean; +begin + if fWrite_ + then h:=CreateFile(pcsz_, GENERIC_WRITE, 0, nil, CREATE_ALWAYS, 0, 0) + else h:=CreateFile(pcsz_, GENERIC_READ, 0, nil, OPEN_EXISTING, 0, 0); + if (h<>INVALID_HANDLE_VALUE) then Result:=True + else begin + Result:=False; + h:=0; + end; +end; + +function LastError: string; +var lpMsgBuf: PChar; +begin + FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER or + FORMAT_MESSAGE_FROM_SYSTEM, + nil, GetLastError, 0, + @lpMsgBuf, 0, nil); + if GetLastError()<>0 then + begin + Result:=StrPas(lpMsgBuf); + CharToOemBuff(@Result[1], @Result[1], Length(Result)); + end + else Result:='no error'; + LocalFree( HLOCAL(lpMsgBuf) ); +end; + +function IsDrive(pcsz_: string; pnDrive_:PChar): boolean; +begin + pcsz_:=AnsiUpperCase(pcsz_); + if (Length(pcsz_)<>2) or (not (pcsz_[1] in ['0'..'9','C'..'Z'])) or (pcsz_[2]<>':') then + Result:=False + else + begin + if (pnDrive_<>nil) then pnDrive_^ := pcsz_[1]; + Result:=True; + end; +end; + +procedure ChangeByteOrder(ptr : PChar; Size : Integer ); +var i : Integer; + c : Char; +begin + for i := 0 to (Size shr 1)-1 do + begin + c := ptr^; + ptr^ := (ptr+1)^; + (ptr+1)^ := c; + Inc(ptr,2); + end; +end; + +//------------------------------------------------------------- +function GetIdeDiskIdentify(Drive: char; IdSector: PIdSector): boolean; +var + hDevice : THandle; + cbBytesReturned : DWORD; + pInData : PSendCmdInParams; + pOutData : Pointer; // PSendCmdOutParams + Buffer : Array[0..BufferSize-1] of Byte; + _devicename: array[0..255] of char; + srbControl : TSrbIoControl absolute Buffer; +begin + Result := False; + if not (Drive in ['0'..'9']) then exit; + FillChar(Buffer,BufferSize,#0); + if Win32Platform=VER_PLATFORM_WIN32_NT then + begin // Windows NT, Windows 2000 + // Get SCSI port handle + StrPCopy(_devicename, '\\.\PhysicalDrive'+Drive); + hDevice := CreateFile(_devicename, + GENERIC_READ or GENERIC_WRITE, + FILE_SHARE_READ or FILE_SHARE_WRITE, + nil, OPEN_EXISTING, 0, 0 ); + if hDevice=INVALID_HANDLE_VALUE then Exit; + try + srbControl.HeaderLength := SizeOf(SRB_IO_CONTROL); + System.Move('SCSIDISK',srbControl.Signature,8); + srbControl.Timeout := 2; + srbControl.Length := DataSize; + srbControl.ControlCode := IOCTL_SCSI_MINIPORT_IDENTIFY; + pInData := PSendCmdInParams(PChar(@Buffer) + +SizeOf(SRB_IO_CONTROL)); + pOutData := pInData; + with pInData^ do + begin + cBufferSize := IDENTIFY_BUFFER_SIZE; + bDriveNumber := ord(Drive)-ord('0'); + with irDriveRegs do + begin + bFeaturesReg := 0; + bSectorCountReg := 1; + bSectorNumberReg := 1; + bCylLowReg := 0; + bCylHighReg := 0; + bDriveHeadReg := $A0 or ((bDriveNumber and 1) shl 4); + bCommandReg := IDE_ID_FUNCTION; + end; + end; + Result:=DeviceIoControl( hDevice, IOCTL_SCSI_MINIPORT, @Buffer, BufferSize, + @Buffer, BufferSize, cbBytesReturned, nil ); + finally + if hDevice <> INVALID_HANDLE_VALUE then + CloseHandle(hDevice); + end; + end + else + begin // Windows 95 OSR2, Windows 98 + hDevice := CreateFile( '\\.\SMARTVSD', 0, 0, nil, + CREATE_NEW, 0, 0 ); + if hDevice=INVALID_HANDLE_VALUE then Exit; + try + pInData := PSendCmdInParams(@Buffer); + pOutData := @pInData^.bBuffer; + with pInData^ do + begin + cBufferSize := IDENTIFY_BUFFER_SIZE; + bDriveNumber := ord(Drive)-ord('0'); + with irDriveRegs do + begin + bFeaturesReg := 0; + bSectorCountReg := 1; + bSectorNumberReg := 1; + bCylLowReg := 0; + bCylHighReg := 0; + bDriveHeadReg := $A0; + bCommandReg := IDE_ID_FUNCTION; + end; + end; + Result:=DeviceIoControl(hDevice, DFP_RECEIVE_DRIVE_DATA, pInData, SizeOf(TSendCmdInParams)-1, + pOutData, W9xBufferSize, cbBytesReturned, nil ); + finally + if hDevice <> INVALID_HANDLE_VALUE then + CloseHandle(hDevice); + end; + end; + CopyMemory(IdSector, PIdSector(PChar(pOutData)+16), sizeof(TIdSector)); +end; + +end. + diff --git a/HddUtil.cfg b/HddUtil.cfg new file mode 100644 index 0000000..5079b08 --- /dev/null +++ b/HddUtil.cfg @@ -0,0 +1,35 @@ +-$A+ +-$B- +-$C+ +-$D+ +-$E- +-$F- +-$G+ +-$H+ +-$I+ +-$J+ +-$K- +-$L+ +-$M- +-$N+ +-$O+ +-$P+ +-$Q- +-$R- +-$S- +-$T- +-$U- +-$V+ +-$W- +-$X+ +-$YD +-$Z1 +-cg +-AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +-H+ +-W+ +-M +-$M16384,1048576 +-K$00400000 +-LE"c:\borland\delphi5\Projects\Bpl" +-LN"c:\borland\delphi5\Projects\Bpl" diff --git a/HddUtil.dof b/HddUtil.dof new file mode 100644 index 0000000..976d69e --- /dev/null +++ b/HddUtil.dof @@ -0,0 +1,85 @@ +[Compiler] +A=1 +B=0 +C=1 +D=1 +E=0 +F=0 +G=1 +H=1 +I=1 +J=1 +K=0 +L=1 +M=0 +N=1 +O=1 +P=1 +Q=0 +R=0 +S=0 +T=0 +U=0 +V=1 +W=0 +X=1 +Y=1 +Z=1 +ShowHints=1 +ShowWarnings=1 +UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +[Linker] +MapFile=0 +OutputObjs=0 +ConsoleApp=1 +DebugInfo=0 +RemoteSymbols=0 +MinStackSize=16384 +MaxStackSize=1048576 +ImageBase=4194304 +ExeDescription= +[Directories] +OutputDir= +UnitOutputDir= +PackageDLLOutputDir= +PackageDCPOutputDir= +SearchPath= +Packages=Vcl50;Vclx50;VclSmp50;Vcldb50;vclado50;ibevnt50;Vclbde50;vcldbx50;Qrpt50;TeeUI50;TeeDB50;Tee50;Dss50;TeeQR50;VCLIB50;Vclmid50;vclie50;Inetdb50;Inet50;NMFast50;webmid50;dclocx50;dclaxserver50 +Conditionals= +DebugSourceDirs= +UsePackages=0 +[Parameters] +RunParams=C:\Borland\Delphi5\Projects\_OriZEmu\Work\FAT\release\dos-hdd.ohi 1: +HostApplication= +[Language] +ActiveLang= +ProjectLang=$00000419 +RootDir= +[Version Info] +IncludeVerInfo=1 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1049 +CodePage=1251 +[Version Info Keys] +CompanyName= +FileDescription=Orion/Z emulator: HDD image creator utility +FileVersion=1.0.0.0 +InternalName=HddUtil +LegalCopyright=(c) 2007 Sergey A. +LegalTrademarks= +OriginalFilename=HddUtil.exe +ProductName=Orion/Z emulator +ProductVersion=1.0.0.0 +Comments=FREEWARE +[HistoryLists\hlUnitAliases] +Count=1 +Item0=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; diff --git a/HddUtil.dpr b/HddUtil.dpr new file mode 100644 index 0000000..9b6bacd --- /dev/null +++ b/HddUtil.dpr @@ -0,0 +1,325 @@ +program HddUtil; +{$APPTYPE CONSOLE} +uses + Windows, + SysUtils, + HDDUtils in 'HDDUtils.pas'; + +{$R *.RES} + +procedure WriteCon(const Fmt: string; const Args: array of const); +begin + Write(Format(Fmt, Args)); +end; + +procedure ReadCon(var s: string); +begin + Readln(s); +end; + +procedure Usage; +begin + WriteCon(#13#10'Hdd Drive Image Processing Utility by Sergey A., version 1.0, freeware.'#13#10#13#10+ + 'Usage: HddUtil [ ] [modifiers]'#13#10#13#10+ + 'Details: HddUtil [/s=] [/c=] [/q]'#13#10+ + ' HddUtil [/s=] [/c=] [/q]'#13#10+ + ' HddUtil /list []'#13#10#13#10+ + ' : HddDrive or Partition, typically "0:".."9:" or "C:".."Z:"'#13#10+ + ' : Disk image (file) to create or write'#13#10+ + ' : decimal number'#13#10+ + ' /s=: 512b-sector (LBA number) to beginning from'#13#10+ + ' /c=: process count of 512b-sectors'#13#10+ + ' /q: quet mode (no progress counter)'#13#10+ + ' /list: show HddDrive(s) info'#13#10#13#10+ + 'Example: HddUtil 0: c:\temp\drive_c_first200sectors.img /c=200 /q'#13#10, + [] + ); + halt(EXIT_FAILURE); +END; + +function PCharNStr(pc:PChar; N: integer): string; +var i: integer; +begin + Result:=''; + i:=0; + while (i#0) do + begin + Result:=Result+pc[i]; + inc(i); + end; +end; + + +function max(a, b: ULONG):ULONG; +begin + if a>b then max:=a else max:=b; +end; + +procedure IdeIdentifyGen(Buffer: PChar; ImageSize: int64; c, h, s: word); +var cs: byte; + i: integer; + li: LARGE_INTEGER; +begin + li.QuadPart:=ImageSize; + li.QuadPart:=li.QuadPart shr 9; // /512 + with PIdSector(Buffer)^ do + begin + StrPCopy(sSerialNumber, 'UNKNOWN '); // serial + ChangeByteOrder(sSerialNumber,SizeOf(sSerialNumber)); + StrPCopy(sFirmwareRev, 'UNKNOWN '); // firmware + ChangeByteOrder(sFirmwareRev,SizeOf(sFirmwareRev)); + StrPCopy(sModelNumber, 'LOCAL DRIVE '); // model + ChangeByteOrder(sModelNumber,SizeOf(sModelNumber)); + end; + PWord(Buffer)^ := $045A; + PWord(@Buffer[2*1])^ := c; + PWord(@Buffer[2*3])^ := h; + PWord(@Buffer[2*6])^ := s; + PLongWord(@Buffer[2*60])^ := li.LowPart; // lba + PLongWord(@Buffer[2*57])^ := PLongWord(@Buffer[2*60])^; + PWord(@Buffer[2*7])^ := PWord(@Buffer[2*61])^; + PWord(@Buffer[2*8])^ := PWord(@Buffer[2*60])^; + PWord(@Buffer[2*20])^ := 3; // a dual ported multi-sector buffer capable of simultaneous transfers with a read caching capability + PWord(@Buffer[2*21])^ := 512; // cache size=256k + PWord(@Buffer[2*22])^ := 4; // ECC bytes + PWord(@Buffer[2*49])^ := $200; // LBA supported + PWord(@Buffer[2*80])^ := $3E; // support specifications up to ATA-5 + PWord(@Buffer[2*81])^ := $13; // ATA/ATAPI-5 T13 1321D revision 3 + PWord(@Buffer[2*82])^ := $60; // supported look-ahead and write cache +// make checksum + Buffer[510] := #$A5; + cs := 0; + for i:=0 to 511 do + cs:=cs + PByte(@Buffer[i])^; + Buffer[511] := chr(0-cs); +end; + +function TextPartType(pt: byte): string; +begin + case pt of + 0: Result:=''; + $01,$04,$06,$0B,$0C,$0E,$0F,$11,$14,$16,$1B,$1C,$1E,$8b,$8c: result:='FAT'; + $21: result:='UZIX'; + $52, $D8, $DB: result:='CP/M'; + $FF, $02, $03: result:='XENIX'; + $07, $86, $87: result:='NTFS'; + $08, $09: result:='AIX or OS/2'; + $63: result:='UNIX'; + $64, $65, $51: result:='Novell'; + $83, $85: result:='Linux'; + $0A: result:='OS/2'; + $05: result:='extended'; + $A0: result:='hiber'; + $A5, $A6, $A9: result:='*BSD'; + $BE: result:='Solaris'; + $82: result:='Linux or Solaris'; + $40: result:='VENIX'; + $C0: result:='CTOS' + else result:='Unknown'; + end; +end; + +const + cmNone=0; + cmRead=1; + cmWrite=2; + cmList=3; + +var + ss, PartInf: string; + nCommand: integer = cmNone; + Drive: Char = ' '; + fQuet: boolean = false; + fVerify: boolean = false; + pcszFile: Array[0..BLOCK_SIZE] of char; + buffer: Array[0..BLOCK_SIZE] of char; + hfile: THANDLE = INVALID_HANDLE_VALUE; + i: integer; + iSector, iMaxSector, iSeek, iCount: int64; + bytesread, dwRet: cardinal; + IdSector: TIdSector; + phis: boolean; + Geometry: TDISKGEOMETRY; + DiskSize, FreeSize: int64; + hdd: THANDLE = INVALID_HANDLE_VALUE; + LastErr: DWORD; + +function GetDiskIdentify(Drive: char; ID_Sector: PIdSector; var PartInfo: string): boolean; +var ii:integer; +begin + PartInfo:=''; + Result:=GetIdeDiskIdentify(Drive, ID_Sector); + LastErr:=GetLastError(); + if not HDDOpen(Drive, True, hdd, phis, DiskSize, FreeSize, @Geometry) then // ReadOnly Allways + exit; + if (not Result) and (LastErr=ERROR_NOT_SUPPORTED) then // The request is not suported (LastErr=50) + begin + IdeIdentifyGen(pointer(ID_Sector), DiskSize, + (Geometry.Cylinders * Geometry.TracksPerCylinder) div 16, + 16, + Geometry.SectorsPerTrack); + Result:=True; + end; + if ReadFile(hdd, pcszFile, BLOCK_SIZE, bytesread, nil) then + begin + ii:=450; + while ii0) and (TextPartType(ord(pcszFile[ii]))<>'') then + PartInfo:=PartInfo+', '; + PartInfo:=PartInfo+TextPartType(ord(pcszFile[ii])); + ii:=ii+16; + end; + end + else + WriteCon(#13#10'Error read HDD MBR'#13#10, []); + if hdd<>INVALID_HANDLE_VALUE then + CloseHandle(hdd); + hdd:=INVALID_HANDLE_VALUE; +end; + +begin + FillChar(pcszFile, sizeof(pcszFile), #0); + iSeek:=0; iCount:=high(iCount); + for i:= 1 to ParamCount do + begin + if (pos('/LIST', AnsiUpperCase(ParamStr(i)))<>0) and (nCommand = cmNone) then + nCommand := cmList + else if (pos('/Q', AnsiUpperCase(ParamStr(i)))<>0) then + fQuet := true + else if (pos('/S', AnsiUpperCase(ParamStr(i)))<>0) then + begin + ss:=copy(ParamStr(i), (pos('/S', AnsiUpperCase(ParamStr(i)))), 255); + if (Length(ss)>2) and (ss[3]='=') then + begin + delete(ss, 1, 3); + iSeek := StrToIntDef(ss, 0); + end; + end + else if (pos('/C', AnsiUpperCase(ParamStr(i)))<>0) then + begin + ss:=copy(ParamStr(i), (pos('/C', AnsiUpperCase(ParamStr(i)))), 255); + if (Length(ss)>2) and (ss[3]='=') then + begin + delete(ss, 1, 3); + iCount := StrToIntDef(ss, 0); + end; + end + else if (ParamStr(i)[1] = '/') then + Usage() + else if (Drive = ' ') and IsDrive(ParamStr(i), @Drive) and (nCommand = cmNone) then + begin + if pcszFile[0]<>#0 + then nCommand := cmWrite + else nCommand := cmRead; + end + else if (pcszFile[0]=#0) and (not IsDrive(ParamStr(i), nil)) { and (nCommand = cmNone) } then + begin + StrPCopy(pcszFile, ParamStr(i)); + if Drive = ' ' + then nCommand := cmWrite + else nCommand := cmRead; + end; + end; + + if nCommand=cmList then + begin + iSeek:=0; iCount:=9; + if Drive in ['0'..'9'] then + begin + iSeek:=ord(Drive)-ord('0'); iCount:=iSeek; + end; + for i:=iSeek to iCount do + begin + if GetDiskIdentify(chr(ord('0')+i), @IdSector, PartInf) then + begin + with IdSector do + begin + ChangeByteOrder(sSerialNumber,SizeOf(sSerialNumber)); + ChangeByteOrder(sFirmwareRev,SizeOf(sFirmwareRev)); + ChangeByteOrder(sModelNumber,SizeOf(sModelNumber)); + end; + if (IdSector.wCapabilities and $200)<>0 then ss:='Supported' else ss:='Not supported'; + WriteCon('Drive %d:'#13#10' Model:%s FirmwareRev:%s SerialNumber:%s'#13#10+ + ' Cyllinders: %d, Heads: %d, Sectors: %d, Size: %d Mb, LBA: %s'#13#10+ + ' Partitions: %s'#13#10#13#10, + [i, trim(PCharNStr(IdSector.sModelNumber, sizeof(IdSector.sModelNumber))), + trim(PCharNStr(IdSector.sFirmwareRev, sizeof(IdSector.sFirmwareRev))), + trim(PCharNStr(IdSector.sSerialNumber, sizeof(IdSector.sSerialNumber))), + IdSector.wNumCyls, IdSector.wNumHeads, IdSector.wSectorsPerTrack, + max(IdSector.ulCurrentCapacity, IdSector.ulTotalAddressableSectors) div 2048, ss, PartInf]); + end + else if LastErr<>ERROR_FILE_NOT_FOUND then + WriteCon(#13#10'Failed to get identify information for drive "%d" : %s'#13#10, [i, LastError()]) + end; + end + else if (nCommand = cmNone) or (Drive = ' ') then // require a command and a drive + Usage() + else if (pcszFile[0]=#0) and (nCommand in [cmRead, cmWrite]) then // read/write require image file + Usage() + else if not HDDOpen(Drive, (Drive='0')or(Drive='C'), hdd, phis, DiskSize, FreeSize, @Geometry) then + WriteCon(#13#10'Failed to open HDD: %s'#13#10, [LastError()]) + else if (pcszFile[0]<>#0) and (not OpenImage(pcszFile, (nCommand = cmRead), hfile)) then + WriteCon(#13#10'Failed to open image: %s'#13#10, [LastError()]) + else if (nCommand = cmWrite) and + ( ((iCount-iSeek<>high(iCount)) and (GetFileSize(hfile, nil) < BLOCK_SIZE*(MIN(DiskSize div BLOCK_SIZE, iCount)-iSeek)) ) or + ((iCount-iSeek=high(iCount)) and (GetFileSize(hfile, nil) <> DiskSize)) + ) then + begin + if iCount=high(iCount) then + FreeSize:=DiskSize + else + FreeSize:=MIN(DiskSize, BLOCK_SIZE*(iCount-iSeek)); + WriteCon(#13#10'Image file of wrong size (should be %s bytes or "/c=%d" modifier must be used)'#13#10, + [IntToStr(FreeSize), GetFileSize(hfile, nil) div BLOCK_SIZE]); + end + else if (not DiskFileSeek(hdd, iSeek, FILE_BEGIN)) then + WriteCon(#13#10'Failed to seek sector: %s'#13#10, [LastError()]) + else + begin + if (nCommand=cmWrite) then + begin + if (Drive='0') or (Drive='C') then + begin + WriteCon(#13#10'Writing of drive %s: disabled!'#13#10, [Drive]); + halt(EXIT_FAILURE); + end; + WriteCon(#13#10'Sure to write image "%s" to HDD "%s" (Yes/No)? ', [pcszFile, Drive]); + ReadCon(ss); + if AnsiUpperCase(ss)<>'YES' then halt(0); + end; + iSector:=0; iMaxSector:=MIN(DiskSize div BLOCK_SIZE, iCount); + while iSector < iMaxSector do + begin + case nCommand of + cmRead: + begin + if ((iSector and 31)=0) and (not fQuet) + then WriteCon(#13'Readed: %u of %u', [iSector, iMaxSector]); + if not (ReadFile(hdd, buffer, BLOCK_SIZE, bytesread, nil) and + WriteFile(hfile, buffer, BLOCK_SIZE, dwRet, nil)) then + begin + WriteCon(#13#10#13#10'Read failed: %s'#13#10, [LastError()]); + halt(EXIT_FAILURE); + end; + end; + cmWrite: + begin + if ((iSector and 31)=0) and (not fQuet) + then WriteCon(#13'Writed: %u of %u', [iSector, iMaxSector]); + if not (ReadFile(hfile, buffer, BLOCK_SIZE, dwRet, nil) and + WriteFile(hdd, buffer, BLOCK_SIZE, bytesread, nil) ) then + begin + WriteCon(#13#10#13#10'Write failed: %s'#13#10, [LastError()]); + halt(EXIT_FAILURE); + end; + end; + end; {case} + inc(iSector); + end; {while} + WriteCon(#13'Complete. '#13#10, [iSector, iMaxSector]); + end; + if hfile<>INVALID_HANDLE_VALUE then + CloseHandle(hfile); + if hdd<>INVALID_HANDLE_VALUE then + CloseHandle(hdd); +end. diff --git a/HddUtil.exe b/HddUtil.exe new file mode 100644 index 0000000..1293ed8 Binary files /dev/null and b/HddUtil.exe differ diff --git a/HddUtil.res b/HddUtil.res new file mode 100644 index 0000000..4fb4acc Binary files /dev/null and b/HddUtil.res differ diff --git a/IpExport.pas b/IpExport.pas new file mode 100644 index 0000000..fef75ab --- /dev/null +++ b/IpExport.pas @@ -0,0 +1,343 @@ +{******************************************************************************} +{ } +{ Internet Protocol Helper API interface Unit for Object Pascal } +{ } +{ Portions created by Microsoft are Copyright (C) 1995-2001 Microsoft } +{ Corporation. All Rights Reserved. } +{ } +{ The original file is: ipexport.h, released July 2000. The original Pascal } +{ code is: IpExport.pas, released September 2000. The initial developer of the } +{ Pascal code is Marcel van Brakel (brakelm@chello.nl). } +{ } +{ Portions created by Marcel van Brakel are Copyright (C) 1999-2001 } +{ Marcel van Brakel. All Rights Reserved. } +{ } +{ Contributor(s): John C. Penman (jcp@craiglockhart.com) } +{ Vladimir Vassiliev (voldemarv@hotpop.com) } +{ } +{ Obtained through: Joint Endeavour of Delphi Innovators (Project JEDI) } +{ } +{ You may retrieve the latest version of this file at the Project JEDI home } +{ page, located at http://delphi-jedi.org or my personal homepage located at } +{ http://members.chello.nl/m.vanbrakel2 } +{ } +{ The contents of this file are used with permission, subject to the Mozilla } +{ Public License Version 1.1 (the "License"); you may not use this file except } +{ in compliance with the License. You may obtain a copy of the License at } +{ http://www.mozilla.org/MPL/MPL-1.1.html } +{ } +{ Software distributed under the License is distributed on an "AS IS" basis, } +{ WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for } +{ the specific language governing rights and limitations under the License. } +{ } +{ Alternatively, the contents of this file may be used under the terms of the } +{ GNU Lesser General Public License (the "LGPL License"), in which case the } +{ provisions of the LGPL License are applicable instead of those above. } +{ If you wish to allow use of your version of this file only under the terms } +{ of the LGPL License and not to allow others to use your version of this file } +{ under the MPL, indicate your decision by deleting the provisions above and } +{ replace them with the notice and other provisions required by the LGPL } +{ License. If you do not delete the provisions above, a recipient may use } +{ your version of this file under either the MPL or the LGPL License. } +{ } +{ For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html } +{ } +{******************************************************************************} + +unit IpExport; + +{$WEAKPACKAGEUNIT} + +{$HPPEMIT ''} +{$HPPEMIT '#include "ipexport.h"'} +{$HPPEMIT ''} + +//{$I WINDEFINES.INC} + +interface + +uses + Windows; + +// +// IP type definitions. +// + +type + IPAddr = Cardinal; // An IP address. + {$EXTERNALSYM IPAddr} + IPMask = Cardinal; // An IP subnet mask. + {$EXTERNALSYM IPMask} + IP_STATUS = Cardinal; // Status code returned from IP APIs. + {$EXTERNALSYM IP_STATUS} + +// +// The ip_option_information structure describes the options to be +// included in the header of an IP packet. The TTL, TOS, and Flags +// values are carried in specific fields in the header. The OptionsData +// bytes are carried in the options area following the standard IP header. +// With the exception of source route options, this data must be in the +// format to be transmitted on the wire as specified in RFC 791. A source +// route option should contain the full route - first hop thru final +// destination - in the route data. The first hop will be pulled out of the +// data and the option will be reformatted accordingly. Otherwise, the route +// option should be formatted as specified in RFC 791. +// + +type + ip_option_information = record + Ttl: Byte; // Time To Live + Tos: Byte; // Type Of Service + Flags: Byte; // IP header flags + OptionsSize: Byte; // Size in bytes of options data + OptionsData: PByte; // Pointer to options data + end; + {$EXTERNALSYM ip_option_information} + TIpOptionInformation = ip_option_information; + PIpOptionInformation = ^ip_option_information; + +// +// The icmp_echo_reply structure describes the data returned in response +// to an echo request. +// + + icmp_echo_reply = record + Address: IPAddr; // Replying address + Status: Cardinal; // Reply IP_STATUS + RoundTripTime: Cardinal; // RTT in milliseconds + DataSize: Word; // Reply data size in bytes + Reserved: Word; // Reserved for system use + Data: Pointer; // Pointer to the reply data + Options: ip_option_information; // Reply options + end; + {$EXTERNALSYM icmp_echo_reply} + PIP_OPTION_INFORMATION = ^IP_OPTION_INFORMATION; + {$EXTERNALSYM PIP_OPTION_INFORMATION} + PICMP_ECHO_REPLY = ^ICMP_ECHO_REPLY; + {$EXTERNALSYM PICMP_ECHO_REPLY} + TIcmpEchoReply = icmp_echo_reply; + PIcmpEchoReply = PICMP_ECHO_REPLY; + + PARP_SEND_REPLY = ^ARP_SEND_REPLY; + {$EXTERNALSYM PARP_SEND_REPLY} + ArpRequestBuffer = record + DestAddress: IPAddr; + SrcAddress: IPAddr; + end; + {$EXTERNALSYM ArpRequestBuffer} + ARP_SEND_REPLY = ArpRequestBuffer; + {$EXTERNALSYM ARP_SEND_REPLY} + TArpRequestBuffer = ARP_SEND_REPLY; + PArpRequestBuffer = PARP_SEND_REPLY; + + _TCP_RESERVE_PORT_RANGE = record + UpperRange: Word; + LowerRange: Word; + end; + {$EXTERNALSYM _TCP_RESERVE_PORT_RANGE} + TCP_RESERVE_PORT_RANGE = _TCP_RESERVE_PORT_RANGE; + {$EXTERNALSYM TCP_RESERVE_PORT_RANGE} + TTcpReservePortRange = _TCP_RESERVE_PORT_RANGE; + PTcpReservePortRange = ^TCP_RESERVE_PORT_RANGE; + +const + MAX_ADAPTER_NAME = 128; + {$EXTERNALSYM MAX_ADAPTER_NAME} + +type + PIP_ADAPTER_INDEX_MAP = ^IP_ADAPTER_INDEX_MAP; + {$EXTERNALSYM PIP_ADAPTER_INDEX_MAP} + _IP_ADAPTER_INDEX_MAP = record + Index: ULONG; + Name: array [0..MAX_ADAPTER_NAME - 1] of WCHAR; + end; + {$EXTERNALSYM _IP_ADAPTER_INDEX_MAP} + IP_ADAPTER_INDEX_MAP = _IP_ADAPTER_INDEX_MAP; + {$EXTERNALSYM IP_ADAPTER_INDEX_MAP} + TIpAdapterIndexMap = IP_ADAPTER_INDEX_MAP; + PIpAdapterIndexMap = PIP_ADAPTER_INDEX_MAP; + + PIP_INTERFACE_INFO = ^IP_INTERFACE_INFO; + {$EXTERNALSYM PIP_INTERFACE_INFO} + _IP_INTERFACE_INFO = record + NumAdapters: Longint; + Adapter: array [0..0] of IP_ADAPTER_INDEX_MAP; + end; + {$EXTERNALSYM _IP_INTERFACE_INFO} + IP_INTERFACE_INFO = _IP_INTERFACE_INFO; + {$EXTERNALSYM IP_INTERFACE_INFO} + TIpInterfaceInfo = IP_INTERFACE_INFO; + PIpInterfaceInfo = PIP_INTERFACE_INFO; + + PIP_UNIDIRECTIONAL_ADAPTER_ADDRESS = ^IP_UNIDIRECTIONAL_ADAPTER_ADDRESS; + {$EXTERNALSYM PIP_UNIDIRECTIONAL_ADAPTER_ADDRESS} + _IP_UNIDIRECTIONAL_ADAPTER_ADDRESS = record + NumAdapters: ULONG; + Address: array [0..0] of IPAddr; + end; + {$EXTERNALSYM _IP_UNIDIRECTIONAL_ADAPTER_ADDRESS} + IP_UNIDIRECTIONAL_ADAPTER_ADDRESS = _IP_UNIDIRECTIONAL_ADAPTER_ADDRESS; + {$EXTERNALSYM IP_UNIDIRECTIONAL_ADAPTER_ADDRESS} + TIpUnidirectionalAdapterAddress = IP_UNIDIRECTIONAL_ADAPTER_ADDRESS; + PIpUnidirectionalAdapterAddress = PIP_UNIDIRECTIONAL_ADAPTER_ADDRESS; + + PIP_ADAPTER_ORDER_MAP = ^IP_ADAPTER_ORDER_MAP; + {$EXTERNALSYM PIP_ADAPTER_ORDER_MAP} + _IP_ADAPTER_ORDER_MAP = record + NumAdapters: ULONG; + AdapterOrder: array [0..0] of ULONG; + end; + {$EXTERNALSYM _IP_ADAPTER_ORDER_MAP} + IP_ADAPTER_ORDER_MAP = _IP_ADAPTER_ORDER_MAP; + {$EXTERNALSYM IP_ADAPTER_ORDER_MAP} + TIpAdapterOrderMap = IP_ADAPTER_ORDER_MAP; + PIpAdapterOrderMap = PIP_ADAPTER_ORDER_MAP; + +// +// IP_STATUS codes returned from IP APIs +// + +const + IP_STATUS_BASE = 11000; + {$EXTERNALSYM IP_STATUS_BASE} + + IP_SUCCESS = 0; + {$EXTERNALSYM IP_SUCCESS} + IP_BUF_TOO_SMALL = IP_STATUS_BASE + 1; + {$EXTERNALSYM IP_BUF_TOO_SMALL} + IP_DEST_NET_UNREACHABLE = IP_STATUS_BASE + 2; + {$EXTERNALSYM IP_DEST_NET_UNREACHABLE} + IP_DEST_HOST_UNREACHABLE = IP_STATUS_BASE + 3; + {$EXTERNALSYM IP_DEST_HOST_UNREACHABLE} + IP_DEST_PROT_UNREACHABLE = IP_STATUS_BASE + 4; + {$EXTERNALSYM IP_DEST_PROT_UNREACHABLE} + IP_DEST_PORT_UNREACHABLE = IP_STATUS_BASE + 5; + {$EXTERNALSYM IP_DEST_PORT_UNREACHABLE} + IP_NO_RESOURCES = IP_STATUS_BASE + 6; + {$EXTERNALSYM IP_NO_RESOURCES} + IP_BAD_OPTION = IP_STATUS_BASE + 7; + {$EXTERNALSYM IP_BAD_OPTION} + IP_HW_ERROR = IP_STATUS_BASE + 8; + {$EXTERNALSYM IP_HW_ERROR} + IP_PACKET_TOO_BIG = IP_STATUS_BASE + 9; + {$EXTERNALSYM IP_PACKET_TOO_BIG} + IP_REQ_TIMED_OUT = IP_STATUS_BASE + 10; + {$EXTERNALSYM IP_REQ_TIMED_OUT} + IP_BAD_REQ = IP_STATUS_BASE + 11; + {$EXTERNALSYM IP_BAD_REQ} + IP_BAD_ROUTE = IP_STATUS_BASE + 12; + {$EXTERNALSYM IP_BAD_ROUTE} + IP_TTL_EXPIRED_TRANSIT = IP_STATUS_BASE + 13; + {$EXTERNALSYM IP_TTL_EXPIRED_TRANSIT} + IP_TTL_EXPIRED_REASSEM = IP_STATUS_BASE + 14; + {$EXTERNALSYM IP_TTL_EXPIRED_REASSEM} + IP_PARAM_PROBLEM = IP_STATUS_BASE + 15; + {$EXTERNALSYM IP_PARAM_PROBLEM} + IP_SOURCE_QUENCH = IP_STATUS_BASE + 16; + {$EXTERNALSYM IP_SOURCE_QUENCH} + IP_OPTION_TOO_BIG = IP_STATUS_BASE + 17; + {$EXTERNALSYM IP_OPTION_TOO_BIG} + IP_BAD_DESTINATION = IP_STATUS_BASE + 18; + {$EXTERNALSYM IP_BAD_DESTINATION} + +// +// The next group are status codes passed up on status indications to +// transport layer protocols. +// + + IP_ADDR_DELETED = IP_STATUS_BASE + 19; + {$EXTERNALSYM IP_ADDR_DELETED} + IP_SPEC_MTU_CHANGE = IP_STATUS_BASE + 20; + {$EXTERNALSYM IP_SPEC_MTU_CHANGE} + IP_MTU_CHANGE = IP_STATUS_BASE + 21; + {$EXTERNALSYM IP_MTU_CHANGE} + IP_UNLOAD = IP_STATUS_BASE + 22; + {$EXTERNALSYM IP_UNLOAD} + IP_ADDR_ADDED = IP_STATUS_BASE + 23; + {$EXTERNALSYM IP_ADDR_ADDED} + IP_MEDIA_CONNECT = IP_STATUS_BASE + 24; + {$EXTERNALSYM IP_MEDIA_CONNECT} + IP_MEDIA_DISCONNECT = IP_STATUS_BASE + 25; + {$EXTERNALSYM IP_MEDIA_DISCONNECT} + IP_BIND_ADAPTER = IP_STATUS_BASE + 26; + {$EXTERNALSYM IP_BIND_ADAPTER} + IP_UNBIND_ADAPTER = IP_STATUS_BASE + 27; + {$EXTERNALSYM IP_UNBIND_ADAPTER} + IP_DEVICE_DOES_NOT_EXIST = IP_STATUS_BASE + 28; + {$EXTERNALSYM IP_DEVICE_DOES_NOT_EXIST} + IP_DUPLICATE_ADDRESS = IP_STATUS_BASE + 29; + {$EXTERNALSYM IP_DUPLICATE_ADDRESS} + IP_INTERFACE_METRIC_CHANGE = IP_STATUS_BASE + 30; + {$EXTERNALSYM IP_INTERFACE_METRIC_CHANGE} + IP_RECONFIG_SECFLTR = IP_STATUS_BASE + 31; + {$EXTERNALSYM IP_RECONFIG_SECFLTR} + IP_NEGOTIATING_IPSEC = IP_STATUS_BASE + 32; + {$EXTERNALSYM IP_NEGOTIATING_IPSEC} + IP_INTERFACE_WOL_CAPABILITY_CHANGE = IP_STATUS_BASE + 33; + {$EXTERNALSYM IP_INTERFACE_WOL_CAPABILITY_CHANGE} + IP_DUPLICATE_IPADD = IP_STATUS_BASE + 34; + {$EXTERNALSYM IP_DUPLICATE_IPADD} + + IP_GENERAL_FAILURE = IP_STATUS_BASE + 50; + {$EXTERNALSYM IP_GENERAL_FAILURE} + MAX_IP_STATUS = IP_GENERAL_FAILURE; + {$EXTERNALSYM MAX_IP_STATUS} + IP_PENDING = IP_STATUS_BASE + 255; + {$EXTERNALSYM IP_PENDING} + +// +// Values used in the IP header Flags field. +// + + IP_FLAG_DF = $2; // Don't fragment this packet. + {$EXTERNALSYM IP_FLAG_DF} + +// +// Supported IP Option Types. +// +// These types define the options which may be used in the OptionsData field +// of the ip_option_information structure. See RFC 791 for a complete +// description of each. +// + + IP_OPT_EOL = 0; // End of list option + {$EXTERNALSYM IP_OPT_EOL} + IP_OPT_NOP = 1; // No operation + {$EXTERNALSYM IP_OPT_NOP} + IP_OPT_SECURITY = $82; // Security option + {$EXTERNALSYM IP_OPT_SECURITY} + IP_OPT_LSRR = $83; // Loose source route + {$EXTERNALSYM IP_OPT_LSRR} + IP_OPT_SSRR = $89; // Strict source route + {$EXTERNALSYM IP_OPT_SSRR} + IP_OPT_RR = $7; // Record route + {$EXTERNALSYM IP_OPT_RR} + IP_OPT_TS = $44; // Timestamp + {$EXTERNALSYM IP_OPT_TS} + IP_OPT_SID = $88; // Stream ID (obsolete) + {$EXTERNALSYM IP_OPT_SID} + IP_OPT_ROUTER_ALERT = $94; // Router Alert Option + {$EXTERNALSYM IP_OPT_ROUTER_ALERT} + + MAX_OPT_SIZE = 40; // Maximum length of IP options in bytes + {$EXTERNALSYM MAX_OPT_SIZE} + +// Ioctls code exposed by Memphis tcpip stack. +// For NT these ioctls are define in ntddip.h (private\inc) + + IOCTL_IP_RTCHANGE_NOTIFY_REQUEST = 101; + {$EXTERNALSYM IOCTL_IP_RTCHANGE_NOTIFY_REQUEST} + IOCTL_IP_ADDCHANGE_NOTIFY_REQUEST = 102; + {$EXTERNALSYM IOCTL_IP_ADDCHANGE_NOTIFY_REQUEST} + IOCTL_ARP_SEND_REQUEST = 103; + {$EXTERNALSYM IOCTL_ARP_SEND_REQUEST} + IOCTL_IP_INTERFACE_INFO = 104; + {$EXTERNALSYM IOCTL_IP_INTERFACE_INFO} + IOCTL_IP_GET_BEST_INTERFACE = 105; + {$EXTERNALSYM IOCTL_IP_GET_BEST_INTERFACE} + IOCTL_IP_UNIDIRECTIONAL_ADAPTER_ADDRESS = 106; + {$EXTERNALSYM IOCTL_IP_UNIDIRECTIONAL_ADAPTER_ADDRESS} + +implementation + +end. diff --git a/IpFunctions.pas b/IpFunctions.pas new file mode 100644 index 0000000..d528631 --- /dev/null +++ b/IpFunctions.pas @@ -0,0 +1,773 @@ +{******************************************************************} +{ } +{ IpTest - IP Helper API Demonstration project } +{ } +{ Portions created by Vladimir Vassiliev are } +{ Copyright (C) 2000 Vladimir Vassiliev. } +{ All Rights Reserved. } +{ } +{ The original file is: IPFunctions.pas, released December 2000. } +{ The initial developer of the Pascal code is Vladimir Vassiliev } +{ (voldemarv@hotpop.com). } +{ } +{ Contributor(s): Marcel van Brakel (brakelm@bart.nl) } +{ John Penman (jcp@craiglockhart.com) } +{ } +{ Obtained through: } +{ Joint Endeavour of Delphi Innovators (Project JEDI) } +{ } +{ You may retrieve the latest version of this file at the Project } +{ JEDI home page, located at http://delphi-jedi.org or Vladimir's } +{ website at http://voldemarv.virtualave.net } +{ } +{ The contents of this file are used with permission, subject to } +{ the Mozilla Public License Version 1.1 (the "License"); you may } +{ not use this file except in compliance with the License. You may } +{ obtain a copy of the License at } +{ http://www.mozilla.org/NPL/NPL-1_1Final.html } +{ } +{ Software distributed under the License is distributed on an } +{ "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or } +{ implied. See the License for the specific language governing } +{ rights and limitations under the License. } +{ } +{******************************************************************} + +unit IPFunctions; + +interface + +uses + Windows, SysUtils, IpHlpApi, IpTypes, IPExport, Iprtrmib; + +type + EIpHlpError = class(Exception); + +resourcestring + sNotImplemented = 'Function %s is not implemented.'; + sInvalidParameter = 'Function %s. Invalid parameter'; + sNoData = 'Function %s. No adapter information exists for the local computer.'; + sNotSupported = 'Function %s is not supported by the operating system.'; + +procedure VVGetNetworkParams(var p: PfixedInfo; var OutBufLen: Cardinal); +procedure VVGetAdaptersInfo(var p: PIpAdapterInfo; var OutBufLen: Cardinal); +procedure VVGetPerAdapterInfo(IfIndex: Cardinal; var p: PIpPerAdapterInfo; + var OutBufLen: Cardinal); +function VVGetNumberOfInterfaces:DWORD; +procedure VVGetAdapterIndex(AdapterName: PWideChar; var IfIndex :Cardinal); +procedure VVGetUniDirectionalAdapterInfo(var p: PIpUnidirectionalAdapterAddress; + var OutBufLen :Cardinal); +procedure VVGetInterfaceInfo(var p: PIpInterfaceInfo; var OutBufLen: Cardinal); +function VVGetFriendlyIfIndex(IfIndex: DWORD):DWORD; +procedure VVGetIfTable(var p: PMibIfTable; // buffer for interface table + var dwSize: Cardinal; // size of buffer + const bOrder: BOOL // sort the table by index? + ); +procedure VVGetIfEntry(pIfRow: PMibIfRow // pointer to interface entry + ); +procedure VVSetIfEntry(IfRow: TMibIfRow // specifies interface and status + ); +procedure VVGetIpAddrTable(var p: PMibIpAddrTable; var Size: Cardinal; + const bOrder: BOOL); +procedure VVAddIPAddress(Address: IPAddr; IPMask: IpMask; IfIndex: DWORD; + var NTEContext: Cardinal; var NTEInstance: Cardinal); +procedure VVDeleteIPAddress(NTEContext: Cardinal); +procedure VVIpReleaseAddress(AdapterInfo: TIpAdapterIndexMap); +procedure VVIpRenewAddress(AdapterInfo: TIpAdapterIndexMap); +procedure VVGetIpNetTable(var p: PMibIpNetTable; // buffer for mapping table + var Size: Cardinal; // size of buffer + const bOrder: BOOL //sort by IP address + ); +procedure VVCreateIpNetEntry(ArpEntry: TMibIpNetRow // pointer to info for new entry + ); +procedure VVDeleteIpNetEntry(ArpEntry: TMibIpNetRow // info identifying entry to delete + ); +procedure VVFlushIpNetTable(dwIfIndex: DWORD // delete ARP entries for this interface + ); +procedure VVCreateProxyArpEntry( + dwAddress, // IP address for which to act as proxy + dwMask, // subnet mask for IP address + dwIfIndex: DWORD // interface on which to proxy + ); +procedure VVDeleteProxyArpEntry( + dwAddress, // IP address for which to act as proxy + dwMask, // subnet mask for IP address + dwIfIndex: DWORD // interface on which to proxy + ); +procedure VVSendARP( + const DestIP, // destination IP address + SrcIP: IPAddr; // IP address of sender + PMacAddr: PULong; // returned physical address + var PhyAddrLen :ULong // length of returned physical addr. + ); +procedure VVGetIpStatistics( + var Stats: TMibIpStats // IP stats + ); +procedure VVGetIcmpStatistics( + var Stats: TMibIcmp // ICMP stats + ); +procedure VVSetIpStatistics( + var IpStats: TMibIpStats // new forwarding and TTL settings + ); +procedure VVSetIpTTL( + nTTL: UINT // new default TTL + ); +procedure VVGetIpForwardTable( + var pIpForwardTable: PMibIpForwardTable; // buffer for routing table + var dwSize: Cardinal; // size of buffer + const bOrder: BOOL // sort the table? + ); +procedure VVCreateIpForwardEntry( + pRoute: PMibIpForwardRow // pointer to route information + ); +procedure VVDeleteIpForwardEntry( + Route: TMibIpForwardRow // pointer to route information + ); +procedure VVSetIpForwardEntry( + Route: TMibIpForwardRow // pointer to route information + ); +procedure VVGetBestRoute( + dwDestAddr, // destination IP address + dwSourceAddr: DWORD; // local source IP address + pBestRoute: PMibIpForwardRow // best route for dest. addr. + ); +procedure VVGetBestInterface( + dwDestAddr: IPAddr; // destination IP address + var dwBestIfIndex: DWORD // index of interface with the best route + ); +procedure VVGetRTTAndHopCount( + const DestIpAddress: IPAddr; // destination IP address + var HopCount: ULONG; // returned hop count + const MaxHops: ULONG; // limit on number of hops to search + var RTT: ULONG // round-trip time + ); +procedure VVNotifyAddrChange(var Handle: THandle; Overlapped: POverlapped); +procedure VVNotifyRouteChange(var Handle: THandle; Overlapped: POverlapped); +procedure VVGetTcpStatistics( + var Stats: TMibTcpStats // pointer to TCP stats + ); +procedure VVGetUdpStatistics( + var Stats: TMibUdpStats // pointer to UDP stats + ); +procedure VVGetTcpTable( + var pTcpTable: PMibTcpTable; // buffer for the connection table + var dwSize: DWORD; // size of the buffer + const bOrder: BOOL // sort the table? + ); +procedure VVGetUdpTable( + var pUdpTable: PMibUdpTable; // buffer for the listener table + var dwSize: DWORD; // size of buffer + bOrder: BOOL // sort the table? + ); +procedure VVSetTcpEntry( + TcpRow: TMibTcpRow // pointer to struct. with new state info + ); +procedure VVEnableRouter( + var Handle: THandle; + var Overlapped: TOverlapped + ); +procedure VVUnenableRouter( + var Overlapped: TOverlapped; + lpdwEnableCount: LPDWORD = Nil + ); + +implementation + +procedure IpHlpError(const FunctionName: string; ErrorCode: DWORD); +begin + case ErrorCode of + ERROR_INVALID_PARAMETER : + raise EIpHlpError.CreateFmt(sInvalidParameter, [FunctionName]); + ERROR_NO_DATA : + raise EIpHlpError.CreateFmt(sNoData, [FunctionName]); + ERROR_NOT_SUPPORTED : + raise EIpHlpError.CreateFmt(sNotSupported, [FunctionName]); + else ; + RaiseLastOSError; + end; +end; + +procedure VVGetNetworkParams(var p: PfixedInfo; var OutBufLen: Cardinal); +var + Res: DWORD; +begin + p := Nil; + OutBufLen := 0; + if @GetNetworkParams = Nil then + raise EIpHlpError.CreateFmt(sNotImplemented, ['GetNetworkParams']); + Res := GetNetworkParams(p, OutBufLen); + if Res = ERROR_BUFFER_OVERFLOW then + begin + Getmem(p, OutBufLen); +// Caller must free this buffer when it is no longer used + FillChar(p^, OutBufLen, #0); + Res := GetNetworkParams(p, OutBufLen); + end; + if Res <> 0 then + IpHlpError('GetNetworkParams', Res); +end; + +procedure VVGetAdaptersInfo(var p: PIpAdapterInfo; var OutBufLen: Cardinal); +var + Res:DWORD; +begin + p := Nil; + OutBufLen := 0; + if @GetAdaptersInfo = Nil then + raise EIpHlpError.CreateFmt(sNotImplemented, ['GetAdaptersInfo']); + Res := GetAdaptersInfo(p, OutBufLen); + if Res = ERROR_BUFFER_OVERFLOW then + begin + Getmem(p, OutBufLen); +// Caller must free this buffer when it is no longer used + FillChar(p^, OutBufLen, #0); + Res := GetAdaptersInfo(p, OutBufLen); + end; + if Res <> 0 then + IpHlpError('GetAdaptersInfo', Res); +end; + +procedure VVGetPerAdapterInfo(IfIndex: Cardinal; var p: PIpPerAdapterInfo; + var OutBufLen: Cardinal); +var + Res: DWORD; +begin + p := Nil; + OutBufLen := 0; + if @GetPerAdapterInfo = Nil then + raise EIpHlpError.CreateFmt(sNotImplemented, ['GetPerAdapterInfo']); + Res := GetPerAdapterInfo(IfIndex,p, OutBufLen); + if Res = ERROR_BUFFER_OVERFLOW then + begin + Getmem(p, OutBufLen); +// Caller must free this buffer when it is no longer used + FillChar(p^, OutBufLen, #0); + Res := GetPerAdapterInfo(IfIndex,p, OutBufLen); + end; + if Res <> 0 then + IpHlpError('GetPerAdapterInfo', Res); +end; + +function VVGetNumberOfInterfaces: DWORD; +var + Res: DWORD; + NumIf: DWORD; +begin + if @GetNumberOfInterfaces = Nil then + raise EIpHlpError.CreateFmt(sNotImplemented, ['GetNumberOfInterfaces']); + Res := GetNumberOfInterfaces(NumIf); + if Res <> 0 then + IpHlpError('GetNumberOfInterfaces', Res); + Result := NumIf; +end; + +procedure VVGetAdapterIndex(AdapterName: PWideChar; var IfIndex :Cardinal); +var + Res: DWORD; +begin + if @GetAdapterIndex = Nil then + raise EIpHlpError.CreateFmt(sNotImplemented, ['GetAdapterIndex']); + Res := GetAdapterIndex(AdapterName, IfIndex); + if Res <> NO_ERROR then + IpHlpError('GetAdapterIndex', Res); +end; + +procedure VVGetUniDirectionalAdapterInfo(var p: PIpUnidirectionalAdapterAddress; + var OutBufLen :Cardinal); +var + Res: DWORD; +begin + p := Nil; + OutBufLen := 0; + if @GetUniDirectionalAdapterInfo = Nil then + raise EIpHlpError.CreateFmt(sNotImplemented, ['GetUniDirectionalAdapterInfo']); + Res := GetUniDirectionalAdapterInfo(p, OutBufLen); + if Res = ERROR_BUFFER_OVERFLOW then + begin + Getmem(p, OutBufLen); +// Caller must free this buffer when it is no longer used + FillChar(p^, OutBufLen, #0); + Res := GetUniDirectionalAdapterInfo(p, OutBufLen); + end; + if Res <> NO_ERROR then + IpHlpError('GetUniDirectionalAdapterInfo', Res); +end; + +procedure VVGetInterfaceInfo(var p: PIpInterfaceInfo; var OutBufLen: Cardinal); +var + Res: DWORD; +begin + p := Nil; + OutBufLen := 0; + if @GetInterfaceInfo = Nil then + raise EIpHlpError.CreateFmt(sNotImplemented, ['GetInterfaceInfo']); + Res := GetInterfaceInfo(p, OutBufLen); + if Res = ERROR_INSUFFICIENT_BUFFER then + begin + Getmem(p, OutBufLen); +// Caller must free this buffer when it is no longer used + FillChar(p^, OutBufLen, #0); + Res := GetInterfaceInfo(p, OutBufLen); + end; + if Res <> NO_ERROR then + IpHlpError('GetInterfaceInfo', Res); +end; + +function VVGetFriendlyIfIndex(IfIndex: DWORD):DWORD; +begin + if @GetFriendlyIfIndex = Nil then + raise EIpHlpError.CreateFmt(sNotImplemented, ['GetFriendlyIfIndex']); + Result := GetFriendlyIfIndex(IfIndex); +end; + +procedure VVGetIfTable(var p: PMibIfTable; var dwSize: Cardinal; + const bOrder: BOOL); +var + Res: DWORD; +begin + p := Nil; + dwSize := 0; + if @GetIfTable = Nil then + raise EIpHlpError.CreateFmt(sNotImplemented, ['GetIfTable']); + Res := GetIfTable(p,dwSize,bOrder); + if Res = ERROR_INSUFFICIENT_BUFFER then + begin + Getmem(p,dwSize); +// Caller must free this buffer when it is no longer used + FillChar(p^,dwSize,#0); + Res := GetIfTable(p,dwSize,bOrder); + end; + if Res <> NO_ERROR then + IpHlpError('GetIfTable', Res); +end; + +procedure VVGetIfEntry(pIfRow: PMibIfRow); +var + Res: DWORD; +begin + if @GetIfEntry = Nil then + raise EIpHlpError.CreateFmt(sNotImplemented, ['GetIfEntry']); + Res := GetIfEntry(pIfRow); + if Res <> NO_ERROR then + IpHlpError('GetIfEntry', Res); +end; + +procedure VVSetIfEntry(IfRow: TMibIfRow); +var + Res: DWORD; +begin + if @SetIfEntry = Nil then + raise EIpHlpError.CreateFmt(sNotImplemented, ['SetIfEntry']); + Res := SetIfEntry(IfRow); // + if Res <> NO_ERROR then + IpHlpError('SetIfEntry', Res); +end; + +procedure VVGetIpAddrTable(var p: PMibIpAddrTable; var Size: Cardinal; + const bOrder: BOOL); +var + Res: DWORD; +begin + p := Nil; + Size := 0; + if @GetIpAddrTable = Nil then + raise EIpHlpError.CreateFmt(sNotImplemented, ['GetIpAddrTable']); + Res := GetIpAddrTable(p,Size,bOrder); + if Res=ERROR_INSUFFICIENT_BUFFER then + begin + Getmem(p,Size); +// Caller must free this buffer when it is no longer used + FillChar(p^,Size,#0); + Res := GetIpAddrTable(p,Size,bOrder); + end; + if Res <> NO_ERROR then + IpHlpError('GetIpAddrTable', Res); +end; + +procedure VVAddIPAddress(Address: IPAddr; IPMask: IpMask; IfIndex: DWORD; + var NTEContext: Cardinal; var NTEInstance: Cardinal); +var + Res: DWORD; +begin + if @AddIPAddress = Nil then + raise EIpHlpError.CreateFmt(sNotImplemented, ['AddIPAddress']); + Res := AddIPAddress(Address, IpMask, IfIndex, NTEContext, NTEInstance); + if Res <> NO_ERROR then + IpHlpError('AddIPAddress', Res); +end; + +procedure VVDeleteIPAddress(NTEContext: Cardinal); +var + Res: DWORD; +begin + if @DeleteIPAddress = Nil then + raise EIpHlpError.CreateFmt(sNotImplemented, ['DeleteIPAddress']); + Res := DeleteIPAddress(NTEContext); + if Res <> NO_ERROR then + IpHlpError('DeleteIPAddress', Res); +end; + +procedure VVIpReleaseAddress(AdapterInfo: TIpAdapterIndexMap); +var + Res: DWORD; +begin + if @IpReleaseAddress = Nil then + raise EIpHlpError.CreateFmt(sNotImplemented, ['IpReleaseAddress']); + Res := IpReleaseAddress(AdapterInfo); // + if Res <> NO_ERROR then + IpHlpError('IpReleaseAddress', Res); +end; + +procedure VVIpRenewAddress(AdapterInfo: TIpAdapterIndexMap); +var + Res: DWORD; +begin + if @IpRenewAddress = Nil then + raise EIpHlpError.CreateFmt(sNotImplemented, ['IpRenewAddress']); + Res := IpRenewAddress(AdapterInfo); // + if Res <> NO_ERROR then + IpHlpError('IpRenewAddress', Res); +end; + +procedure VVGetIpNetTable(var p: PMibIpNetTable; var Size: Cardinal; + const bOrder: BOOL); +var + Res: DWORD; +begin + p := Nil; + Size := 0; + if @GetIpNetTable = Nil then + raise EIpHlpError.CreateFmt(sNotImplemented, ['GetIpNetTable']); + Res := GetIpNetTable(p, Size, bOrder); + if Res = ERROR_INSUFFICIENT_BUFFER then + begin + Getmem(p,Size); +// Caller must free this buffer when it is no longer used + FillChar(p^, Size, #0); + Res := GetIpNetTable(p, Size, bOrder); + end; + if Res <> NO_ERROR then + IpHlpError('GetIpNetTable', Res); +end; + +procedure VVCreateIpNetEntry(ArpEntry: TMibIpNetRow); +var + Res: DWORD; +begin + if @CreateIpNetEntry = Nil then + raise EIpHlpError.CreateFmt(sNotImplemented, ['CreateIpNetEntry']); + Res := CreateIpNetEntry(ArpEntry); // + if Res <> NO_ERROR then + IpHlpError('CreateIpNetEntry', Res); +end; + +procedure VVDeleteIpNetEntry(ArpEntry: TMibIpNetRow); +var + Res: DWORD; +begin + if @DeleteIpNetEntry = Nil then + raise EIpHlpError.CreateFmt(sNotImplemented, ['DeleteIpNetEntry']); + Res := DeleteIpNetEntry(ArpEntry); // + if Res <> NO_ERROR then + IpHlpError('DeleteIpNetEntry', Res); +end; + +procedure VVFlushIpNetTable(dwIfIndex: DWORD); +var + Res: DWORD; +begin + if @FlushIpNetTable = Nil then + raise EIpHlpError.CreateFmt(sNotImplemented, ['FlushIpNetTable']); + Res := FlushIpNetTable(dwIfIndex); + if Res <> NO_ERROR then + IpHlpError('FlushIpNetTable', Res); +end; + +procedure VVCreateProxyArpEntry(dwAddress, dwMask, dwIfIndex: DWORD); +var + Res: DWORD; +begin + if @CreateProxyArpEntry = Nil then + raise EIpHlpError.CreateFmt(sNotImplemented, ['CreateProxyArpEntry']); + Res := CreateProxyArpEntry(dwAddress, dwMask, dwIfIndex); + if Res <> NO_ERROR then + IpHlpError('CreateProxyArpEntry', Res); +end; + +procedure VVDeleteProxyArpEntry(dwAddress, dwMask, dwIfIndex: DWORD); +var + Res: DWORD; +begin + if @DeleteProxyArpEntry = Nil then + raise EIpHlpError.CreateFmt(sNotImplemented, ['DeleteProxyArpEntry']); + Res := DeleteProxyArpEntry(dwAddress, dwMask, dwIfIndex); + if Res <> NO_ERROR then + IpHlpError('DeleteProxyArpEntry', Res); +end; + +procedure VVSendARP(const DestIP, SrcIP: IPAddr; + PMacAddr :PULong; var PhyAddrLen: ULong); +var + Res: DWORD; +begin + if @SendARP = Nil then + raise EIpHlpError.CreateFmt(sNotImplemented, ['SendARP']); + Res := SendARP(DestIP, SrcIP, PMacAddr, PhyAddrLen); + if Res <> NO_ERROR then + IpHlpError('SendARP', Res); +end; + +procedure VVGetIpStatistics(var Stats: TMibIpStats); +var + Res: DWORD; +begin + if @GetIpStatistics = Nil then + raise EIpHlpError.CreateFmt(sNotImplemented, ['GetIpStatistics']); + Res := GetIpStatistics(Stats); // + if Res <> NO_ERROR then + IpHlpError('GetIpStatistics', Res); +end; + +procedure VVGetIcmpStatistics(var Stats: TMibIcmp); +var + Res: DWORD; +begin + if @GetIcmpStatistics = Nil then + raise EIpHlpError.CreateFmt(sNotImplemented, ['GetIcmpStatistics']); + Res := GetIcmpStatistics(Stats); // + if Res <> NO_ERROR then + IpHlpError('GetIcmpStatistics', Res); +end; + +procedure VVSetIpStatistics(var IpStats: TMibIpStats); +var + Res: DWORD; +begin + if @SetIpStatistics = Nil then + raise EIpHlpError.CreateFmt(sNotImplemented, ['SetIpStatistics']); + Res := SetIpStatistics(IpStats); // + if Res <> NO_ERROR then + IpHlpError('SetIpStatistics', Res); +end; + +procedure VVSetIpTTL(nTTL: UINT); +var + Res: DWORD; +begin + if @SetIpTTL = Nil then + raise EIpHlpError.CreateFmt(sNotImplemented, ['SetIpTTL']); + Res := SetIpTTL(nTTL); + if Res <> NO_ERROR then + IpHlpError('SetIpTTL', Res); +end; + +procedure VVGetIpForwardTable(var pIpForwardTable: PMibIpForwardTable; + var dwSize: Cardinal; const bOrder: BOOL); +var + Res: DWORD; +begin + pIpForwardTable := Nil; + dwSize := 0; + if @GetIpForwardTable = Nil then + raise EIpHlpError.CreateFmt(sNotImplemented, ['GetIpForwardTable']); + Res := GetIpForwardTable(pIpForwardTable,dwSize,bOrder); + if (Res <> NO_ERROR) and (dwSize>0) then + begin + Getmem(pIpForwardTable,dwSize); +// Caller must free this buffer when it is no longer used + FillChar(pIpForwardTable^,dwSize,#0); + Res := GetIpForwardTable(pIpForwardTable,dwSize,bOrder); + end; + if Res <> 0 then + IpHlpError('GetIpForwardTable', Res); +end; + +procedure VVCreateIpForwardEntry(pRoute: PMibIpForwardRow); +var + Res: DWORD; +begin + if @CreateIpForwardEntry = Nil then + raise EIpHlpError.CreateFmt(sNotImplemented, ['CreateIpForwardEntry']); + Res := CreateIpForwardEntry(pRoute^); //To test + if Res <> NO_ERROR then + IpHlpError('CreateIpForwardEntry', Res); +end; + +procedure VVDeleteIpForwardEntry(Route: TMibIpForwardRow); +var + Res: DWORD; +begin + if @DeleteIpForwardEntry = Nil then + raise EIpHlpError.CreateFmt(sNotImplemented, ['DeleteIpForwardEntry']); + Res := DeleteIpForwardEntry(Route); // + if Res <> NO_ERROR then + IpHlpError('DeleteIpForwardEntry', Res); +end; + +procedure VVSetIpForwardEntry(Route: TMibIpForwardRow); +var + Res: DWORD; +begin + if @SetIpForwardEntry = Nil then + raise EIpHlpError.CreateFmt(sNotImplemented, ['SetIpForwardEntry']); + Res := SetIpForwardEntry(Route); // + if Res <> NO_ERROR then + IpHlpError('SetIpForwardEntry', Res); +end; + +procedure VVGetBestRoute(dwDestAddr, dwSourceAddr: DWORD; + pBestRoute: PMibIpForwardRow); +var + Res: DWORD; +begin + if @GetBestRoute = Nil then + raise EIpHlpError.CreateFmt(sNotImplemented, ['GetBestRoute']); + Res := GetBestRoute(dwDestAddr, dwSourceAddr, pBestRoute); + if Res <> NO_ERROR then + IpHlpError('GetBestRoute', Res); +end; + +procedure VVGetBestInterface(dwDestAddr: IPAddr; var dwBestIfIndex: DWORD); +var + Res: DWORD; +begin + if @GetBestInterface = Nil then + raise EIpHlpError.CreateFmt(sNotImplemented, ['GetBestInterface']); + Res := GetBestInterface(dwDestAddr, dwBestIfIndex); + if Res <> NO_ERROR then + IpHlpError('GetBestInterface', Res); +end; + +procedure VVGetRTTAndHopCount(const DestIpAddress: IPAddr; var HopCount: ULONG; + const MaxHops: ULONG; var RTT: ULONG); +var + Res:BOOL; +begin + if @GetRTTAndHopCount = Nil then + raise EIpHlpError.CreateFmt(sNotImplemented, ['GetRTTAndHopCount']); + Res := GetRTTAndHopCount(DestIpAddress, HopCount, MaxHops, RTT); + if not Res then + RaiseLastOSError; +end; + +procedure VVNotifyAddrChange(var Handle: THandle; Overlapped: POverlapped); +var + Res: DWORD; +begin + if @NotifyAddrChange = Nil then + raise EIpHlpError.CreateFmt(sNotImplemented, ['NotifyAddrChange']); + Res := NotifyAddrChange(Handle, Overlapped); // + if Res <> ERROR_IO_PENDING then + IpHlpError('NotifyAddrChange', Res); +end; + +procedure VVNotifyRouteChange(var Handle: THandle; Overlapped: POverlapped); +var + Res: DWORD; +begin + if @NotifyRouteChange = Nil then + raise EIpHlpError.CreateFmt(sNotImplemented, ['NotifyRouteChange']); + Res := NotifyRouteChange(Handle, Overlapped); // + if Res <> ERROR_IO_PENDING then + IpHlpError('NotifyRouteChange', Res); +end; + +procedure VVGetTcpStatistics(var Stats: TMibTcpStats); +var + Res: DWORD; +begin + if @GetTcpStatistics = Nil then + raise EIpHlpError.CreateFmt(sNotImplemented, ['GetTcpStatistics']); + Res := GetTcpStatistics(Stats); // + if Res <> NO_ERROR then + IpHlpError('GetTcpStatistics', Res); +end; + +procedure VVGetUdpStatistics(var Stats: TMibUdpStats); +var + Res: DWORD; +begin + if @GetUdpStatistics = Nil then + raise EIpHlpError.CreateFmt(sNotImplemented, ['GetUdpStatistics']); + Res := GetUdpStatistics(Stats); // + if Res <> NO_ERROR then + IpHlpError('GetUdpStatistics', Res); +end; + +procedure VVGetTcpTable(var pTcpTable: PMibTcpTable; var dwSize: DWORD; + const bOrder: BOOL); +var + Res: DWORD; +begin + pTcpTable := Nil; + dwSize := 0; + if @GetTcpTable = Nil then + raise EIpHlpError.CreateFmt(sNotImplemented, ['GetTcpTable']); + Res := GetTcpTable(pTcpTable, dwSize, bOrder); + if Res = ERROR_INSUFFICIENT_BUFFER then + begin + Getmem(pTcpTable, dwSize); +// Caller must free this buffer when it is no longer used + FillChar(pTcpTable^, dwSize, #0); + Res := GetTcpTable(pTcpTable, dwSize, bOrder); + end; + if Res <> NO_ERROR then + IpHlpError('GetTcpTable', Res); +end; + +procedure VVGetUdpTable(var pUdpTable: PMibUdpTable; var dwSize: DWORD; + bOrder: BOOL); +var + Res: DWORD; +begin + pUdpTable := Nil; + dwSize := 0; + if @GetUdpTable = Nil then + raise EIpHlpError.CreateFmt(sNotImplemented, ['GetUdpTable']); + Res := GetUdpTable(pUdpTable, dwSize, bOrder); + if Res = ERROR_INSUFFICIENT_BUFFER then + begin + Getmem(pUdpTable, dwSize); +// Caller must free this buffer when it is no longer used + FillChar(pUdpTable^, dwSize, #0); + Res := GetUdpTable(pUdpTable, dwSize, bOrder); + end; + if Res <> NO_ERROR then + IpHlpError('GetUdpTable', Res); +end; + +procedure VVSetTcpEntry(TcpRow: TMibTcpRow); +var + Res: DWORD; +begin + if @SetTcpEntry = Nil then + raise EIpHlpError.CreateFmt(sNotImplemented, ['SetTcpEntry']); + Res := SetTcpEntry(TcpRow); // + if Res <> NO_ERROR then + IpHlpError('SetTcpEntry', Res); +end; + +procedure VVEnableRouter(var Handle: THandle; var Overlapped: TOverlapped); +var + Res: DWORD; +begin + if @EnableRouter = Nil then + raise EIpHlpError.CreateFmt(sNotImplemented, ['EnableRouter']); + Res := EnableRouter(Handle, @Overlapped); // + if Res <> ERROR_IO_PENDING then + RaiseLastOSError; +end; + +procedure VVUnenableRouter(var Overlapped: TOverlapped; + lpdwEnableCount: LPDWORD = Nil); +var + Res: DWORD; +begin + if @UnEnableRouter = Nil then + raise EIpHlpError.CreateFmt(sNotImplemented, ['UnEnableRouter']); + Res := UnEnableRouter(@Overlapped, lpdwEnableCount); // + if Res <> NO_ERROR then + RaiseLastOSError; +end; + +end. diff --git a/IpHlpApi.pas b/IpHlpApi.pas new file mode 100644 index 0000000..8f48132 --- /dev/null +++ b/IpHlpApi.pas @@ -0,0 +1,758 @@ +{******************************************************************************} +{ } +{ Internet Protocol Helper API interface Unit for Object Pascal } +{ } +{ Portions created by Microsoft are Copyright (C) 1995-2001 Microsoft } +{ Corporation. All Rights Reserved. } +{ } +{ The original file is: iphlpapi.h, released July 2000. The original Pascal } +{ code is: IpHlpApi.pas, released September 2000. The initial developer of the } +{ Pascal code is Marcel van Brakel (brakelm@chello.nl). } +{ } +{ Portions created by Marcel van Brakel are Copyright (C) 1999-2001 } +{ Marcel van Brakel. All Rights Reserved. } +{ } +{ Contributor(s): John C. Penman (jcp@craiglockhart.com) } +{ Vladimir Vassiliev (voldemarv@hotpop.com) } +{ } +{ Obtained through: Joint Endeavour of Delphi Innovators (Project JEDI) } +{ } +{ You may retrieve the latest version of this file at the Project JEDI home } +{ page, located at http://delphi-jedi.org or my personal homepage located at } +{ http://members.chello.nl/m.vanbrakel2 } +{ } +{ The contents of this file are used with permission, subject to the Mozilla } +{ Public License Version 1.1 (the "License"); you may not use this file except } +{ in compliance with the License. You may obtain a copy of the License at } +{ http://www.mozilla.org/MPL/MPL-1.1.html } +{ } +{ Software distributed under the License is distributed on an "AS IS" basis, } +{ WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for } +{ the specific language governing rights and limitations under the License. } +{ } +{ Alternatively, the contents of this file may be used under the terms of the } +{ GNU Lesser General Public License (the "LGPL License"), in which case the } +{ provisions of the LGPL License are applicable instead of those above. } +{ If you wish to allow use of your version of this file only under the terms } +{ of the LGPL License and not to allow others to use your version of this file } +{ under the MPL, indicate your decision by deleting the provisions above and } +{ replace them with the notice and other provisions required by the LGPL } +{ License. If you do not delete the provisions above, a recipient may use } +{ your version of this file under either the MPL or the LGPL License. } +{ } +{ For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html } +{ } +{******************************************************************************} + +unit IpHlpApi; + +{$WEAKPACKAGEUNIT} + +{$HPPEMIT ''} +{$HPPEMIT '#include "iphlpapi.h"'} +{$HPPEMIT ''} + +//{$I WINDEFINES.INC} + +{.$DEFINE IPHLPAPI_LINKONREQUEST} +{$IFDEF IPHLPAPI_LINKONREQUEST} + {$DEFINE IPHLPAPI_DYNLINK} +{$ENDIF} +{.$DEFINE IPHLPAPI_DYNLINK} + +interface + +uses + Windows, IpExport, IpRtrMib, IpTypes; + +////////////////////////////////////////////////////////////////////////////// +// // +// IPRTRMIB.H has the definitions of the strcutures used to set and get // +// information // +// // +////////////////////////////////////////////////////////////////////////////// + +// #include +// #include +// #include + +////////////////////////////////////////////////////////////////////////////// +// // +// The GetXXXTable APIs take a buffer and a size of buffer. If the buffer // +// is not large enough, they APIs return ERROR_INSUFFICIENT_BUFFER and // +// *pdwSize is the required buffer size // +// The bOrder is a BOOLEAN, which if TRUE sorts the table according to // +// MIB-II (RFC XXXX) // +// // +////////////////////////////////////////////////////////////////////////////// + + +////////////////////////////////////////////////////////////////////////////// +// // +// Retrieves the number of interfaces in the system. These include LAN and // +// WAN interfaces // +// // +////////////////////////////////////////////////////////////////////////////// + +{$IFNDEF IPHLPAPI_DYNLINK} + +function GetNumberOfInterfaces(var pdwNumIf: DWORD): DWORD; stdcall; +{$EXTERNALSYM GetNumberOfInterfaces} + +{$ELSE} + +var + GetNumberOfInterfaces: function (var pdwNumIf: DWORD): DWORD; stdcall; + {$EXTERNALSYM GetNumberOfInterfaces} + +{$ENDIF} + +////////////////////////////////////////////////////////////////////////////// +// // +// Gets the MIB-II ifEntry // +// The dwIndex field of the MIB_IFROW should be set to the index of the // +// interface being queried // +// // +////////////////////////////////////////////////////////////////////////////// + +{$IFNDEF IPHLPAPI_DYNLINK} + +function GetIfEntry(pIfRow: PMIB_IFROW): DWORD; stdcall; +{$EXTERNALSYM GetIfEntry} + +{$ELSE} + +var + GetIfEntry: function (pIfRow: PMIB_IFROW): DWORD; stdcall; + {$EXTERNALSYM GetIfEntry} + +{$ENDIF} + +////////////////////////////////////////////////////////////////////////////// +// // +// Gets the MIB-II IfTable // +// // +////////////////////////////////////////////////////////////////////////////// + +{$IFNDEF IPHLPAPI_DYNLINK} + +function GetIfTable(pIfTable: PMIB_IFTABLE; var pdwSize: ULONG; bOrder: BOOL): DWORD; stdcall; +{$EXTERNALSYM GetIfTable} + +{$ELSE} + +var + GetIfTable: function (pIfTable: PMIB_IFTABLE; var pdwSize: ULONG; bOrder: BOOL): DWORD; stdcall; + {$EXTERNALSYM GetIfTable} + +{$ENDIF} + +////////////////////////////////////////////////////////////////////////////// +// // +// Gets the Interface to IP Address mapping // +// // +////////////////////////////////////////////////////////////////////////////// + +{$IFNDEF IPHLPAPI_DYNLINK} + +function GetIpAddrTable(pIpAddrTable: PMIB_IPADDRTABLE; var pdwSize: ULONG; bOrder: BOOL): DWORD; stdcall; +{$EXTERNALSYM GetIpAddrTable} + +{$ELSE} + +var + GetIpAddrTable: function (pIpAddrTable: PMIB_IPADDRTABLE; var pdwSize: ULONG; bOrder: BOOL): DWORD; stdcall; + {$EXTERNALSYM GetIpAddrTable} + +{$ENDIF} + +////////////////////////////////////////////////////////////////////////////// +// // +// Gets the current IP Address to Physical Address (ARP) mapping // +// // +////////////////////////////////////////////////////////////////////////////// + +{$IFNDEF IPHLPAPI_DYNLINK} + +function GetIpNetTable(pIpNetTable: PMIB_IPNETTABLE; var pdwSize: ULONG; bOrder: BOOL): DWORD; stdcall; +{$EXTERNALSYM GetIpNetTable} + +{$ELSE} + +var + GetIpNetTable: function (pIpNetTable: PMIB_IPNETTABLE; var pdwSize: ULONG; bOrder: BOOL): DWORD; stdcall; + {$EXTERNALSYM GetIpNetTable} + +{$ENDIF} + +////////////////////////////////////////////////////////////////////////////// +// // +// Gets the IP Routing Table (RFX XXXX) // +// // +////////////////////////////////////////////////////////////////////////////// + +{$IFNDEF IPHLPAPI_DYNLINK} + +function GetIpForwardTable(pIpForwardTable: PMIB_IPFORWARDTABLE; var pdwSize: ULONG; + bOrder: BOOL): DWORD; stdcall; +{$EXTERNALSYM GetIpForwardTable} + +{$ELSE} + +var + GetIpForwardTable: function (pIpForwardTable: PMIB_IPFORWARDTABLE; + var pdwSize: ULONG; bOrder: BOOL): DWORD; stdcall; + {$EXTERNALSYM GetIpForwardTable} + +{$ENDIF} + +////////////////////////////////////////////////////////////////////////////// +// // +// Gets TCP Connection/UDP Listener Table // +// // +////////////////////////////////////////////////////////////////////////////// + +{$IFNDEF IPHLPAPI_DYNLINK} + +function GetTcpTable(pTcpTable: PMIB_TCPTABLE; var pdwSize: DWORD; bOrder: BOOL): DWORD; stdcall; +{$EXTERNALSYM GetTcpTable} + +function GetUdpTable(pUdpTable: PMIB_UDPTABLE; var pdwSize: DWORD; bOrder: BOOL): DWORD; stdcall; +{$EXTERNALSYM GetUdpTable} + +{$ELSE} + +var + GetTcpTable: function (pTcpTable: PMIB_TCPTABLE; var pdwSize: DWORD; bOrder: BOOL): DWORD; stdcall; + {$EXTERNALSYM GetTcpTable} + + GetUdpTable: function (pUdpTable: PMIB_UDPTABLE; var pdwSize: DWORD; bOrder: BOOL): DWORD; stdcall; + {$EXTERNALSYM GetUdpTable} + +{$ENDIF} + +////////////////////////////////////////////////////////////////////////////// +// // +// Gets IP/ICMP/TCP/UDP Statistics // +// // +////////////////////////////////////////////////////////////////////////////// + +{$IFNDEF IPHLPAPI_DYNLINK} + +function GetIpStatistics(var pStats: MIB_IPSTATS): DWORD; stdcall; +{$EXTERNALSYM GetIpStatistics} + +function GetIcmpStatistics(var pStats: MIB_ICMP): DWORD; stdcall; +{$EXTERNALSYM GetIcmpStatistics} + +function GetTcpStatistics(var pStats: MIB_TCPSTATS): DWORD; stdcall; +{$EXTERNALSYM GetTcpStatistics} + +function GetUdpStatistics(var pStats: MIB_UDPSTATS): DWORD; stdcall; +{$EXTERNALSYM GetUdpStatistics} + +{$ELSE} + +var + GetIpStatistics: function (var pStats: MIB_IPSTATS): DWORD; stdcall; + {$EXTERNALSYM GetIpStatistics} + + GetIcmpStatistics: function (var pStats: MIB_ICMP): DWORD; stdcall; + {$EXTERNALSYM GetIcmpStatistics} + + GetTcpStatistics: function (var pStats: MIB_TCPSTATS): DWORD; stdcall; + {$EXTERNALSYM GetTcpStatistics} + + GetUdpStatistics: function (var pStats: MIB_UDPSTATS): DWORD; stdcall; + {$EXTERNALSYM GetUdpStatistics} + +{$ENDIF} + +////////////////////////////////////////////////////////////////////////////// +// // +// Used to set the ifAdminStatus on an interface. The only fields of the // +// MIB_IFROW that are relevant are the dwIndex (index of the interface // +// whose status needs to be set) and the dwAdminStatus which can be either // +// MIB_IF_ADMIN_STATUS_UP or MIB_IF_ADMIN_STATUS_DOWN // +// // +////////////////////////////////////////////////////////////////////////////// + +{$IFNDEF IPHLPAPI_DYNLINK} + +function SetIfEntry(const pIfRow: MIB_IFROW): DWORD; stdcall; +{$EXTERNALSYM SetIfEntry} + +{$ELSE} + +var + SetIfEntry: function (const pIfRow: MIB_IFROW): DWORD; stdcall; + {$EXTERNALSYM SetIfEntry} + +{$ENDIF} + +////////////////////////////////////////////////////////////////////////////// +// // +// Used to create, modify or delete a route. In all cases the // +// dwForwardIfIndex, dwForwardDest, dwForwardMask, dwForwardNextHop and // +// dwForwardPolicy MUST BE SPECIFIED. Currently dwForwardPolicy is unused // +// and MUST BE 0. // +// For a set, the complete MIB_IPFORWARDROW structure must be specified // +// // +////////////////////////////////////////////////////////////////////////////// + +{$IFNDEF IPHLPAPI_DYNLINK} + +function CreateIpForwardEntry(const pRoute: MIB_IPFORWARDROW): DWORD; stdcall; +{$EXTERNALSYM CreateIpForwardEntry} + +function SetIpForwardEntry(const pRoute: MIB_IPFORWARDROW): DWORD; stdcall; +{$EXTERNALSYM SetIpForwardEntry} + +function DeleteIpForwardEntry(const pRoute: MIB_IPFORWARDROW): DWORD; stdcall; +{$EXTERNALSYM DeleteIpForwardEntry} + +{$ELSE} + +var + CreateIpForwardEntry: function (const pRoute: MIB_IPFORWARDROW): DWORD; stdcall; + {$EXTERNALSYM CreateIpForwardEntry} + + SetIpForwardEntry: function (const pRoute: MIB_IPFORWARDROW): DWORD; stdcall; + {$EXTERNALSYM SetIpForwardEntry} + + DeleteIpForwardEntry: function (const pRoute: MIB_IPFORWARDROW): DWORD; stdcall; + {$EXTERNALSYM DeleteIpForwardEntry} + +{$ENDIF} + +////////////////////////////////////////////////////////////////////////////// +// // +// Used to set the ipForwarding to ON or OFF (currently only ON->OFF is // +// allowed) and to set the defaultTTL. If only one of the fields needs to // +// be modified and the other needs to be the same as before the other field // +// needs to be set to MIB_USE_CURRENT_TTL or MIB_USE_CURRENT_FORWARDING as // +// the case may be // +// // +////////////////////////////////////////////////////////////////////////////// + +{$IFNDEF IPHLPAPI_DYNLINK} + +function SetIpStatistics(const pIpStats: MIB_IPSTATS): DWORD; stdcall; +{$EXTERNALSYM SetIpStatistics} + +{$ELSE} + +var + SetIpStatistics: function (const pIpStats: MIB_IPSTATS): DWORD; stdcall; + {$EXTERNALSYM SetIpStatistics} + +{$ENDIF} + +////////////////////////////////////////////////////////////////////////////// +// // +// Used to set the defaultTTL. // +// // +////////////////////////////////////////////////////////////////////////////// + +{$IFNDEF IPHLPAPI_DYNLINK} + +function SetIpTTL(nTTL: UINT): DWORD; stdcall; +{$EXTERNALSYM SetIpTTL} + +{$ELSE} + + SetIpTTL: function (nTTL: UINT): DWORD; stdcall; + {$EXTERNALSYM SetIpTTL} + +{$ENDIF} + +////////////////////////////////////////////////////////////////////////////// +// // +// Used to create, modify or delete an ARP entry. In all cases the dwIndex // +// dwAddr field MUST BE SPECIFIED. // +// For a set, the complete MIB_IPNETROW structure must be specified // +// // +////////////////////////////////////////////////////////////////////////////// + +{$IFNDEF IPHLPAPI_DYNLINK} + +function CreateIpNetEntry(const pArpEntry: MIB_IPNETROW): DWORD; stdcall; +{$EXTERNALSYM CreateIpNetEntry} + +function SetIpNetEntry(const pArpEntry: MIB_IPNETROW): DWORD; stdcall; +{$EXTERNALSYM SetIpNetEntry} + +function DeleteIpNetEntry(const pArpEntry: MIB_IPNETROW): DWORD; stdcall; +{$EXTERNALSYM DeleteIpNetEntry} + +function FlushIpNetTable(dwIfIndex: DWORD): DWORD; stdcall; +{$EXTERNALSYM FlushIpNetTable} + +{$ELSE} + +var + CreateIpNetEntry: function (const pArpEntry: MIB_IPNETROW): DWORD; stdcall; + {$EXTERNALSYM CreateIpNetEntry} + + SetIpNetEntry: function (const pArpEntry: MIB_IPNETROW): DWORD; stdcall; + {$EXTERNALSYM SetIpNetEntry} + + DeleteIpNetEntry: function (const pArpEntry: MIB_IPNETROW): DWORD; stdcall; + {$EXTERNALSYM DeleteIpNetEntry} + + FlushIpNetTable: function (dwIfIndex: DWORD): DWORD; stdcall; + {$EXTERNALSYM FlushIpNetTable} + +{$ENDIF} + +////////////////////////////////////////////////////////////////////////////// +// // +// Used to create or delete a Proxy ARP entry. The dwIndex is the index of // +// the interface on which to PARP for the dwAddress. If the interface is // +// of a type that doesnt support ARP, e.g. PPP, then the call will fail // +// // +////////////////////////////////////////////////////////////////////////////// + +{$IFNDEF IPHLPAPI_DYNLINK} + +function CreateProxyArpEntry(dwAddress, dwMask, dwIfIndex: DWORD): DWORD; stdcall; +{$EXTERNALSYM CreateProxyArpEntry} + +function DeleteProxyArpEntry(dwAddress, dwMask, dwIfIndex: DWORD): DWORD; stdcall; +{$EXTERNALSYM DeleteProxyArpEntry} + +{$ELSE} + +var + CreateProxyArpEntry: function (dwAddress, dwMask, dwIfIndex: DWORD): DWORD; stdcall; + {$EXTERNALSYM CreateProxyArpEntry} + + DeleteProxyArpEntry: function (dwAddress, dwMask, dwIfIndex: DWORD): DWORD; stdcall; + {$EXTERNALSYM DeleteProxyArpEntry} + +{$ENDIF} + +////////////////////////////////////////////////////////////////////////////// +// // +// Used to set the state of a TCP Connection. The only state that it can be // +// set to is MIB_TCP_STATE_DELETE_TCB. The complete MIB_TCPROW structure // +// MUST BE SPECIFIED // +// // +////////////////////////////////////////////////////////////////////////////// + +{$IFNDEF IPHLPAPI_DYNLINK} + +function SetTcpEntry(const pTcpRow: MIB_TCPROW): DWORD; stdcall; +{$EXTERNALSYM SetTcpEntry} + +function GetInterfaceInfo(pIfTable: PIP_INTERFACE_INFO; var dwOutBufLen: ULONG): DWORD; stdcall; +{$EXTERNALSYM GetInterfaceInfo} + +function GetUniDirectionalAdapterInfo(pIPIfInfo: PIP_UNIDIRECTIONAL_ADAPTER_ADDRESS; + var dwOutBufLen: ULONG): DWORD; stdcall; +{$EXTERNALSYM GetUniDirectionalAdapterInfo(OUT PIP_UNIDIRECTIONAL_ADAPTER_ADDRESS pIPIfInfo} + +{$ELSE} + +var + SetTcpEntry: function (const pTcpRow: MIB_TCPROW): DWORD; stdcall; + {$EXTERNALSYM SetTcpEntry} + + GetInterfaceInfo: function (pIfTable: PIP_INTERFACE_INFO; var dwOutBufLen: ULONG): DWORD; stdcall; + {$EXTERNALSYM GetInterfaceInfo} + + GetUniDirectionalAdapterInfo: function (pIPIfInfo: PIP_UNIDIRECTIONAL_ADAPTER_ADDRESS; + var dwOutBufLen: ULONG): DWORD; stdcall; + {$EXTERNALSYM GetUniDirectionalAdapterInfo(OUT PIP_UNIDIRECTIONAL_ADAPTER_ADDRESS pIPIfInfo} + +{$ENDIF} + +////////////////////////////////////////////////////////////////////////////// +// // +// Gets the "best" outgoing interface for the specified destination address // +// // +////////////////////////////////////////////////////////////////////////////// + +{$IFNDEF IPHLPAPI_DYNLINK} + +function GetBestInterface(dwDestAddr: IPAddr; var pdwBestIfIndex: DWORD): DWORD; stdcall; +{$EXTERNALSYM GetBestInterface} + +{$ELSE} + +var + GetBestInterface: function (dwDestAddr: IPAddr; var pdwBestIfIndex: DWORD): DWORD; stdcall; + {$EXTERNALSYM GetBestInterface} + +{$ENDIF} + +////////////////////////////////////////////////////////////////////////////// +// // +// Gets the best (longest matching prefix) route for the given destination // +// If the source address is also specified (i.e. is not 0x00000000), and // +// there are multiple "best" routes to the given destination, the returned // +// route will be one that goes out over the interface which has an address // +// that matches the source address // +// // +////////////////////////////////////////////////////////////////////////////// + +{$IFNDEF IPHLPAPI_DYNLINK} + +function GetBestRoute(dwDestAddr, dwSourceAddr: DWORD; pBestRoute: PMIB_IPFORWARDROW): DWORD; stdcall; +{$EXTERNALSYM GetBestRoute} + +function NotifyAddrChange(var Handle: THandle; overlapped: POVERLAPPED): DWORD; stdcall; +{$EXTERNALSYM NotifyAddrChange} + +function NotifyRouteChange(var Handle: THandle; overlapped: POVERLAPPED): DWORD; stdcall; +{$EXTERNALSYM NotifyRouteChange} + +function GetAdapterIndex(AdapterName: LPWSTR; var IfIndex: ULONG): DWORD; stdcall; +{$EXTERNALSYM GetAdapterIndex} + +function AddIPAddress(Address: IPAddr; IpMask: IPMask; IfIndex: DWORD; + var NTEContext, NTEInstance: ULONG): DWORD; stdcall; +{$EXTERNALSYM AddIPAddress} + +function DeleteIPAddress(NTEContext: ULONG): DWORD; stdcall; +{$EXTERNALSYM DeleteIPAddress} + +function GetNetworkParams(pFixedInfo: PFIXED_INFO; var pOutBufLen: ULONG): DWORD; stdcall; +{$EXTERNALSYM GetNetworkParams} + +function GetAdaptersInfo(pAdapterInfo: PIP_ADAPTER_INFO; var pOutBufLen: ULONG): DWORD; stdcall; +{$EXTERNALSYM GetAdaptersInfo} + +function GetPerAdapterInfo(IfIndex: ULONG; pPerAdapterInfo: PIP_PER_ADAPTER_INFO; + var pOutBufLen: ULONG): DWORD; stdcall; +{$EXTERNALSYM GetPerAdapterInfo} + +function IpReleaseAddress(const AdapterInfo: IP_ADAPTER_INDEX_MAP): DWORD; stdcall; +{$EXTERNALSYM IpReleaseAddress} + +function IpRenewAddress(const AdapterInfo: IP_ADAPTER_INDEX_MAP): DWORD; stdcall; +{$EXTERNALSYM IpRenewAddress} + +function SendARP(const DestIP, SrcIP: IPAddr; pMacAddr: PULONG; var PhyAddrLen: ULONG): DWORD; stdcall; +{$EXTERNALSYM SendARP} + +function GetRTTAndHopCount(DestIpAddress: IPAddr; var HopCount: ULONG; + MaxHops: ULONG; var RTT: ULONG): BOOL; stdcall; +{$EXTERNALSYM GetRTTAndHopCount} + +function GetFriendlyIfIndex(IfIndex: DWORD): DWORD; stdcall; +{$EXTERNALSYM GetFriendlyIfIndex} + +function EnableRouter(var pHandle: THandle; pOverlapped: POVERLAPPED): DWORD; stdcall; +{$EXTERNALSYM EnableRouter} + +function UnenableRouter(pOverlapped: POVERLAPPED; lpdwEnableCount: LPDWORD): DWORD; stdcall; +{$EXTERNALSYM UnenableRouter} + +{$ELSE} + +var + GetBestRoute: function (dwDestAddr, dwSourceAddr: DWORD; pBestRoute: PMIB_IPFORWARDROW): DWORD; stdcall; + {$EXTERNALSYM GetBestRoute} + + NotifyAddrChange: function (var Handle: THandle; overlapped: POVERLAPPED): DWORD; stdcall; + {$EXTERNALSYM NotifyAddrChange} + + NotifyRouteChange: function (var Handle: THandle; overlapped: POVERLAPPED): DWORD; stdcall; + {$EXTERNALSYM NotifyRouteChange} + + GetAdapterIndex: function (AdapterName: LPWSTR; var IfIndex: ULONG): DWORD; stdcall; + {$EXTERNALSYM GetAdapterIndex} + + AddIPAddress: function (Address: IPAddr; IpMask: IPMask; IfIndex: DWORD; + var NTEContext, NTEInstance: ULONG): DWORD; stdcall; + {$EXTERNALSYM AddIPAddress} + + DeleteIPAddress: function (NTEContext: ULONG): DWORD; stdcall; + {$EXTERNALSYM DeleteIPAddress} + + GetNetworkParams: function (pFixedInfo: PFIXED_INFO; var pOutBufLen: ULONG): DWORD; stdcall; + {$EXTERNALSYM GetNetworkParams} + + GetAdaptersInfo: function (pAdapterInfo: PIP_ADAPTER_INFO; var pOutBufLen: ULONG): DWORD; stdcall; + {$EXTERNALSYM GetAdaptersInfo} + + GetPerAdapterInfo: function (IfIndex: ULONG; pPerAdapterInfo: PIP_PER_ADAPTER_INFO; + var pOutBufLen: ULONG): DWORD; stdcall; + {$EXTERNALSYM GetPerAdapterInfo} + + IpReleaseAddress: function (const AdapterInfo: IP_ADAPTER_INDEX_MAP): DWORD; stdcall; + {$EXTERNALSYM IpReleaseAddress} + + IpRenewAddress: function (const AdapterInfo: IP_ADAPTER_INDEX_MAP): DWORD; stdcall; + {$EXTERNALSYM IpRenewAddress} + + SendARP: function (const DestIP, SrcIP: IPAddr; pMacAddr: PULONG; var PhyAddrLen: ULONG): DWORD; stdcall; + {$EXTERNALSYM SendARP} + + GetRTTAndHopCount: function (DestIpAddress: IPAddr; var HopCount: ULONG; + MaxHops: ULONG; var RTT: ULONG): BOOL; stdcall; + {$EXTERNALSYM GetRTTAndHopCount} + + GetFriendlyIfIndex: function (IfIndex: DWORD): DWORD; stdcall; + {$EXTERNALSYM GetFriendlyIfIndex} + + EnableRouter: function (var pHandle: THandle; pOverlapped: POVERLAPPED): DWORD; stdcall; + {$EXTERNALSYM EnableRouter} + + UnenableRouter: function (pOverlapped: POVERLAPPED; lpdwEnableCount: LPDWORD): DWORD; stdcall; + {$EXTERNALSYM UnenableRouter} + +{$ENDIF} + +{$IFDEF IPHLPAPI_LINKONREQUEST} + +function IpHlpApiInitAPI: Boolean; +procedure IpHlpApiFreeAPI; + +{$ENDIF} + +function IpHlpApiCheckAPI: Boolean; + +implementation + +const + iphlpapilib = 'iphlpapi.dll'; + +{$IFNDEF IPHLPAPI_DYNLINK} + +function GetNumberOfInterfaces; external iphlpapilib name 'GetNumberOfInterfaces'; +function GetIfEntry; external iphlpapilib name 'GetIfEntry'; +function GetIfTable; external iphlpapilib name 'GetIfTable'; +function GetIpAddrTable; external iphlpapilib name 'GetIpAddrTable'; +function GetIpNetTable; external iphlpapilib name 'GetIpNetTable'; +function GetIpForwardTable; external iphlpapilib name 'GetIpForwardTable'; +function GetTcpTable; external iphlpapilib name 'GetTcpTable'; +function GetUdpTable; external iphlpapilib name 'GetUdpTable'; +function GetIpStatistics; external iphlpapilib name 'GetIpStatistics'; +function GetIcmpStatistics; external iphlpapilib name 'GetIcmpStatistics'; +function GetTcpStatistics; external iphlpapilib name 'GetTcpStatistics'; +function GetUdpStatistics; external iphlpapilib name 'GetUdpStatistics'; +function SetIfEntry; external iphlpapilib name 'SetIfEntry'; +function CreateIpForwardEntry; external iphlpapilib name 'CreateIpForwardEntry'; +function SetIpForwardEntry; external iphlpapilib name 'SetIpForwardEntry'; +function DeleteIpForwardEntry; external iphlpapilib name 'DeleteIpForwardEntry'; +function SetIpStatistics; external iphlpapilib name 'SetIpStatistics'; +function SetIpTTL; external iphlpapilib name 'SetIpTTL'; +function CreateIpNetEntry; external iphlpapilib name 'CreateIpNetEntry'; +function SetIpNetEntry; external iphlpapilib name 'SetIpNetEntry'; +function DeleteIpNetEntry; external iphlpapilib name 'DeleteIpNetEntry'; +function FlushIpNetTable; external iphlpapilib name 'FlushIpNetTable'; +function CreateProxyArpEntry; external iphlpapilib name 'CreateProxyArpEntry'; +function DeleteProxyArpEntry; external iphlpapilib name 'DeleteProxyArpEntry'; +function SetTcpEntry; external iphlpapilib name 'SetTcpEntry'; +function GetInterfaceInfo; external iphlpapilib name 'GetInterfaceInfo'; +function GetUniDirectionalAdapterInfo; external iphlpapilib name 'GetUniDirectionalAdapterInfo'; +function GetBestInterface; external iphlpapilib name 'GetBestInterface'; +function GetBestRoute; external iphlpapilib name 'GetBestRoute'; +function NotifyAddrChange; external iphlpapilib name 'NotifyAddrChange'; +function NotifyRouteChange; external iphlpapilib name 'NotifyRouteChange'; +function GetAdapterIndex; external iphlpapilib name 'GetAdapterIndex'; +function AddIPAddress; external iphlpapilib name 'AddIPAddress'; +function DeleteIPAddress; external iphlpapilib name 'DeleteIPAddress'; +function GetNetworkParams; external iphlpapilib name 'GetNetworkParams'; +function GetAdaptersInfo; external iphlpapilib name 'GetAdaptersInfo'; +function GetPerAdapterInfo; external iphlpapilib name 'GetPerAdapterInfo'; +function IpReleaseAddress; external iphlpapilib name 'IpReleaseAddress'; +function IpRenewAddress; external iphlpapilib name 'IpRenewAddress'; +function SendARP; external iphlpapilib name 'SendARP'; +function GetRTTAndHopCount; external iphlpapilib name 'GetRTTAndHopCount'; +function GetFriendlyIfIndex; external iphlpapilib name 'GetFriendlyIfIndex'; +function EnableRouter; external iphlpapilib name 'EnableRouter'; +function UnenableRouter; external iphlpapilib name 'UnenableRouter'; + +{$ELSE} + +var + HIpHlpApi: THandle = 0; + +function IpHlpApiInitAPI: Boolean; +begin + Result := False; + if HIphlpapi = 0 then HIpHlpApi := LoadLibrary(iphlpapilib); + if HIpHlpApi > HINSTANCE_ERROR then + begin + @GetNetworkParams := GetProcAddress(HIpHlpApi, 'GetNetworkParams'); + @GetAdaptersInfo := GetProcAddress(HIpHlpApi, 'GetAdaptersInfo'); + @GetPerAdapterInfo := GetProcAddress(HIpHlpApi, 'GetPerAdapterInfo'); + @GetAdapterIndex := GetProcAddress(HIpHlpApi, 'GetAdapterIndex'); + @GetUniDirectionalAdapterInfo := GetProcAddress(HIpHlpApi, 'GetUniDirectionalAdapterInfo'); + @GetNumberOfInterfaces := GetProcAddress(HIpHlpApi, 'GetNumberOfInterfaces'); + @GetInterfaceInfo := GetProcAddress(HIpHlpApi, 'GetInterfaceInfo'); + @GetFriendlyIfIndex := GetProcAddress(HIpHlpApi, 'GetFriendlyIfIndex'); + @GetIfTable := GetProcAddress(HIpHlpApi, 'GetIfTable'); + @GetIfEntry := GetProcAddress(HIpHlpApi, 'GetIfEntry'); + @SetIfEntry := GetProcAddress(HIpHlpApi, 'SetIfEntry'); + @GetIpAddrTable := GetProcAddress(HIpHlpApi, 'GetIpAddrTable'); + @AddIPAddress := GetProcAddress(HIpHlpApi, 'AddIPAddress'); + @DeleteIPAddress := GetProcAddress(HIpHlpApi, 'DeleteIPAddress'); + @IpReleaseAddress := GetProcAddress(HIpHlpApi, 'IpReleaseAddress'); + @IpRenewAddress := GetProcAddress(HIpHlpApi, 'IpRenewAddress'); + @GetIpNetTable := GetProcAddress(HIpHlpApi, 'GetIpNetTable'); + @CreateIpNetEntry := GetProcAddress(HIpHlpApi, 'CreateIpNetEntry'); + @DeleteIpNetEntry := GetProcAddress(HIpHlpApi, 'DeleteIpNetEntry'); + @CreateProxyArpEntry := GetProcAddress(HIpHlpApi, 'CreateProxyArpEntry'); + @DeleteProxyArpEntry := GetProcAddress(HIpHlpApi, 'DeleteProxyArpEntry'); + @SendARP := GetProcAddress(HIpHlpApi, 'SendARP'); + @GetIpStatistics := GetProcAddress(HIpHlpApi, 'GetIpStatistics'); + @GetIcmpStatistics := GetProcAddress(HIpHlpApi, 'GetIcmpStatistics'); + @SetIpStatistics := GetProcAddress(HIpHlpApi, 'SetIpStatistics'); + @SetIpTTL := GetProcAddress(HIpHlpApi, 'SetIpTTL'); + @GetIpForwardTable := GetProcAddress(HIpHlpApi,'GetIpForwardTable'); + @CreateIpForwardEntry := GetProcAddress(HIpHlpApi, 'CreateIpForwardEntry'); + @GetTcpTable := GetProcAddress(HIpHlpApi, 'GetTcpTable'); + @GetUdpTable := GetProcAddress(HIpHlpApi, 'GetUdpTable'); + @GetTcpStatistics := GetProcAddress(HIpHlpApi, 'GetTcpStatistics'); + @GetUdpStatistics := GetProcAddress(HIpHlpApi, 'GetUdpStatistics'); + @SetIpForwardEntry := GetProcAddress(HIpHlpApi, 'SetIpForwardEntry'); + @DeleteIpForwardEntry := GetProcAddress(HIpHlpApi, 'DeleteIpForwardEntry'); + @SetIpNetEntry := GetProcAddress(HIpHlpApi, 'SetIpNetEntry'); + @SetTcpEntry := GetProcAddress(HIpHlpApi, 'SetTcpEntry'); + @GetBestRoute := GetProcAddress(HIpHlpApi, 'GetBestRoute'); + @NotifyAddrChange := GetProcAddress(HIpHlpApi, 'NotifyAddrChange'); + @NotifyRouteChange := GetProcAddress(HIpHlpApi, 'NotifyRouteChange'); + @GetBestInterface := GetProcAddress(HIpHlpApi, 'GetBestInterface'); + @GetRTTAndHopCount := GetProcAddress(HIpHlpApi, 'GetRTTAndHopCount'); + @EnableRouter := GetProcAddress(HIpHlpApi, 'EnableRouter'); + @UnenableRouter := GetProcAddress(HIpHlpApi, 'UnenableRouter'); + Result := True; + end; +end; + +procedure IpHlpApiFreeAPI; +begin + if HIpHlpApi <> 0 then FreeLibrary(HIpHlpApi); + HIpHlpApi := 0; +end; + +{$ENDIF} + +function IpHlpApiCheckAPI: Boolean; +begin + {$IFDEF IPHLPAPI_DYNLINK} + Result := HIpHlpApi <> 0; + {$ELSE} + Result := True; + {$ENDIF} +end; + +initialization + + {$IFDEF IPHLPAPI_DYNLINK} + {$IFNDEF IPHLPAPI_LINKONREQUEST} + IpHlpApiInitAPI; + {$ENDIF} + {$ENDIF} + +finalization + + {$IFDEF IPHLPAPI_DYNLINK} + IpHlpApiFreeAPI; + {$ENDIF} + +end. diff --git a/IpIfConst.pas b/IpIfConst.pas new file mode 100644 index 0000000..8097829 --- /dev/null +++ b/IpIfConst.pas @@ -0,0 +1,474 @@ +{******************************************************************************} +{ } +{ Internet Protocol Helper API interface Unit for Object Pascal } +{ } +{ Portions created by Microsoft are Copyright (C) 1995-2001 Microsoft } +{ Corporation. All Rights Reserved. } +{ } +{ The original file is: ipifcons.h, released July 2000. The original Pascal } +{ code is: IpIfCons.pas, released September 2000. The initial developer of the } +{ Pascal code is Marcel van Brakel (brakelm@chello.nl). } +{ } +{ Portions created by Marcel van Brakel are Copyright (C) 1999-2001 } +{ Marcel van Brakel. All Rights Reserved. } +{ } +{ Contributor(s): John C. Penman (jcp@craiglockhart.com) } +{ Vladimir Vassiliev (voldemarv@hotpop.com) } +{ } +{ Obtained through: Joint Endeavour of Delphi Innovators (Project JEDI) } +{ } +{ You may retrieve the latest version of this file at the Project JEDI home } +{ page, located at http://delphi-jedi.org or my personal homepage located at } +{ http://members.chello.nl/m.vanbrakel2 } +{ } +{ The contents of this file are used with permission, subject to the Mozilla } +{ Public License Version 1.1 (the "License"); you may not use this file except } +{ in compliance with the License. You may obtain a copy of the License at } +{ http://www.mozilla.org/MPL/MPL-1.1.html } +{ } +{ Software distributed under the License is distributed on an "AS IS" basis, } +{ WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for } +{ the specific language governing rights and limitations under the License. } +{ } +{ Alternatively, the contents of this file may be used under the terms of the } +{ GNU Lesser General Public License (the "LGPL License"), in which case the } +{ provisions of the LGPL License are applicable instead of those above. } +{ If you wish to allow use of your version of this file only under the terms } +{ of the LGPL License and not to allow others to use your version of this file } +{ under the MPL, indicate your decision by deleting the provisions above and } +{ replace them with the notice and other provisions required by the LGPL } +{ License. If you do not delete the provisions above, a recipient may use } +{ your version of this file under either the MPL or the LGPL License. } +{ } +{ For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html } +{ } +{******************************************************************************} + +unit IpIfConst; + +{$WEAKPACKAGEUNIT} + +{$HPPEMIT ''} +{$HPPEMIT '#include "ipifcons.h"'} +{$HPPEMIT ''} + +//{$I WINDEFINES.INC} + +interface + +////////////////////////////////////////////////////////////////////////////// +// // +// Media types // +// // +////////////////////////////////////////////////////////////////////////////// + +const + MIN_IF_TYPE = 1; + {$EXTERNALSYM MIN_IF_TYPE} + + IF_TYPE_OTHER = 1; // None of the below + {$EXTERNALSYM IF_TYPE_OTHER} + IF_TYPE_REGULAR_1822 = 2; + {$EXTERNALSYM IF_TYPE_REGULAR_1822} + IF_TYPE_HDH_1822 = 3; + {$EXTERNALSYM IF_TYPE_HDH_1822} + IF_TYPE_DDN_X25 = 4; + {$EXTERNALSYM IF_TYPE_DDN_X25} + IF_TYPE_RFC877_X25 = 5; + {$EXTERNALSYM IF_TYPE_RFC877_X25} + IF_TYPE_ETHERNET_CSMACD = 6; + {$EXTERNALSYM IF_TYPE_ETHERNET_CSMACD} + IF_TYPE_IS088023_CSMACD = 7; + {$EXTERNALSYM IF_TYPE_IS088023_CSMACD} + IF_TYPE_ISO88024_TOKENBUS = 8; + {$EXTERNALSYM IF_TYPE_ISO88024_TOKENBUS} + IF_TYPE_ISO88025_TOKENRING = 9; + {$EXTERNALSYM IF_TYPE_ISO88025_TOKENRING} + IF_TYPE_ISO88026_MAN = 10; + {$EXTERNALSYM IF_TYPE_ISO88026_MAN} + IF_TYPE_STARLAN = 11; + {$EXTERNALSYM IF_TYPE_STARLAN} + IF_TYPE_PROTEON_10MBIT = 12; + {$EXTERNALSYM IF_TYPE_PROTEON_10MBIT} + IF_TYPE_PROTEON_80MBIT = 13; + {$EXTERNALSYM IF_TYPE_PROTEON_80MBIT} + IF_TYPE_HYPERCHANNEL = 14; + {$EXTERNALSYM IF_TYPE_HYPERCHANNEL} + IF_TYPE_FDDI = 15; + {$EXTERNALSYM IF_TYPE_FDDI} + IF_TYPE_LAP_B = 16; + {$EXTERNALSYM IF_TYPE_LAP_B} + IF_TYPE_SDLC = 17; + {$EXTERNALSYM IF_TYPE_SDLC} + IF_TYPE_DS1 = 18; // DS1-MIB + {$EXTERNALSYM IF_TYPE_DS1} + IF_TYPE_E1 = 19; // Obsolete; see DS1-MIB + {$EXTERNALSYM IF_TYPE_E1} + IF_TYPE_BASIC_ISDN = 20; + {$EXTERNALSYM IF_TYPE_BASIC_ISDN} + IF_TYPE_PRIMARY_ISDN = 21; + {$EXTERNALSYM IF_TYPE_PRIMARY_ISDN} + IF_TYPE_PROP_POINT2POINT_SERIAL = 22; // proprietary serial + {$EXTERNALSYM IF_TYPE_PROP_POINT2POINT_SERIAL} + IF_TYPE_PPP = 23; + {$EXTERNALSYM IF_TYPE_PPP} + IF_TYPE_SOFTWARE_LOOPBACK = 24; + {$EXTERNALSYM IF_TYPE_SOFTWARE_LOOPBACK} + IF_TYPE_EON = 25; // CLNP over IP + {$EXTERNALSYM IF_TYPE_EON} + IF_TYPE_ETHERNET_3MBIT = 26; + {$EXTERNALSYM IF_TYPE_ETHERNET_3MBIT} + IF_TYPE_NSIP = 27; // XNS over IP + {$EXTERNALSYM IF_TYPE_NSIP} + IF_TYPE_SLIP = 28; // Generic Slip + {$EXTERNALSYM IF_TYPE_SLIP} + IF_TYPE_ULTRA = 29; // ULTRA Technologies + {$EXTERNALSYM IF_TYPE_ULTRA} + IF_TYPE_DS3 = 30; // DS3-MIB + {$EXTERNALSYM IF_TYPE_DS3} + IF_TYPE_SIP = 31; // SMDS, coffee + {$EXTERNALSYM IF_TYPE_SIP} + IF_TYPE_FRAMERELAY = 32; // DTE only + {$EXTERNALSYM IF_TYPE_FRAMERELAY} + IF_TYPE_RS232 = 33; + {$EXTERNALSYM IF_TYPE_RS232} + IF_TYPE_PARA = 34; // Parallel port + {$EXTERNALSYM IF_TYPE_PARA} + IF_TYPE_ARCNET = 35; + {$EXTERNALSYM IF_TYPE_ARCNET} + IF_TYPE_ARCNET_PLUS = 36; + {$EXTERNALSYM IF_TYPE_ARCNET_PLUS} + IF_TYPE_ATM = 37; // ATM cells + {$EXTERNALSYM IF_TYPE_ATM} + IF_TYPE_MIO_X25 = 38; + {$EXTERNALSYM IF_TYPE_MIO_X25} + IF_TYPE_SONET = 39; // SONET or SDH + {$EXTERNALSYM IF_TYPE_SONET} + IF_TYPE_X25_PLE = 40; + {$EXTERNALSYM IF_TYPE_X25_PLE} + IF_TYPE_ISO88022_LLC = 41; + {$EXTERNALSYM IF_TYPE_ISO88022_LLC} + IF_TYPE_LOCALTALK = 42; + {$EXTERNALSYM IF_TYPE_LOCALTALK} + IF_TYPE_SMDS_DXI = 43; + {$EXTERNALSYM IF_TYPE_SMDS_DXI} + IF_TYPE_FRAMERELAY_SERVICE = 44; // FRNETSERV-MIB + {$EXTERNALSYM IF_TYPE_FRAMERELAY_SERVICE} + IF_TYPE_V35 = 45; + {$EXTERNALSYM IF_TYPE_V35} + IF_TYPE_HSSI = 46; + {$EXTERNALSYM IF_TYPE_HSSI} + IF_TYPE_HIPPI = 47; + {$EXTERNALSYM IF_TYPE_HIPPI} + IF_TYPE_MODEM = 48; // Generic Modem + {$EXTERNALSYM IF_TYPE_MODEM} + IF_TYPE_AAL5 = 49; // AAL5 over ATM + {$EXTERNALSYM IF_TYPE_AAL5} + IF_TYPE_SONET_PATH = 50; + {$EXTERNALSYM IF_TYPE_SONET_PATH} + IF_TYPE_SONET_VT = 51; + {$EXTERNALSYM IF_TYPE_SONET_VT} + IF_TYPE_SMDS_ICIP = 52; // SMDS InterCarrier Interface + {$EXTERNALSYM IF_TYPE_SMDS_ICIP} + IF_TYPE_PROP_VIRTUAL = 53; // Proprietary virtual/internal + {$EXTERNALSYM IF_TYPE_PROP_VIRTUAL} + IF_TYPE_PROP_MULTIPLEXOR = 54; // Proprietary multiplexing + {$EXTERNALSYM IF_TYPE_PROP_MULTIPLEXOR} + IF_TYPE_IEEE80212 = 55; // 100BaseVG + {$EXTERNALSYM IF_TYPE_IEEE80212} + IF_TYPE_FIBRECHANNEL = 56; + {$EXTERNALSYM IF_TYPE_FIBRECHANNEL} + IF_TYPE_HIPPIINTERFACE = 57; + {$EXTERNALSYM IF_TYPE_HIPPIINTERFACE} + IF_TYPE_FRAMERELAY_INTERCONNECT = 58; // Obsolete, use 32 or 44 + {$EXTERNALSYM IF_TYPE_FRAMERELAY_INTERCONNECT} + IF_TYPE_AFLANE_8023 = 59; // ATM Emulated LAN for 802.3 + {$EXTERNALSYM IF_TYPE_AFLANE_8023} + IF_TYPE_AFLANE_8025 = 60; // ATM Emulated LAN for 802.5 + {$EXTERNALSYM IF_TYPE_AFLANE_8025} + IF_TYPE_CCTEMUL = 61; // ATM Emulated circuit + {$EXTERNALSYM IF_TYPE_CCTEMUL} + IF_TYPE_FASTETHER = 62; // Fast Ethernet (100BaseT) + {$EXTERNALSYM IF_TYPE_FASTETHER} + IF_TYPE_ISDN = 63; // ISDN and X.25 + {$EXTERNALSYM IF_TYPE_ISDN} + IF_TYPE_V11 = 64; // CCITT V.11/X.21 + {$EXTERNALSYM IF_TYPE_V11} + IF_TYPE_V36 = 65; // CCITT V.36 + {$EXTERNALSYM IF_TYPE_V36} + IF_TYPE_G703_64K = 66; // CCITT G703 at 64Kbps + {$EXTERNALSYM IF_TYPE_G703_64K} + IF_TYPE_G703_2MB = 67; // Obsolete; see DS1-MIB + {$EXTERNALSYM IF_TYPE_G703_2MB} + IF_TYPE_QLLC = 68; // SNA QLLC + {$EXTERNALSYM IF_TYPE_QLLC} + IF_TYPE_FASTETHER_FX = 69; // Fast Ethernet (100BaseFX) + {$EXTERNALSYM IF_TYPE_FASTETHER_FX} + IF_TYPE_CHANNEL = 70; + {$EXTERNALSYM IF_TYPE_CHANNEL} + IF_TYPE_IEEE80211 = 71; // Radio spread spectrum + {$EXTERNALSYM IF_TYPE_IEEE80211} + IF_TYPE_IBM370PARCHAN = 72; // IBM System 360/370 OEMI Channel + {$EXTERNALSYM IF_TYPE_IBM370PARCHAN} + IF_TYPE_ESCON = 73; // IBM Enterprise Systems Connection + {$EXTERNALSYM IF_TYPE_ESCON} + IF_TYPE_DLSW = 74; // Data Link Switching + {$EXTERNALSYM IF_TYPE_DLSW} + IF_TYPE_ISDN_S = 75; // ISDN S/T interface + {$EXTERNALSYM IF_TYPE_ISDN_S} + IF_TYPE_ISDN_U = 76; // ISDN U interface + {$EXTERNALSYM IF_TYPE_ISDN_U} + IF_TYPE_LAP_D = 77; // Link Access Protocol D + {$EXTERNALSYM IF_TYPE_LAP_D} + IF_TYPE_IPSWITCH = 78; // IP Switching Objects + {$EXTERNALSYM IF_TYPE_IPSWITCH} + IF_TYPE_RSRB = 79; // Remote Source Route Bridging + {$EXTERNALSYM IF_TYPE_RSRB} + IF_TYPE_ATM_LOGICAL = 80; // ATM Logical Port + {$EXTERNALSYM IF_TYPE_ATM_LOGICAL} + IF_TYPE_DS0 = 81; // Digital Signal Level 0 + {$EXTERNALSYM IF_TYPE_DS0} + IF_TYPE_DS0_BUNDLE = 82; // Group of ds0s on the same ds1 + {$EXTERNALSYM IF_TYPE_DS0_BUNDLE} + IF_TYPE_BSC = 83; // Bisynchronous Protocol + {$EXTERNALSYM IF_TYPE_BSC} + IF_TYPE_ASYNC = 84; // Asynchronous Protocol + {$EXTERNALSYM IF_TYPE_ASYNC} + IF_TYPE_CNR = 85; // Combat Net Radio + {$EXTERNALSYM IF_TYPE_CNR} + IF_TYPE_ISO88025R_DTR = 86; // ISO 802.5r DTR + {$EXTERNALSYM IF_TYPE_ISO88025R_DTR} + IF_TYPE_EPLRS = 87; // Ext Pos Loc Report Sys + {$EXTERNALSYM IF_TYPE_EPLRS} + IF_TYPE_ARAP = 88; // Appletalk Remote Access Protocol + {$EXTERNALSYM IF_TYPE_ARAP} + IF_TYPE_PROP_CNLS = 89; // Proprietary Connectionless Proto + {$EXTERNALSYM IF_TYPE_PROP_CNLS} + IF_TYPE_HOSTPAD = 90; // CCITT-ITU X.29 PAD Protocol + {$EXTERNALSYM IF_TYPE_HOSTPAD} + IF_TYPE_TERMPAD = 91; // CCITT-ITU X.3 PAD Facility + {$EXTERNALSYM IF_TYPE_TERMPAD} + IF_TYPE_FRAMERELAY_MPI = 92; // Multiproto Interconnect over FR + {$EXTERNALSYM IF_TYPE_FRAMERELAY_MPI} + IF_TYPE_X213 = 93; // CCITT-ITU X213 + {$EXTERNALSYM IF_TYPE_X213} + IF_TYPE_ADSL = 94; // Asymmetric Digital Subscrbr Loop + {$EXTERNALSYM IF_TYPE_ADSL} + IF_TYPE_RADSL = 95; // Rate-Adapt Digital Subscrbr Loop + {$EXTERNALSYM IF_TYPE_RADSL} + IF_TYPE_SDSL = 96; // Symmetric Digital Subscriber Loop + {$EXTERNALSYM IF_TYPE_SDSL} + IF_TYPE_VDSL = 97; // Very H-Speed Digital Subscrb Loop + {$EXTERNALSYM IF_TYPE_VDSL} + IF_TYPE_ISO88025_CRFPRINT = 98; // ISO 802.5 CRFP + {$EXTERNALSYM IF_TYPE_ISO88025_CRFPRINT} + IF_TYPE_MYRINET = 99; // Myricom Myrinet + {$EXTERNALSYM IF_TYPE_MYRINET} + IF_TYPE_VOICE_EM = 100; // Voice recEive and transMit + {$EXTERNALSYM IF_TYPE_VOICE_EM} + IF_TYPE_VOICE_FXO = 101; // Voice Foreign Exchange Office + {$EXTERNALSYM IF_TYPE_VOICE_FXO} + IF_TYPE_VOICE_FXS = 102; // Voice Foreign Exchange Station + {$EXTERNALSYM IF_TYPE_VOICE_FXS} + IF_TYPE_VOICE_ENCAP = 103; // Voice encapsulation + {$EXTERNALSYM IF_TYPE_VOICE_ENCAP} + IF_TYPE_VOICE_OVERIP = 104; // Voice over IP encapsulation + {$EXTERNALSYM IF_TYPE_VOICE_OVERIP} + IF_TYPE_ATM_DXI = 105; // ATM DXI + {$EXTERNALSYM IF_TYPE_ATM_DXI} + IF_TYPE_ATM_FUNI = 106; // ATM FUNI + {$EXTERNALSYM IF_TYPE_ATM_FUNI} + IF_TYPE_ATM_IMA = 107; // ATM IMA + {$EXTERNALSYM IF_TYPE_ATM_IMA} + IF_TYPE_PPPMULTILINKBUNDLE = 108; // PPP Multilink Bundle + {$EXTERNALSYM IF_TYPE_PPPMULTILINKBUNDLE} + IF_TYPE_IPOVER_CDLC = 109; // IBM ipOverCdlc + {$EXTERNALSYM IF_TYPE_IPOVER_CDLC} + IF_TYPE_IPOVER_CLAW = 110; // IBM Common Link Access to Workstn + {$EXTERNALSYM IF_TYPE_IPOVER_CLAW} + IF_TYPE_STACKTOSTACK = 111; // IBM stackToStack + {$EXTERNALSYM IF_TYPE_STACKTOSTACK} + IF_TYPE_VIRTUALIPADDRESS = 112; // IBM VIPA + {$EXTERNALSYM IF_TYPE_VIRTUALIPADDRESS} + IF_TYPE_MPC = 113; // IBM multi-proto channel support + {$EXTERNALSYM IF_TYPE_MPC} + IF_TYPE_IPOVER_ATM = 114; // IBM ipOverAtm + {$EXTERNALSYM IF_TYPE_IPOVER_ATM} + IF_TYPE_ISO88025_FIBER = 115; // ISO 802.5j Fiber Token Ring + {$EXTERNALSYM IF_TYPE_ISO88025_FIBER} + IF_TYPE_TDLC = 116; // IBM twinaxial data link control + {$EXTERNALSYM IF_TYPE_TDLC} + IF_TYPE_GIGABITETHERNET = 117; + {$EXTERNALSYM IF_TYPE_GIGABITETHERNET} + IF_TYPE_HDLC = 118; + {$EXTERNALSYM IF_TYPE_HDLC} + IF_TYPE_LAP_F = 119; + {$EXTERNALSYM IF_TYPE_LAP_F} + IF_TYPE_V37 = 120; + {$EXTERNALSYM IF_TYPE_V37} + IF_TYPE_X25_MLP = 121; // Multi-Link Protocol + {$EXTERNALSYM IF_TYPE_X25_MLP} + IF_TYPE_X25_HUNTGROUP = 122; // X.25 Hunt Group + {$EXTERNALSYM IF_TYPE_X25_HUNTGROUP} + IF_TYPE_TRANSPHDLC = 123; + {$EXTERNALSYM IF_TYPE_TRANSPHDLC} + IF_TYPE_INTERLEAVE = 124; // Interleave channel + {$EXTERNALSYM IF_TYPE_INTERLEAVE} + IF_TYPE_FAST = 125; // Fast channel + {$EXTERNALSYM IF_TYPE_FAST} + IF_TYPE_IP = 126; // IP (for APPN HPR in IP networks) + {$EXTERNALSYM IF_TYPE_IP} + IF_TYPE_DOCSCABLE_MACLAYER = 127; // CATV Mac Layer + {$EXTERNALSYM IF_TYPE_DOCSCABLE_MACLAYER} + IF_TYPE_DOCSCABLE_DOWNSTREAM = 128; // CATV Downstream interface + {$EXTERNALSYM IF_TYPE_DOCSCABLE_DOWNSTREAM} + IF_TYPE_DOCSCABLE_UPSTREAM = 129; // CATV Upstream interface + {$EXTERNALSYM IF_TYPE_DOCSCABLE_UPSTREAM} + IF_TYPE_A12MPPSWITCH = 130; // Avalon Parallel Processor + {$EXTERNALSYM IF_TYPE_A12MPPSWITCH} + IF_TYPE_TUNNEL = 131; // Encapsulation interface + {$EXTERNALSYM IF_TYPE_TUNNEL} + IF_TYPE_COFFEE = 132; // Coffee pot + {$EXTERNALSYM IF_TYPE_COFFEE} + IF_TYPE_CES = 133; // Circuit Emulation Service + {$EXTERNALSYM IF_TYPE_CES} + IF_TYPE_ATM_SUBINTERFACE = 134; // ATM Sub Interface + {$EXTERNALSYM IF_TYPE_ATM_SUBINTERFACE} + IF_TYPE_L2_VLAN = 135; // Layer 2 Virtual LAN using 802.1Q + {$EXTERNALSYM IF_TYPE_L2_VLAN} + IF_TYPE_L3_IPVLAN = 136; // Layer 3 Virtual LAN using IP + {$EXTERNALSYM IF_TYPE_L3_IPVLAN} + IF_TYPE_L3_IPXVLAN = 137; // Layer 3 Virtual LAN using IPX + {$EXTERNALSYM IF_TYPE_L3_IPXVLAN} + IF_TYPE_DIGITALPOWERLINE = 138; // IP over Power Lines + {$EXTERNALSYM IF_TYPE_DIGITALPOWERLINE} + IF_TYPE_MEDIAMAILOVERIP = 139; // Multimedia Mail over IP + {$EXTERNALSYM IF_TYPE_MEDIAMAILOVERIP} + IF_TYPE_DTM = 140; // Dynamic syncronous Transfer Mode + {$EXTERNALSYM IF_TYPE_DTM} + IF_TYPE_DCN = 141; // Data Communications Network + {$EXTERNALSYM IF_TYPE_DCN} + IF_TYPE_IPFORWARD = 142; // IP Forwarding Interface + {$EXTERNALSYM IF_TYPE_IPFORWARD} + IF_TYPE_MSDSL = 143; // Multi-rate Symmetric DSL + {$EXTERNALSYM IF_TYPE_MSDSL} + IF_TYPE_IEEE1394 = 144; // IEEE1394 High Perf Serial Bus + {$EXTERNALSYM IF_TYPE_IEEE1394} + + MAX_IF_TYPE = 144; + {$EXTERNALSYM MAX_IF_TYPE} + +////////////////////////////////////////////////////////////////////////////// +// // +// Access types // +// // +////////////////////////////////////////////////////////////////////////////// + + IF_ACCESS_LOOPBACK = 1; + {$EXTERNALSYM IF_ACCESS_LOOPBACK} + IF_ACCESS_BROADCAST = 2; + {$EXTERNALSYM IF_ACCESS_BROADCAST} + IF_ACCESS_POINTTOPOINT = 3; + {$EXTERNALSYM IF_ACCESS_POINTTOPOINT} + IF_ACCESS_POINTTOMULTIPOINT = 4; + {$EXTERNALSYM IF_ACCESS_POINTTOMULTIPOINT} + +////////////////////////////////////////////////////////////////////////////// +// // +// Connection Types // +// // +////////////////////////////////////////////////////////////////////////////// + + IF_CONNECTION_DEDICATED = 1; + {$EXTERNALSYM IF_CONNECTION_DEDICATED} + IF_CONNECTION_PASSIVE = 2; + {$EXTERNALSYM IF_CONNECTION_PASSIVE} + IF_CONNECTION_DEMAND = 3; + {$EXTERNALSYM IF_CONNECTION_DEMAND} + + IF_ADMIN_STATUS_UP = 1; + {$EXTERNALSYM IF_ADMIN_STATUS_UP} + IF_ADMIN_STATUS_DOWN = 2; + {$EXTERNALSYM IF_ADMIN_STATUS_DOWN} + IF_ADMIN_STATUS_TESTING = 3; + {$EXTERNALSYM IF_ADMIN_STATUS_TESTING} + +////////////////////////////////////////////////////////////////////////////// +// // +// The following are the the operational states for WAN and LAN interfaces. // +// The order of the states seems weird, but is done for a purpose. All // +// states >= CONNECTED can transmit data right away. States >= DISCONNECTED // +// can tx data but some set up might be needed. States < DISCONNECTED can // +// not transmit data. // +// A card is marked UNREACHABLE if DIM calls InterfaceUnreachable for // +// reasons other than failure to connect. // +// // +// NON_OPERATIONAL -- Valid for LAN Interfaces. Means the card is not // +// working or not plugged in or has no address. // +// UNREACHABLE -- Valid for WAN Interfaces. Means the remote site is // +// not reachable at this time. // +// DISCONNECTED -- Valid for WAN Interfaces. Means the remote site is // +// not connected at this time. // +// CONNECTING -- Valid for WAN Interfaces. Means a connection attempt // +// has been initiated to the remote site. // +// CONNECTED -- Valid for WAN Interfaces. Means the remote site is // +// connected. // +// OPERATIONAL -- Valid for LAN Interfaces. Means the card is plugged // +// in and working. // +// // +// It is the users duty to convert these values to MIB-II values if they // +// are to be used by a subagent // +// // +////////////////////////////////////////////////////////////////////////////// + + IF_OPER_STATUS_NON_OPERATIONAL = 0; + {$EXTERNALSYM IF_OPER_STATUS_NON_OPERATIONAL} + IF_OPER_STATUS_UNREACHABLE = 1; + {$EXTERNALSYM IF_OPER_STATUS_UNREACHABLE} + IF_OPER_STATUS_DISCONNECTED = 2; + {$EXTERNALSYM IF_OPER_STATUS_DISCONNECTED} + IF_OPER_STATUS_CONNECTING = 3; + {$EXTERNALSYM IF_OPER_STATUS_CONNECTING} + IF_OPER_STATUS_CONNECTED = 4; + {$EXTERNALSYM IF_OPER_STATUS_CONNECTED} + IF_OPER_STATUS_OPERATIONAL = 5; + {$EXTERNALSYM IF_OPER_STATUS_OPERATIONAL} + + MIB_IF_TYPE_OTHER = 1; + {$EXTERNALSYM MIB_IF_TYPE_OTHER} + MIB_IF_TYPE_ETHERNET = 6; + {$EXTERNALSYM MIB_IF_TYPE_ETHERNET} + MIB_IF_TYPE_TOKENRING = 9; + {$EXTERNALSYM MIB_IF_TYPE_TOKENRING} + MIB_IF_TYPE_FDDI = 15; + {$EXTERNALSYM MIB_IF_TYPE_FDDI} + MIB_IF_TYPE_PPP = 23; + {$EXTERNALSYM MIB_IF_TYPE_PPP} + MIB_IF_TYPE_LOOPBACK = 24; + {$EXTERNALSYM MIB_IF_TYPE_LOOPBACK} + MIB_IF_TYPE_SLIP = 28; + {$EXTERNALSYM MIB_IF_TYPE_SLIP} + + MIB_IF_ADMIN_STATUS_UP = 1; + {$EXTERNALSYM MIB_IF_ADMIN_STATUS_UP} + MIB_IF_ADMIN_STATUS_DOWN = 2; + {$EXTERNALSYM MIB_IF_ADMIN_STATUS_DOWN} + MIB_IF_ADMIN_STATUS_TESTING = 3; + {$EXTERNALSYM MIB_IF_ADMIN_STATUS_TESTING} + + MIB_IF_OPER_STATUS_NON_OPERATIONAL = 0; + {$EXTERNALSYM MIB_IF_OPER_STATUS_NON_OPERATIONAL} + MIB_IF_OPER_STATUS_UNREACHABLE = 1; + {$EXTERNALSYM MIB_IF_OPER_STATUS_UNREACHABLE} + MIB_IF_OPER_STATUS_DISCONNECTED = 2; + {$EXTERNALSYM MIB_IF_OPER_STATUS_DISCONNECTED} + MIB_IF_OPER_STATUS_CONNECTING = 3; + {$EXTERNALSYM MIB_IF_OPER_STATUS_CONNECTING} + MIB_IF_OPER_STATUS_CONNECTED = 4; + {$EXTERNALSYM MIB_IF_OPER_STATUS_CONNECTED} + MIB_IF_OPER_STATUS_OPERATIONAL = 5; + {$EXTERNALSYM MIB_IF_OPER_STATUS_OPERATIONAL} + +implementation + +end. diff --git a/IpRtrMib.pas b/IpRtrMib.pas new file mode 100644 index 0000000..45f511e --- /dev/null +++ b/IpRtrMib.pas @@ -0,0 +1,1062 @@ +{******************************************************************************} +{ } +{ Management Information Base API interface Unit for Object Pascal } +{ } +{ Portions created by Microsoft are Copyright (C) 1995-2001 Microsoft } +{ Corporation. All Rights Reserved. } +{ } +{ The original file is: iprtrmib.h, released July 2000. The original Pascal } +{ code is: IpRtrMib.pas, released September 2000. The initial developer of the } +{ Pascal code is Marcel van Brakel (brakelm@chello.nl). } +{ } +{ Portions created by Marcel van Brakel are Copyright (C) 1999-2001 } +{ Marcel van Brakel. All Rights Reserved. } +{ } +{ Contributor(s): John C. Penman (jcp@craiglockhart.com) } +{ Vladimir Vassiliev (voldemarv@hotpop.com) } +{ } +{ Obtained through: Joint Endeavour of Delphi Innovators (Project JEDI) } +{ } +{ You may retrieve the latest version of this file at the Project JEDI home } +{ page, located at http://delphi-jedi.org or my personal homepage located at } +{ http://members.chello.nl/m.vanbrakel2 } +{ } +{ The contents of this file are used with permission, subject to the Mozilla } +{ Public License Version 1.1 (the "License"); you may not use this file except } +{ in compliance with the License. You may obtain a copy of the License at } +{ http://www.mozilla.org/MPL/MPL-1.1.html } +{ } +{ Software distributed under the License is distributed on an "AS IS" basis, } +{ WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for } +{ the specific language governing rights and limitations under the License. } +{ } +{ Alternatively, the contents of this file may be used under the terms of the } +{ GNU Lesser General Public License (the "LGPL License"), in which case the } +{ provisions of the LGPL License are applicable instead of those above. } +{ If you wish to allow use of your version of this file only under the terms } +{ of the LGPL License and not to allow others to use your version of this file } +{ under the MPL, indicate your decision by deleting the provisions above and } +{ replace them with the notice and other provisions required by the LGPL } +{ License. If you do not delete the provisions above, a recipient may use } +{ your version of this file under either the MPL or the LGPL License. } +{ } +{ For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html } +{ } +{******************************************************************************} + +unit IpRtrMib; + +{$WEAKPACKAGEUNIT} + +{$HPPEMIT ''} +{$HPPEMIT '#include "iprtrmib.h"'} +{$HPPEMIT ''} + +//{$I WINDEFINES.INC} + +interface + +uses + Windows; + +////////////////////////////////////////////////////////////////////////////// +// // +// Included to get the value of MAX_INTERFACE_NAME_LEN // +// // +////////////////////////////////////////////////////////////////////////////// + +// #include + +////////////////////////////////////////////////////////////////////////////// +// // +// Included to get the necessary constants // +// // +////////////////////////////////////////////////////////////////////////////// + +// #include + +////////////////////////////////////////////////////////////////////////////// +// // +// This is the Id for IP Router Manager. The Router Manager handles // +// MIB-II, Forwarding MIB and some enterprise specific information. // +// Calls made with any other ID are passed on to the corresponding protocol // +// For example, an MprAdminMIBXXX call with a protocol ID of PID_IP and // +// a routing Id of 0xD will be sent to the IP Router Manager and then // +// forwarded to OSPF // +// This lives in the same number space as the protocol Ids of RIP, OSPF // +// etc, so any change made to it should be done keeping this in mind // +// // +////////////////////////////////////////////////////////////////////////////// + +const + MAX_INTERFACE_NAME_LEN = 256; // MPRAPI.H + {$EXTERNALSYM MAX_INTERFACE_NAME_LEN} + + IPRTRMGR_PID = 10000; + {$EXTERNALSYM IPRTRMGR_PID} + + ANY_SIZE = 1; + {$EXTERNALSYM ANY_SIZE} + +////////////////////////////////////////////////////////////////////////////// +// // +// The following #defines are the Ids of the MIB variables made accessible // +// to the user via MprAdminMIBXXX Apis. It will be noticed that these are // +// not the same as RFC 1213, since the MprAdminMIBXXX APIs work on rows and // +// groups instead of scalar variables // +// // +////////////////////////////////////////////////////////////////////////////// + + IF_NUMBER = 0; + {$EXTERNALSYM IF_NUMBER} + IF_TABLE = IF_NUMBER + 1; + {$EXTERNALSYM IF_TABLE} + IF_ROW = IF_TABLE + 1; + {$EXTERNALSYM IF_ROW} + IP_STATS = IF_ROW + 1; + {$EXTERNALSYM IP_STATS} + IP_ADDRTABLE = IP_STATS + 1; + {$EXTERNALSYM IP_ADDRTABLE} + IP_ADDRROW = IP_ADDRTABLE + 1; + {$EXTERNALSYM IP_ADDRROW} + IP_FORWARDNUMBER = IP_ADDRROW + 1; + {$EXTERNALSYM IP_FORWARDNUMBER} + IP_FORWARDTABLE = IP_FORWARDNUMBER + 1; + {$EXTERNALSYM IP_FORWARDTABLE} + IP_FORWARDROW = IP_FORWARDTABLE + 1; + {$EXTERNALSYM IP_FORWARDROW} + IP_NETTABLE = IP_FORWARDROW + 1; + {$EXTERNALSYM IP_NETTABLE} + IP_NETROW = IP_NETTABLE + 1; + {$EXTERNALSYM IP_NETROW} + ICMP_STATS = IP_NETROW + 1; + {$EXTERNALSYM ICMP_STATS} + TCP_STATS = ICMP_STATS + 1; + {$EXTERNALSYM TCP_STATS} + TCP_TABLE = TCP_STATS + 1; + {$EXTERNALSYM TCP_TABLE} + TCP_ROW = TCP_TABLE + 1; + {$EXTERNALSYM TCP_ROW} + UDP_STATS = TCP_ROW + 1; + {$EXTERNALSYM UDP_STATS} + UDP_TABLE = UDP_STATS + 1; + {$EXTERNALSYM UDP_TABLE} + UDP_ROW = UDP_TABLE + 1; + {$EXTERNALSYM UDP_ROW} + MCAST_MFE = UDP_ROW + 1; + {$EXTERNALSYM MCAST_MFE} + MCAST_MFE_STATS = MCAST_MFE + 1; + {$EXTERNALSYM MCAST_MFE_STATS} + BEST_IF = MCAST_MFE_STATS + 1; + {$EXTERNALSYM BEST_IF} + BEST_ROUTE = BEST_IF + 1; + {$EXTERNALSYM BEST_ROUTE} + PROXY_ARP = BEST_ROUTE + 1; + {$EXTERNALSYM PROXY_ARP} + MCAST_IF_ENTRY = PROXY_ARP + 1; + {$EXTERNALSYM MCAST_IF_ENTRY} + MCAST_GLOBAL = MCAST_IF_ENTRY + 1; + {$EXTERNALSYM MCAST_GLOBAL} + IF_STATUS = MCAST_GLOBAL + 1; + {$EXTERNALSYM IF_STATUS} + MCAST_BOUNDARY = IF_STATUS + 1; + {$EXTERNALSYM MCAST_BOUNDARY} + MCAST_SCOPE = MCAST_BOUNDARY + 1; + {$EXTERNALSYM MCAST_SCOPE} + DEST_MATCHING = MCAST_SCOPE + 1; + {$EXTERNALSYM DEST_MATCHING} + DEST_LONGER = DEST_MATCHING + 1; + {$EXTERNALSYM DEST_LONGER} + DEST_SHORTER = DEST_LONGER + 1; + {$EXTERNALSYM DEST_SHORTER} + ROUTE_MATCHING = DEST_SHORTER + 1; + {$EXTERNALSYM ROUTE_MATCHING} + ROUTE_LONGER = ROUTE_MATCHING + 1; + {$EXTERNALSYM ROUTE_LONGER} + ROUTE_SHORTER = ROUTE_LONGER + 1; + {$EXTERNALSYM ROUTE_SHORTER} + ROUTE_STATE = ROUTE_SHORTER + 1; + {$EXTERNALSYM ROUTE_STATE} + + NUMBER_OF_EXPORTED_VARIABLES = ROUTE_STATE + 1; + {$EXTERNALSYM NUMBER_OF_EXPORTED_VARIABLES} + +////////////////////////////////////////////////////////////////////////////// +// // +// MIB_OPAQUE_QUERY is the structure filled in by the user to identify a // +// MIB variable // +// // +// dwVarId ID of MIB Variable (One of the Ids #defined above) // +// dwVarIndex Variable sized array containing the indices needed to // +// identify a variable. NOTE: Unlike SNMP we dont require that // +// a scalar variable be indexed by 0 // +// // +////////////////////////////////////////////////////////////////////////////// + +type + PMIB_OPAQUE_QUERY = ^MIB_OPAQUE_QUERY; + {$EXTERNALSYM PMIB_OPAQUE_QUERY} + _MIB_OPAQUE_QUERY = record + dwVarId: DWORD; + rgdwVarIndex: array [0..ANY_SIZE - 1] of DWORD; + end; + {$EXTERNALSYM _MIB_OPAQUE_QUERY} + MIB_OPAQUE_QUERY = _MIB_OPAQUE_QUERY; + {$EXTERNALSYM MIB_OPAQUE_QUERY} + TMibOpaqueQuery = MIB_OPAQUE_QUERY; + PMibOpaqueQuery = PMIB_OPAQUE_QUERY; + +////////////////////////////////////////////////////////////////////////////// +// // +// The following are the structures which are filled in and returned to the // +// user when a query is made, OR are filled in BY THE USER when a set is // +// done // +// // +////////////////////////////////////////////////////////////////////////////// + +type + PMIB_IFNUMBER = ^MIB_IFNUMBER; + {$EXTERNALSYM PMIB_IFNUMBER} + _MIB_IFNUMBER = record + dwValue: DWORD; + end; + {$EXTERNALSYM _MIB_IFNUMBER} + MIB_IFNUMBER = _MIB_IFNUMBER; + {$EXTERNALSYM MIB_IFNUMBER} + TMibIfnumber = MIB_IFNUMBER; + PMibIfnumber = PMIB_IFNUMBER; + +const + MAXLEN_IFDESCR = 256; + {$EXTERNALSYM MAXLEN_IFDESCR} + MAXLEN_PHYSADDR = 8; + {$EXTERNALSYM MAXLEN_PHYSADDR} + +type + PMIB_IFROW = ^MIB_IFROW; + {$EXTERNALSYM PMIB_IFROW} + _MIB_IFROW = record + wszName: array [0..MAX_INTERFACE_NAME_LEN - 1] of WCHAR; + dwIndex: DWORD; + dwType: DWORD; + dwMtu: DWORD; + dwSpeed: DWORD; + dwPhysAddrLen: DWORD; + bPhysAddr: array [0..MAXLEN_PHYSADDR - 1] of BYTE; + dwAdminStatus: DWORD; + dwOperStatus: DWORD; + dwLastChange: DWORD; + dwInOctets: DWORD; + dwInUcastPkts: DWORD; + dwInNUcastPkts: DWORD; + dwInDiscards: DWORD; + dwInErrors: DWORD; + dwInUnknownProtos: DWORD; + dwOutOctets: DWORD; + dwOutUcastPkts: DWORD; + dwOutNUcastPkts: DWORD; + dwOutDiscards: DWORD; + dwOutErrors: DWORD; + dwOutQLen: DWORD; + dwDescrLen: DWORD; + bDescr: array[0..MAXLEN_IFDESCR - 1] of BYTE; + end; + {$EXTERNALSYM _MIB_IFROW} + MIB_IFROW = _MIB_IFROW; + {$EXTERNALSYM MIB_IFROW} + TMibIfRow = MIB_IFROW; + PMibIfRow = PMIB_IFROW; + + PMIB_IFTABLE = ^MIB_IFTABLE; + {$EXTERNALSYM PMIB_IFTABLE} + _MIB_IFTABLE = record + dwNumEntries: DWORD; + table: array [0..ANY_SIZE - 1] of MIB_IFROW; + end; + {$EXTERNALSYM _MIB_IFTABLE} + MIB_IFTABLE = _MIB_IFTABLE; + {$EXTERNALSYM MIB_IFTABLE} + TMibIftable = MIB_IFTABLE; + PMibIftable = PMIB_IFTABLE; + +// #define SIZEOF_IFTABLE(X) (FIELD_OFFSET(MIB_IFTABLE,table[0]) + ((X) * sizeof(MIB_IFROW)) + ALIGN_SIZE) + +type + PMibIcmpStats = ^TMibIcmpStats; + _MIBICMPSTATS = record + dwMsgs: DWORD; + dwErrors: DWORD; + dwDestUnreachs: DWORD; + dwTimeExcds: DWORD; + dwParmProbs: DWORD; + dwSrcQuenchs: DWORD; + dwRedirects: DWORD; + dwEchos: DWORD; + dwEchoReps: DWORD; + dwTimestamps: DWORD; + dwTimestampReps: DWORD; + dwAddrMasks: DWORD; + dwAddrMaskReps: DWORD; + end; + {$EXTERNALSYM _MIBICMPSTATS} + MIBICMPSTATS = _MIBICMPSTATS; + {$EXTERNALSYM MIBICMPSTATS} + TMibIcmpStats = _MIBICMPSTATS; + + PMibIcmpInfo = ^TMibIcmpInfo; + _MIBICMPINFO = record + icmpInStats: MIBICMPSTATS; + icmpOutStats: MIBICMPSTATS; + end; + {$EXTERNALSYM _MIBICMPINFO} + MIBICMPINFO = _MIBICMPINFO; + {$EXTERNALSYM MIBICMPINFO} + TMibIcmpInfo = MIBICMPINFO; + + PMIB_ICMP = ^MIB_ICMP; + {$EXTERNALSYM PMIB_ICMP} + _MIB_ICMP = record + stats: MIBICMPINFO; + end; + {$EXTERNALSYM _MIB_ICMP} + MIB_ICMP = _MIB_ICMP; + {$EXTERNALSYM MIB_ICMP} + TMibIcmp = MIB_ICMP; + PMibIcmp = PMIB_ICMP; + + PMIB_UDPSTATS = ^MIB_UDPSTATS; + {$EXTERNALSYM PMIB_UDPSTATS} + _MIB_UDPSTATS = record + dwInDatagrams: DWORD; + dwNoPorts: DWORD; + dwInErrors: DWORD; + dwOutDatagrams: DWORD; + dwNumAddrs: DWORD; + end; + {$EXTERNALSYM _MIB_UDPSTATS} + MIB_UDPSTATS = _MIB_UDPSTATS; + {$EXTERNALSYM MIB_UDPSTATS} + TMibUdpStats = MIB_UDPSTATS; + PMibUdpStats = PMIB_UDPSTATS; + + PMIB_UDPROW = ^MIB_UDPROW; + {$EXTERNALSYM PMIB_UDPROW} + _MIB_UDPROW = record + dwLocalAddr: DWORD; + dwLocalPort: DWORD; + end; + {$EXTERNALSYM _MIB_UDPROW} + MIB_UDPROW = _MIB_UDPROW; + {$EXTERNALSYM MIB_UDPROW} + TMibUdpRow = MIB_UDPROW; + PMibUdpRow = PMIB_UDPROW; + + PMIB_UDPTABLE = ^MIB_UDPTABLE; + {$EXTERNALSYM PMIB_UDPTABLE} + _MIB_UDPTABLE = record + dwNumEntries: DWORD; + table: array [0..ANY_SIZE - 1] of MIB_UDPROW; + end; + {$EXTERNALSYM _MIB_UDPTABLE} + MIB_UDPTABLE = _MIB_UDPTABLE; + {$EXTERNALSYM MIB_UDPTABLE} + TMibUdpTable = MIB_UDPTABLE; + PMibUdpTable = PMIB_UDPTABLE; + +// #define SIZEOF_UDPTABLE(X) (FIELD_OFFSET(MIB_UDPTABLE, table[0]) + ((X) * sizeof(MIB_UDPROW)) + ALIGN_SIZE) + + PMIB_TCPSTATS = ^MIB_TCPSTATS; + {$EXTERNALSYM PMIB_TCPSTATS} + _MIB_TCPSTATS = record + dwRtoAlgorithm: DWORD; + dwRtoMin: DWORD; + dwRtoMax: DWORD; + dwMaxConn: DWORD; + dwActiveOpens: DWORD; + dwPassiveOpens: DWORD; + dwAttemptFails: DWORD; + dwEstabResets: DWORD; + dwCurrEstab: DWORD; + dwInSegs: DWORD; + dwOutSegs: DWORD; + dwRetransSegs: DWORD; + dwInErrs: DWORD; + dwOutRsts: DWORD; + dwNumConns: DWORD; + end; + {$EXTERNALSYM _MIB_TCPSTATS} + MIB_TCPSTATS = _MIB_TCPSTATS; + {$EXTERNALSYM MIB_TCPSTATS} + TMibTcpStats = MIB_TCPSTATS; + PMibTcpStats = PMIB_TCPSTATS; + +const + MIB_TCP_RTO_OTHER = 1; + {$EXTERNALSYM MIB_TCP_RTO_OTHER} + MIB_TCP_RTO_CONSTANT = 2; + {$EXTERNALSYM MIB_TCP_RTO_CONSTANT} + MIB_TCP_RTO_RSRE = 3; + {$EXTERNALSYM MIB_TCP_RTO_RSRE} + MIB_TCP_RTO_VANJ = 4; + {$EXTERNALSYM MIB_TCP_RTO_VANJ} + + MIB_TCP_MAXCONN_DYNAMIC = DWORD(-1); + {$EXTERNALSYM MIB_TCP_MAXCONN_DYNAMIC} + +type + PMIB_TCPROW = ^MIB_TCPROW; + {$EXTERNALSYM PMIB_TCPROW} + _MIB_TCPROW = record + dwState: DWORD; + dwLocalAddr: DWORD; + dwLocalPort: DWORD; + dwRemoteAddr: DWORD; + dwRemotePort: DWORD; + end; + {$EXTERNALSYM _MIB_TCPROW} + MIB_TCPROW = _MIB_TCPROW; + {$EXTERNALSYM MIB_TCPROW} + TMibTcpRow = MIB_TCPROW; + PMibTcpRow = PMIB_TCPROW; + +const + MIB_TCP_STATE_CLOSED = 1; + {$EXTERNALSYM MIB_TCP_STATE_CLOSED} + MIB_TCP_STATE_LISTEN = 2; + {$EXTERNALSYM MIB_TCP_STATE_LISTEN} + MIB_TCP_STATE_SYN_SENT = 3; + {$EXTERNALSYM MIB_TCP_STATE_SYN_SENT} + MIB_TCP_STATE_SYN_RCVD = 4; + {$EXTERNALSYM MIB_TCP_STATE_SYN_RCVD} + MIB_TCP_STATE_ESTAB = 5; + {$EXTERNALSYM MIB_TCP_STATE_ESTAB} + MIB_TCP_STATE_FIN_WAIT1 = 6; + {$EXTERNALSYM MIB_TCP_STATE_FIN_WAIT1} + MIB_TCP_STATE_FIN_WAIT2 = 7; + {$EXTERNALSYM MIB_TCP_STATE_FIN_WAIT2} + MIB_TCP_STATE_CLOSE_WAIT = 8; + {$EXTERNALSYM MIB_TCP_STATE_CLOSE_WAIT} + MIB_TCP_STATE_CLOSING = 9; + {$EXTERNALSYM MIB_TCP_STATE_CLOSING} + MIB_TCP_STATE_LAST_ACK = 10; + {$EXTERNALSYM MIB_TCP_STATE_LAST_ACK} + MIB_TCP_STATE_TIME_WAIT = 11; + {$EXTERNALSYM MIB_TCP_STATE_TIME_WAIT} + MIB_TCP_STATE_DELETE_TCB = 12; + {$EXTERNALSYM MIB_TCP_STATE_DELETE_TCB} + +type + PMIB_TCPTABLE = ^MIB_TCPTABLE; + {$EXTERNALSYM PMIB_TCPTABLE} + _MIB_TCPTABLE = record + dwNumEntries: DWORD; + table: array [0..ANY_SIZE - 1] of MIB_TCPROW; + end; + {$EXTERNALSYM _MIB_TCPTABLE} + MIB_TCPTABLE = _MIB_TCPTABLE; + {$EXTERNALSYM MIB_TCPTABLE} + TMibTcpTable = MIB_TCPTABLE; + PMibTcpTable = PMIB_TCPTABLE; + +// #define SIZEOF_TCPTABLE(X) (FIELD_OFFSET(MIB_TCPTABLE,table[0]) + ((X) * sizeof(MIB_TCPROW)) + ALIGN_SIZE) + +const + MIB_USE_CURRENT_TTL = DWORD(-1); + {$EXTERNALSYM MIB_USE_CURRENT_TTL} + MIB_USE_CURRENT_FORWARDING = DWORD(-1); + {$EXTERNALSYM MIB_USE_CURRENT_FORWARDING} + +type + PMIB_IPSTATS = ^MIB_IPSTATS; + {$EXTERNALSYM PMIB_IPSTATS} + _MIB_IPSTATS = record + dwForwarding: DWORD; + dwDefaultTTL: DWORD; + dwInReceives: DWORD; + dwInHdrErrors: DWORD; + dwInAddrErrors: DWORD; + dwForwDatagrams: DWORD; + dwInUnknownProtos: DWORD; + dwInDiscards: DWORD; + dwInDelivers: DWORD; + dwOutRequests: DWORD; + dwRoutingDiscards: DWORD; + dwOutDiscards: DWORD; + dwOutNoRoutes: DWORD; + dwReasmTimeout: DWORD; + dwReasmReqds: DWORD; + dwReasmOks: DWORD; + dwReasmFails: DWORD; + dwFragOks: DWORD; + dwFragFails: DWORD; + dwFragCreates: DWORD; + dwNumIf: DWORD; + dwNumAddr: DWORD; + dwNumRoutes: DWORD; + end; + {$EXTERNALSYM _MIB_IPSTATS} + MIB_IPSTATS = _MIB_IPSTATS; + {$EXTERNALSYM MIB_IPSTATS} + TMibIpStats = MIB_IPSTATS; + PMibIpStats = PMIB_IPSTATS; + +const + MIB_IP_FORWARDING = 1; + {$EXTERNALSYM MIB_IP_FORWARDING} + MIB_IP_NOT_FORWARDING = 2; + {$EXTERNALSYM MIB_IP_NOT_FORWARDING} + +type + PMIB_IPADDRROW = ^MIB_IPADDRROW; + {$EXTERNALSYM PMIB_IPADDRROW} + _MIB_IPADDRROW = record + dwAddr: DWORD; + dwIndex: DWORD; + dwMask: DWORD; + dwBCastAddr: DWORD; + dwReasmSize: DWORD; + unused1: Word; + unused2: Word; + end; + {$EXTERNALSYM _MIB_IPADDRROW} + MIB_IPADDRROW = _MIB_IPADDRROW; + {$EXTERNALSYM MIB_IPADDRROW} + TMibIpAddrRow = MIB_IPADDRROW; + PMibIpAddrRow = PMIB_IPADDRROW; + + PMIB_IPADDRTABLE = ^MIB_IPADDRTABLE; + {$EXTERNALSYM PMIB_IPADDRTABLE} + _MIB_IPADDRTABLE = record + dwNumEntries: DWORD; + table: array [0..ANY_SIZE - 1] of MIB_IPADDRROW; + end; + {$EXTERNALSYM _MIB_IPADDRTABLE} + MIB_IPADDRTABLE = _MIB_IPADDRTABLE; + {$EXTERNALSYM MIB_IPADDRTABLE} + TMibIpAddrTable = _MIB_IPADDRTABLE; + PMibIpAddrTable = PMIB_IPADDRTABLE; + +// #define SIZEOF_IPADDRTABLE(X) (FIELD_OFFSET(MIB_IPADDRTABLE,table[0]) + ((X) * sizeof(MIB_IPADDRROW)) + ALIGN_SIZE) + +type + PMIB_IPFORWARDNUMBER = ^MIB_IPFORWARDNUMBER; + {$EXTERNALSYM PMIB_IPFORWARDNUMBER} + _MIB_IPFORWARDNUMBER = record + dwValue: DWORD; + end; + {$EXTERNALSYM _MIB_IPFORWARDNUMBER} + MIB_IPFORWARDNUMBER = _MIB_IPFORWARDNUMBER; + {$EXTERNALSYM MIB_IPFORWARDNUMBER} + TMibIpForwardNumber = MIB_IPFORWARDNUMBER; + PMibIpForwardNumber = PMIB_IPFORWARDNUMBER; + + PMIB_IPFORWARDROW = ^MIB_IPFORWARDROW; + {$EXTERNALSYM PMIB_IPFORWARDROW} + _MIB_IPFORWARDROW = record + dwForwardDest: DWORD; + dwForwardMask: DWORD; + dwForwardPolicy: DWORD; + dwForwardNextHop: DWORD; + dwForwardIfIndex: DWORD; + dwForwardType: DWORD; + dwForwardProto: DWORD; + dwForwardAge: DWORD; + dwForwardNextHopAS: DWORD; + dwForwardMetric1: DWORD; + dwForwardMetric2: DWORD; + dwForwardMetric3: DWORD; + dwForwardMetric4: DWORD; + dwForwardMetric5: DWORD; + end; + {$EXTERNALSYM _MIB_IPFORWARDROW} + MIB_IPFORWARDROW = _MIB_IPFORWARDROW; + {$EXTERNALSYM MIB_IPFORWARDROW} + TMibIpForwardRow = MIB_IPFORWARDROW; + PMibIpForwardRow = PMIB_IPFORWARDROW; + +const + MIB_IPROUTE_TYPE_OTHER = 1; + {$EXTERNALSYM MIB_IPROUTE_TYPE_OTHER} + MIB_IPROUTE_TYPE_INVALID = 2; + {$EXTERNALSYM MIB_IPROUTE_TYPE_INVALID} + MIB_IPROUTE_TYPE_DIRECT = 3; + {$EXTERNALSYM MIB_IPROUTE_TYPE_DIRECT} + MIB_IPROUTE_TYPE_INDIRECT = 4; + {$EXTERNALSYM MIB_IPROUTE_TYPE_INDIRECT} + + MIB_IPROUTE_METRIC_UNUSED = DWORD(-1); + {$EXTERNALSYM MIB_IPROUTE_METRIC_UNUSED} + +// +// THESE MUST MATCH the ids in routprot.h +// + +const + MIB_IPPROTO_OTHER = 1; + {$EXTERNALSYM MIB_IPPROTO_OTHER} + MIB_IPPROTO_LOCAL = 2; + {$EXTERNALSYM MIB_IPPROTO_LOCAL} + MIB_IPPROTO_NETMGMT = 3; + {$EXTERNALSYM MIB_IPPROTO_NETMGMT} + MIB_IPPROTO_ICMP = 4; + {$EXTERNALSYM MIB_IPPROTO_ICMP} + MIB_IPPROTO_EGP = 5; + {$EXTERNALSYM MIB_IPPROTO_EGP} + MIB_IPPROTO_GGP = 6; + {$EXTERNALSYM MIB_IPPROTO_GGP} + MIB_IPPROTO_HELLO = 7; + {$EXTERNALSYM MIB_IPPROTO_HELLO} + MIB_IPPROTO_RIP = 8; + {$EXTERNALSYM MIB_IPPROTO_RIP} + MIB_IPPROTO_IS_IS = 9; + {$EXTERNALSYM MIB_IPPROTO_IS_IS} + MIB_IPPROTO_ES_IS = 10; + {$EXTERNALSYM MIB_IPPROTO_ES_IS} + MIB_IPPROTO_CISCO = 11; + {$EXTERNALSYM MIB_IPPROTO_CISCO} + MIB_IPPROTO_BBN = 12; + {$EXTERNALSYM MIB_IPPROTO_BBN} + MIB_IPPROTO_OSPF = 13; + {$EXTERNALSYM MIB_IPPROTO_OSPF} + MIB_IPPROTO_BGP = 14; + {$EXTERNALSYM MIB_IPPROTO_BGP} + + MIB_IPPROTO_NT_AUTOSTATIC = 10002; + {$EXTERNALSYM MIB_IPPROTO_NT_AUTOSTATIC} + MIB_IPPROTO_NT_STATIC = 10006; + {$EXTERNALSYM MIB_IPPROTO_NT_STATIC} + MIB_IPPROTO_NT_STATIC_NON_DOD = 10007; + {$EXTERNALSYM MIB_IPPROTO_NT_STATIC_NON_DOD} + +type + PMIB_IPFORWARDTABLE = ^MIB_IPFORWARDTABLE; + {$EXTERNALSYM PMIB_IPFORWARDTABLE} + _MIB_IPFORWARDTABLE = record + dwNumEntries: DWORD; + table: array [0..ANY_SIZE - 1] of MIB_IPFORWARDROW; + end; + {$EXTERNALSYM _MIB_IPFORWARDTABLE} + MIB_IPFORWARDTABLE = _MIB_IPFORWARDTABLE; + {$EXTERNALSYM MIB_IPFORWARDTABLE} + TMibIpForwardTable = MIB_IPFORWARDTABLE; + PMibIpForwardTable = PMIB_IPFORWARDTABLE; + +// #define SIZEOF_IPFORWARDTABLE(X) (FIELD_OFFSET(MIB_IPFORWARDTABLE,table[0]) + ((X) * sizeof(MIB_IPFORWARDROW)) + ALIGN_SIZE) + +type + PMIB_IPNETROW = ^MIB_IPNETROW; + {$EXTERNALSYM PMIB_IPNETROW} + _MIB_IPNETROW = record + dwIndex: DWORD; + dwPhysAddrLen: DWORD; + bPhysAddr: array [0..MAXLEN_PHYSADDR - 1] of BYTE; + dwAddr: DWORD; + dwType: DWORD; + end; + {$EXTERNALSYM _MIB_IPNETROW} + MIB_IPNETROW = _MIB_IPNETROW; + {$EXTERNALSYM MIB_IPNETROW} + TMibIpNetRow = MIB_IPNETROW; + PMibIpNetRow = PMIB_IPNETROW; + +const + MIB_IPNET_TYPE_OTHER = 1; + {$EXTERNALSYM MIB_IPNET_TYPE_OTHER} + MIB_IPNET_TYPE_INVALID = 2; + {$EXTERNALSYM MIB_IPNET_TYPE_INVALID} + MIB_IPNET_TYPE_DYNAMIC = 3; + {$EXTERNALSYM MIB_IPNET_TYPE_DYNAMIC} + MIB_IPNET_TYPE_STATIC = 4; + {$EXTERNALSYM MIB_IPNET_TYPE_STATIC} + +type + PMIB_IPNETTABLE = ^MIB_IPNETTABLE; + {$EXTERNALSYM PMIB_IPNETTABLE} + _MIB_IPNETTABLE = record + dwNumEntries: DWORD; + table: array [0..ANY_SIZE - 1] of MIB_IPNETROW; + end; + {$EXTERNALSYM _MIB_IPNETTABLE} + MIB_IPNETTABLE = _MIB_IPNETTABLE; + {$EXTERNALSYM MIB_IPNETTABLE} + TMibIpNetTable = MIB_IPNETTABLE; + PMibIpNetTable = PMIB_IPNETTABLE; + +// #define SIZEOF_IPNETTABLE(X) (FIELD_OFFSET(MIB_IPNETTABLE, table[0]) + ((X) * sizeof(MIB_IPNETROW)) + ALIGN_SIZE) + +type + PMIB_IPMCAST_OIF = ^MIB_IPMCAST_OIF; + {$EXTERNALSYM PMIB_IPMCAST_OIF} + _MIB_IPMCAST_OIF = record + dwOutIfIndex: DWORD; + dwNextHopAddr: DWORD; + pvReserved: Pointer; + dwReserved: DWORD; + end; + {$EXTERNALSYM _MIB_IPMCAST_OIF} + MIB_IPMCAST_OIF = _MIB_IPMCAST_OIF; + {$EXTERNALSYM MIB_IPMCAST_OIF} + TMibIpmCastOif = MIB_IPMCAST_OIF; + PMibIpmCastOif = PMIB_IPMCAST_OIF; + + PMIB_IPMCAST_MFE = ^MIB_IPMCAST_MFE; + {$EXTERNALSYM PMIB_IPMCAST_MFE} + _MIB_IPMCAST_MFE = record + dwGroup: DWORD; + dwSource: DWORD; + dwSrcMask: DWORD; + dwUpStrmNgbr: DWORD; + dwInIfIndex: DWORD; + dwInIfProtocol: DWORD; + dwRouteProtocol: DWORD; + dwRouteNetwork: DWORD; + dwRouteMask: DWORD; + ulUpTime: ULONG; + ulExpiryTime: ULONG; + ulTimeOut: ULONG; + ulNumOutIf: ULONG; + fFlags: DWORD; + dwReserved: DWORD; + rgmioOutInfo: array [0..ANY_SIZE - 1] of MIB_IPMCAST_OIF; + end; + {$EXTERNALSYM _MIB_IPMCAST_MFE} + MIB_IPMCAST_MFE = _MIB_IPMCAST_MFE; + {$EXTERNALSYM MIB_IPMCAST_MFE} + TMibIpmCastMfe = MIB_IPMCAST_MFE; + PMibIpmCastMfe = PMIB_IPMCAST_MFE; + + PMIB_MFE_TABLE = ^MIB_MFE_TABLE; + {$EXTERNALSYM PMIB_MFE_TABLE} + _MIB_MFE_TABLE = record + dwNumEntries: DWORD; + table: array [0..ANY_SIZE - 1] of MIB_IPMCAST_MFE; + end; + {$EXTERNALSYM _MIB_MFE_TABLE} + MIB_MFE_TABLE = _MIB_MFE_TABLE; + {$EXTERNALSYM MIB_MFE_TABLE} + TMibMfeTable = MIB_MFE_TABLE; + PMibMfeTable = PMIB_MFE_TABLE; + + +// #define SIZEOF_BASIC_MIB_MFE \ +// (ULONG)(FIELD_OFFSET(MIB_IPMCAST_MFE, rgmioOutInfo[0])) + +// #define SIZEOF_MIB_MFE(X) \ +// (SIZEOF_BASIC_MIB_MFE + ((X) * sizeof(MIB_IPMCAST_OIF))) + +type + PMIB_IPMCAST_OIF_STATS = ^MIB_IPMCAST_OIF_STATS; + {$EXTERNALSYM PMIB_IPMCAST_OIF_STATS} + _MIB_IPMCAST_OIF_STATS = record + dwOutIfIndex: DWORD; + dwNextHopAddr: DWORD; + pvDialContext: Pointer; + ulTtlTooLow: ULONG; + ulFragNeeded: ULONG; + ulOutPackets: ULONG; + ulOutDiscards: ULONG; + end; + {$EXTERNALSYM _MIB_IPMCAST_OIF_STATS} + MIB_IPMCAST_OIF_STATS = _MIB_IPMCAST_OIF_STATS; + {$EXTERNALSYM MIB_IPMCAST_OIF_STATS} + TMibIpmCastOifStats = MIB_IPMCAST_OIF_STATS; + PMibIpmCastOifStats = PMIB_IPMCAST_OIF_STATS; + + PMIB_IPMCAST_MFE_STATS = ^MIB_IPMCAST_MFE_STATS; + {$EXTERNALSYM PMIB_IPMCAST_MFE_STATS} + _MIB_IPMCAST_MFE_STATS = record + dwGroup: DWORD; + dwSource: DWORD; + dwSrcMask: DWORD; + dwUpStrmNgbr: DWORD; + dwInIfIndex: DWORD; + dwInIfProtocol: DWORD; + dwRouteProtocol: DWORD; + dwRouteNetwork: DWORD; + dwRouteMask: DWORD; + ulUpTime: ULONG; + ulExpiryTime: ULONG; + ulNumOutIf: ULONG; + ulInPkts: ULONG; + ulInOctets: ULONG; + ulPktsDifferentIf: ULONG; + ulQueueOverflow: ULONG; + rgmiosOutStats: array [0..ANY_SIZE - 1] of MIB_IPMCAST_OIF_STATS; + end; + {$EXTERNALSYM _MIB_IPMCAST_MFE_STATS} + MIB_IPMCAST_MFE_STATS = _MIB_IPMCAST_MFE_STATS; + {$EXTERNALSYM MIB_IPMCAST_MFE_STATS} + TMibIpmCastMfeStats = MIB_IPMCAST_MFE_STATS; + PMibIpmCastMfeStats = PMIB_IPMCAST_MFE_STATS; + + PMIB_MFE_STATS_TABLE = ^MIB_MFE_STATS_TABLE; + {$EXTERNALSYM PMIB_MFE_STATS_TABLE} + _MIB_MFE_STATS_TABLE = record + dwNumEntries: DWORD; + table: array [0..ANY_SIZE - 1] of MIB_IPMCAST_MFE_STATS; + end; + {$EXTERNALSYM _MIB_MFE_STATS_TABLE} + MIB_MFE_STATS_TABLE = _MIB_MFE_STATS_TABLE; + {$EXTERNALSYM MIB_MFE_STATS_TABLE} + TMibMfeStatsTable = MIB_MFE_STATS_TABLE; + PMibMfeStatsTable = PMIB_MFE_STATS_TABLE; + +// #define SIZEOF_BASIC_MIB_MFE_STATS \ +// (ULONG)(FIELD_OFFSET(MIB_IPMCAST_MFE_STATS, rgmiosOutStats[0])) + +// #define SIZEOF_MIB_MFE_STATS(X) \ +// (SIZEOF_BASIC_MIB_MFE_STATS + ((X) * sizeof(MIB_IPMCAST_OIF_STATS))) + +type + PMIB_IPMCAST_GLOBAL = ^MIB_IPMCAST_GLOBAL; + {$EXTERNALSYM PMIB_IPMCAST_GLOBAL} + _MIB_IPMCAST_GLOBAL = record + dwEnable: DWORD; + end; + {$EXTERNALSYM _MIB_IPMCAST_GLOBAL} + MIB_IPMCAST_GLOBAL = _MIB_IPMCAST_GLOBAL; + {$EXTERNALSYM MIB_IPMCAST_GLOBAL} + TMibIpmCastGlobal = MIB_IPMCAST_GLOBAL; + PMibIpmCastGlobal = PMIB_IPMCAST_GLOBAL; + + PMIB_IPMCAST_IF_ENTRY = ^MIB_IPMCAST_IF_ENTRY; + {$EXTERNALSYM PMIB_IPMCAST_IF_ENTRY} + _MIB_IPMCAST_IF_ENTRY = record + dwIfIndex: DWORD; + dwTtl: DWORD; + dwProtocol: DWORD; + dwRateLimit: DWORD; + ulInMcastOctets: ULONG; + ulOutMcastOctets: ULONG; + end; + {$EXTERNALSYM _MIB_IPMCAST_IF_ENTRY} + MIB_IPMCAST_IF_ENTRY = _MIB_IPMCAST_IF_ENTRY; + {$EXTERNALSYM MIB_IPMCAST_IF_ENTRY} + TMibIpmCastIfEntry = MIB_IPMCAST_IF_ENTRY; + PMibIpmCastIfEntry = PMIB_IPMCAST_IF_ENTRY; + + PMIB_IPMCAST_IF_TABLE = ^MIB_IPMCAST_IF_TABLE; + {$EXTERNALSYM PMIB_IPMCAST_IF_TABLE} + _MIB_IPMCAST_IF_TABLE = record + dwNumEntries: DWORD; + table: array [0..ANY_SIZE - 1] of MIB_IPMCAST_IF_ENTRY; + end; + {$EXTERNALSYM _MIB_IPMCAST_IF_TABLE} + MIB_IPMCAST_IF_TABLE = _MIB_IPMCAST_IF_TABLE; + {$EXTERNALSYM MIB_IPMCAST_IF_TABLE} + TMibIpmCastIfTable = MIB_IPMCAST_IF_TABLE; + PMibIpmCastIfTable = PMIB_IPMCAST_IF_TABLE; + +// #define SIZEOF_MCAST_IF_TABLE(X) (FIELD_OFFSET(MIB_IPMCAST_IF_TABLE,table[0]) + ((X) * sizeof(MIB_IPMCAST_IF_ENTRY)) + ALIGN_SIZE) + +type + PMIB_IPMCAST_BOUNDARY = ^MIB_IPMCAST_BOUNDARY; + {$EXTERNALSYM PMIB_IPMCAST_BOUNDARY} + _MIB_IPMCAST_BOUNDARY = record + dwIfIndex: DWORD; + dwGroupAddress: DWORD; + dwGroupMask: DWORD; + dwStatus: DWORD; + end; + {$EXTERNALSYM _MIB_IPMCAST_BOUNDARY} + MIB_IPMCAST_BOUNDARY = _MIB_IPMCAST_BOUNDARY; + {$EXTERNALSYM MIB_IPMCAST_BOUNDARY} + TMibIpmCastBoundary = MIB_IPMCAST_BOUNDARY; + PMibIpmCastBoundary = PMIB_IPMCAST_BOUNDARY; + + PMIB_IPMCAST_BOUNDARY_TABLE = ^MIB_IPMCAST_BOUNDARY_TABLE; + {$EXTERNALSYM PMIB_IPMCAST_BOUNDARY_TABLE} + _MIB_IPMCAST_BOUNDARY_TABLE = record + dwNumEntries: DWORD; + table: array [0..ANY_SIZE - 1] of MIB_IPMCAST_BOUNDARY; + end; + {$EXTERNALSYM _MIB_IPMCAST_BOUNDARY_TABLE} + MIB_IPMCAST_BOUNDARY_TABLE = _MIB_IPMCAST_BOUNDARY_TABLE; + {$EXTERNALSYM MIB_IPMCAST_BOUNDARY_TABLE} + TMibIpmCastBoundaryTable = MIB_IPMCAST_BOUNDARY_TABLE; + PMibIpmCastBoundaryTable = PMIB_IPMCAST_BOUNDARY_TABLE; + +// #define SIZEOF_BOUNDARY_TABLE(X) (FIELD_OFFSET(MIB_IPMCAST_BOUNDARY_TABLE,table[0]) + ((X) * sizeof(MIB_IPMCAST_BOUNDARY)) + ALIGN_SIZE) + +type + PMIB_BOUNDARYROW = ^MIB_BOUNDARYROW; + {$EXTERNALSYM PMIB_BOUNDARYROW} + MIB_BOUNDARYROW = record + dwGroupAddress: DWORD; + dwGroupMask: DWORD; + end; + {$EXTERNALSYM MIB_BOUNDARYROW} + TMibBoundaryRow = MIB_BOUNDARYROW; + PMibBoundaryRow = PMIB_BOUNDARYROW; + +// Structure matching what goes in the registry in a block of type +// IP_MCAST_LIMIT_INFO. This contains the fields of +// MIB_IPMCAST_IF_ENTRY which are configurable. + + PMIB_MCAST_LIMIT_ROW = ^MIB_MCAST_LIMIT_ROW; + {$EXTERNALSYM PMIB_MCAST_LIMIT_ROW} + MIB_MCAST_LIMIT_ROW = record + dwTtl: DWORD; + dwRateLimit: DWORD; + end; + {$EXTERNALSYM MIB_MCAST_LIMIT_ROW} + TMibMcastLimitRow = MIB_MCAST_LIMIT_ROW; + PMibMcastLimitRow = PMIB_MCAST_LIMIT_ROW; + +const + MAX_SCOPE_NAME_LEN = 255; + {$EXTERNALSYM MAX_SCOPE_NAME_LEN} + +// +// Scope names are unicode. SNMP and MZAP use UTF-8 encoding. +// + +type + SN_CHAR = WCHAR; + {$EXTERNALSYM SN_CHAR} + SCOPE_NAME_BUFFER = array [0..MAX_SCOPE_NAME_LEN] of SN_CHAR; + {$EXTERNALSYM SCOPE_NAME_BUFFER} + SCOPE_NAME = ^SN_CHAR; + {$EXTERNALSYM SCOPE_NAME} + + PMIB_IPMCAST_SCOPE = ^MIB_IPMCAST_SCOPE; + {$EXTERNALSYM PMIB_IPMCAST_SCOPE} + _MIB_IPMCAST_SCOPE = record + dwGroupAddress: DWORD; + dwGroupMask: DWORD; + snNameBuffer: SCOPE_NAME_BUFFER; + dwStatus: DWORD; + end; + {$EXTERNALSYM _MIB_IPMCAST_SCOPE} + MIB_IPMCAST_SCOPE = _MIB_IPMCAST_SCOPE; + {$EXTERNALSYM MIB_IPMCAST_SCOPE} + TMibIpmCastScope = MIB_IPMCAST_SCOPE; + PMibIpmCastScope = PMIB_IPMCAST_SCOPE; + + PMIB_IPDESTROW = ^MIB_IPDESTROW; + {$EXTERNALSYM PMIB_IPDESTROW} + _MIB_IPDESTROW = record + ForwardRow: MIB_IPFORWARDROW; + dwForwardPreference: DWORD; + dwForwardViewSet: DWORD; + end; + {$EXTERNALSYM _MIB_IPDESTROW} + MIB_IPDESTROW = _MIB_IPDESTROW; + {$EXTERNALSYM MIB_IPDESTROW} + TMibIpDestRow = MIB_IPDESTROW; + PMibIpDestRow = PMIB_IPDESTROW; + + PMIB_IPDESTTABLE = ^MIB_IPDESTTABLE; + {$EXTERNALSYM PMIB_IPDESTTABLE} + _MIB_IPDESTTABLE = record + dwNumEntries: DWORD; + table: array [0..ANY_SIZE - 1] of MIB_IPDESTROW; + end; + {$EXTERNALSYM _MIB_IPDESTTABLE} + MIB_IPDESTTABLE = _MIB_IPDESTTABLE; + {$EXTERNALSYM MIB_IPDESTTABLE} + TMibIpDestTable = MIB_IPDESTTABLE; + PMibIpDestTable = PMIB_IPDESTTABLE; + + PMIB_BEST_IF = ^MIB_BEST_IF; + {$EXTERNALSYM PMIB_BEST_IF} + _MIB_BEST_IF = record + dwDestAddr: DWORD; + dwIfIndex: DWORD; + end; + {$EXTERNALSYM _MIB_BEST_IF} + MIB_BEST_IF = _MIB_BEST_IF; + {$EXTERNALSYM MIB_BEST_IF} + TMibBestIf = MIB_BEST_IF; + PMibBestIf = PMIB_BEST_IF; + + PMIB_PROXYARP = ^MIB_PROXYARP; + {$EXTERNALSYM PMIB_PROXYARP} + _MIB_PROXYARP = record + dwAddress: DWORD; + dwMask: DWORD; + dwIfIndex: DWORD; + end; + {$EXTERNALSYM _MIB_PROXYARP} + MIB_PROXYARP = _MIB_PROXYARP; + {$EXTERNALSYM MIB_PROXYARP} + TMibProxyArp = MIB_PROXYARP; + PMibProxyArp = PMIB_PROXYARP; + + PMIB_IFSTATUS = ^MIB_IFSTATUS; + {$EXTERNALSYM PMIB_IFSTATUS} + _MIB_IFSTATUS = record + dwIfIndex: DWORD; + dwAdminStatus: DWORD; + dwOperationalStatus: DWORD; + bMHbeatActive: BOOL; + bMHbeatAlive: BOOL; + end; + {$EXTERNALSYM _MIB_IFSTATUS} + MIB_IFSTATUS = _MIB_IFSTATUS; + {$EXTERNALSYM MIB_IFSTATUS} + TMibIfStatus = MIB_IFSTATUS; + PMibIfStatus = PMIB_IFSTATUS; + + PMIB_ROUTESTATE = ^MIB_ROUTESTATE; + {$EXTERNALSYM PMIB_ROUTESTATE} + _MIB_ROUTESTATE = record + bRoutesSetToStack: BOOL; + end; + {$EXTERNALSYM _MIB_ROUTESTATE} + MIB_ROUTESTATE = _MIB_ROUTESTATE; + {$EXTERNALSYM MIB_ROUTESTATE} + TMibRouteState = MIB_ROUTESTATE; + PMibRouteState = PMIB_ROUTESTATE; + +////////////////////////////////////////////////////////////////////////////// +// // +// All the info passed to (SET/CREATE) and from (GET/GETNEXT/GETFIRST) // +// IP Router Manager is encapsulated in the following "discriminated" // +// union. To pass, say MIB_IFROW, use the following code // +// // +// PMIB_OPAQUE_INFO pInfo; // +// PMIB_IFROW pIfRow; // +// DWORD rgdwBuff[(MAX_MIB_OFFSET + sizeof(MIB_IFROW))/sizeof(DWORD) + 1]; // +// // +// pInfo = (PMIB_OPAQUE_INFO)rgdwBuffer; // +// pIfRow = (MIB_IFROW *)(pInfo->rgbyData); // +// // +// This can also be accomplished by using the following macro // +// // +// DEFINE_MIB_BUFFER(pInfo,MIB_IFROW, pIfRow); // +// // +////////////////////////////////////////////////////////////////////////////// + +type + PMibOpaqueInfo = ^TMibOpaqueInfo; + _MIB_OPAQUE_INFO = record + dwId: DWORD; + case Integer of + 0: (ullAlign: Int64); // ULONGLONG (unsigned!) + 1: (rgbyData: array [0..0] of BYTE); + end; + {$EXTERNALSYM _MIB_OPAQUE_INFO} + MIB_OPAQUE_INFO = _MIB_OPAQUE_INFO; + {$EXTERNALSYM MIB_OPAQUE_INFO} + TMibOpaqueInfo = MIB_OPAQUE_INFO; + +const + MAX_MIB_OFFSET = 8; + {$EXTERNALSYM MAX_MIB_OFFSET} + +// #define MIB_INFO_SIZE(S) (MAX_MIB_OFFSET + sizeof(S)) + +// #define MIB_INFO_SIZE_IN_DWORDS(S) \ +// ((MIB_INFO_SIZE(S))/sizeof(DWORD) + 1) + +// #define DEFINE_MIB_BUFFER(X,Y,Z) \ +// DWORD __rgdwBuff[MIB_INFO_SIZE_IN_DWORDS(Y)]; \ +// PMIB_OPAQUE_INFO X = (PMIB_OPAQUE_INFO)__rgdwBuff; \ +// Y * Z = (Y *)(X->rgbyData) + +// #define CAST_MIB_INFO(X,Y,Z) Z = (Y)(X->rgbyData) + +implementation + +end. diff --git a/IpTypes.pas b/IpTypes.pas new file mode 100644 index 0000000..cde652f --- /dev/null +++ b/IpTypes.pas @@ -0,0 +1,228 @@ +{******************************************************************************} +{ } +{ Internet Protocol Helper API interface Unit for Object Pascal } +{ } +{ Portions created by Microsoft are Copyright (C) 1995-2001 Microsoft } +{ Corporation. All Rights Reserved. } +{ } +{ The original file is: iptypes.h, released July 2000. The original Pascal } +{ code is: IpTypes.pas, released September 2000. The initial developer of the } +{ Pascal code is Marcel van Brakel (brakelm@chello.nl). } +{ } +{ Portions created by Marcel van Brakel are Copyright (C) 1999-2001 } +{ Marcel van Brakel. All Rights Reserved. } +{ } +{ Contributor(s): John C. Penman (jcp@craiglockhart.com) } +{ Vladimir Vassiliev (voldemarv@hotpop.com) } +{ } +{ Obtained through: Joint Endeavour of Delphi Innovators (Project JEDI) } +{ } +{ You may retrieve the latest version of this file at the Project JEDI home } +{ page, located at http://delphi-jedi.org or my personal homepage located at } +{ http://members.chello.nl/m.vanbrakel2 } +{ } +{ The contents of this file are used with permission, subject to the Mozilla } +{ Public License Version 1.1 (the "License"); you may not use this file except } +{ in compliance with the License. You may obtain a copy of the License at } +{ http://www.mozilla.org/MPL/MPL-1.1.html } +{ } +{ Software distributed under the License is distributed on an "AS IS" basis, } +{ WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for } +{ the specific language governing rights and limitations under the License. } +{ } +{ Alternatively, the contents of this file may be used under the terms of the } +{ GNU Lesser General Public License (the "LGPL License"), in which case the } +{ provisions of the LGPL License are applicable instead of those above. } +{ If you wish to allow use of your version of this file only under the terms } +{ of the LGPL License and not to allow others to use your version of this file } +{ under the MPL, indicate your decision by deleting the provisions above and } +{ replace them with the notice and other provisions required by the LGPL } +{ License. If you do not delete the provisions above, a recipient may use } +{ your version of this file under either the MPL or the LGPL License. } +{ } +{ For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html } +{ } +{******************************************************************************} + +unit IpTypes; + +{$WEAKPACKAGEUNIT} + +{$HPPEMIT ''} +{$HPPEMIT '#include "iptypes.h"'} +{$HPPEMIT ''} + +//{$I WINDEFINES.INC} + +interface + +uses + Windows; + +type + // #include + time_t = Longint; + {$EXTERNALSYM time_t} + +// Definitions and structures used by getnetworkparams and getadaptersinfo apis + +const + MAX_ADAPTER_DESCRIPTION_LENGTH = 128; // arb. + {$EXTERNALSYM MAX_ADAPTER_DESCRIPTION_LENGTH} + MAX_ADAPTER_NAME_LENGTH = 256; // arb. + {$EXTERNALSYM MAX_ADAPTER_NAME_LENGTH} + MAX_ADAPTER_ADDRESS_LENGTH = 8; // arb. + {$EXTERNALSYM MAX_ADAPTER_ADDRESS_LENGTH} + DEFAULT_MINIMUM_ENTITIES = 32; // arb. + {$EXTERNALSYM DEFAULT_MINIMUM_ENTITIES} + MAX_HOSTNAME_LEN = 128; // arb. + {$EXTERNALSYM MAX_HOSTNAME_LEN} + MAX_DOMAIN_NAME_LEN = 128; // arb. + {$EXTERNALSYM MAX_DOMAIN_NAME_LEN} + MAX_SCOPE_ID_LEN = 256; // arb. + {$EXTERNALSYM MAX_SCOPE_ID_LEN} + +// +// types +// + +// Node Type + + BROADCAST_NODETYPE = 1; + {$EXTERNALSYM BROADCAST_NODETYPE} + PEER_TO_PEER_NODETYPE = 2; + {$EXTERNALSYM PEER_TO_PEER_NODETYPE} + MIXED_NODETYPE = 4; + {$EXTERNALSYM MIXED_NODETYPE} + HYBRID_NODETYPE = 8; + {$EXTERNALSYM HYBRID_NODETYPE} + +// Adapter Type + + IF_OTHER_ADAPTERTYPE = 0; + {$EXTERNALSYM IF_OTHER_ADAPTERTYPE} + IF_ETHERNET_ADAPTERTYPE = 1; + {$EXTERNALSYM IF_ETHERNET_ADAPTERTYPE} + IF_TOKEN_RING_ADAPTERTYPE = 2; + {$EXTERNALSYM IF_TOKEN_RING_ADAPTERTYPE} + IF_FDDI_ADAPTERTYPE = 3; + {$EXTERNALSYM IF_FDDI_ADAPTERTYPE} + IF_PPP_ADAPTERTYPE = 4; + {$EXTERNALSYM IF_PPP_ADAPTERTYPE} + IF_LOOPBACK_ADAPTERTYPE = 5; + {$EXTERNALSYM IF_LOOPBACK_ADAPTERTYPE} + IF_SLIP_ADAPTERTYPE = 6; + {$EXTERNALSYM IF_SLIP_ADAPTERTYPE} + +// +// IP_ADDRESS_STRING - store an IP address as a dotted decimal string +// + +type + PIP_MASK_STRING = ^IP_MASK_STRING; + {$EXTERNALSYM PIP_MASK_STRING} + IP_ADDRESS_STRING = record + S: array [0..15] of Char; + end; + {$EXTERNALSYM IP_ADDRESS_STRING} + PIP_ADDRESS_STRING = ^IP_ADDRESS_STRING; + {$EXTERNALSYM PIP_ADDRESS_STRING} + IP_MASK_STRING = IP_ADDRESS_STRING; + {$EXTERNALSYM IP_MASK_STRING} + TIpAddressString = IP_ADDRESS_STRING; + PIpAddressString = PIP_MASK_STRING; + +// +// IP_ADDR_STRING - store an IP address with its corresponding subnet mask, +// both as dotted decimal strings +// + + PIP_ADDR_STRING = ^IP_ADDR_STRING; + {$EXTERNALSYM PIP_ADDR_STRING} + _IP_ADDR_STRING = record + Next: PIP_ADDR_STRING; + IpAddress: IP_ADDRESS_STRING; + IpMask: IP_MASK_STRING; + Context: DWORD; + end; + {$EXTERNALSYM _IP_ADDR_STRING} + IP_ADDR_STRING = _IP_ADDR_STRING; + {$EXTERNALSYM IP_ADDR_STRING} + TIpAddrString = IP_ADDR_STRING; + PIpAddrString = PIP_ADDR_STRING; + +// +// ADAPTER_INFO - per-adapter information. All IP addresses are stored as +// strings +// + + PIP_ADAPTER_INFO = ^IP_ADAPTER_INFO; + {$EXTERNALSYM PIP_ADAPTER_INFO} + _IP_ADAPTER_INFO = record + Next: PIP_ADAPTER_INFO; + ComboIndex: DWORD; + AdapterName: array [0..MAX_ADAPTER_NAME_LENGTH + 3] of Char; + Description: array [0..MAX_ADAPTER_DESCRIPTION_LENGTH + 3] of Char; + AddressLength: UINT; + Address: array [0..MAX_ADAPTER_ADDRESS_LENGTH - 1] of BYTE; + Index: DWORD; + Type_: UINT; + DhcpEnabled: UINT; + CurrentIpAddress: PIP_ADDR_STRING; + IpAddressList: IP_ADDR_STRING; + GatewayList: IP_ADDR_STRING; + DhcpServer: IP_ADDR_STRING; + HaveWins: BOOL; + PrimaryWinsServer: IP_ADDR_STRING; + SecondaryWinsServer: IP_ADDR_STRING; + LeaseObtained: time_t; + LeaseExpires: time_t; + end; + {$EXTERNALSYM _IP_ADAPTER_INFO} + IP_ADAPTER_INFO = _IP_ADAPTER_INFO; + {$EXTERNALSYM IP_ADAPTER_INFO} + TIpAdapterInfo = IP_ADAPTER_INFO; + PIpAdapterInfo = PIP_ADAPTER_INFO; + +// +// IP_PER_ADAPTER_INFO - per-adapter IP information such as DNS server list. +// + + PIP_PER_ADAPTER_INFO = ^IP_PER_ADAPTER_INFO; + {$EXTERNALSYM PIP_PER_ADAPTER_INFO} + _IP_PER_ADAPTER_INFO = record + AutoconfigEnabled: UINT; + AutoconfigActive: UINT; + CurrentDnsServer: PIP_ADDR_STRING; + DnsServerList: IP_ADDR_STRING; + end; + {$EXTERNALSYM _IP_PER_ADAPTER_INFO} + IP_PER_ADAPTER_INFO = _IP_PER_ADAPTER_INFO; + {$EXTERNALSYM IP_PER_ADAPTER_INFO} + TIpPerAdapterInfo = IP_PER_ADAPTER_INFO; + PIpPerAdapterInfo = PIP_PER_ADAPTER_INFO; + +// +// FIXED_INFO - the set of IP-related information which does not depend on DHCP +// + + PFIXED_INFO = ^FIXED_INFO; + {$EXTERNALSYM PFIXED_INFO} + FIXED_INFO = record + HostName: array [0..MAX_HOSTNAME_LEN + 3] of Char; + DomainName: array[0..MAX_DOMAIN_NAME_LEN + 3] of Char; + CurrentDnsServer: PIP_ADDR_STRING; + DnsServerList: IP_ADDR_STRING; + NodeType: UINT; + ScopeId: array [0..MAX_SCOPE_ID_LEN + 3] of Char; + EnableRouting: UINT; + EnableProxy: UINT; + EnableDns: UINT; + end; + {$EXTERNALSYM FIXED_INFO} + TFixedInfo = FIXED_INFO; + PFixedInfo = PFIXED_INFO; + +implementation + +end. diff --git a/NetworkFunctions.pas b/NetworkFunctions.pas new file mode 100644 index 0000000..fcd66aa --- /dev/null +++ b/NetworkFunctions.pas @@ -0,0 +1,523 @@ +{----------------------------------------------------------------------------- +The contents of this file are subject to the Mozilla Public License +Version 1.1 (the "License"); you may not use this file except in compliance +with the License. You may obtain a copy of the License at +http://www.mozilla.org/MPL/MPL-1.1.html + +Software distributed under the License is distributed on an "AS IS" basis, +WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for +the specific language governing rights and limitations under the License. + +The Original Code is: NetworkFunctions.PAS, released on 2003-05-13. + +The Initial Developer of the Original Code is Olivier Sannier +[obones@altern.org] +Portions created by Olivier Sannier are Copyright (C) 2003 Olivier Sannier. +All Rights Reserved. + +Contributor(s): none to date. + +You may retrieve the latest version of this file at the Connection Manager +home page, located at http://cnxmanager.sourceforge.net + +Known Issues: none to date. + +Description: This unit contains some functions to help get information + on the network configuration of the current computer +-----------------------------------------------------------------------------} +// $Id: NetworkFunctions.pas,v 1.7 2005/05/19 20:23:12 obones Exp $ +unit NetworkFunctions; + +interface + +uses Classes; + +// Fills the given List with the names of all installed network adapters +// on the current computer. The List must be created before the call +// and will be cleared by the procedure. The Objects porperty of the +// List will be filled with the index of the adapters, so that you can +// use them in a call to GetUpBytes for instance +// (doing GetUpBytes(Cardinal(List.Objects[i])); ) +// +// Parameters: +// List a TStrings instance that will be filled with the list of +// installed network adapters for the current computer +// +procedure GetAdaptersList(List : TStrings); + +// Returns the number of uploaded bytes (sent) through the given +// adapter, or 0 if the Adapter is incorrect +// +// Parameters: +// Adapter The index of a valid network adapter for this computer +// +// Return value: +// The number of bytes uploaded (sent) through the given adapter +// +function GetUpBytes(Adapter : Cardinal) : cardinal; + +// Returns the number of downloaded bytes (received) through the given +// adapter, or 0 if the Adapter is incorrect +// +// Parameters: +// Adapter The index of a valid network adapter for this computer +// +// Return value: +// The number of bytes downloaded (received) through the given adapter +// +function GetDownBytes(Adapter : Cardinal) : cardinal; + +// Returns the string representation of the given value as scientific +// number following the SI recommandations. (eg, 1000 is 1k) +// It can also follow the recommandations for binary numbers, where +// 1k is 1024 and a suffix is added (hence 1024 is 1ki) +// +// Parameters: +// value The value to convert +// MaxDecimals The maximum number of decimals to show in the string +// If the value is 2.10k then 2.1k will be shown +// If the value is 2.342k then 2.34k will be shown +// separator A string to add between the number representation +// and the power prefix. Defaults to '' (empty string) +// binary If true, the binary conversion rules are used +// Defaults to False +// binarySuffix The suffix to added when converting according to +// binary rules. Defaults to 'i', the recommanded +// value for SI compliant values +// +// Return value: +// The converted number as a string +// +function BytesToSI(value : Int64; + MaxDecimals : Integer = 2; + separator : string = ''; + binary : Boolean=False; + binarySuffix : string='i' + ): string; + +type + TCallNetShResult = (nsrOk, nsrNotFound, nsrOther); + TOutputCallback = procedure(Line: string; var Aborted: Boolean); +// Calls Netsh with the given parameters and returns the +// result of ShellExecute + +{$IFDEF CALL_NET_SH} + +function CallNetSh(Parameters : string; + OutputCallback : TOutputCallback = nil): TCallNetShResult; + +{$ENDIF} + +// Returns the names of the available connections, as taken +// from the registry. These names are the ones to use with +// Netsh. The names list must be created by the caller +procedure GetConnectionInfo(Names, Guids: TStrings); +procedure AdaptersInfo(Names: TStrings); + +function UrlDecode(S : String) : String; +function UrlEncode(S : String) : String; + + +implementation + +uses Windows, SysUtils, Math, IPHlpApi, IPRtrMIB, IPTypes, IpIfConst, ShellApi, Registry +{$IFDEF CALL_NET_SH} +, CapExec +{$ENDIF} +; + +procedure GetAdaptersList(List : TStrings); +var + Size: Cardinal; + IntfTable: PMibIfTable; + I: Integer; + MibRow: TMibIfRow; + itemIndex : integer; +begin + List.Clear; + + // ask for size + Size := 0; + if GetIfTable(nil, Size, True) = ERROR_INSUFFICIENT_BUFFER then + begin + // if we were given the size + // then we allocate what's needed for it + IntfTable := AllocMem(Size); + try + // asks for Interface information table + if GetIfTable(IntfTable, Size, True) = NO_ERROR then + begin + // and fill the combo box + for I := 0 to IntfTable^.dwNumEntries - 1 do + begin + MibRow := IntfTable.Table[I]; + // add the name + itemIndex := List.Add(PChar(@MIbRow.bDescr[0])); + // and store the index + List.Objects[itemIndex] := TObject(MibRow.dwIndex); + end; + end; + finally + // always free + FreeMem(IntfTable); + end; + end; +end; + +function GetUpBytes(Adapter : Cardinal) : cardinal; +var + row : TMIBIFRow; +begin + row.dwIndex := Adapter; + if GetIfEntry(@row) = NO_ERROR then + begin + Result := row.dwOutOctets; + end + else + begin + Result := 0; + end; +end; + +function GetDownBytes(Adapter : Cardinal) : cardinal; +var + row : TMIBIFRow; +begin + row.dwIndex := Adapter; + if GetIfEntry(@row) = NO_ERROR then + begin + Result := row.dwInOctets; + end + else + begin + Result := 0; + end; +end; + +function BytesToSI(value : int64; + MaxDecimals : Integer; + separator : string; + binary : Boolean; + binarySuffix : string + ): string; +const prefixes : array[0..8] of string = ('', 'k','M','G','T', 'P', 'E', 'Z', 'Y'); +var + divider : integer; + prefixIndex : cardinal; + suffix : string; + FloatValue : Extended; + SignPrefix : string; + Precision : Integer; + StrRounded : String; + i : Integer; +begin + // decide the divider + if binary then + begin + divider := 1024; + suffix := binarySuffix; + end + else + begin + divider := 1000; + suffix := ''; + end; + + // decide the sign prefix + if Value < 0 then + begin + SignPrefix := '-'; + FloatValue := -Value; + end + else + begin + SignPrefix := ''; + FloatValue := Value; + end; + + // at first, no prefix + prefixIndex := 0; + while (FloatValue / divider) >= 1 do + begin + // divide by divider + FloatValue := FloatValue / divider; + // use next prefix + inc(prefixIndex); + end; + + // calculate precision + StrRounded := IntToStr(Round(Power(10, MaxDecimals) * FloatValue)); + i := Length(StrRounded); + Precision := MaxDecimals; + while StrRounded[i] = '0' do + begin + Dec(I); + Dec(Precision); + end; + + // return result + Result := SignPrefix + Format('%.*f', [Precision, FloatValue]) + separator + prefixes[prefixIndex] + suffix; +end; + +type + TOutputCallbackHolder = class(TObject) + private + FOutputCallback: TOutputCallback; + procedure CaptureLine(const Line: string; var Aborted: Boolean); + public + constructor Create(OutputCallback: TOutputCallback); + end; + +constructor TOutputCallbackHolder.Create(OutputCallback: TOutputCallback); +begin + inherited Create; + FOutputCallback := OutputCallback; +end; + +procedure TOutputCallbackHolder.CaptureLine(const Line: string; var Aborted: Boolean); +begin + if Assigned(FOutputCallback) then + FOutputCallback(Line, Aborted); +end; + +var stbuf:array[0..MAX_PATH] of char; + +{$IFDEF CALL_NET_SH} + +function CallNetSh(Parameters : string; OutputCallback : TOutputCallback): TCallNetShResult; +var + szParameters: PChar; + tmp : Boolean; + NetshFileName: string; + CaptureResult: Integer; + callbackHolder: TOutputCallbackHolder; +begin + // Test for netsh presence + NetshFileName := ''; + if GetSystemDirectory(stbuf, MAX_PATH)>0 then + NetshFileName := string(stbuf) + '\netsh.exe'; + if not FileExists(NetshFileName) then + begin + if GetWindowsDirectory(stbuf, MAX_PATH)>0 then + NetshFileName := string(stbuf) + '\netsh.Exe'; + if not FileExists(NetshFileName) then + NetshFileName := ''; + end; + if NetshFileName = '' then + begin + Result := nsrNotFound; + end + else + begin + // Prepare callback holder + callbackHolder := TOutputCallbackHolder.Create(OutputCallback); + try + szParameters := GetMemory(Length(Parameters)); + try + // Ensure that the parameters are in the OEM page code. + //CharToOEM(PChar(Parameters), szParameters); + StrPCopy(szParameters, Parameters); + + tmp := False; + OutputCallback(NetshFileName+ ' '+ szParameters, tmp); + + + // Now call netsh + CaptureResult := CaptureExecute(NetshFileName, + SzParameters, + GetCurrentDir, + callbackHolder.CaptureLine); + Result := nsrOk; + if CaptureResult = -1 then + Result := nsrOther + finally + FreeMemory(szParameters); + end; + finally + callbackHolder.Free; + end; + end; +end; + +{$ENDIF} + +procedure GetConnectionInfo(Names, Guids: TStrings); +const + StartKey = '\SYSTEM\CurrentControlSet\Control\Network'; + SubKeyNetName = 'Class'; + SubKeyNetValue = 'Net'; + NameValueName = 'Name'; + ShowIconValueName = 'ShowIcon'; +var + Reg: TRegistry; + KeyNames : TStringList; + i : Integer; + KeyFound : Boolean; + Key : string; +begin + Names.Clear; + + // Access the registry in read only mode + Reg := TRegistry.Create(HKEY_LOCAL_MACHINE); + KeyNames := TStringList.Create; + try + Reg.RootKey := HKEY_LOCAL_MACHINE; + Reg.OpenKeyReadOnly(StartKey); + + // Need to find the child that has a value named + // 'Class' which value is 'Net' + Reg.GetKeyNames(KeyNames); + i := 0; + KeyFound := False; + Key := StartKey; + while (i < KeyNames.Count) and not KeyFound do + begin + Reg.OpenKeyReadOnly(Key+'\'+KeyNames[i]); + if Reg.ReadString(SubKeyNetName) = SubKeyNetValue then + KeyFound := True; + Inc(i); + end; + + // Found a key, open it and read its subkeys + // which in turn contain the names we are looking for + // in their Connection subkey + if KeyFound then + begin + Key := '\'+Reg.CurrentPath; + Reg.OpenKeyReadOnly(KeyNames[i-1]); + Reg.GetKeyNames(KeyNames); + for i := 0 to KeyNames.Count - 1 do + begin + Reg.OpenKeyReadOnly(Key+'\'+KeyNames[i]+'\Connection'); + if Reg.ValueExists(NameValueName) then + begin + // This below has been removed, there must be another way + // to find if an interface is valid or not +{ // do not add if ShowIcon is 0. + if not (Reg.ValueExists(ShowIconValueName) and + (Reg.ReadInteger(ShowIconValueName) = 0)) then} + Names.Add(Reg.ReadString(NameValueName)); + Guids.Add(KeyNames[i]); + end; + end; + end; + finally + Reg.Free; + KeyNames.Free; + end; +end; + +function XDigit(Ch : char) : Integer; +begin + if ch in ['0'..'9'] then + Result := ord(Ch) - ord('0') + else + Result := (ord(Ch) and 15) + 9; +end; + +function IsXDigit(Ch : char) : Boolean; +begin + Result := (ch in ['0'..'9']) or (ch in ['a'..'f']) or (ch in ['A'..'F']); +end; + +function htoin(value : PChar; len : Integer) : Integer; +var + i : Integer; +begin + Result := 0; + i := 0; + while (i < len) and (Value[i] = ' ') do + i := i + 1; + while (i < len) and (isxDigit(Value[i])) do begin + Result := Result * 16 + xdigit(Value[i]); + i := i + 1; + end; +end; + +function htoi2(value : PChar) : Integer; +begin + Result := htoin(value, 2); +end; + + +function UrlEncode(S : String) : String; +var + I : Integer; +begin + Result := ''; + for I := 1 to Length(S) do begin + if S[I] in ['0'..'9', 'A'..'Z', 'a'..'z'] then + Result := Result + S[I] + else + Result := Result + '%' + IntToHex(Ord(S[I]), 2); + end; +end; + +function UrlDecode(S : String) : String; +var + I : Integer; + Ch : Char; +begin + Result := ''; + I := 1; + while (I <= Length(S)) and (S[I] <> '&') do begin + Ch := S[I]; + if Ch = '%' then begin + Ch := chr(htoi2(@S[I + 1])); + Inc(I, 2); + end + else if Ch = '+' then + Ch := ' '; + Result := Result + Ch; + Inc(I); + end; +end; + +// serge +procedure AdaptersInfo(Names: TStrings); +var + pAdapterInfo, pAdapt: PIP_ADAPTER_INFO; + pAddrStr:PIP_ADDR_STRING; + Err, AdapterInfoSize: DWORD; +begin +//Очищаю список устройств + Names.Clear; +//Получить количество устройств + AdapterInfoSize:=0; + Err:=GetAdaptersInfo(nil, AdapterInfoSize); +//Если произошла ошибка, то... + if (Err<>0) and (Err<>ERROR_BUFFER_OVERFLOW) then + begin + Names.Add('Error'); + exit; + end; +//Получить информацию об устройствах. + pAdapterInfo := PIP_ADAPTER_INFO(GlobalAlloc(GPTR, AdapterInfoSize)); + GetAdaptersInfo(pAdapterInfo, AdapterInfoSize); + pAdapt := pAdapterInfo; +//Проверяю тип полученного адаптера + while pAdapt<>nil do + begin + case pAdapt.Type_ of + MIB_IF_TYPE_ETHERNET: + Names.Add('Ethernet adapter '+pAdapt.AdapterName); + MIB_IF_TYPE_TOKENRING: + Names.Add('Token Ring adapter '+pAdapt.AdapterName); + MIB_IF_TYPE_FDDI: + Names.Add('FDDI adapter '+pAdapt.AdapterName); + MIB_IF_TYPE_PPP: + Names.Add('PPP adapter '+pAdapt.AdapterName); + MIB_IF_TYPE_LOOPBACK: + Names.Add('Loopback adapter '+pAdapt.AdapterName); + MIB_IF_TYPE_SLIP: + Names.Add('Slip adapter '+pAdapt.AdapterName); + MIB_IF_TYPE_OTHER: + Names.Add('Other adapter '+pAdapt.AdapterName); + end; + pAdapt := pAdapt.Next; + end; +// GlobalFree(Cardinal(pFixedInfo)); +end; + + +end. diff --git a/OrionZEm.cfg b/OrionZEm.cfg new file mode 100644 index 0000000..d0e679a --- /dev/null +++ b/OrionZEm.cfg @@ -0,0 +1,36 @@ +-$A+ +-$B- +-$C+ +-$D+ +-$E- +-$F- +-$G+ +-$H+ +-$I+ +-$J+ +-$K- +-$L+ +-$M- +-$N+ +-$O+ +-$P+ +-$Q- +-$R- +-$S- +-$T- +-$U- +-$V+ +-$W- +-$X+ +-$YD +-$Z1 +-cg +-AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +-H+ +-W+ +-M +-$M16384,1048576 +-K$00400000 +-LE"c:\borland\delphi5\Projects\Bpl" +-LN"c:\borland\delphi5\Projects\Bpl" +-DORIONZEM diff --git a/OrionZEm.dis b/OrionZEm.dis new file mode 100644 index 0000000..6c630c7 --- /dev/null +++ b/OrionZEm.dis @@ -0,0 +1,1270 @@ +"00","NOP" +"01 m","LD BC,m" +"02","LD (BC),A" +"03","INC BC" +"04","INC B" +"05","DEC B" +"06 n","LD B,n" +"07","RLCA" +"08","EX AF,AF'" +"09","ADD HL,BC" +"0A","LD A,(BC)" +"0B","DEC BC" +"0C","INC C" +"0D","DEC C" +"0E n","LD C,n" +"0F","RRCA" +"10 e","DJNZ e" +"11 m","LD DE,m" +"12","LD (DE),A" +"13","INC DE" +"14","INC D" +"15","DEC D" +"16 n","LD D,n" +"17","RLA" +"18 e","JR e" +"19","ADD HL,DE" +"1A","LD A,(DE)" +"1B","DEC DE" +"1C","INC E" +"1D","DEC E" +"1E n","LD E,n" +"1F","RRA" +"20 e","JR NZ, e" +"21 m","LD HL,m" +"22 m","LD (m),HL" +"23","INC HL" +"24","INC H" +"25","DEC H" +"26 n","LD H,n" +"27","DAA" +"28 e","JR Z, e " +"29","ADD HL,HL" +"2A m","LD HL,(m)" +"2B","DEC HL" +"2C","INC L" +"2D","DEC L" +"2E n","LD L,n" +"2F","CPL" +"30 e","JR NC, e" +"31 m","LD SP,m" +"32 m","LD (m),A" +"33","INC SP" +"34","INC (HL)" +"35","DEC (HL)" +"36 n","LD (HL),n" +"37","SCF" +"38 e","JR C, e" +"39","ADD HL,SP" +"3A m","LD A,(m)" +"3B","DEC SP" +"3C","INC A" +"3D","DEC A" +"3E n","LD A,n" +"3F","CCF" +"40","LD B,B" +"41","LD B,C" +"42","LD B,D" +"43","LD B,E" +"44","LD B,H" +"45","LD B,L" +"46","LD B,(HL)" +"47","LD B,A" +"48","LD C,B" +"49","LD C,C" +"4A","LD C,D" +"4B","LD C,E" +"4C","LD C,H" +"4D","LD C,L" +"4E","LD C,(HL)" +"4F","LD C,A" +"50","LD D,B" +"51","LD D,C" +"52","LD D,D" +"53","LD D,E" +"54","LD D,H" +"55","LD D,L" +"56","LD D,(HL)" +"57","LD D,A" +"58","LD E,B" +"59","LD E,C" +"5A","LD E,D" +"5B","LD E,E" +"5C","LD E,H" +"5D","LD E,L" +"5E","LD E,(HL)" +"5F","LD E,A" +"60","LD H,B" +"61","LD H,C" +"62","LD H,D" +"63","LD H,E" +"64","LD H,H" +"65","LD H,L" +"66","LD H,(HL)" +"67","LD H,A" +"68","LD L,B" +"69","LD L,C" +"6A","LD L,D" +"6B","LD L,E" +"6C","LD L,H" +"6D","LD L,L" +"6E","LD L,(HL)" +"6F","LD L,A" +"70","LD (HL),B" +"71","LD (HL),C" +"72","LD (HL),D" +"73","LD (HL),E" +"74","LD (HL),H" +"75","LD (HL),L" +"76","HALT" +"77","LD (HL),A" +"78","LD A,B" +"79","LD A,C" +"7A","LD A,D" +"7B","LD A,E" +"7C","LD A,H" +"7D","LD A,L" +"7E","LD A,(HL)" +"7F","LD A,A" +"80","ADD A,B" +"81","ADD A,C" +"82","ADD A,D" +"83","ADD A,E" +"84","ADD A,H" +"85","ADD A,L" +"86","ADD A,(HL)" +"87","ADD A,A" +"88","ADC A,B" +"89","ADC A,C" +"8A","ADC A,D" +"8B","ADC A,E" +"8C","ADC A,H" +"8D","ADC A,L" +"8E","ADC A,(HL)" +"8F","ADC A,A" +"90","SUB B" +"91","SUB C" +"92","SUB D" +"93","SUB E" +"94","SUB H" +"95","SUB L" +"96","SUB (HL)" +"97","SUB A" +"98","SBC A,B" +"99","SBC A,C" +"9A","SBC A,D" +"9B","SBC A,E" +"9C","SBC A,H" +"9D","SBC A,L" +"9E","SBC A,(HL)" +"9F","SBC A,A" +"A0","AND B" +"A1","AND C" +"A2","AND D" +"A3","AND E" +"A4","AND H" +"A5","AND L" +"A6","AND (HL)" +"A7","AND A" +"A8","XOR B" +"A9","XOR C" +"AA","XOR D" +"AB","XOR E" +"AC","XOR H" +"AD","XOR L" +"AE","XOR (HL)" +"AF","XOR A" +"B0","OR B" +"B1","OR C" +"B2","OR D" +"B3","OR E" +"B4","OR H" +"B5","OR L" +"B6","OR (HL)" +"B7","OR A" +"B8","CP B" +"B9","CP C" +"BA","CP D" +"BB","CP E" +"BC","CP H" +"BD","CP L" +"BE","CP (HL)" +"BF","CP A" +"C0","RET NZ" +"C1","POP BC" +"C2 m","JP NZ, m" +"C3 m","JP m" +"C4 m","CALL NZ, m" +"C5","PUSH BC" +"C6 n","ADD A,n" +"C7","RST 0H" +"C8","RET Z" +"C9","RET" +"CA m","JP Z, m" +"CB00","RLC B" +"CB01","RLC C" +"CB02","RLC D" +"CB03","RLC E" +"CB04","RLC H" +"CB05","RLC L" +"CB06","RLC (HL)" +"CB07","RLC A" +"CB08","RRC B" +"CB09","RRC C" +"CB0A","RRC D" +"CB0B","RRC E" +"CB0C","RRC H" +"CB0D","RRC L" +"CB0E","RRC (HL)" +"CB0F","RRC A" +"CB10","RL B" +"CB11","RL C" +"CB12","RL D" +"CB13","RL E" +"CB14","RL H" +"CB15","RL L" +"CB16","RL (HL)" +"CB17","RL A" +"CB18","RR B" +"CB19","RR C" +"CB1A","RR D" +"CB1B","RR E" +"CB1C","RR H" +"CB1D","RR L" +"CB1E","RR (HL)" +"CB1F","RR A" +"CB20","SLA B" +"CB21","SLA C" +"CB22","SLA D" +"CB23","SLA E" +"CB24","SLA H" +"CB25","SLA L" +"CB26","SLA (HL)" +"CB27","SLA A" +"CB28","SRA B" +"CB29","SRA C" +"CB2A","SRA D" +"CB2B","SRA E" +"CB2C","SRA H" +"CB2D","SRA L" +"CB2E","SRA (HL)" +"CB2F","SRA A" +"CB30","SLL B*" +"CB31","SLL C*" +"CB32","SLL D*" +"CB33","SLL E*" +"CB34","SLL H*" +"CB35","SLL L*" +"CB36","SLL (HL)*" +"CB37","SLL A*" +"CB38","SRL B" +"CB39","SRL C" +"CB3A","SRL D" +"CB3B","SRL E" +"CB3C","SRL H" +"CB3D","SRL L" +"CB3E","SRL (HL)" +"CB3F","SRL A" +"CB40","BIT 0,B" +"CB41","BIT 0,C" +"CB42","BIT 0,D" +"CB43","BIT 0,E" +"CB44","BIT 0,H" +"CB45","BIT 0,L" +"CB46","BIT 0,(HL)" +"CB47","BIT 0,A" +"CB48","BIT 1,B" +"CB49","BIT 1,C" +"CB4A","BIT 1,D" +"CB4B","BIT 1,E" +"CB4C","BIT 1,H" +"CB4D","BIT 1,L" +"CB4E","BIT 1,(HL)" +"CB4F","BIT 1,A" +"CB50","BIT 2,B" +"CB51","BIT 2,C" +"CB52","BIT 2,D" +"CB53","BIT 2,E" +"CB54","BIT 2,H" +"CB55","BIT 2,L" +"CB56","BIT 2,(HL)" +"CB57","BIT 2,A" +"CB58","BIT 3,B" +"CB59","BIT 3,C" +"CB5A","BIT 3,D" +"CB5B","BIT 3,E" +"CB5C","BIT 3,H" +"CB5D","BIT 3,L" +"CB5E","BIT 3,(HL)" +"CB5F","BIT 3,A" +"CB60","BIT 4,B" +"CB61","BIT 4,C" +"CB62","BIT 4,D" +"CB63","BIT 4,E" +"CB64","BIT 4,H" +"CB65","BIT 4,L" +"CB66","BIT 4,(HL)" +"CB67","BIT 4,A" +"CB68","BIT 5,B" +"CB69","BIT 5,C" +"CB6A","BIT 5,D" +"CB6B","BIT 5,E" +"CB6C","BIT 5,H" +"CB6D","BIT 5,L" +"CB6E","BIT 5,(HL)" +"CB6F","BIT 5,A" +"CB70","BIT 6,B" +"CB71","BIT 6,C" +"CB72","BIT 6,D" +"CB73","BIT 6,E" +"CB74","BIT 6,H" +"CB75","BIT 6,L" +"CB76","BIT 6,(HL)" +"CB77","BIT 6,A" +"CB78","BIT 7,B" +"CB79","BIT 7,C" +"CB7A","BIT 7,D" +"CB7B","BIT 7,E" +"CB7C","BIT 7,H" +"CB7D","BIT 7,L" +"CB7E","BIT 7,(HL)" +"CB7F","BIT 7,A" +"CB80","RES 0,B" +"CB81","RES 0,C" +"CB82","RES 0,D" +"CB83","RES 0,E" +"CB84","RES 0,H" +"CB85","RES 0,L" +"CB86","RES 0,(HL)" +"CB87","RES 0,A" +"CB88","RES 1,B" +"CB89","RES 1,C" +"CB8A","RES 1,D" +"CB8B","RES 1,E" +"CB8C","RES 1,H" +"CB8D","RES 1,L" +"CB8E","RES 1,(HL)" +"CB8F","RES 1,A" +"CB90","RES 2,B" +"CB91","RES 2,C" +"CB92","RES 2,D" +"CB93","RES 2,E" +"CB94","RES 2,H" +"CB95","RES 2,L" +"CB96","RES 2,(HL)" +"CB97","RES 2,A" +"CB98","RES 3,B" +"CB99","RES 3,C" +"CB9A","RES 3,D" +"CB9B","RES 3,E" +"CB9C","RES 3,H" +"CB9D","RES 3,L" +"CB9E","RES 3,(HL)" +"CB9F","RES 3,A" +"CBA0","RES 4,B" +"CBA1","RES 4,C" +"CBA2","RES 4,D" +"CBA3","RES 4,E" +"CBA4","RES 4,H" +"CBA5","RES 4,L" +"CBA6","RES 4,(HL)" +"CBA7","RES 4,A" +"CBA8","RES 5,B" +"CBA9","RES 5,C" +"CBAA","RES 5,D" +"CBAB","RES 5,E" +"CBAC","RES 5,H" +"CBAD","RES 5,L" +"CBAE","RES 5,(HL)" +"CBAF","RES 5,A" +"CBB0","RES 6,B" +"CBB1","RES 6,C" +"CBB2","RES 6,D" +"CBB3","RES 6,E" +"CBB4","RES 6,H" +"CBB5","RES 6,L" +"CBB6","RES 6,(HL)" +"CBB7","RES 6,A" +"CBB8","RES 7,B" +"CBB9","RES 7,C" +"CBBA","RES 7,D" +"CBBB","RES 7,E" +"CBBC","RES 7,H" +"CBBD","RES 7,L" +"CBBE","RES 7,(HL)" +"CBBF","RES 7,A" +"CBC0","SET 0,B" +"CBC1","SET 0,C" +"CBC2","SET 0,D" +"CBC3","SET 0,E" +"CBC4","SET 0,H" +"CBC5","SET 0,L" +"CBC6","SET 0,(HL)" +"CBC7","SET 0,A" +"CBC8","SET 1,B" +"CBC9","SET 1,C" +"CBCA","SET 1,D" +"CBCB","SET 1,E" +"CBCC","SET 1,H" +"CBCD","SET 1,L" +"CBCE","SET 1,(HL)" +"CBCF","SET 1,A" +"CBD0","SET 2,B" +"CBD1","SET 2,C" +"CBD2","SET 2,D" +"CBD3","SET 2,E" +"CBD4","SET 2,H" +"CBD5","SET 2,L" +"CBD6","SET 2,(HL)" +"CBD7","SET 2,A" +"CBD8","SET 3,B" +"CBD9","SET 3,C" +"CBDA","SET 3,D" +"CBDB","SET 3,E" +"CBDC","SET 3,H" +"CBDD","SET 3,L" +"CBDE","SET 3,(HL)" +"CBDF","SET 3,A" +"CBE0","SET 4,B" +"CBE1","SET 4,C" +"CBE2","SET 4,D" +"CBE3","SET 4,E" +"CBE4","SET 4,H" +"CBE5","SET 4,L" +"CBE6","SET 4,(HL)" +"CBE7","SET 4,A" +"CBE8","SET 5,B" +"CBE9","SET 5,C" +"CBEA","SET 5,D" +"CBEB","SET 5,E" +"CBEC","SET 5,H" +"CBED","SET 5,L" +"CBEE","SET 5,(HL)" +"CBEF","SET 5,A" +"CBF0","SET 6,B" +"CBF1","SET 6,C" +"CBF2","SET 6,D" +"CBF3","SET 6,E" +"CBF4","SET 6,H" +"CBF5","SET 6,L" +"CBF6","SET 6,(HL)" +"CBF7","SET 6,A" +"CBF8","SET 7,B" +"CBF9","SET 7,C" +"CBFA","SET 7,D" +"CBFB","SET 7,E" +"CBFC","SET 7,H" +"CBFD","SET 7,L" +"CBFE","SET 7,(HL)" +"CBFF","SET 7,A" +"CC m","CALL Z, m" +"CD m","CALL m" +"CE n","ADC A,n" +"CF","RST 8H" +"D0","RET NC" +"D1","POP DE" +"D2 m","JP NC, m" +"D3 n","OUT (n),A" +"D4 m","CALL NC, m" +"D5","PUSH DE" +"D6 n","SUB n" +"D7","RST 10H" +"D8","RET C" +"D9","EXX" +"DA m","JP C, m" +"DB n","IN A,(n)" +"DC m","CALL C, m" +"DD09","ADD IX,BC" +"DD19","ADD IX,DE" +"DD21 m","LD IX,m" +"DD22 m","LD (m),IX" +"DD23","INC IX" +"DD24","INC IXH*" +"DD25","DEC IXH*" +"DD26 n","LD IXH,n*" +"DD29","ADD IX,IX" +"DD2A m","LD IX,(m)" +"DD2B","DEC IX" +"DD2C","INC IXL*" +"DD2D","DEC IXL*" +"DD2E n","LD IXL,n*" +"DD34 d","INC (IX+d)" +"DD35 d","DEC (IX+d)" +"DD36 d n","LD (IX+d),n" +"DD39","ADD IX,SP" +"DD44","LD B,IXH*" +"DD45","LD B,IXL*" +"DD46 d","LD B,(IX+d)" +"DD4C","LD C,IXH*" +"DD4D","LD C,IXL*" +"DD4E d","LD C,(IX+d)" +"DD54","LD D,IXH*" +"DD55","LD D,IXL*" +"DD56 d","LD D,(IX+d)" +"DD5C","LD E,IXH*" +"DD5D","LD E,IXL*" +"DD5E d","LD E,(IX+d)" +"DD60","LD IXH,B*" +"DD61","LD IXH,C*" +"DD62","LD IXH,D*" +"DD63","LD IXH,E*" +"DD64","LD IXH,IXH*" +"DD65","LD IXH,IXL*" +"DD66 d","LD H,(IX+d)" +"DD67","LD IXH,A*" +"DD68","LD IXL,B*" +"DD69","LD IXL,C*" +"DD6A","LD IXL,D*" +"DD6B","LD IXL,E*" +"DD6C","LD IXL,IXH*" +"DD6D","LD IXL,IXL*" +"DD6E d","LD L,(IX+d)" +"DD6F","LD IXL,A*" +"DD70 d","LD (IX+d),B" +"DD71 d","LD (IX+d),C" +"DD72 d","LD (IX+d),D" +"DD73 d","LD (IX+d),E" +"DD74 d","LD (IX+d),H" +"DD75 d","LD (IX+d),L" +"DD77 d","LD (IX+d),A" +"DD7C","LD A,IXH*" +"DD7D","LD A,IXL*" +"DD7E d","LD A,(IX+d)" +"DD84","ADD A,IXH*" +"DD85","ADD A,IXL*" +"DD86 d","ADD A,(IX+d)" +"DD8C","ADC A,IXH*" +"DD8D","ADC A,IXL*" +"DD8E d","ADC A,(IX+d)" +"DD94","SUB IXH*" +"DD95","SUB IXL*" +"DD96 d","SUB (IX+d)" +"DD9C","SBC A,IXH*" +"DD9D","SBC A,IXL*" +"DD9E d","SBC A,(IX+d)" +"DDA4","AND IXH*" +"DDA5","AND IXL*" +"DDA6 d","AND (IX+d)" +"DDAC","XOR IXH*" +"DDAD","XOR IXL*" +"DDAE d","XOR (IX+d)" +"DDB4","OR IXH*" +"DDB5","OR IXL*" +"DDB6 d","OR (IX+d)" +"DDBC","CP IXH*" +"DDBD","CP IXL*" +"DDBE d","CP (IX+d)" +"DDCB d 00","LD B,RLC (IX+d)*" +"DDCB d 01","LD C,RLC (IX+d)*" +"DDCB d 02","LD D,RLC (IX+d)*" +"DDCB d 03","LD E,RLC (IX+d)*" +"DDCB d 04","LD H,RLC (IX+d)*" +"DDCB d 05","LD L,RLC (IX+d)*" +"DDCB d 06","RLC (IX+d)" +"DDCB d 07","LD A,RLC (IX+d)*" +"DDCB d 08","LD B,RRC (IX+d)*" +"DDCB d 09","LD C,RRC (IX+d)*" +"DDCB d 0A","LD D,RRC (IX+d)*" +"DDCB d 0B","LD E,RRC (IX+d)*" +"DDCB d 0C","LD H,RRC (IX+d)*" +"DDCB d 0D","LD L,RRC (IX+d)*" +"DDCB d 0E","RRC (IX+d)" +"DDCB d 0F","LD A,RRC (IX+d)*" +"DDCB d 10","LD B,RL (IX+d)*" +"DDCB d 11","LD C,RL (IX+d)*" +"DDCB d 12","LD D,RL (IX+d)*" +"DDCB d 13","LD E,RL (IX+d)*" +"DDCB d 14","LD H,RL (IX+d)*" +"DDCB d 15","LD L,RL (IX+d)*" +"DDCB d 16","RL (IX+d)" +"DDCB d 17","LD A,RL (IX+d)*" +"DDCB d 18","LD B,RR (IX+d)*" +"DDCB d 19","LD C,RR (IX+d)*" +"DDCB d 1A","LD D,RR (IX+d)*" +"DDCB d 1B","LD E,RR (IX+d)*" +"DDCB d 1C","LD H,RR (IX+d)*" +"DDCB d 1D","LD L,RR (IX+d)*" +"DDCB d 1E","RR (IX+d)" +"DDCB d 1F","LD A,RR (IX+d)*" +"DDCB d 20","LD B,SLA (IX+d)*" +"DDCB d 21","LD C,SLA (IX+d)*" +"DDCB d 22","LD D,SLA (IX+d)*" +"DDCB d 23","LD E,SLA (IX+d)*" +"DDCB d 24","LD H,SLA (IX+d)*" +"DDCB d 25","LD L,SLA (IX+d)*" +"DDCB d 26","SLA (IX+d)" +"DDCB d 27","LD A,SLA (IX+d)*" +"DDCB d 28","LD B,SRA (IX+d)*" +"DDCB d 29","LD C,SRA (IX+d)*" +"DDCB d 2A","LD D,SRA (IX+d)*" +"DDCB d 2B","LD E,SRA (IX+d)*" +"DDCB d 2C","LD H,SRA (IX+d)*" +"DDCB d 2D","LD L,SRA (IX+d)*" +"DDCB d 2E","SRA (IX+d)" +"DDCB d 2F","LD A,SRA (IX+d)*" +"DDCB d 30","LD B,SLL (IX+d)*" +"DDCB d 31","LD C,SLL (IX+d)*" +"DDCB d 32","LD D,SLL (IX+d)*" +"DDCB d 33","LD E,SLL (IX+d)*" +"DDCB d 34","LD H,SLL (IX+d)*" +"DDCB d 35","LD L,SLL (IX+d)*" +"DDCB d 36","SLL (IX+d)*" +"DDCB d 37","LD A,SLL (IX+d)*" +"DDCB d 38","LD B,SRL (IX+d)*" +"DDCB d 39","LD C,SRL (IX+d)*" +"DDCB d 3A","LD D,SRL (IX+d)*" +"DDCB d 3B","LD E,SRL (IX+d)*" +"DDCB d 3C","LD H,SRL (IX+d)*" +"DDCB d 3D","LD L,SRL (IX+d)*" +"DDCB d 3E","SRL (IX+d)" +"DDCB d 3F","LD A,SRL (IX+d)*" +"DDCB d 40","BIT 0,(IX+d)*" +"DDCB d 41","BIT 0,(IX+d)*" +"DDCB d 42","BIT 0,(IX+d)*" +"DDCB d 43","BIT 0,(IX+d)*" +"DDCB d 44","BIT 0,(IX+d)*" +"DDCB d 45","BIT 0,(IX+d)*" +"DDCB d 46","BIT 0,(IX+d)" +"DDCB d 47","BIT 0,(IX+d)*" +"DDCB d 48","BIT 1,(IX+d)*" +"DDCB d 49","BIT 1,(IX+d)*" +"DDCB d 4A","BIT 1,(IX+d)*" +"DDCB d 4B","BIT 1,(IX+d)*" +"DDCB d 4C","BIT 1,(IX+d)*" +"DDCB d 4D","BIT 1,(IX+d)*" +"DDCB d 4E","BIT 1,(IX+d)" +"DDCB d 4F","BIT 1,(IX+d)*" +"DDCB d 50","BIT 2,(IX+d)*" +"DDCB d 51","BIT 2,(IX+d)*" +"DDCB d 52","BIT 2,(IX+d)*" +"DDCB d 53","BIT 2,(IX+d)*" +"DDCB d 54","BIT 2,(IX+d)*" +"DDCB d 55","BIT 2,(IX+d)*" +"DDCB d 56","BIT 2,(IX+d)" +"DDCB d 57","BIT 2,(IX+d)*" +"DDCB d 58","BIT 3,(IX+d)*" +"DDCB d 59","BIT 3,(IX+d)*" +"DDCB d 5A","BIT 3,(IX+d)*" +"DDCB d 5B","BIT 3,(IX+d)*" +"DDCB d 5C","BIT 3,(IX+d)*" +"DDCB d 5D","BIT 3,(IX+d)*" +"DDCB d 5E","BIT 3,(IX+d)" +"DDCB d 5F","BIT 3,(IX+d)*" +"DDCB d 60","BIT 4,(IX+d)*" +"DDCB d 61","BIT 4,(IX+d)*" +"DDCB d 62","BIT 4,(IX+d)*" +"DDCB d 63","BIT 4,(IX+d)*" +"DDCB d 64","BIT 4,(IX+d)*" +"DDCB d 65","BIT 4,(IX+d)*" +"DDCB d 66","BIT 4,(IX+d)" +"DDCB d 67","BIT 4,(IX+d)*" +"DDCB d 68","BIT 5,(IX+d)*" +"DDCB d 69","BIT 5,(IX+d)*" +"DDCB d 6A","BIT 5,(IX+d)*" +"DDCB d 6B","BIT 5,(IX+d)*" +"DDCB d 6C","BIT 5,(IX+d)*" +"DDCB d 6D","BIT 5,(IX+d)*" +"DDCB d 6E","BIT 5,(IX+d)" +"DDCB d 6F","BIT 5,(IX+d)*" +"DDCB d 70","BIT 6,(IX+d)*" +"DDCB d 71","BIT 6,(IX+d)*" +"DDCB d 72","BIT 6,(IX+d)*" +"DDCB d 73","BIT 6,(IX+d)*" +"DDCB d 74","BIT 6,(IX+d)*" +"DDCB d 75","BIT 6,(IX+d)*" +"DDCB d 76","BIT 6,(IX+d)" +"DDCB d 77","BIT 6,(IX+d)*" +"DDCB d 78","BIT 7,(IX+d)*" +"DDCB d 79","BIT 7,(IX+d)*" +"DDCB d 7A","BIT 7,(IX+d)*" +"DDCB d 7B","BIT 7,(IX+d)*" +"DDCB d 7C","BIT 7,(IX+d)*" +"DDCB d 7D","BIT 7,(IX+d)*" +"DDCB d 7E","BIT 7,(IX+d)" +"DDCB d 7F","BIT 7,(IX+d)*" +"DDCB d 80","LD B,RES 0,(IX+d)*" +"DDCB d 81","LD C,RES 0,(IX+d)*" +"DDCB d 82","LD D,RES 0,(IX+d)*" +"DDCB d 83","LD E,RES 0,(IX+d)*" +"DDCB d 84","LD H,RES 0,(IX+d)*" +"DDCB d 85","LD L,RES 0,(IX+d)*" +"DDCB d 86","RES 0,(IX+d)" +"DDCB d 87","LD A,RES 0,(IX+d)*" +"DDCB d 88","LD B,RES 1,(IX+d)*" +"DDCB d 89","LD C,RES 1,(IX+d)*" +"DDCB d 8A","LD D,RES 1,(IX+d)*" +"DDCB d 8B","LD E,RES 1,(IX+d)*" +"DDCB d 8C","LD H,RES 1,(IX+d)*" +"DDCB d 8D","LD L,RES 1,(IX+d)*" +"DDCB d 8E","RES 1,(IX+d)" +"DDCB d 8F","LD A,RES 1,(IX+d)*" +"DDCB d 90","LD B,RES 2,(IX+d)*" +"DDCB d 91","LD C,RES 2,(IX+d)*" +"DDCB d 92","LD D,RES 2,(IX+d)*" +"DDCB d 93","LD E,RES 2,(IX+d)*" +"DDCB d 94","LD H,RES 2,(IX+d)*" +"DDCB d 95","LD L,RES 2,(IX+d)*" +"DDCB d 96","RES 2,(IX+d)" +"DDCB d 97","LD A,RES 2,(IX+d)*" +"DDCB d 98","LD B,RES 3,(IX+d)*" +"DDCB d 99","LD C,RES 3,(IX+d)*" +"DDCB d 9A","LD D,RES 3,(IX+d)*" +"DDCB d 9B","LD E,RES 3,(IX+d)*" +"DDCB d 9C","LD H,RES 3,(IX+d)*" +"DDCB d 9D","LD L,RES 3,(IX+d)*" +"DDCB d 9E","RES 3,(IX+d)" +"DDCB d 9F","LD A,RES 3,(IX+d)*" +"DDCB d A0","LD B,RES 4,(IX+d)*" +"DDCB d A1","LD C,RES 4,(IX+d)*" +"DDCB d A2","LD D,RES 4,(IX+d)*" +"DDCB d A3","LD E,RES 4,(IX+d)*" +"DDCB d A4","LD H,RES 4,(IX+d)*" +"DDCB d A5","LD L,RES 4,(IX+d)*" +"DDCB d A6","RES 4,(IX+d)" +"DDCB d A7","LD A,RES 4,(IX+d)*" +"DDCB d A8","LD B,RES 5,(IX+d)*" +"DDCB d A9","LD C,RES 5,(IX+d)*" +"DDCB d AA","LD D,RES 5,(IX+d)*" +"DDCB d AB","LD E,RES 5,(IX+d)*" +"DDCB d AC","LD H,RES 5,(IX+d)*" +"DDCB d AD","LD L,RES 5,(IX+d)*" +"DDCB d AE","RES 5,(IX+d)" +"DDCB d AF","LD A,RES 5,(IX+d)*" +"DDCB d B0","LD B,RES 6,(IX+d)*" +"DDCB d B1","LD C,RES 6,(IX+d)*" +"DDCB d B2","LD D,RES 6,(IX+d)*" +"DDCB d B3","LD E,RES 6,(IX+d)*" +"DDCB d B4","LD H,RES 6,(IX+d)*" +"DDCB d B5","LD L,RES 6,(IX+d)*" +"DDCB d B6","RES 6,(IX+d)" +"DDCB d B7","LD A,RES 6,(IX+d)*" +"DDCB d B8","LD B,RES 7,(IX+d)*" +"DDCB d B9","LD C,RES 7,(IX+d)*" +"DDCB d BA","LD D,RES 7,(IX+d)*" +"DDCB d BB","LD E,RES 7,(IX+d)*" +"DDCB d BC","LD H,RES 7,(IX+d)*" +"DDCB d BD","LD L,RES 7,(IX+d)*" +"DDCB d BE","RES 7,(IX+d)" +"DDCB d BF","LD A,RES 7,(IX+d)*" +"DDCB d C0","LD B,SET 0,(IX+d)*" +"DDCB d C1","LD C,SET 0,(IX+d)*" +"DDCB d C2","LD D,SET 0,(IX+d)*" +"DDCB d C3","LD E,SET 0,(IX+d)*" +"DDCB d C4","LD H,SET 0,(IX+d)*" +"DDCB d C5","LD L,SET 0,(IX+d)*" +"DDCB d C6","SET 0,(IX+d)" +"DDCB d C7","LD A,SET 0,(IX+d)*" +"DDCB d C8","LD B,SET 1,(IX+d)*" +"DDCB d C9","LD C,SET 1,(IX+d)*" +"DDCB d CA","LD D,SET 1,(IX+d)*" +"DDCB d CB","LD E,SET 1,(IX+d)*" +"DDCB d CC","LD H,SET 1,(IX+d)*" +"DDCB d CD","LD L,SET 1,(IX+d)*" +"DDCB d CE","SET 1,(IX+d)" +"DDCB d CF","LD A,SET 1,(IX+d)*" +"DDCB d D0","LD B,SET 2,(IX+d)*" +"DDCB d D1","LD C,SET 2,(IX+d)*" +"DDCB d D2","LD D,SET 2,(IX+d)*" +"DDCB d D3","LD E,SET 2,(IX+d)*" +"DDCB d D4","LD H,SET 2,(IX+d)*" +"DDCB d D5","LD L,SET 2,(IX+d)*" +"DDCB d D6","SET 2,(IX+d)" +"DDCB d D7","LD A,SET 2,(IX+d)*" +"DDCB d D8","LD B,SET 3,(IX+d)*" +"DDCB d D9","LD C,SET 3,(IX+d)*" +"DDCB d DA","LD D,SET 3,(IX+d)*" +"DDCB d DB","LD E,SET 3,(IX+d)*" +"DDCB d DC","LD H,SET 3,(IX+d)*" +"DDCB d DD","LD L,SET 3,(IX+d)*" +"DDCB d DE","SET 3,(IX+d)" +"DDCB d DF","LD A,SET 3,(IX+d)*" +"DDCB d E0","LD B,SET 4,(IX+d)*" +"DDCB d E1","LD C,SET 4,(IX+d)*" +"DDCB d E2","LD D,SET 4,(IX+d)*" +"DDCB d E3","LD E,SET 4,(IX+d)*" +"DDCB d E4","LD H,SET 4,(IX+d)*" +"DDCB d E5","LD L,SET 4,(IX+d)*" +"DDCB d E6","SET 4,(IX+d)" +"DDCB d E7","LD A,SET 4,(IX+d)*" +"DDCB d E8","LD B,SET 5,(IX+d)*" +"DDCB d E9","LD C,SET 5,(IX+d)*" +"DDCB d EA","LD D,SET 5,(IX+d)*" +"DDCB d EB","LD E,SET 5,(IX+d)*" +"DDCB d EC","LD H,SET 5,(IX+d)*" +"DDCB d ED","LD L,SET 5,(IX+d)*" +"DDCB d EE","SET 5,(IX+d)" +"DDCB d EF","LD A,SET 5,(IX+d)*" +"DDCB d F0","LD B,SET 6,(IX+d)*" +"DDCB d F1","LD C,SET 6,(IX+d)*" +"DDCB d F2","LD D,SET 6,(IX+d)*" +"DDCB d F3","LD E,SET 6,(IX+d)*" +"DDCB d F4","LD H,SET 6,(IX+d)*" +"DDCB d F5","LD L,SET 6,(IX+d)*" +"DDCB d F6","SET 6,(IX+d)" +"DDCB d F7","LD A,SET 6,(IX+d)*" +"DDCB d F8","LD B,SET 7,(IX+d)*" +"DDCB d F9","LD C,SET 7,(IX+d)*" +"DDCB d FA","LD D,SET 7,(IX+d)*" +"DDCB d FB","LD E,SET 7,(IX+d)*" +"DDCB d FC","LD H,SET 7,(IX+d)*" +"DDCB d FD","LD L,SET 7,(IX+d)*" +"DDCB d FE","SET 7,(IX+d)" +"DDCB d FF","LD A,SET 7,(IX+d)*" +"DDE1","POP IX" +"DDE3","EX (SP),IX" +"DDE5","PUSH IX" +"DDE9","JP (IX)" +"DDF9","LD SP,IX" +"DE n","SBC A,n" +"DF","RST 18H" +"E0","RET PO" +"E1","POP HL" +"E2 m","JP PO, m" +"E3","EX (SP),HL" +"E4 m","CALL PO, m" +"E5","PUSH HL" +"E6 n","AND n" +"E7","RST 20H" +"E8","RET PE" +"E9","JP (HL)" +"EA m","JP PE, m" +"EB","EX DE,HL" +"EC m","CALL PE, m" +"ED40","IN B,(C)" +"ED41","OUT (C),B" +"ED42","SBC HL,BC" +"ED43 m","LD (m),BC" +"ED44","NEG" +"ED45","RETN" +"ED46","IM 0" +"ED47","LD I,A" +"ED48","IN C,(C)" +"ED49","OUT (C),C" +"ED4A","ADC HL,BC" +"ED4B m","LD BC,(m)" +"ED4C","NEG*" +"ED4D","RETI" +"ED4E","IM 0*" +"ED4F","LD R,A" +"ED50","IN D,(C)" +"ED51","OUT (C),D" +"ED52","SBC HL,DE" +"ED53 m","LD (m),DE" +"ED54","NEG*" +"ED55","RETN*" +"ED56","IM 1" +"ED57","LD A,I" +"ED58","IN E,(C)" +"ED59","OUT (C),E" +"ED5A","ADC HL,DE" +"ED5B m","LD DE,(m)" +"ED5C","NEG*" +"ED5D","RETN*" +"ED5E","IM 2" +"ED5F","LD A,R" +"ED60","IN H,(C)" +"ED61","OUT (C),H" +"ED62","SBC HL,HL" +"ED63 m","LD (m),HL" +"ED64","NEG*" +"ED65","RETN*" +"ED66","IM 0*" +"ED67","RRD" +"ED68","IN L,(C)" +"ED69","OUT (C),L" +"ED6A","ADC HL,HL" +"ED6B m","LD HL,(m)" +"ED6C","NEG*" +"ED6D","RETN*" +"ED6E","IM 0*" +"ED6F","RLD" +"ED70","IN F,(C)*" +"ED71","OUT (C),0*" +"ED72","SBC HL,SP" +"ED73 m","LD (m),SP" +"ED74","NEG*" +"ED75","RETN*" +"ED76","IM 1*" +"ED78","IN A,(C)" +"ED79","OUT (C),A" +"ED7A","ADC HL,SP" +"ED7B m","LD SP,(m)" +"ED7C","NEG*" +"ED7D","RETN*" +"ED7E","IM 2*" +"EDA0","LDI" +"EDA1","CPI" +"EDA2","INI" +"EDA3","OUTI" +"EDA8","LDD" +"EDA9","CPD" +"EDAA","IND" +"EDAB","OUTD" +"EDB0","LDIR" +"EDB1","CPIR" +"EDB2","INIR" +"EDB3","OTIR" +"EDB8","LDDR" +"EDB9","CPDR" +"EDBA","INDR" +"EDBB","OTDR" +"EDBC","GetKey [RazorkOS]" +"EDBD","PushMouseX-Y [RazorkOS]" +"EE n","XOR n" +"EF","RST 28H" +"F0","RET P" +"F1","POP AF" +"F2 m","JP P, m" +"F3","DI" +"F4 m","CALL P, m" +"F5","PUSH AF" +"F6 n","OR n" +"F7","RST 30H" +"F8","RET M" +"F9","LD SP,HL" +"FA m","JP M, m" +"FB","EI" +"FC m","CALL M, m" +"FD09","ADD IY,BC" +"FD19","ADD IY,DE" +"FD21 m","LD IY, m " +"FD22 m","LD (m),IY" +"FD23","INC IY" +"FD24","INC IYH*" +"FD25","DEC IYH*" +"FD26 n","LD IYH,n*" +"FD29","ADD IY,IY" +"FD2A m","LD IY,(m)" +"FD2B","DEC IY" +"FD2C","INC IYL*" +"FD2D","DEC IYL*" +"FD2E n","LD IYL,n*" +"FD34 d","INC (IY+d)" +"FD35 d","DEC (IY+d)" +"FD36 d n","LD (IY+d),n" +"FD39","ADD IY,SP" +"FD44","LD B,IYH*" +"FD45","LD B,IYL*" +"FD46 d","LD B,(IY+d)" +"FD4C","LD C,IYH*" +"FD4D","LD C,IYL*" +"FD4E d","LD C,(IY+d)" +"FD54","LD D,IYH*" +"FD55","LD D,IYL*" +"FD56 d","LD D,(IY+d)" +"FD5C","LD E,IYH*" +"FD5D","LD E,IYL*" +"FD5E d","LD E,(IY+d)" +"FD60","LD IYH,B*" +"FD61","LD IYH,C*" +"FD62","LD IYH,D*" +"FD63","LD IYH,E*" +"FD64","LD IYH,IYH*" +"FD65","LD IYH,IYL*" +"FD66 d","LD H,(IY+d)" +"FD67","LD IYH,A*" +"FD68","LD IYL,B*" +"FD69","LD IYL,C*" +"FD6A","LD IYL,D*" +"FD6B","LD IYL,E*" +"FD6C","LD IYL,IYH*" +"FD6D","LD IYL,IYL*" +"FD6E d","LD L,(IY+d)" +"FD6F","LD IYL,A*" +"FD70 d","LD (IY+d),B" +"FD71 d","LD (IY+d),C" +"FD72 d","LD (IY+d),D" +"FD73 d","LD (IY+d),E" +"FD74 d","LD (IY+d),H" +"FD75 d","LD (IY+d),L" +"FD77 d","LD (IY+d),A" +"FD7C","LD A,IYH*" +"FD7D","LD A,IYL*" +"FD7E d","LD A,(IY+d)" +"FD84","ADD A,IYH*" +"FD85","ADD A,IYL*" +"FD86 d","ADD A,(IY+d)" +"FD8C","ADC A,IYH*" +"FD8D","ADC A,IYL*" +"FD8E d","ADC A,(IY+d)" +"FD94","SUB IYH*" +"FD95","SUB IYL*" +"FD96 d","SUB (IY+d)" +"FD9C","SBC A,IYH*" +"FD9D","SBC A,IYL*" +"FD9E d","SBC A,(IY+d)" +"FDA4","AND IYH*" +"FDA5","AND IYL*" +"FDA6 d","AND (IY+d)" +"FDAC","XOR IYH*" +"FDAD","XOR IYL*" +"FDAE d","XOR (IY+d)" +"FDB4","OR IYH*" +"FDB5","OR IYL*" +"FDB6 d","OR (IY+d)" +"FDBC","CP IYH*" +"FDBD","CP IYL*" +"FDBE d","CP (IY+d)" +"FDCB d 00","LD B,RLC (IY+d)*" +"FDCB d 01","LD C,RLC (IY+d)*" +"FDCB d 02","LD D,RLC (IY+d)*" +"FDCB d 03","LD E,RLC (IY+d)*" +"FDCB d 04","LD H,RLC (IY+d)*" +"FDCB d 05","LD L,RLC (IY+d)*" +"FDCB d 06","RLC (IY+d)" +"FDCB d 07","LD A,RLC (IY+d)*" +"FDCB d 08","LD B,RRC (IY+d)*" +"FDCB d 09","LD C,RRC (IY+d)*" +"FDCB d 0A","LD D,RRC (IY+d)*" +"FDCB d 0B","LD E,RRC (IY+d)*" +"FDCB d 0C","LD H,RRC (IY+d)*" +"FDCB d 0D","LD L,RRC (IY+d)*" +"FDCB d 0E","RRC (IY+d)" +"FDCB d 0F","LD A,RRC (IY+d)*" +"FDCB d 10","LD B,RL (IY+d)*" +"FDCB d 11","LD C,RL (IY+d)*" +"FDCB d 12","LD D,RL (IY+d)*" +"FDCB d 13","LD E,RL (IY+d)*" +"FDCB d 14","LD H,RL (IY+d)*" +"FDCB d 15","LD L,RL (IY+d)*" +"FDCB d 16","RL (IY+d)" +"FDCB d 17","LD A,RL (IY+d)*" +"FDCB d 18","LD B,RR (IY+d)*" +"FDCB d 19","LD C,RR (IY+d)*" +"FDCB d 1A","LD D,RR (IY+d)*" +"FDCB d 1B","LD E,RR (IY+d)*" +"FDCB d 1C","LD H,RR (IY+d)*" +"FDCB d 1D","LD L,RR (IY+d)*" +"FDCB d 1E","RR (IY+d)" +"FDCB d 1F","LD A,RR (IY+d)*" +"FDCB d 20","LD B,SLA (IY+d)*" +"FDCB d 21","LD C,SLA (IY+d)*" +"FDCB d 22","LD D,SLA (IY+d)*" +"FDCB d 23","LD E,SLA (IY+d)*" +"FDCB d 24","LD H,SLA (IY+d)*" +"FDCB d 25","LD L,SLA (IY+d)*" +"FDCB d 26","SLA (IY+d)" +"FDCB d 27","LD A,SLA (IY+d)*" +"FDCB d 28","LD B,SRA (IY+d)*" +"FDCB d 29","LD C,SRA (IY+d)*" +"FDCB d 2A","LD D,SRA (IY+d)*" +"FDCB d 2B","LD E,SRA (IY+d)*" +"FDCB d 2C","LD H,SRA (IY+d)*" +"FDCB d 2D","LD L,SRA (IY+d)*" +"FDCB d 2E","SRA (IY+d)" +"FDCB d 2F","LD A,SRA (IY+d)*" +"FDCB d 30","LD B,SLL (IY+d)*" +"FDCB d 31","LD C,SLL (IY+d)*" +"FDCB d 32","LD D,SLL (IY+d)*" +"FDCB d 33","LD E,SLL (IY+d)*" +"FDCB d 34","LD H,SLL (IY+d)*" +"FDCB d 35","LD L,SLL (IY+d)*" +"FDCB d 36","SLL (IY+d)*" +"FDCB d 37","LD A,SLL (IY+d)*" +"FDCB d 38","LD B,SRL (IY+d)*" +"FDCB d 39","LD C,SRL (IY+d)*" +"FDCB d 3A","LD D,SRL (IY+d)*" +"FDCB d 3B","LD E,SRL (IY+d)*" +"FDCB d 3C","LD H,SRL (IY+d)*" +"FDCB d 3D","LD L,SRL (IY+d)*" +"FDCB d 3E","SRL (IY+d)" +"FDCB d 3F","LD A,SRL (IY+d)*" +"FDCB d 40","BIT 0,(IY+d)*" +"FDCB d 41","BIT 0,(IY+d)*" +"FDCB d 42","BIT 0,(IY+d)*" +"FDCB d 43","BIT 0,(IY+d)*" +"FDCB d 44","BIT 0,(IY+d)*" +"FDCB d 45","BIT 0,(IY+d)*" +"FDCB d 46","BIT 0,(IY+d)" +"FDCB d 47","BIT 0,(IY+d)*" +"FDCB d 48","BIT 1,(IY+d)*" +"FDCB d 49","BIT 1,(IY+d)*" +"FDCB d 4A","BIT 1,(IY+d)*" +"FDCB d 4B","BIT 1,(IY+d)*" +"FDCB d 4C","BIT 1,(IY+d)*" +"FDCB d 4D","BIT 1,(IY+d)*" +"FDCB d 4E","BIT 1,(IY+d)" +"FDCB d 4F","BIT 1,(IY+d)*" +"FDCB d 50","BIT 2,(IY+d)*" +"FDCB d 51","BIT 2,(IY+d)*" +"FDCB d 52","BIT 2,(IY+d)*" +"FDCB d 53","BIT 2,(IY+d)*" +"FDCB d 54","BIT 2,(IY+d)*" +"FDCB d 55","BIT 2,(IY+d)*" +"FDCB d 56","BIT 2,(IY+d)" +"FDCB d 57","BIT 2,(IY+d)*" +"FDCB d 58","BIT 3,(IY+d)*" +"FDCB d 59","BIT 3,(IY+d)*" +"FDCB d 5A","BIT 3,(IY+d)*" +"FDCB d 5B","BIT 3,(IY+d)*" +"FDCB d 5C","BIT 3,(IY+d)*" +"FDCB d 5D","BIT 3,(IY+d)*" +"FDCB d 5E","BIT 3,(IY+d)" +"FDCB d 5F","BIT 3,(IY+d)*" +"FDCB d 60","BIT 4,(IY+d)*" +"FDCB d 61","BIT 4,(IY+d)*" +"FDCB d 62","BIT 4,(IY+d)*" +"FDCB d 63","BIT 4,(IY+d)*" +"FDCB d 64","BIT 4,(IY+d)*" +"FDCB d 65","BIT 4,(IY+d)*" +"FDCB d 66","BIT 4,(IY+d)" +"FDCB d 67","BIT 4,(IY+d)*" +"FDCB d 68","BIT 5,(IY+d)*" +"FDCB d 69","BIT 5,(IY+d)*" +"FDCB d 6A","BIT 5,(IY+d)*" +"FDCB d 6B","BIT 5,(IY+d)*" +"FDCB d 6C","BIT 5,(IY+d)*" +"FDCB d 6D","BIT 5,(IY+d)*" +"FDCB d 6E","BIT 5,(IY+d)" +"FDCB d 6F","BIT 5,(IY+d)*" +"FDCB d 70","BIT 6,(IY+d)*" +"FDCB d 71","BIT 6,(IY+d)*" +"FDCB d 72","BIT 6,(IY+d)*" +"FDCB d 73","BIT 6,(IY+d)*" +"FDCB d 74","BIT 6,(IY+d)*" +"FDCB d 75","BIT 6,(IY+d)*" +"FDCB d 76","BIT 6,(IY+d)" +"FDCB d 77","BIT 6,(IY+d)*" +"FDCB d 78","BIT 7,(IY+d)*" +"FDCB d 79","BIT 7,(IY+d)*" +"FDCB d 7A","BIT 7,(IY+d)*" +"FDCB d 7B","BIT 7,(IY+d)*" +"FDCB d 7C","BIT 7,(IY+d)*" +"FDCB d 7D","BIT 7,(IY+d)*" +"FDCB d 7E","BIT 7,(IY+d)" +"FDCB d 7F","BIT 7,(IY+d)*" +"FDCB d 80","LD B,RES 0,(IY+d)*" +"FDCB d 81","LD C,RES 0,(IY+d)*" +"FDCB d 82","LD D,RES 0,(IY+d)*" +"FDCB d 83","LD E,RES 0,(IY+d)*" +"FDCB d 84","LD H,RES 0,(IY+d)*" +"FDCB d 85","LD L,RES 0,(IY+d)*" +"FDCB d 86","RES 0,(IY+d)" +"FDCB d 87","LD A,RES 0,(IY+d)*" +"FDCB d 88","LD B,RES 1,(IY+d)*" +"FDCB d 89","LD C,RES 1,(IY+d)*" +"FDCB d 8A","LD D,RES 1,(IY+d)*" +"FDCB d 8B","LD E,RES 1,(IY+d)*" +"FDCB d 8C","LD H,RES 1,(IY+d)*" +"FDCB d 8D","LD L,RES 1,(IY+d)*" +"FDCB d 8E","RES 1,(IY+d)" +"FDCB d 8F","LD A,RES 1,(IY+d)*" +"FDCB d 90","LD B,RES 2,(IY+d)*" +"FDCB d 91","LD C,RES 2,(IY+d)*" +"FDCB d 92","LD D,RES 2,(IY+d)*" +"FDCB d 93","LD E,RES 2,(IY+d)*" +"FDCB d 94","LD H,RES 2,(IY+d)*" +"FDCB d 95","LD L,RES 2,(IY+d)*" +"FDCB d 96","RES 2,(IY+d)" +"FDCB d 97","LD A,RES 2,(IY+d)*" +"FDCB d 98","LD B,RES 3,(IY+d)*" +"FDCB d 99","LD C,RES 3,(IY+d)*" +"FDCB d 9A","LD D,RES 3,(IY+d)*" +"FDCB d 9B","LD E,RES 3,(IY+d)*" +"FDCB d 9C","LD H,RES 3,(IY+d)*" +"FDCB d 9D","LD L,RES 3,(IY+d)*" +"FDCB d 9E","RES 3,(IY+d)" +"FDCB d 9F","LD A,RES 3,(IY+d)*" +"FDCB d A0","LD B,RES 4,(IY+d)*" +"FDCB d A1","LD C,RES 4,(IY+d)*" +"FDCB d A2","LD D,RES 4,(IY+d)*" +"FDCB d A3","LD E,RES 4,(IY+d)*" +"FDCB d A4","LD H,RES 4,(IY+d)*" +"FDCB d A5","LD L,RES 4,(IY+d)*" +"FDCB d A6","RES 4,(IY+d)" +"FDCB d A7","LD A,RES 4,(IY+d)*" +"FDCB d A8","LD B,RES 5,(IY+d)*" +"FDCB d A9","LD C,RES 5,(IY+d)*" +"FDCB d AA","LD D,RES 5,(IY+d)*" +"FDCB d AB","LD E,RES 5,(IY+d)*" +"FDCB d AC","LD H,RES 5,(IY+d)*" +"FDCB d AD","LD L,RES 5,(IY+d)*" +"FDCB d AE","RES 5,(IY+d)" +"FDCB d AF","LD A,RES 5,(IY+d)*" +"FDCB d B0","LD B,RES 6,(IY+d)*" +"FDCB d B1","LD C,RES 6,(IY+d)*" +"FDCB d B2","LD D,RES 6,(IY+d)*" +"FDCB d B3","LD E,RES 6,(IY+d)*" +"FDCB d B4","LD H,RES 6,(IY+d)*" +"FDCB d B5","LD L,RES 6,(IY+d)*" +"FDCB d B6","RES 6,(IY+d)" +"FDCB d B7","LD A,RES 6,(IY+d)*" +"FDCB d B8","LD B,RES 7,(IY+d)*" +"FDCB d B9","LD C,RES 7,(IY+d)*" +"FDCB d BA","LD D,RES 7,(IY+d)*" +"FDCB d BB","LD E,RES 7,(IY+d)*" +"FDCB d BC","LD H,RES 7,(IY+d)*" +"FDCB d BD","LD L,RES 7,(IY+d)*" +"FDCB d BE","RES 7,(IY+d)" +"FDCB d BF","LD A,RES 7,(IY+d)*" +"FDCB d C0","LD B,SET 0,(IY+d)*" +"FDCB d C1","LD C,SET 0,(IY+d)*" +"FDCB d C2","LD D,SET 0,(IY+d)*" +"FDCB d C3","LD E,SET 0,(IY+d)*" +"FDCB d C4","LD H,SET 0,(IY+d)*" +"FDCB d C5","LD L,SET 0,(IY+d)*" +"FDCB d C6","SET 0,(IY+d)" +"FDCB d C7","LD A,SET 0,(IY+d)*" +"FDCB d C8","LD B,SET 1,(IY+d)*" +"FDCB d C9","LD C,SET 1,(IY+d)*" +"FDCB d CA","LD D,SET 1,(IY+d)*" +"FDCB d CB","LD E,SET 1,(IY+d)*" +"FDCB d CC","LD H,SET 1,(IY+d)*" +"FDCB d CD","LD L,SET 1,(IY+d)*" +"FDCB d CE","SET 1,(IY+d)" +"FDCB d CF","LD A,SET 1,(IY+d)*" +"FDCB d D0","LD B,SET 2,(IY+d)*" +"FDCB d D1","LD C,SET 2,(IY+d)*" +"FDCB d D2","LD D,SET 2,(IY+d)*" +"FDCB d D3","LD E,SET 2,(IY+d)*" +"FDCB d D4","LD H,SET 2,(IY+d)*" +"FDCB d D5","LD L,SET 2,(IY+d)*" +"FDCB d D6","SET 2,(IY+d)" +"FDCB d D7","LD A,SET 2,(IY+d)*" +"FDCB d D8","LD B,SET 3,(IY+d)*" +"FDCB d D9","LD C,SET 3,(IY+d)*" +"FDCB d DA","LD D,SET 3,(IY+d)*" +"FDCB d DB","LD E,SET 3,(IY+d)*" +"FDCB d DC","LD H,SET 3,(IY+d)*" +"FDCB d DD","LD L,SET 3,(IY+d)*" +"FDCB d DE","SET 3,(IY+d)" +"FDCB d DF","LD A,SET 3,(IY+d)*" +"FDCB d E0","LD B,SET 4,(IY+d)*" +"FDCB d E1","LD C,SET 4,(IY+d)*" +"FDCB d E2","LD D,SET 4,(IY+d)*" +"FDCB d E3","LD E,SET 4,(IY+d)*" +"FDCB d E4","LD H,SET 4,(IY+d)*" +"FDCB d E5","LD L,SET 4,(IY+d)*" +"FDCB d E6","SET 4,(IY+d)" +"FDCB d E7","LD A,SET 4,(IY+d)*" +"FDCB d E8","LD B,SET 5,(IY+d)*" +"FDCB d E9","LD C,SET 5,(IY+d)*" +"FDCB d EA","LD D,SET 5,(IY+d)*" +"FDCB d EB","LD E,SET 5,(IY+d)*" +"FDCB d EC","LD H,SET 5,(IY+d)*" +"FDCB d ED","LD L,SET 5,(IY+d)*" +"FDCB d EE","SET 5,(IY+d)" +"FDCB d EF","LD A,SET 5,(IY+d)*" +"FDCB d F0","LD B,SET 6,(IY+d)*" +"FDCB d F1","LD C,SET 6,(IY+d)*" +"FDCB d F2","LD D,SET 6,(IY+d)*" +"FDCB d F3","LD E,SET 6,(IY+d)*" +"FDCB d F4","LD H,SET 6,(IY+d)*" +"FDCB d F5","LD L,SET 6,(IY+d)*" +"FDCB d F6","SET 6,(IY+d)" +"FDCB d F7","LD A,SET 6,(IY+d)*" +"FDCB d F8","LD B,SET 7,(IY+d)*" +"FDCB d F9","LD C,SET 7,(IY+d)*" +"FDCB d FA","LD D,SET 7,(IY+d)*" +"FDCB d FB","LD E,SET 7,(IY+d)*" +"FDCB d FC","LD H,SET 7,(IY+d)*" +"FDCB d FD","LD L,SET 7,(IY+d)*" +"FDCB d FE","SET 7,(IY+d)" +"FDCB d FF","LD A,SET 7,(IY+d)*" +"FDE1","POP IY" +"FDE3","EX (SP),IY" +"FDE5","PUSH IY" +"FDE9","JP (IY)" +"FDF9","LD SP,IY" +"FE n","CP n" +"FF","RST 38H" diff --git a/OrionZEm.dof b/OrionZEm.dof new file mode 100644 index 0000000..481778a --- /dev/null +++ b/OrionZEm.dof @@ -0,0 +1,89 @@ +[Compiler] +A=1 +B=0 +C=1 +D=1 +E=0 +F=0 +G=1 +H=1 +I=1 +J=1 +K=0 +L=1 +M=0 +N=1 +O=1 +P=1 +Q=0 +R=0 +S=0 +T=0 +U=0 +V=1 +W=0 +X=1 +Y=1 +Z=1 +ShowHints=1 +ShowWarnings=1 +UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +[Linker] +MapFile=0 +OutputObjs=0 +ConsoleApp=1 +DebugInfo=0 +RemoteSymbols=0 +MinStackSize=16384 +MaxStackSize=1048576 +ImageBase=4194304 +ExeDescription= +[Directories] +OutputDir= +UnitOutputDir= +PackageDLLOutputDir= +PackageDCPOutputDir= +SearchPath= +Packages=Vcl50;Vclx50;VclSmp50;Vcldb50;vclado50;ibevnt50;Vclbde50;vcldbx50;Qrpt50;TeeUI50;TeeDB50;Tee50;Dss50;TeeQR50;VCLIB50;Vclmid50;vclie50;Inetdb50;Inet50;NMFast50;webmid50;dclocx50;dclaxserver50;DelphiX_for5 +Conditionals=ORIONZEM +DebugSourceDirs= +UsePackages=0 +[Parameters] +RunParams= +HostApplication= +[Language] +ActiveLang= +ProjectLang=$00000419 +RootDir= +[Version Info] +IncludeVerInfo=1 +AutoIncBuild=1 +MajorVer=1 +MinorVer=0 +Release=9 +Build=4 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1049 +CodePage=1251 +[Version Info Keys] +CompanyName= +FileDescription=Homebrew computer Orion/Z (Orion-128 + Z80-CARD-II) emulator +FileVersion=1.0.9.4 +InternalName=OrionZEmu +LegalCopyright=Copyright (c) 2016 Sergey A. +LegalTrademarks= +OriginalFilename=OrionZEm.exe +ProductName=Orion/Z emulator +ProductVersion=1.09 +Comments=FREEWARE +[HistoryLists\hlConditionals] +Count=2 +Item0=ORIONZEM +Item1=USE_SOUND +[HistoryLists\hlUnitAliases] +Count=1 +Item0=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; diff --git a/OrionZEm.dpr b/OrionZEm.dpr new file mode 100644 index 0000000..ce5bd99 --- /dev/null +++ b/OrionZEm.dpr @@ -0,0 +1,51 @@ +///////////////////////////////////////////////////////////////////////// +// // +// Orion/Z (Orion-128 + Z80-CARD-II) emulator, version 1.9 // +// // +// Author: Sergey A. // +// // +// Copyright (C) 2006-2016 Sergey A. // +// // +// This program is free software; you can redistribute it and/or // +// modify it in any ways. // +// This program is distributed "AS IS" 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. // +// // +///////////////////////////////////////////////////////////////////////// + +program OrionZEm; + +uses + Forms, + mainwin in 'mainwin.pas' {frmMain}, + modWaveOut in 'modWaveOut.pas', + modZ80 in 'modZ80.pas', + ScrThrd in 'ScrThrd.pas', + mod8255 in 'mod8255.pas', + mod1793 in 'mod1793.pas', + modOrion in 'modOrion.pas', + mod146818 in 'mod146818.pas', + settswin in 'settswin.pas' {frmSetts}, + uIniMngr in 'uIniMngr.pas', + frmAbout in 'frmAbout.pas' {AboutBox}, + modAY8912 in 'modAY8912.pas', + modHDD in 'modHDD.pas', + HDDUtils in 'HDDUtils.pas', + modF600 in 'modF600.pas', + frmSaveOrd in 'frmSaveOrd.pas' {FrmSave}, + uPackOdi in 'UTILS\OdiWcx-OhiWcx\uPackOdi.pas', + wcxhead in 'UTILS\OdiWcx-OhiWcx\wcxhead.pas', + frNewVal in 'frNewVal.pas' {frmNewVal}, + modSD in 'modSD.pas', + mod232 in 'mod232.pas', + EthThrd in 'EthThrd.pas', + mod8019as in 'mod8019as.pas'; + +{$R *.RES} + +begin + Application.Initialize; + Application.CreateForm(TfrmMain, frmMain); + Application.Run; +end. diff --git a/OrionZEm.exe b/OrionZEm.exe new file mode 100644 index 0000000..2e77209 Binary files /dev/null and b/OrionZEm.exe differ diff --git a/OrionZEm.inc b/OrionZEm.inc new file mode 100644 index 0000000..3b0634f --- /dev/null +++ b/OrionZEm.inc @@ -0,0 +1,5 @@ +{$DEFINE USE_SOUND} +//{$DEFINE FREEWARE} +//{$DEFINE DEBUG} +//{$DEFINE XDEBUG} +//{$DEFINE SD_DEBUG} diff --git a/OrionZEm.ini b/OrionZEm.ini new file mode 100644 index 0000000..a4e0118 --- /dev/null +++ b/OrionZEm.ini @@ -0,0 +1,85 @@ +[PARAMS] +MAXRECENT=8 +KEYDELAY=0 +RESTOREODI=1 +ODI_DRIVEA=C:\TEMP\ALTAIRDOS11.ODI +ODI_DRIVEB= +AUTOSNAPSHOT=0 +F600Plugin= +F600Function=-1 +ScrZoom=1 +ScrTop=38 +ScrLeft=157 +USE_DPBLESS_DISKS=0 + +[HARDWARE] +ROMDISK=.\ROM\romdisk8.bin +ROMF800=.\ROM\M34zrk.bin +CPUSPEEDMODE=2 +Z80CARDMODE=5 +KEYRUSLAT=120 +SOUNDENABLED=1 +AYENABLED=1 +KEYBTYPE=0 +KEYEXTEND=1 +HDDPort=2 +HDDMaster=C:\tty-sd.OHI +HDDSlave= +HDDMasterRO=0 +HDDSlaveRO=0 +FDD_HD=1 +PRO_ROM1=.\ROM\ROM1-320.BIN +PRO_ROM2=.\ROM\ROM2-320.BIN +PRO_DIPSW=166 +*PRO_DIPSW=197 +SDcard= +SDcardRO=0 +SDScheme=0 +ComPortName=CNCB0 +ComPortExists=1 +PFC=1 +MC146818RAM=5254430000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 +MC146818DT=0 +MC146818DD=0 +RTCMODE=2 +PortFErom=1 +MEMSIZEMODE=4 +ProMaster=C:\tty-sd5.OHI +ProSlave= +ProMasterRO=0 +ProSlaveRO=0 + +[F600Plugin] +PrnMode=1 +PrnFile=C:\prn_out.txt +PrnFont=Courier +PrnFontSize=10 +PrnPrn=0 +PrnFNew=0 +PrnCP=1 +BorderTop=30 +BorderLeft=99 +BorderRight=10 +BorderBottom=30 +PrnScheme=1 + +[ETHERNET] +EthConnName=Local Area Connection TAP1 +EthConnGUID={890DF3E8-60EE-4271-91E7-E1D4EEA2AC69} +EthMode=0 +MAC0=0 +MAC1=255 +MAC2=83 +MAC3=69 +MAC4=82 +MAC5=71 + +[RECENT] +C:\TEMP\ALTAIRDOS11.ODI +C:\PRODOS20.ODI +C:\DISK9.ODI +C:\BORLAND\DELPHI5\PROJECTS\_ORIZEMU\DISKS\ALTAIRDOS35R.ODI +C:\DSK.ODI +C:\BORLAND\DELPHI5\PROJECTS\_ORIZEMU\DISKS\WAV22.ODI +C:\BORLAND\DELPHI5\PROJECTS\_ORIZEMU\DISKS\WAV081116.ODI +D:\_C\DISKS\DISK1.ODI diff --git a/OrionZEm.res b/OrionZEm.res new file mode 100644 index 0000000..37c641e Binary files /dev/null and b/OrionZEm.res differ diff --git a/ScrThrd.pas b/ScrThrd.pas new file mode 100644 index 0000000..8d8aa14 --- /dev/null +++ b/ScrThrd.pas @@ -0,0 +1,400 @@ +///////////////////////////////////////////////////////////////////////// +// // +// Orion/Z (Orion-128 + Z80-CARD-II) emulator, version 1.9 // +// // +// Author: Sergey A. // +// // +// Copyright (C) 2006-2016 Sergey A. // +// // +// This program is free software; you can redistribute it and/or // +// modify it in any ways. // +// This program is distributed "AS IS" 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 ScrThrd; + +interface + +{ + 1.2. ОРГАНИЗАЦИЯ ЭКРАННОЙ ПАМЯТИ + -------------------------------- + + Экранная память располагается в 0 и 1 страницах ОЗУ, при- +чем количество экранов и распределение сегментов в них зависит +от текущего цветового режима, задаваемого разрядами порта 0F8H: + + D4 D3 D2 D1 D0 + ------------------ + 0 x 0 0 0 - монохромный, палитра 1 + 0 x 0 0 1 - монохромный, палитра 2 + 0 x 0 1 x - запрет видеосигнала + 0 x 1 0 0 - 2-битный (4-цветный), палитра 1 + 0 x 1 0 1 - 2-битный (4-цветный), палитра 2 + 0 x 1 1 x - 16-цветный с групповым кодированием + 0 1 1 1 x - псевдоцветной (цвет - в порт 0FCH) + 1 x 0 x x - 3-битный (8-цветный RGB) + 1 x 1 x x - 4-битный (16-цветный RGBI) + + В монохромном режиме палитре 1 соответствует комбинация +цветов - (черный, зеленый), палитре 2 - (белый, зеленый). В +4-цветном (2-х битовом) режиме палитре 1 соответствуют цвета - +(черный, синий, зеленый, красный), палитре 2 - (белый, синий, +зеленый, красный). + Код палитры для псевдоцветного режима записывается в порт +с адресом 0FCH. + Выбор на отображение одного из 4-х экранов выполняется пу- +тем записи номера экрана в порт 0FAH: + + D0 \ номер экрана + D1 / + D6 - выключение регенерации ОЗУ + D7 - включение широкого экрана + + Разряды D2-D5 являются резервными. + + Если разряд D7 установлен в единицу, то ширина экрана сос- +тавляет 512 точек (64 байта), что при высоте 256 байт соответс- +твует объему памяти 16 Кбайт. В противном случае экранная плос- +кость ОЗУ имеет ширину 384 точки (48 байт) и занимает объем 12 +Кбайт. + В 3-х битном и 4-х битном (EGA-режим) цветовых режимах до- +пускается использование только двух экранов, поэтому разряд D0 +порта 0FAH игнорируется. + Рассмотрим распределение сегментов экранного ОЗУ в различ- +ных цветовых режимах. + + 1.2.3 МОНОХРОМНЫЙ И ПСЕВДОЦВЕТНОЙ РЕЖИМЫ + ---------------------------------------- + + В монохромном и псевдоцветном режимах возможно использова- +ние до 4-х экранов, занимающих только сегменты 0-й страницы +ОЗУ: + + Стр.0 Экран 12 К Экран 16 К + --------¬ ------------ ------------ + Экран 0 ->¦ 3 ¦ C000H..EFFFH C000H..FFFFH + ¦=======¦ + Экран 1 ->¦ 2 ¦ 8000H..AFFFH 8000H..BFFFH + ¦=======¦ + Экран 2 ->¦ 1 ¦ 4000H..6FFFH 4000H..7FFFH + ¦=======¦ + Экран 3 ->¦ 0 ¦ 0000H..2FFFH 0000H..3FFFH + L-------- + + В монохромном режиме единичному значению некоторого бита +экранного сегмента ОЗУ соответствует засветка изображаемой точ- +ки, нулевому - гашение. + В псевдоцветном режиме цвет отображаемых точек зависит от +кода палитры, записанного в порт 0FCH. Старшие 4 бита значения +этого порта определяют один из 16 цветов фона (для погашенных +точек), младшие 4 бита - один из 16 цветов переднего плана (для +засвеченных точек). + Заметим, что при широком экране-0 область 0F000H..0FFFFH +экрана (не путать с системной областью 0F000H..0FFFFH) доступна +только через окно. Прямой доступ к экрану возможен только по +адресам 0C000-0EFFFH. Это относится ко всем цветовым режимам. + + + 1.2.4. 4-ЦВЕТНЫЙ РЕЖИМ + ----------------------- + + В 4-цветном (2-битном) режиме цвет каждой отображаемой +точки зависит от соответствующих битов двух экранных плоскостей +(сегментов), находящихся в страницах 0 и 1 ОЗУ: + + + Стр.0 Стр.1 + --------T-------¬ + Экран 0 ->¦ 3 ¦ 7 ¦ + ¦=======+=======¦ + Экран 1 ->¦ 2 ¦ 6 ¦ + ¦=======+=======¦ + Экран 2 ->¦ 1 ¦ 5 ¦ + ¦=======+=======¦ + Экран 3 ->¦ 0 ¦ 4 ¦ + L-------+-------- + L--¬ ---- + + 0 0 -> черный (белый) + 0 1 -> красный + 1 0 -> зеленый + 1 1 -> синий + + + 1.2.5. 8-ЦВЕТНЫЙ и 16-ЦВЕТНЫЙ РЕЖИМЫ + ------------------------------------- + + Это новый графический режим. Функционально он тождествен +EGA режиму на IBM PC AT (был широко распространен на 286 моде- +лях). В 8-цветном (3-битном) и 16-цветном (4-битном) режимах +для формирования отображаемой точки в каждом из двух экранов +используются соответственно 3 и 4 плоскости экранного ОЗУ: + + Стр.0 Стр.1 + --------T-------¬ + ¦ 3 (G)¦ 7 (I)¦ + Экран 0 ->+-------+-------+ + ¦ 2 (R)¦ 6 (B)¦ + ¦=======+=======¦ + ¦ 1 (G)¦ 5 (I)¦ + Экран 1 ->+-------+-------+ + ¦ 0 (R)¦ 4 (B)¦ + L-------+-------- + + Сегментам 3 и 1 соответствует зеленый цвет (G), 2 и 0 - +красный (R), 6 и 4 - синий (B), 7 и 5 (в 3-битном режиме не ис- +пользуются) - управление яркостью (I). + + Путем записи комбинации битов в соответствующие сегменты +экрана можно получить точку заданного цвета. + + + 1.2.6. РЕЖИМ С ГРУППОВЫМ КОДИРОВАНИЕМ ЦВЕТА + ------------------------------------------- + + В 16-цветном режиме с групповым кодированием каждый из 4-х +экранов формируется из содержимого двух сегментов памяти: из +плоскости изображения (0 страница ОЗУ) и плоскости цветовых ат- +рибутов (1 страница ОЗУ), причем восьми соседним точкам плос- +кости изображения, расположенным в пределах одного байта, соот- +ветствует один байт из плоскости цветовых атрибутов. + + Старшие 4 бита в байте цветового атрибута определяют цвет +фона (для погашенных точек), младшие 4 бита - цвет переднего +плана (для засвеченных точек) в пределах одного экранного бай- +та. + + Стр.0 Стр.1 + (изобр) (цвет) + --------T-------¬ + Экран 0 ->¦ 3 ¦ 7 ¦ + ¦=======+=======¦ + Экран 1 ->¦ 2 ¦ 6 ¦ + ¦=======+=======¦ + Экран 2 ->¦ 1 ¦ 5 ¦ + ¦=======+=======¦ + Экран 3 ->¦ 0 ¦ 4 ¦ + L-------+-------- + + Для всех цветовых режимов действует ограничение на исполь- +зование широкого экрана с номером 0, описанное в П.1.2.3. + Следует помнить, что экраны аппаратно привязаны к конкрет- +ным сегментам ОЗУ, а не к окнам, т.е. отображение информации +экрана не зависит от рабочей страницы ОЗУ и включения / выклю- +чения окон. + +} + +{$I 'OrionZEm.inc'} + + +uses + Windows, Messages, SysUtils, Classes; + +type + TScrThread = class(TThread) + private + FScrMode, FScrAddr, FSX, FSY, FMX, FMode: Integer; + procedure DrawScreen; + procedure BlankScreen; + protected + procedure Execute; override; + public + constructor Create(SX, SY, MX, ScrMode: Integer); + destructor Destroy; override; + end; + +implementation + +Uses modOrion, MainWin; + +constructor TScrThread.Create(SX, SY, MX, ScrMode: Integer); +begin + FSX:=SX; + FSY:=SY; + FMX:=MX; + FMode:=ScrMode; + inherited Create(True); // Create Suspended +end; + +destructor TScrThread.Destroy; +begin + inherited; +end; + +procedure TScrThread.BlankScreen; +begin + frmMain.BlankOrionScreen; +end; + +procedure TScrThread.DrawScreen; +begin + frmMain.DrawOrionScreen; +end; + +procedure TScrThread.Execute; +var + x, y, b, tmpx, x_3, ty1, ty2, ty3: integer; + RamCell0, RamCell1, RamCell2, RamCell3, ci, cr, cg, cb: byte; + Color, c0, c1, c2, c3: COLORREF; +begin + repeat + if not DoNotUpdateScr then + begin + if Z80CardMode>=Z80_ORIONPRO_v2 then tmpx:=31 else tmpx:=7; + FScrMode:=MainPort[$F8] and tmpx; + if FScrMode and 16 = 0 then + FScrAddr:=ScrBase[(MainPort[$FA]) and 3] + else + FScrAddr:=ScrBase[(MainPort[$FA]) and 3 or 1]; // Orion-Pro mode + case FScrMode of + 0: begin c0:=RGB(0,0,0); c1:=RGB(0,255,0); end; + 1: begin c0:=RGB(200,180,40); c1:=RGB(50,250,250); end; + 2,3: begin + DoNotUpdateScr:=True; + Synchronize(BlankScreen); + end; + 4: begin c0:=RGB(0,0,0); c1:=RGB(0,0,192); c2:=RGB(0,192,0); c3:=RGB(192,0,0); end; + 5: begin c0:=RGB(192,192,192); c1:=RGB(0,0,192); c2:=RGB(0,192,0); c3:=RGB(192,0,0); end; + end; + if not (FScrMode in [2,3]) then + for x := 0 to (FSX div 8) - 1 do + begin + x_3:=x shl 3; // вычисляем левый верхний угол точки + for y := 0 to FSY - 1 do + begin + RamCell0:=RAMarr[0, FScrAddr]; // страница 0 + if (FScrMode in [14,15]) and (Z80CardMode>=Z80_ORIONPRO_v2) then + RamCell1:=MainPort[$FC] // Orion-Pro pseudocolor mode + else + RamCell1:=RAMarr[1, FScrAddr]; // страница 1 + RamCell2:=RAMarr[0, FScrAddr+$4000]; // страница 0 + RamCell3:=RAMarr[1, FScrAddr+$4000]; // страница 1 + case FMode of // вычисляем левый верхний угол точки + SCR_ZOOM_X1: + ty1:=y * FMX; + SCR_ZOOM_X2: + ty1:=y * FMX *2; // (y*384) *4 ( *4 = horz*2 + vert*2 ) + SCR_ZOOM_X25: + ty1:=((y * 5) shr 1) * FMX ; + SCR_ZOOM_X3: + ty1:=y * FMX *3; + end; + ty2:=ty1 + FMX; // (y*384)*4 + 384*2 ( shift to second row ) + ty3:=ty2 + FMX; // shift to third row + case FScrMode of + 6,7,14,15: + begin + cr:=0; cg:=0; cb:=0; + ci:=((RamCell1 and $80) shr 1) and $FE; // фон - старший ниббл + if (RamCell1 and $40 <>0) then cr:=191+ci; + if (RamCell1 and $20 <>0) then cg:=191+ci; + if (RamCell1 and $10 <>0) then cb:=191+ci; + c0:=RGB(cb, cg, cr); + cr:=0; cg:=0; cb:=0; + ci:=((RamCell1 and 8) shl 3) and $FE; // цвет - младший ниббл + if (RamCell1 and 4 <>0) then cr:=191+ci; + if (RamCell1 and 2 <>0) then cg:=191+ci; + if (RamCell1 and 1 <>0) then cb:=191+ci; + c1:=RGB(cb, cg, cr); + end; + end; + for b:=7 downto 0 do + begin + case FScrMode of + 0,1,6,7,14,15: if (RamCell0 and 1)=0 then Color:=c0 else Color:=c1; + 4,5: begin + case ((RamCell0 and 1) shl 1) or (RamCell1 and 1) of + 0: Color:=c0; + 1: Color:=c1; + 2: Color:=c2 + else Color:=c3; + end; + RamCell1 := RamCell1 shr 1; + end + else begin + case FScrMode and 20 of + 16: begin // Orion-Pro 3-bit color mode + if (RamCell0 and 1 = 0) then cr:=0 else cr:=191; + if (RamCell1 and 1 = 0) then cb:=0 else cb:=191; + if (RamCell2 and 1 = 0) then cg:=0 else cg:=191; + RamCell1 := RamCell1 shr 1; + RamCell2 := RamCell2 shr 1; + Color:=RGB(cb, cg, cr); + end; + 20: begin // Orion-Pro 4-bit color mode + if (RamCell3 and 1 = 0) then ci:=0 else ci:=63; + if (RamCell0 and 1 = 0) then cr:=0 else cr:=191+ci; + if (RamCell1 and 1 = 0) then cb:=0 else cb:=191+ci; + if (RamCell2 and 1 = 0) then cg:=0 else cg:=191+ci; + RamCell1 := RamCell1 shr 1; + RamCell2 := RamCell2 shr 1; + RamCell3 := RamCell3 shr 1; + Color:=RGB(cb, cg, cr); + end; + end; + end; + end; + RamCell0 := RamCell0 shr 1; + case FMode of + SCR_ZOOM_X1: + begin + TBig(Scr^)[x_3 + b + ty1] := Color; + end; + SCR_ZOOM_X2: + begin // x=0..384/8, y=0..255 + tmpx:=(x_3 + b) shl 1; // (x*8 + 0..7) *2 + TBig(Scr^)[tmpx + ty1] := Color; // left half point (first row) + TBig(Scr^)[tmpx + 1 + ty1] := Color; // right half point + TBig(Scr^)[tmpx + ty2] := Color; // left half point (second row) + TBig(Scr^)[tmpx + 1 + ty2] := Color; // right half point + end; + SCR_ZOOM_X25: + begin + tmpx:=((x_3 + b) * 5) shr 1; // 0, 2, 5, 7, 10, 12, 15, ... + TBig(Scr^)[tmpx + ty1] := Color; // line 1 + TBig(Scr^)[tmpx + 1 + ty1] := Color; + TBig(Scr^)[tmpx + ty2] := Color; // line 2 + TBig(Scr^)[tmpx + 1 + ty2] := Color; + if boolean(b and 1) then + begin + TBig(Scr^)[tmpx + 2 + ty1] := Color; + TBig(Scr^)[tmpx + 2 + ty2] := Color; + if boolean(y and 1) then + TBig(Scr^)[tmpx + 2 + ty3] := Color; + end; + if boolean(y and 1) then + begin + TBig(Scr^)[tmpx + ty3] := Color; // line 3 + TBig(Scr^)[tmpx + 1 + ty3] := Color; + end; + end; + SCR_ZOOM_X3: + begin + tmpx:=(x_3 + b) *3 ; + TBig(Scr^)[tmpx + ty1] := Color; // line 1 + TBig(Scr^)[tmpx + 1 + ty1] := Color; + TBig(Scr^)[tmpx + 2 + ty1] := Color; + TBig(Scr^)[tmpx + ty2] := Color; // line 2 + TBig(Scr^)[tmpx + 1 + ty2] := Color; + TBig(Scr^)[tmpx + 2 + ty2] := Color; + TBig(Scr^)[tmpx + ty3] := Color; // line 3 + TBig(Scr^)[tmpx + 1 + ty3] := Color; + TBig(Scr^)[tmpx + 2 + ty3] := Color; + end; + end; + end; + inc(FScrAddr); + end; + end; + Synchronize(DrawScreen); + end; + sleep(19); + until Terminated; +end; + +end. diff --git a/_bootsector.txt b/_bootsector.txt new file mode 100644 index 0000000..85784a1 --- /dev/null +++ b/_bootsector.txt @@ -0,0 +1,27 @@ +struct BootSector +{ +WORD LoadAddress; +WORD RunAddress; +WORD LoadSectorCount; +BYTE SizeDisk; /* 0-5.25", 1-8" */ +BYTE Density; /* 0-FM, 1-MFM */ +BYTE TpI; /* 0-48 TpI, 1-96 TpI, 2-135 TpI */ +BYTE SkewFactor; /* 1-no sector tranlation else = len(_SecTran) */ +BYTE SecSize; /* 0-128, 1-256, 2-512, 3-1024 */ +BYTE InSide; /* 0-single, 1-double */ +WORD SecPerTrack; +WORD TrkPerDisk; +/*DPB*/ +WORD SPT; /* logical sector(128) per track */ +BYTE BSH; /* block shift */ +BYTE BLM; /* block shift mask */ +BYTE EXM; /* extent mask EXM=(BLM+1)*128/1024 - 1 - [DSM/256] */ +WORD DSM; /* disk size - 1 */ +WORD DRM; /* dir entry - 1 */ +WORD AL; /* dir allocation */ +WORD CKS; /* dir check table size CKS=(DRM+1)/4; 0 for fixed disk */ +WORD OFS; /* offset, reserved tracks count */ +BYTE CheckSum; +BYTE SecTran[96]; +}; + diff --git a/_build.bat b/_build.bat new file mode 100644 index 0000000..93ba7e1 --- /dev/null +++ b/_build.bat @@ -0,0 +1,3 @@ +dcc32 OrionZEm.dpr -H- -W- -B -$D- -$L- +dcc32 F600prn.dpr -H- -W- -B -$D- -$L- +dcc32 HddUtil.dpr -H- -W- -B -$D- -$L- diff --git a/_history.txt b/_history.txt new file mode 100644 index 0000000..62ae2f2 --- /dev/null +++ b/_history.txt @@ -0,0 +1,210 @@ +Версия 1.09, (31.08.2016): +---------------------------------------- +Добавлено: эмуляция страниц ROM2 для Ориона-ПРО, эмуляция платы IDE-RTC + (512ВИ1, IDE) и AY-8910 на портах Ориона-ПРО + + + +Версия 1.08, (31.12.2011): +---------------------------------------- + +Добавлено: режим эмуляции страниц ROM-диска + (страницы по 64к переключаемые D0..D3 порта 0FEh). + +Изменено: иконка приложения. :) + + + +Версия 1.07, (10.06.2011): +---------------------------------------- + +Добавлено: режим эмуляции Ethernet-адаптера на чипе RTL8019AS, + порты F770..F77F - регистры управления (16 регистров RTL8019AS), + F780..F7FF - регистр данных (все 128 адресов - один регистр: + так сделано для быстрых пересылок при помощи LDIR). + UTILS\OpenVPN-TAP - дистрибутив виртуального Ethernet-адаптера + (TAP-адаптера) для Windows + + + + +Версия 1.06, (10.04.2010): +---------------------------------------- + +Добавлено: режим эмуляции последовательного порта (RS-232), порты F764,F765. + UTILS\com0com - дистрибутив виртуального COM-порта для Windows + +Исправлено: Исправлены ошибки в эмуляции SD-карт (команды CMD9, CMD10). + + + + +Версия 1.05, (10.02.2010): +---------------------------------------- + +Добавлено: + режим эмуляции SD CARD. Эмулируются 2 варианта: + = совместимо по схеме с n8vem (port F762): + http://n8vem-sbc.pbworks.com/browse/#view=ViewFolder¶m=N8VEM%20Schematics + = совместимо по схеме с MSX MMC-drive V1 (port F762, F763): + http://msx.retro8bits.com/sd-mmc-drive.html + В железе оба варианта не проверялись, только в эмуляторе! + +Исправлено: работа кнопки F8 (Step over) в отладчике. + +Изменено: небольшие косметические изменения окна отладчика. + + + + +Версия 1.04, (08.02.2009): +---------------------------------------- + +Добавлено: + режим эмуляции московской Z80 CARD (описана в журнале + Радио 96/4), не содержавшей каких-то изысков типа + прерываний или диспетчера ОЗУ, но самой совместимой с + "классическим" Орионом на i8080 (например, в части + странного решения выводить Beeper-звук по EI/DI). + ! ID режима эмуляции сместился на 1 - проверьте + закладку CPU в окне настроек. + + добавлена возможность сохранения в файл скриншота + (BMP-картинки) экрана (новый пункт в меню снапшотов). + + добавлены файлы .\ROM\TestZ80.BIN, .\ROM\M1rk.bin, + а также несколько заметок о Мониторах-1...3. + +Исправлено: некоторые изменения в движке Z80 - тест ZEXALL теперь + не выдает ошибок - спасибо RAMIROS-у (автор VirtualVector) + +Изменено: утилиты DiskUtil, HddUtil, OdiWcx, OhiWcx распространяются + теперь как отдельно от эмулятора (т.к. правятся независимо), + так и в общем с ним архиве - для удобства. + + + +Версия 1.03, build 1.0.3.8 (18.09.2008): +---------------------------------------- + +Все то же, что и в build 1.0.3.6. Добавлена возможность грузить + *.BRU, *.ORD, *.RKO в RAM-диск "В" (ОЗУ второй страницы) + не только из командной строки, но и из меню (кнопка Открыть). + + + +Версия 1.03, build 1.0.3.6 (15.09.2008): +---------------------------------------- +Добавлено: - при запуске эмулятора можно передать параметры - + имена файлов *.BRU, *.ORD, *.RKO. Эти файлы обычно + содержат ORDOS-код. Эмулятор загружает их в RAM-диск + "В" (ОЗУ второй страницы) так, как они перечислены в + командной строке (один за одним пока хватает места в + ОЗУ второй страницы). + Файлы-снапшоты и файлы-образы_дисков передаются и + обрабатываются как и ранее (первый-второй параметры, + или не указываются), следом за ними (или вместо них) + можно передавать имена файлов *.BRU, *.ORD, *.RKO. + + +Версия 1.03 (07.04.2008): +------------------------- +Добавлено: - Эмуляция Орион-ПРО +Исправлено: - эмуляция клавиатуры МС7007 по Московской схеме + + + +Версия 1.02 (19.11.2007): +------------------------- +Добавлено: - на порту F600 кроме эмуляции IDE-контроллера + добавлена эмуляция произвольных внешних устройств. + Модели устройств хранятся в подключаемых модулях + (плагинах) - специализированных dll, подключающихся + "на лету" (без дополнительного конфигурирования - + просто копируя dll в каталог эмулятора). В настройках + эмулятора один из плагинов (одно устройство на порт + F600) выбирается из списка. В плагине F600prn.dll + реализован эмулятор принтера (печать в файл или на + реальный принтер) для двух наиболее часто + использовавшихся на Орионе вариантов схем подключения + принтера с интерфейсом CENTRONICS. + - реализованы дополнительные режимы масштабирования + изображения (по-прежнему, кратное масштабирование). + К ранее существовавшим режимам х1 (1:1), х2 (1:2) + добавлены режимы х2.5 (1:2.5), х3 (1:3) +Изменено: - немного видоизменен интерфейс: теперь нет закладок + Screen, Debug - эти режимы отображения теперь + включаются соотвествующими кнопками на панели + инструментов. Режим масштабирования сохраняется в INI + + + +Версия 1.01b (23.09.2007): +------------------------- +Исправлено: - отлажена процедура записи/чтения снапшотов. + Снапшоты предыдущих версий читаться не будут + (изменилась CRC), да и вряд ли они у кого-то + были, т.к. раньше снапшоты при загрузке сбоили. + - исправлена ошибка в эмуляции клавиатуры МС7007, + включенной по Московской схеме + - почищено некоторое количество внутренних + некрасивостей + +Добавлено: - режим "Пауза" теперь можно включать не только + мышью, но и с клавиатуры кнопкой Pause/Break + - при запуске эмулятора можно передать параметры: + имена файлов. Если это файл-снапшот, то он будет + загружен; если это файл-образ_диска, то он будет + установлен как образ диска "A". Второй параметр + командной строки предполагается как образ диска + "B". Теперь можно, к примеру, создать в Windows + ассоциации OrionZEm.exe с файлами "*.ori", "*.odi" + и открывать такие файлы прямо из Проводника по + двойному щелчку. + ВНИМАНИЕ: + - если OrionZEm.exe запущен как ассоциация файла + Windows, все пути в файле настроек эмулятора + (OrionZEm.ini) должны быть полными (формат вида + "от текущего каталога: .\dir1\dir2\file" всего + вероятнее не будет работать, т.к. текущий + каталог при таком запуске уже скорее всего не + является каталогом эмулятора). + - если OrionZEm.exe запущен с параметрами, то + автоматическое восстановление автоснапшота из + AutoSnap.ori не вызывается, т.к. оно перекроет + переданные параметры своими. + - при загрузке снапшоты восстаналивают полное + состояние эмулятора (т.е. включая файловые + буфера ОС в памяти Ориона), но они не + восстанавливают содержимое файлов образов + дисков/HDD (это не дело эмулятора). Поэтому + если между записью снапшота и его + восстановлением содержимое файлов образов + поменялось, возможны неувязки при записи в + эти файлы! Это не ошибка эмулятора! + + +Версия 1.01 (01.09.2007): +------------------------- + +Исправлено:- почищены ошибки эмуляции HDD (IDE/ATA) + + + +Версия 1.0.alpha: +----------------- + +Добавлено: - эмуляция IDE на порту F500/F600 + - эмуляция всех типов клавиатур: + РК-86 (было с версии 0.99), + MC-7007 (оба варианта, но вариант + "Москва" не проверялся) + - эмуляция HD-форматов дискет - ODI + образы "дисков" могут быть любого размера, + но должны содержать корректный DPB + (пример - формат OD2 в \OdiWcx\odi.ini) +Исправлено:- убраны ошибки встроенного дизассемблера + + + + +Версия 0.999alpha и ниже: +--------------------------- + +Изменения не фиксировались. \ No newline at end of file diff --git a/_ports.txt b/_ports.txt new file mode 100644 index 0000000..0768a9e --- /dev/null +++ b/_ports.txt @@ -0,0 +1,413 @@ +========================= ОРИОН - 128 + Z80 Card II ============================ + + Порт F8 (F800) - Управление цветом. Если в порт записывается байт с + битом D2, равным 0, дисплей работает в монохромном + (двуцветном) режиме. Если бит D1=0, устанавливается + 16-цветный режим работы дисплея, а если D1=1 - + дисплей переходит в четырехцветный режим. + + Последний триггер DD30 меняет палитру цветов в двух- + (монохромный на цветном дисплее) и четырехцветных режимах. + + D7=1 - включить экран 480 точек + + Порт F9 (F900) - Упр.страницами для режима "Орион-128". + Порт FA (FA00) - Упр.экранами + "1" D0,D1 - номер экрана (0-3) + D2-D5 - резерв + D6 - выкл.регенерации ОЗУ (чтоб ОЗУ сдохло) + D7 - экран 384/512 точек (по горизонтали) + + Порт FB - УПРАВЛЕНИЕ ПРЕРЫВАНИЯМИ И ДИСПЕТЧЕРОМ: + + D7 D6 D5 D4 D3 D2 D1 D0 + ! ! ! ! ! ! ! ! + MZ INT XMEM RZRV BS1 BS0 SS1 SS0 + ! ! ! ! ! ! ! ! + ! ! ! ! ! ! !______!____ SEGMENT SELECT + ! ! ! ! !______!__________________ BANK SELECT + ! ! ! ! + ! ! ! !________ РЕЗЕРВ ДЛЯ BANK SELECT (ВСЕГДА = 0) + ! ! !_______________ FULL RAM MEMORY (ПРИ D5=1 0-FFFF - ОЗУ) + ! !______________________ INT ENABLE (ПРИ D5=0 ЗАПРЕЩЕНЫ) + !_____________________________ DISPATCHER OFF (ПРИ D7=1 ОТКЛЮЧЕН !) + +БИТЫ BS1,BS0 ОПРЕДЕЛЯЮТ НОМЕР БАНКИ ОЗУ, А БИТЫ SS1,SS0 ОПРЕДЕЛЯЮТ КАКОЙ +16-ТИ КИЛОБАЙТОВЫЙ УЧАСТОК ИЗ ЭТОЙ БАНКИ БУДЕТ ДОСТУПЕН ПО АДРЕСАМ 0-3FFF. +ДАННЫЕ, ЗАПИСАННЫЕ В ПОРТ, МОЖНО СЧИТАТЬ С ПОРТА FB (АЛЬТАИР,SUPER-3) + + Порт FC - УПРАВЛЕНИЕ ТЕНЕВЫМ ПЗУ. НА ПЛАТАХ "СУПЕР-3" БИТОМ D7 ВКЛ-СЯ ТЕНЕВОЕ ПЗУ + + Порт FD - Резерв адреса для двухбайтовых + адресов портов расширений "ZX". + Порт FE - В ЭМУЛЯТОРЕ "СИНКЛЕРА" ЗВУК И КЛАВИАТУРА (ПРОГРАМНЫЙ ЗВУК ПО БИТУ D4) + Порт FF - "ПРОГРАМНЫЙ КЛЮЧ" ДЛЯ ВЫВОДА ЗВУКА (ПЕРЕКЛЮЧАЕТСЯ ПО КАЖДОМУ ОБРАЩЕНИЮ) + + + Порты 0F8H...0FAH работают только на запись, в режиме "Orion-128" они доступны + также как ячейки памяти 0F800H, 0F900H, 0FA00H. + + + АДРЕСАЦИЯ ВНЕШНИХ УСТРОЙСТВ + +В ОБЛАСТИ ПАМЯТИ (НЕДОСТУПНЫ В РЕЖИМЕ FULL RAM MEMORY): +F400..F403 - ППА КЛАВИАТУРЫ +F500..F503 - ППА ROM-Disk +F600..F603 - ППА Printer +F700/F720 - КОНТРОЛЛЕР ДИСКОВОДА (F720/D3,D6 - ПЛОТНОСТЬ ЗАПИСИ) +F760 - ПДП 1810ВТ37 ИЛИ i8237, ДЛЯ БЛИТТЕРА И РАБОТЫ КНГМД-HD/КНЖМД +F780 - ВНЕШНИЙ ЭЛ.ДИСК (1-16 МБАЙТ) +F7B0 - ЧАСЫ 512ВИ1 (ОРИОНСОФТ), BlackCat: 512ВИ1 на порту F760 + + +=================================== ORION - PRO ================================ + +Для выбора номера рабочей (текущей) страницы +используется порт с адресом 08H (для режима "Орион-128" - +0F900H). Все страницы равносильны, и нет необходимости работать +именно в нулевой (только для режима Pro). В режиме "Орион-128" +для переключения страниц ОЗУ можно использовать порт с адресом +0F9H. + + Распределение сегментов по страницам основного ОЗУ: + + Стр.0 Стр.1 Стр.2 Стр.3 Стр.4 Стр.5 Стр.6 Стр.7 +FFFFH -------T------T------T------T------T------T------T------¬ + ¦ 3 ¦ 7 ¦ 11 ¦ 15 ¦ 19 ¦ 23 ¦ 27 ¦ 31 ¦ +C000H +------+------+------+------+------+------+------+------+ + ¦ 2 ¦ 6 ¦ 10 ¦ 14 ¦ 18 ¦ 22 ¦ 26 ¦ 30 ¦ +8000H +------+------+------+------+------+------+------+------+ + ¦ 1 ¦ 5 ¦ 9 ¦ 13 ¦ 17 ¦ 21 ¦ 25 ¦ 29 ¦ +4000H +------+------+------+------+------+------+------+------+ + ¦ 0 ¦ 4 ¦ 8 ¦ 12 ¦ 16 ¦ 20 ¦ 24 ¦ 28 ¦ +0000H L------¦------¦------¦------¦------¦------¦------¦------- + + + Доступ к сегментам ОЗУ осуществляется через три независи- +мых окна, которые можно "открыть" в адресном пространстве про- +цессора в пределах рабочей страницы ОЗУ: + + Окно ОЗУ "RAM2" - 8000-BFFFH + Окно ОЗУ "RAM1" - 4000-7FFFH + Окно ОЗУ "RAM0" - 0000-3FFFH + + Назначение разрядов порта 0AH следующее: + + D0 - 1 = включить окно ОЗУ "RAM0" + D1 - 1 = включить окно ОЗУ "RAM1" + D2 - 1 = включить окно ОЗУ "RAM2" + D3 - включить окно ПЗУ "ROM2-BIOS" + D4 - включить окно ПЗУ "ROM1-BIOS" + D5 - включить тактовую частоту процессора 2.5 МГц + D6 - отключить переключение ОЗУ 0F000H..0FFFFH (в режиме + "Orion-128" игнорируется) + D7 - включить режим "Orion-128" (область 0F000H..0FFFFH + недоступна для записи). + + Для выбора сегментов в каждом из окон "RAM0", "RAM1", +"RAM2" в компьютере предусмотрены три порта с адресами соот- +ветственно 04H, 05H, 06H, в которые могут быть записаны номера +сегментов ОЗУ. Порты диспетчера 04H, 05H, 06H, 08H, 0AH доступны +как для записи, так и для чтения. + + Область памяти 0F000H..0FFFFH в режиме "Orion-Pro" (разряд +D7 порта 0AH установлен в 0) доступна как для чтения, так и для записи. +Кроме того, программно можно установить режим, при котором указанная область +или переключается вместе с переключением страниц (D6=0), или не переключается +(D6=1) и проецирует "верхние" 4к сегмента 31 (1Fh). + В режиме "Orion-128" (разряд D7 порта 0AH установлен в 1) +указанная область памяти является не переключаемой независимо +от значения разряда D6, к тому же ячейки с адресами +0F400H..0FA00H доступны как порты (причем порты 0F800H..0FA00H +доступны только на запись, так как при чтении по адресам +0F800H..0FFFFH включается ОЗУ). + + Постоянная память, расположенная на основной плате, состоит +из двух частей: + + "ROM1-BIOS" - стартовое ПЗУ объемом 8 Кбайт; + "ROM2-BIOS" - ПЗУ пользователя объемом 8-64 Кбайт. + + Для доступа к постоянной памяти в адресном пространстве +процессора предусмотрено включение соответственно двух ROM-окон +ПЗУ. + Окно для "ROM1-BIOS" включается по адресам 0000H..1FFFH +при аппаратном сбросе компьютера, тем самым обеспечивая доступ +к стартовым и другим подпрограммам. + Для управления включением и выключением окна "ROM1-BIOS" +предназначен бит D4 порта диспетчера 0AH. + Включением окна "ROM2-BIOS" по адресам 2000H..3FFFH управ- +ляет бит D3 порта 0AH (независимо от окна "ROM1-BIOS"), причем +доступ к ПЗУ в этом окне осуществляется по сегментам размером +8Кбайт (отсюда и минимальный размер ПЗУ). Номер сегмента +"ROM2-BIOS" записывается в специальный порт с адресом 09H, +допускающий как запись, так и чтение информации. + Окна ПЗУ имеют самый высокий приоритет: если окно +"ROM1-BIOS" и/или "ROM2-BIOS" включено, то доступ к нему обес- +печивается из любой текущей страницы, в том числе при "откры- +том" окне ОЗУ "RAM0". + + 3. ПОРТЫ ВВОДА-ВЫВОДА + --------------------- + + В режиме "Orion-128" (бит D7 порта 0AH установлен в 1) +разрешен доступ к портам 0F400H..0FA00H, адресуемым через об- +ласть памяти, и к портам 10H..14H, 18H..1BH, 0F8H..0FFH, а так- +же портам периферии - с помощью команд процессора IN, OUT. + В режиме "Orion-Pro" (бит D7 порта 0AH установлен в 0) +доступ к портам как к ячейкам ОЗУ запрещен. + + Назначение портов: + + 00H - состояние DIP-переключателей (SW), определяющих + конфигурацию системы; + 01H - данные принтера "Centronics"; + 02H - сигналы управления принтером; + 03H - регистр настройки портов 00H..02H; + 04H - регистр сегментов для окна "RAM0"; + 05H - регистр сегментов для окна "RAM1"; + 06H - регистр сегментов для окна "RAM2"; + 07H - регистр настройки портов 04H..06H; + 08H - регистр страниц ОЗУ; + 09H - регистр сегментов "ROM2-BIOS"; + 0AH - диспетчер управления конфигурацией памяти; + 0BH - регистр настройки портов 08H..0AH; + 0CH..0FH - системный резерв; + 10H..13H - порты контроллера дисковода КР1818ВГ93 (в режи- + ме "Orion-128" доступны также через ячейки па- + мяти 0F700H..0F703H, 0F710H..0F714H, 0F720H): + 10H - регистр команд; + 11H - регистр дорожек; + 12H - регистр секторов; + 13H - регистр данных; + 14H - регистр управления контроллером дисковода; + в режиме "Orion-128" доступен также через ячей- + ки 0F704H, 0F714H, 0F720H; + 18H..1BH - универсальный порт, используемый как порт кла- + виатуры; в режиме "Orion-128" может быть перек- + лючен (параллельно с обращением 18-1BH) на ад- + реса одного из портов 0F4XXH, 0F5XXH, 0F6XXH по + выбору пользователя; + + 0F8H - регистр управления цветовым режимом дисплея; + в режиме "Orion-128" доступен также как ячейка + 0F800H; + 0F9H - регистр страниц; для режима "Orion-128" досту- + пен также как ячейка 0F900H; + 0FAH - регистр номера и размера экрана; в режиме + "Orion-128" доступен также как ячейка 0FA00H; + 0FBH - регистр включения прерываний от таймера (D6); + 0FCH - регистр цвета для псевдоцветного режима; + 0FFH - порт звука. + +======================================================================== + + + ОРГАНИЗАЦИЯ ЭКРАННОЙ ПАМЯТИ Orion-PRO, Ориона-128 + ------------------------------------------------- + + Экранная память располагается в 0 и 1 страницах ОЗУ, при- +чем количество экранов и распределение сегментов в них зависит +от текущего цветового режима, задаваемого разрядами порта 0F8H: + + D4 D3 D2 D1 D0 + ------------------ + 0 x 0 0 0 - монохромный, палитра 1 + 0 x 0 0 1 - монохромный, палитра 2 + 0 x 0 1 x - запрет видеосигнала + 0 x 1 0 0 - 2-битный (4-цветный), палитра 1 + 0 x 1 0 1 - 2-битный (4-цветный), палитра 2 + 0 x 1 1 x - 16-цветный с групповым кодированием + 0 1 1 1 x - псевдоцветной (цвет - в порт 0FCH) + 1 x 0 x x - 3-битный (8-цветный RGB) + 1 x 1 x x - 4-битный (16-цветный RGBI) + + Для Ориона-128 то же, но только D0..D2. Режимы от D3,D4 недоступны + + В монохромном режиме палитре 1 соответствует комбинация +цветов - (черный, зеленый), палитре 2 - (белый, зеленый). В +4-цветном (2-х битовом) режиме палитре 1 соответствуют цвета - +(черный, синий, зеленый, красный), палитре 2 - (белый, синий, +зеленый, красный). + Код палитры для псевдоцветного режима записывается в порт +с адресом 0FCH. + Выбор на отображение одного из 4-х экранов выполняется пу- +тем записи номера экрана в порт 0FAH: + + D0 \ номер экрана + D1 / + D6 - выключение регенерации ОЗУ + D7 - включение широкого экрана + + Разряды D2-D5 являются резервными. + + Если разряд D7 установлен в единицу, то ширина экрана сос- +тавляет 512 точек (64 байта), что при высоте 256 байт соответс- +твует объему памяти 16 Кбайт. В противном случае экранная плос- +кость ОЗУ имеет ширину 384 точки (48 байт) и занимает объем 12 +Кбайт. + В 3-х битном и 4-х битном (EGA-режим) цветовых режимах до- +пускается использование только двух экранов, поэтому разряд D0 +порта 0FAH игнорируется. + Рассмотрим распределение сегментов экранного ОЗУ в различ- +ных цветовых режимах. + + 1.2.3 МОНОХРОМНЫЙ И ПСЕВДОЦВЕТНОЙ РЕЖИМЫ + ---------------------------------------- + + В монохромном и псевдоцветном режимах возможно использова- +ние до 4-х экранов, занимающих только сегменты 0-й страницы +ОЗУ: + + Стр.0 Экран 12 К Экран 16 К + --------¬ ------------ ------------ + Экран 0 ->¦ 3 ¦ C000H..EFFFH C000H..FFFFH + ¦=======¦ + Экран 1 ->¦ 2 ¦ 8000H..AFFFH 8000H..BFFFH + ¦=======¦ + Экран 2 ->¦ 1 ¦ 4000H..6FFFH 4000H..7FFFH + ¦=======¦ + Экран 3 ->¦ 0 ¦ 0000H..2FFFH 0000H..3FFFH + L-------- + + В монохромном режиме единичному значению некоторого бита +экранного сегмента ОЗУ соответствует засветка изображаемой точ- +ки, нулевому - гашение. + В псевдоцветном режиме цвет отображаемых точек зависит от +кода палитры, записанного в порт 0FCH. Старшие 4 бита значения +этого порта определяют один из 16 цветов фона (для погашенных +точек), младшие 4 бита - один из 16 цветов переднего плана (для +засвеченных точек). + Заметим, что при широком экране-0 область 0F000H..0FFFFH +экрана (не путать с системной областью 0F000H..0FFFFH) доступна +только через окно. Прямой доступ к экрану возможен только по +адресам 0C000-0EFFFH. Это относится ко всем цветовым режимам. + + + 1.2.4. 4-ЦВЕТНЫЙ РЕЖИМ + ----------------------- + + В 4-цветном (2-битном) режиме цвет каждой отображаемой +точки зависит от соответствующих битов двух экранных плоскостей +(сегментов), находящихся в страницах 0 и 1 ОЗУ: + + + Стр.0 Стр.1 + --------T-------¬ + Экран 0 ->¦ 3 ¦ 7 ¦ + ¦=======+=======¦ + Экран 1 ->¦ 2 ¦ 6 ¦ + ¦=======+=======¦ + Экран 2 ->¦ 1 ¦ 5 ¦ + ¦=======+=======¦ + Экран 3 ->¦ 0 ¦ 4 ¦ + L-------+-------- + L--¬ ---- + + 0 0 -> черный (белый) + 0 1 -> красный + 1 0 -> зеленый + 1 1 -> синий + + + 1.2.5. 8-ЦВЕТНЫЙ и 16-ЦВЕТНЫЙ РЕЖИМЫ ОРИОН-ПРО + ----------------------------------------------- + + Это новый графический режим. Функционально он тождествен +EGA режиму на IBM PC AT (был широко распространен на 286 моде- +лях). В 8-цветном (3-битном) и 16-цветном (4-битном) режимах +для формирования отображаемой точки в каждом из двух экранов +используются соответственно 3 и 4 плоскости экранного ОЗУ: + + Стр.0 Стр.1 + --------T-------¬ + ¦ 3 (G)¦ 7 (I)¦ + Экран 0 ->+-------+-------+ + ¦ 2 (R)¦ 6 (B)¦ + ¦=======+=======¦ + ¦ 1 (G)¦ 5 (I)¦ + Экран 1 ->+-------+-------+ + ¦ 0 (R)¦ 4 (B)¦ + L-------+-------- + + Сегментам 3 и 1 соответствует зеленый цвет (G), 2 и 0 - +красный (R), 6 и 4 - синий (B), 7 и 5 (в 3-битном режиме не ис- +пользуются) - управление яркостью (I). + + Путем записи комбинации битов в соответствующие сегменты +экрана можно получить точку заданного цвета. + + + 1.2.6. РЕЖИМ С ГРУППОВЫМ КОДИРОВАНИЕМ ЦВЕТА + ------------------------------------------- + + В 16-цветном режиме с групповым кодированием каждый из 4-х +экранов формируется из содержимого двух сегментов памяти: из +плоскости изображения (0 страница ОЗУ) и плоскости цветовых ат- +рибутов (1 страница ОЗУ), причем восьми соседним точкам плос- +кости изображения, расположенным в пределах одного байта, соот- +ветствует один байт из плоскости цветовых атрибутов. + + Старшие 4 бита в байте цветового атрибута определяют цвет +фона (для погашенных точек), младшие 4 бита - цвет переднего +плана (для засвеченных точек) в пределах одного экранного бай- +та. + + Стр.0 Стр.1 + (изобр) (цвет) + --------T-------¬ + Экран 0 ->¦ 3 ¦ 7 ¦ + ¦=======+=======¦ + Экран 1 ->¦ 2 ¦ 6 ¦ + ¦=======+=======¦ + Экран 2 ->¦ 1 ¦ 5 ¦ + ¦=======+=======¦ + Экран 3 ->¦ 0 ¦ 4 ¦ + L-------+-------- + + Для всех цветовых режимов действует ограничение на исполь- +зование широкого экрана с номером 0, описанное в П.1.2.3. + Следует помнить, что экраны аппаратно привязаны к конкрет- +ным сегментам ОЗУ, а не к окнам, т.е. отображение информации +экрана не зависит от рабочей страницы ОЗУ и включения / выклю- +чения окон. + + Периферия + --------- + +по портам RS-232 и AY: + +30H - регистр данных ВВ51 "COM1" (DD7) +31H - регистр управления ВВ51 "COM1" (DD7) +34H - регистр данных ВВ51 "COM2" (DD8) +35H - регистр управления ВВ51 "COM2" (DD8) +38H - счетчик 1 ВИ53 (DD6) +39H - счетчик 2 ВИ53 (DD6) +3AH - счетчик 3 ВИ53 (DD6) +3BH - регистр управления ВИ53 (DD6) +3EH - запись данных музыкального процессора (DD9) +3FH - чтение данных музыкального процессора (DD9) +3FH - запись номера регистра музыкального процессора (DD9) + +по HDD-RTC: + +50H ; dannye CMOS +51H ; adres CMOS +56H ; alxt.registr sostoqniq +56H ; registr uprawleniq +57H ; st.bajt registra dannyh +58H ; ml.bajt registra dannyh +59H ; registr o{ibok +59H ; registr swojstw +5AH ; s~et~ik seektorow +5BH ; registr sektora +5CH ; ml.bajt nom.cilindra +5DH ; st.bajt nom.cilindra +5EH ; registr golowki i ustrojstwa +5FH ; registr sostoqniq +5FH ; registr komand + +70..77h - порт COM3 (БИС 16C550), коммуникация с "внешним миром"; +78..7Fh - порт COM4 (БИС 16C550), резерв "для чего-нибудь ещё"; +80..84h - RAM-диск 1 Мб (СОЗУ 2х512 Кб); +88..8Fh - SDHC (на МК). diff --git a/_read_me.txt b/_read_me.txt new file mode 100644 index 0000000..98f04e6 --- /dev/null +++ b/_read_me.txt @@ -0,0 +1,175 @@ +////////////////////////////////////////////////////////////////////////// +// // +// Orion/Z (Orion-128 + Z80-CARD-II, ORION-Pro) emulator, version 1.05. // +// // +// // +// Author: Sergey A. // +// // +// Copyright (C)2006-2016 Sergey A. // +// // +// This program is free software; you can redistribute it and/or // +// modify it in any ways. // +// This program is distributed "AS IS" 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. // +// // +////////////////////////////////////////////////////////////////////////// + +Вашему вниманию представляется программа Orion/Z emulator. +Это эмулятор домашнего компьютера Орион-128, описанного в +журнале Радио N1 за 1990г., и модифицированного при помощи +Z80 Card II (ленинградский вариант установки Z80 в Орион), +а также модификацию Орион-ПРО (Orion-Power). + +Программа не требует установки, работает из текущего каталога +куда будет распакована, настройки хранятся в файле, одноименном +исполняемому, но с расширением INI. + + +Технические характеристики эмулируемого компьютера: + +процессор - Z80 2.5 МГц (режимы турбо: 3.5/5/7/10/20 MГц) +память (ОЗУ) - 512кб (аналог реальных Орион-Супер4, Орион-ПРО) +клавиатура - РК86, МС7007 Лениград (совместимо с РК), МС7007 Москва +ROM-BIOS - страндартный, содержится во внешнем файле +ROM-DISK - страндартный + расширенный режим (16 страниц по 64к, + переключаемые битами D0..D3 порта 0FEh), содержится во + внешнем файле +КНГМД - эмуляция 1818ВГ93, 2 привода (ODI-файлы) + порты F700..7003/F710..F713/F720/F714, 10h..14h + эмулируется режим HD (ODI-диски более 800к) +ЧАСЫ (RTC) - эмуляция 512ВИ1 на порту F760 (BlackCat inc.) +муз.процессор- эмуляция AY-3-8910 на портах BFFD/FFFD +IDE (HDD) - эмуляция контролера IDE на 580вв55 (порт F500/F600) +Принтер - эмуляция 2-х схем принтера CENTRONICS (порт F600) +SD CARD - Эмулируются 2 варианта: + = совместимо по схеме с n8vem (port F762): + http://n8vem-sbc.pbworks.com/browse/#view=ViewFolder¶m=N8VEM%20Schematics + = совместимо по схеме с MSX MMC-drive V1 (port F762, F763): + http://msx.retro8bits.com/sd-mmc-drive.html + В железе оба варианта не проверялись, только в эмуляторе! + Эмулируются только SDC карты (non-SDHC, объемом до 1Gb). +последовательный порт (RS-232) - порты F764,F765. +Ethernet-адаптер на чипе RTL8019AS - порты F770..F77F, F780..F7FF + +Минимальные требования к PC: + +Celeron 400Мгц / 64М RAM / 2M HDD free / Windows 9x, 2000, XP + + + При запуске эмулятора можно передать параметры: имена +файлов. Если это файл-снапшот, то он будет загружен; если это +файл-образ_диска, то он будет установлен как образ диска "A". +Второй параметр командной строки предполагается как образ диска +"B". Также при запуске эмулятора можно передать параметры - имена +файлов *.BRU, *.ORD, *.RKO. Эти файлы обычно содержат ORDOS-код. +Эмулятор загружает их в RAM-диск "В" (ОЗУ второй страницы) так как +они перечислены в командной строке (один за одним пока хватает +места в ОЗУ второй страницы). + Можно, к примеру, создать в Windows ассоциации OrionZEm.exe +с файлами "*.ori", "*.odi" и открывать такие файлы прямо из +Проводника Windows по двойному щелчку. В этом случае все пути в +файле настроек эмулятора (OrionZEm.ini) должны быть полными +(формат вида "от текущего каталога: .\dir1\dir2\file" всего +вероятнее не будет работать, т.к. текущий каталог при таком +запуске уже скорее всего не является каталогом эмулятора). + ВНИМАНИЕ: +- если OrionZEm.exe запущен с параметрами, то автоматическое + восстановление автоснапшота из AutoSnap.ori не вызывается, + т.к. оно перекроет переданные параметры своими. +- при загрузке снапшоты восстаналивают полное состояние эмулятора + (т.е. включая файловые буфера ОС в памяти Ориона), но они не + восстанавливают содержимое файлов образов дисков/HDD (это не + дело эмулятора). Поэтому если между записью снапшота и его + восстановлением содержимое файлов образов поменялось, то + возможны неувязки при записи в эти файлы программами Ориона + (например, в CP/M)! Это не ошибка эмулятора! + + На порту F600 кроме эмуляции IDE-контроллера добавлена эмуляция +произвольных внешних устройств. Модели устройств хранятся в +подключаемых модулях (плагинах) - специализированных dll, +подключающихся "на лету" (без дополнительного конфигурирования +эмулятора - просто копируя dll в каталог эмулятора, что не отменяет +необходимости конфигурирования самих плагинов - у каждого плагина +могут быть внутренние настройки - жмите "Configure plugin" на +закладке "port F600" эмулятора). В настройках эмулятора один из +плагинов (одно устройство на порт F600) выбирается из списка. + В плагине F600prn.dll реализован эмулятор принтера (печать в +файл или на реальный принтер) для двух наиболее часто +использовавшихся на Орионе вариантов схем подключения +принтера с интерфейсом CENTRONICS. Печать тестировалась на +лазерном принтере под Windows XP. В эмуляторе для тестирования +применялась АСРМ 1.53 с драйвером LPR.COM А.Грачева +(Centronix, A0..A7 - data, C7 - strobe, C3 - ready=/busy). + + +В составе эмулятора распространяется утилита HddUtil.exe, с помощью +которой под Windows NT, 2000, XP, Vista можно создать посекторный +образ HDD (как целиком, так и логическго раздела - партиции) в файле +(программа работает аналогично утилите DiskUtil.exe, создающей +ODI-образы дискет). +Запустите HddUtil.exe без параметров - программа покажет список ключей. + + В общих чертах про ODI-"диски". Первое с чего нужно начать, это +сопоставить виртуальным (эмулируемым программой OrionZEm) дисководам +файлы-образы дискет. Это делается при помощи двух кнопок в панели +инструментов эмулятора (в верхней части окна): на одной кнопке +написано "А" - тут по нажатию в выпадающем меню можно выбрать файл-образ +для дисковода А (floppy 0) или очистить привод - "извлечь дискету". +Аналогично по кнопке "B" для дисковода В (floppy 1). + Ньюанс: поведение Ориона по включению/сбросу зависит от того, +какой тип Монитора (базовой программы - загрузчика в ПЗУ F800) +использован: некоторые из них загружают с RomDisk-а ORDOS, некоторые +сразу загружают CP/M с дисковода "А". Набор разных Мониторов и небольшое +их описание лежит в подкаталоге .\ROM\ архива эмулятора. +Файл Монитора указывается в настройках эмулятора. + Незагрузочные диски обычно могут быть 2х вариантов: + --1. Диски с исполняемыми файлами (программами или играми) под CP/М - + классическую операционную систему 8-битных ПК, заточенную под + работу с дисководами. Такие файлы имеют расширение COM (как в + MS-DOS) и могут запускаться непосредственно из коммандного режима + CP/M (набрав имя файла) или из графической программы-оболочки + типа NortonCommander или BridgePanels. + --2. Диски с программами или играми под ORDOS - оригинальную систему, + расчитанную на работу с Rom-Disk (ПЗУ) и квазидисками (ОЗУ). + Обычно это диски с файловой системой CP/M, содержащие файлы с + расширением ORD или BRU. Эти файлы нельзя непосредственно + запустить из CP/M, их нужно скопировать на "квазидиск", а затем + уже запускать под ОС ORDOS. Для копирования файлов BRU с дисков + CP/M на "квазизиск" в ОЗУ можно воспользоваться программой ATLAS, + расположенной в ROM-Диске эмулятора .\ROM\romdisk1.bin (его нужно + указать как файл ROM-диска в настройках эмулятора). ATLAS в + псевдографическом режиме выбирает с дискеты CP/M файлы *.BRU + (*.ORD не понимает - их нужно под CP/M переименовывать в *.BRU) + и копирует их на квазидиски ORDOS, а уже под ORDOS в командном + режиме или оболочке NC с этими файлами можно работать. + + + В Версии 1.06 добавлен режим эмуляции последовательного порта (RS-232), +порты F764,F765. Эмулятор осуществляет ввод\вывод в реально существующий в РС +СОМ-порт. Поэтому есть 2 варианта использования этого режима: в настройках +эмулятора выбрать реальный СОМ-порт и подключить к нему некое устройство, либо +создать в Windows пару виртуальных СОМ-портов на нульмодемном соединении +(я для этого использую бесплатную утилиту com0com, но есть и платные аналоги), +на одном конце повесить эмулятор (выбрать порт CNCB0), а на другом (CNCA0) - +эмулятор устройства или программу терминал. + + +Соответствие некоторых спецкнопок в эмуляторе (RK=PC): +УСТ = Home +ПС = End +СТР = Ins +ЗБ = BackSpace +AP2 = Esc +F1..F5 = F1..F5 +Ctrl+G = Del +Ctrl+R = PgUp +Ctrl+C = PgDown +РусLat = F8=F9=Scroll (смотря как настроено в настройках эмулятора на закладке + "keyboard") + +C учетом "TurboPascal-style"-расширителя (включается в настройках эмулятора на +закладке "keyboard") добавляются PC-комбинации Ctrl+кнопка для курсорных и +фукциональных кнопок, которые транслируются Ориону в "CTRL-Q-кнопка"-сочетания. +За соответствием (если кому-то нужно, в чем я по правде сказать - сомневаюсь) - +добро пожаловать в исходники (mod8255.pas). diff --git a/_rko.txt b/_rko.txt new file mode 100644 index 0000000..bad245e --- /dev/null +++ b/_rko.txt @@ -0,0 +1,11 @@ +Формат tape-файлов *.rko: +------------------------- + +8 байт имя +64 нулевых байт, потом 0E6h (синхробайты) +2 байта начало (обычно 0000) +2 байта конец (старший байт первый) +16 байт ORDOS-заголовок +(конец-начало-10h) данные +3 нулевых байта, потом 0E6h (синхробайты) +2 байта контрольная сумма diff --git a/frNewVal.dfm b/frNewVal.dfm new file mode 100644 index 0000000..41f5299 --- /dev/null +++ b/frNewVal.dfm @@ -0,0 +1,55 @@ +object frmNewVal: TfrmNewVal + Left = 275 + Top = 196 + BorderIcons = [biSystemMenu] + BorderStyle = bsSingle + Caption = 'Enter new value for ' + ClientHeight = 90 + ClientWidth = 313 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + Position = poScreenCenter + PixelsPerInch = 96 + TextHeight = 13 + object btnOK: TButton + Left = 31 + Top = 56 + Width = 75 + Height = 25 + Caption = 'OK' + Default = True + ModalResult = 1 + TabOrder = 1 + end + object btnCancel: TButton + Left = 208 + Top = 56 + Width = 75 + Height = 25 + Cancel = True + Caption = 'Cancel' + ModalResult = 2 + TabOrder = 2 + end + object meValue: TMaskEdit + Left = 128 + Top = 16 + Width = 49 + Height = 28 + EditMask = 'aaaa;1;_' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -16 + Font.Name = 'MS Sans Serif' + Font.Style = [] + MaxLength = 4 + ParentFont = False + TabOrder = 0 + Text = ' ' + end +end diff --git a/frNewVal.pas b/frNewVal.pas new file mode 100644 index 0000000..706ea77 --- /dev/null +++ b/frNewVal.pas @@ -0,0 +1,82 @@ +///////////////////////////////////////////////////////////////////////// +// // +// Orion/Z (Orion-128 + Z80-CARD-II) emulator, version 1.9 // +// // +// Author: Sergey A. // +// // +// Copyright (C) 2006-2016 Sergey A. // +// // +// This program is free software; you can redistribute it and/or // +// modify it in any ways. // +// This program is distributed "AS IS" 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 frNewVal; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, Mask; + +const + strictMask16: string = 'AAAA;1;_'; + freeMask16: string = 'aaaa;1;_'; + strictMask8: string = 'AA;1;_'; + freeMask8: string = 'aa;1;_'; + +type + TfrmNewVal = class(TForm) + btnOK: TButton; + btnCancel: TButton; + meValue: TMaskEdit; + private + { Private declarations } + public + { Public declarations } + end; + + function GetValue16(title: string; DefaultValue: integer; var Value:string; var Mask: integer): integer; + +var + frmNewVal: TfrmNewVal; + +implementation + +uses mainwin; + +{$R *.DFM} + +function GetValue16(title: string; DefaultValue: integer; var Value:string; var Mask: integer): integer; +begin + frmNewVal:=TfrmNewVal.Create(Application); + if (Assigned(frmNewVal)) then with frmNewVal do + try + Caption:=Caption+title; + meValue.EditMask:=Value; + if pos(';', Value)=3 then + meValue.Text:=IntToHex(DefaultValue and $FF, 2) + else + meValue.Text:=IntToHex(DefaultValue and $FFFF, 4); + if ShowModal()=mrOK then + begin + Value:=meValue.Text; + Result:=GetHexMasked16(meValue.Text, Mask); + end + else + begin + Value:=''; + Result:=DefaultValue; + Mask:=0; + end; + Free; + finally + frmNewVal:=nil; + end; +end; + + +end. diff --git a/frmAbout.dfm b/frmAbout.dfm new file mode 100644 index 0000000..0df1d97 Binary files /dev/null and b/frmAbout.dfm differ diff --git a/frmAbout.pas b/frmAbout.pas new file mode 100644 index 0000000..67492e8 --- /dev/null +++ b/frmAbout.pas @@ -0,0 +1,56 @@ +///////////////////////////////////////////////////////////////////////// +// // +// Orion/Z (Orion-128 + Z80-CARD-II) emulator, version 1.9 // +// // +// Author: Sergey A. // +// // +// Copyright (C) 2006-2016 Sergey A. // +// // +// This program is free software; you can redistribute it and/or // +// modify it in any ways. // +// This program is distributed "AS IS" 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 frmAbout; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, ExtCtrls; + +type + TAboutBox = class(TForm) + Button1: TButton; + Panel1: TPanel; + Image1: TImage; + TitleLabel: TLabel; + Label1: TLabel; + VersionLabel: TLabel; + ServerMemo: TMemo; + procedure FormActivate(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + AboutBox: TAboutBox = nil; + +implementation + +{$R *.DFM} + +procedure TAboutBox.FormActivate(Sender: TObject); +begin + OnActivate:=nil; + TitleLabel.Caption:=Application.Title; + Image1.Picture.Icon.Assign(Application.Icon); +end; + +end. diff --git a/frmSaveOrd.dfm b/frmSaveOrd.dfm new file mode 100644 index 0000000..66cb637 --- /dev/null +++ b/frmSaveOrd.dfm @@ -0,0 +1,48 @@ +object FrmSave: TFrmSave + Left = 529 + Top = 255 + Width = 342 + Height = 344 + BorderIcons = [biSystemMenu] + Caption = 'Select ORDOS file(s) to save (use ctrl+mouse)' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + Position = poScreenCenter + PixelsPerInch = 96 + TextHeight = 13 + object lbOrdFiles: TListBox + Left = 8 + Top = 10 + Width = 317 + Height = 259 + Anchors = [akLeft, akTop, akRight, akBottom] + ItemHeight = 13 + MultiSelect = True + TabOrder = 0 + end + object BtnSave: TButton + Left = 8 + Top = 282 + Width = 75 + Height = 25 + Anchors = [akLeft, akBottom] + Caption = 'Save' + ModalResult = 1 + TabOrder = 1 + end + object BtnCancel: TButton + Left = 250 + Top = 282 + Width = 75 + Height = 25 + Anchors = [akRight, akBottom] + Caption = 'Cancel' + ModalResult = 2 + TabOrder = 2 + end +end diff --git a/frmSaveOrd.pas b/frmSaveOrd.pas new file mode 100644 index 0000000..f91da70 --- /dev/null +++ b/frmSaveOrd.pas @@ -0,0 +1,43 @@ +///////////////////////////////////////////////////////////////////////// +// // +// Orion/Z (Orion-128 + Z80-CARD-II) emulator, version 1.9 // +// // +// Author: Sergey A. // +// // +// Copyright (C) 2006-2016 Sergey A. // +// // +// This program is free software; you can redistribute it and/or // +// modify it in any ways. // +// This program is distributed "AS IS" 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 frmSaveOrd; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls; + +type + TFrmSave = class(TForm) + lbOrdFiles: TListBox; + BtnSave: TButton; + BtnCancel: TButton; + private + { Private declarations } + public + { Public declarations } + end; + +var + FrmSave: TFrmSave; + +implementation + +{$R *.DFM} + +end. diff --git a/mainwin.dfm b/mainwin.dfm new file mode 100644 index 0000000..65294b5 Binary files /dev/null and b/mainwin.dfm differ diff --git a/mainwin.pas b/mainwin.pas new file mode 100644 index 0000000..19a95f4 --- /dev/null +++ b/mainwin.pas @@ -0,0 +1,2596 @@ +///////////////////////////////////////////////////////////////////////// +// // +// Orion/Z (Orion-128 + Z80-CARD-II) emulator, version 1.9 // +// // +// Author: Sergey A. // +// // +// Copyright (C) 2006-2016 Sergey A. // +// // +// This program is free software; you can redistribute it and/or // +// modify it in any ways. // +// This program is distributed "AS IS" 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 mainwin; + +interface + + +{$I 'OrionZEm.inc'} + + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + ExtCtrls, StdCtrls, ComCtrls, Menus, ToolWin, MMSystem, Math, + uIniMngr, ScrThrd, mod8019as, modWaveOut, Grids, Mask, ActnList, ImgList, StdActns; + +const + ODI_EXT='ODI'; + RKO_EXT='RKO'; + ORD_EXT='ORD'; + BRU_EXT='BRU'; + ODI_FILTER='Orion Disk Images (*.'+ODI_EXT+')|*.'+ODI_EXT+'|Any file (*.*)|*.*'; + ORD_FILTER='Orion ORDOS files (*.'+ORD_EXT+';*.'+BRU_EXT+';*.'+RKO_EXT+')|*.'+ORD_EXT+';*.'+BRU_EXT+';*.'+RKO_EXT+'|Any file (*.*)|*.*'; + TAG_STR='Orion/Z snapshot '; + AutoSnapName='AutoSnap.ori'; + RAMDISK_TOP = 61439; + +// ini sections + stSectionParams = 'PARAMS'; + stSectionHard = 'HARDWARE'; + stSectionEth = 'ETHERNET'; + stReadOnly=' [ReadOnly]'; + +type + TOFileType = (ftUnknown, ftSnapshot, ftDiskImage, ftRko, ftOrd, ftBru); + + TfrmMain = class(TForm) + StatusBar: TStatusBar; + ToolBar: TToolBar; + ToolButtonPause: TToolButton; + ToolButton2: TToolButton; + ToolButtonReset: TToolButton; + ToolButton4: TToolButton; + ToolButtonZoom: TToolButton; + ToolButton1: TToolButton; + ToolButtonFloppyA: TToolButton; + ToolButton5: TToolButton; + ToolButtonFloppyB: TToolButton; + ActionList1: TActionList; + ImageList1: TImageList; + ActPause: TAction; + ActReset: TAction; + ActZoom: TAction; + ActFloppyA: TAction; + ActFloppyB: TAction; + OdiPopupMenu: TPopupMenu; + ItemBrowse: TMenuItem; + N1: TMenuItem; + ItemRecent: TMenuItem; + ToolButton7: TToolButton; + ToolButtonSettings: TToolButton; + ActSettings: TAction; + OpenDialog: TOpenDialog; + SaveDialog: TSaveDialog; + ItemClear: TMenuItem; + ToolButton3: TToolButton; + ToolButton6: TToolButton; + ActHelp: TAction; + ToolButton8: TToolButton; + ToolButtonSnapshot: TToolButton; + SnapPopupMenu: TPopupMenu; + Saveshapshot128k1: TMenuItem; + Saveshapshot256k1: TMenuItem; + Saveshapshot512k1: TMenuItem; + N2: TMenuItem; + Loadsnapshot1: TMenuItem; + ItemInfo: TMenuItem; + N3: TMenuItem; + AutoSnapshot1: TMenuItem; + ActScr: TAction; + ToolButtonOpen: TToolButton; + ToolButton10: TToolButton; + pnScr: TPanel; + pbDraw: TPaintBox; + pnDbg: TPanel; + Bevel1: TBevel; + ToolButtonScr: TToolButton; + ToolButtonDbg: TToolButton; + ToolButton13: TToolButton; + ToolButton14: TToolButton; + ActDbg: TAction; + ZoomPopupMenu: TPopupMenu; + x1menuitem: TMenuItem; + x2menuitem: TMenuItem; + x25menuitem: TMenuItem; + x3menuitem: TMenuItem; + ActOpenSave: TAction; + OpenPopupMenu: TPopupMenu; + ItemLoad: TMenuItem; + N4: TMenuItem; + ItemSave: TMenuItem; + N5: TMenuItem; + Savescreenpicture1: TMenuItem; + DebuggerMenu: TPopupMenu; + ItemModify: TMenuItem; + N6: TMenuItem; + ItemSetCondition: TMenuItem; + ItemClearCondition: TMenuItem; + ActDbgStepInto: TAction; + ActDbgStepOver: TAction; + N7: TMenuItem; + ItemPause: TMenuItem; + Panel1: TPanel; + MemDump: TMemo; + Panel2: TPanel; + Panel3: TPanel; + Label3: TLabel; + Label4: TLabel; + SGRegMain: TStringGrid; + SGRegAlter: TStringGrid; + SGHistory: TStringGrid; + cbBreakPoint: TCheckBox; + cbConditions: TCheckBox; + meBreakPoint: TMaskEdit; + BtnStepInto: TButton; + BtnStepOver: TButton; + SGFlags: TStringGrid; + SGPortDump: TStringGrid; + sgPort1Dump: TStringGrid; + sgPort2Dump: TStringGrid; + Panel4: TPanel; + MEDumpAddr: TMaskEdit; + BtnModyByte: TButton; + BtnSaveMem: TButton; + MESaveCnt: TMaskEdit; + Label2: TLabel; + btnPageAddress: TButton; + Label1: TLabel; + Bevel2: TBevel; + Label5: TLabel; + PageAddressMenu: TPopupMenu; + F9HL1: TMenuItem; + F9HL2: TMenuItem; + F9BC1: TMenuItem; + F9IX1: TMenuItem; + F9IY1: TMenuItem; + F9SP1: TMenuItem; + F9PC1: TMenuItem; + F9Ix2: TMenuItem; + procedure FormDestroy(Sender: TObject); + procedure FormResize(Sender: TObject); + procedure pbDrawPaint(Sender: TObject); + procedure FormActivate(Sender: TObject); + procedure FormClose(Sender: TObject; var Action: TCloseAction); + procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean); + procedure MEDumpAddrChange(Sender: TObject); + procedure BtnModyByteClick(Sender: TObject); + procedure ActPauseExecute(Sender: TObject); + procedure ActResetExecute(Sender: TObject); + procedure ActZoomExecute(Sender: TObject); + procedure ItemBrowseClick(Sender: TObject); + procedure ToolButtonFloppyAClick(Sender: TObject); + procedure ToolButtonFloppyBClick(Sender: TObject); + procedure BtnSaveMemClick(Sender: TObject); + procedure ItemClearClick(Sender: TObject); + procedure cbBreakPointClick(Sender: TObject); + procedure ItemRecentClick(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure ActSettingsExecute(Sender: TObject); + procedure ActHelpExecute(Sender: TObject); + procedure Saveshapshot128k1Click(Sender: TObject); + procedure Saveshapshot256k1Click(Sender: TObject); + procedure Saveshapshot512k1Click(Sender: TObject); + procedure Loadsnapshot1Click(Sender: TObject); + procedure ToolButtonSnapshotClick(Sender: TObject); + procedure AutoSnapshot1Click(Sender: TObject); + procedure ActScrExecute(Sender: TObject); + procedure ActDbgExecute(Sender: TObject); + procedure x1menuitemClick(Sender: TObject); + procedure ActOpenSaveExecute(Sender: TObject); + procedure ItemLoadClick(Sender: TObject); + procedure ItemSaveClick(Sender: TObject); + procedure Savescreenpicture1Click(Sender: TObject); + procedure DebuggerMenuPopup(Sender: TObject); + procedure ActDbgStepIntoExecute(Sender: TObject); + procedure ActDbgStepOverExecute(Sender: TObject); + procedure ItemModifyClick(Sender: TObject); + procedure ItemClearConditionClick(Sender: TObject); + procedure ItemSetConditionClick(Sender: TObject); + procedure cbConditionsClick(Sender: TObject); + procedure F9Click(Sender: TObject); + procedure btnPageAddressClick(Sender: TObject); + private + { Private declarations } + DisSL: TStringList; + FMainIniFile: TAsofIniFile; + IniManager: TIniManager; + ScrBitmap: TBitmap; + SX, SY: Integer; + ScrThread: TScrThread; + FDriveindex: integer; + FLcdRusLat: integer; + function ProcessCmdLine: boolean; + function disasm(PC:integer; var OP: string):integer; + function CheckFileExists(FlName:string):string; + function DetectFileType(FName: string; var Fsz: integer):TOFileType; + procedure SetFloppyHint(FDIndex: integer; isReadOnly: boolean); + procedure CreateBitmap(aSX, aSY: Integer); + procedure DeleteBitmap; + procedure RecreateBitmap(aSX, aSY: Integer); + procedure StartScrThread; + procedure StopScrThread; + procedure InitRAMArr; + procedure InitEmulator; + procedure InitSGRegPort; + procedure InitDezSL; + procedure AppKeyDown(var msg : TMsg; var Handled: Boolean); + procedure MyIdleHandler(Sender: TObject; var Done: Boolean); + procedure SaveSnapshot(Pages: integer; FName: string); + procedure LoadSnapshot(FName: string); + procedure ShowRusLat; + procedure SetFormSize; + procedure SetZoomChecks; + public + procedure CPUSuspend; + procedure CPUResume; + procedure InitEthernet; + procedure ShowMemDump(PauseCPU: boolean); + procedure ShowSGReg; + procedure ShowSGPort; + procedure BindIniParameters; + procedure BlankOrionScreen; + procedure DrawOrionScreen; + procedure SetROMBIOS(FName: string); // load ROMF800.BIN into array + procedure SetROMDISK(FName: string); // load ROMFDISK.BIN into array + procedure SetROM1BIOS(FName: string); // load ROM1BIOS.BIN into array + procedure SetROM2BIOS(FName: string); // load ROM2BIOS.BIN into array + end; + + TBig = array[0..0] of Integer; + + BytePtr = ^byte; + WordPtr = ^word; + DWordPtr = ^longword; + +var + frmMain: TfrmMain; + Scr: Pointer; + + FMaxRecent, ScrTop, ScrLeft: integer; + FRestoreODI: boolean; + FODI_DriveA, FODI_DriveB: string; + FAutoSnapshot: boolean; + GUIDList: TStringList; + FNE2kDevice: TNE2kDevice; + +procedure Scr480(outbyte: byte); +procedure chrtrn(var buf: string; from_tbl, to_tbl: string); +function padl(stt:string;max:integer;ch:string):string; +Function LeftSubstr(var s:String): String; +function AddSlash(str: string): string; +function GetHexMasked4(ch: char; var Mask: byte): byte; +function GetHexMasked16(st: string; var Mask: integer): integer; + +implementation + +{$R *.DFM} + +Uses modOrion, modZ80, mod1793, mod8255, mod146818, modAY8912, modHdd, modSD, mod232, EthThrd, uCRC32, settswin, + frmAbout, frmSaveOrd, frNewVal; + +Var + OriHeader: TOriHeader; + +function AddSlash(str: string): string; +begin + Result:=str; + if (Length(Result)>0) and (Result[Length(Result)]<>'\') + then Result:=Result+'\'; +end; + +function LeftSubstrList(var s:String; DelimList: string): String; +var ch:char; + j:integer; +begin + Result:=''; + if Length(s)<1 then exit; + j:=0; + if (s[1]=' ')then s:=TrimLeft(s); + if (s[1]='"')or(s[1]='''') then + begin + inc(j); + ch:=s[1]; + while (jch) do inc(j); + if (Length(s)>1)and(j>1) then Result:=copy(s, 2, j-1); + if (j#9) do inc(j); + Result:=copy(s, 1, j); + end; + while (j0)or(s[j+1]=#9)) do inc(j); + delete(s,1,j); +end; + +Function LeftSubstr(var s:String): String; +begin + Result:=LeftSubstrList(s, ' ,'); +end; + +procedure CloseWaveOut(); +var + lRet: LongInt; +begin + {lRet :=} waveOutReset(glphWaveOut); + For lRet := 1 To NUM_WAV_BUFFERS do + waveOutUnprepareHeader(glphWaveOut, @gtWavHdr[lRet], sizeof(gtWavHdr[lRet])); + + For lRet := 1 To NUM_WAV_BUFFERS do + begin + GlobalUnlock(ghMem[lRet]); + GlobalFree(ghMem[lRet]); + end; + + waveOutClose(glphWaveOut); + glphWaveOut:=-1; + SoundEnabled := False; +End; + +Function InitializeWaveOut : Boolean; +{$IFDEF USE_SOUND} + var lRet : integer; sErrMsg : String; lCounter : integer; lCounter2 : integer; +{$ENDIF} +begin + If not SoundEnabled Then + begin + InitializeWaveOut := False; + Exit; + End; +{$IFDEF USE_SOUND} +// If glphWaveOut<>-1 Then +// CloseWaveOut(); + glBeeperVal := 128; + With gtWavFormat do + begin + wFormatTag := WAVE_FORMAT_PCM; + nChannels := 1; + nSamplesPerSec := WAVE_FREQUENCY; + nAvgBytesPerSec := WAVE_FREQUENCY; + nBlockAlign := 1; + wBitsPerSample := 8; + cbSize := 0; + End; + + lRet := waveOutOpen(@glphWaveOut, WAVE_MAPPER, @gtWavFormat, 0, 0, CALLBACK_NULL); + If lRet <> MMSYSERR_NOERROR Then + begin + SetLength(sErrMsg, 256); + waveOutGetErrorText(lRet, PChar(sErrMsg), 255); + Application.MessageBox( + PChar('Error initialising WaveOut device.' + #13#10#13#10 + sErrMsg), + PChar(Application.Title), + MB_OK or MB_ICONEXCLAMATION); + InitializeWaveOut := False; + Exit; + End; + + For lCounter := 1 To NUM_WAV_BUFFERS do + begin + ghMem[lCounter] := GlobalAlloc(GPTR, WAV_BUFFER_SIZE+100); + gpMem[lCounter] := GlobalLock(ghMem[lCounter]); + gtWavHdr[lCounter].lpData := gpMem[lCounter]; + gtWavHdr[lCounter].dwBufferLength := WAV_BUFFER_SIZE; + gtWavHdr[lCounter].dwUser := 0; + gtWavHdr[lCounter].dwFlags := 0; + gtWavHdr[lCounter].dwLoops := 0; + gtWavHdr[lCounter].lpNext := nil; + + lRet := waveOutPrepareHeader(glphWaveOut, + @gtWavHdr[lCounter], + sizeof(gtWavHdr[lCounter])); // WAVEHDR + + If lRet <> MMSYSERR_NOERROR Then + begin + SetLength(sErrMsg, 256); + waveOutGetErrorText(lRet, PChar(sErrMsg), 255); + Application.MessageBox( + PChar('Error preparing wave header.' + #13#10#13#10 + sErrMsg), + PChar(Application.Title), + MB_OK or MB_ICONEXCLAMATION); + waveOutClose(glphWaveOut); + For lCounter2 := 1 To NUM_WAV_BUFFERS do + begin + GlobalUnlock(ghMem[lCounter2]); + GlobalFree(ghMem[lCounter2]); + end; + InitializeWaveOut := False; + Exit; + End; + end; + For lCounter := 0 To 48000 do + gcWaveOut[lCounter] := glBeeperVal; +{$ENDIF} + InitializeWaveOut := True; +End; + +procedure TfrmMain.CreateBitmap(aSX, aSY: Integer); +var + BInfo: tagBITMAPINFO; +begin + // Создание DIB + SX := aSX; SY := aSY; + BInfo.bmiHeader.biSize := sizeof(tagBITMAPINFOHEADER); + BInfo.bmiHeader.biWidth := SX; + BInfo.bmiHeader.biHeight := -SY; + BInfo.bmiHeader.biPlanes := 1; + BInfo.bmiHeader.biBitCount := 32; + BInfo.bmiHeader.biCompression := BI_RGB; + ScrBitmap := TBitmap.Create(); + ScrBitmap.Handle := CreateDIBSection(Canvas.Handle, BInfo, DIB_RGB_COLORS, Scr, 0, 0); + ZeroMemory(Scr, SX * SY * 4); +end; + +procedure TfrmMain.DeleteBitmap; +begin + // Удаление DIB + ScrBitmap.FreeImage(); + ScrBitmap.Destroy; +end; + +procedure TfrmMain.RecreateBitmap(aSX, aSY: Integer); +var + BInfo: tagBITMAPINFO; +begin + // Пересоздание DIB при изменении размеров "экрана" + ScrBitmap.FreeImage(); + SX := aSX; SY := aSY; + BInfo.bmiHeader.biSize := sizeof(tagBITMAPINFOHEADER); + BInfo.bmiHeader.biWidth := SX; + BInfo.bmiHeader.biHeight := -SY; + BInfo.bmiHeader.biPlanes := 1; + BInfo.bmiHeader.biBitCount := 32; + BInfo.bmiHeader.biCompression := BI_RGB; + ScrBitmap.Handle := CreateDIBSection(Canvas.Handle, BInfo, DIB_RGB_COLORS, Scr, 0, 0); + ZeroMemory(Scr, SX * SY * 4); +end; + +procedure TfrmMain.FormDestroy(Sender: TObject); +begin + DeleteBitmap(); +end; + +procedure TfrmMain.StartScrThread; +begin + if Assigned(ScrThread) then StopScrThread; + ScrThread:=TScrThread.Create(ScrWidthArr[ScrWidth, 0], ScrHeightArr[0], + ScrWidthArr[ScrWidth, ScrZoom], ScrZoom); { create suspended } + ScrThread.Priority := tpLower; // tpNormal; { set the priority to normal } + ScrThread.Resume; { now run the thread } +end; + +procedure TfrmMain.StopScrThread; +begin + if not Assigned(ScrThread) then exit; + if ScrThread.Suspended then ScrThread.Resume; + ScrThread.Terminate; + ScrThread.WaitFor; + ScrThread.Free; + ScrThread:=nil; +end; + +procedure TfrmMain.DrawOrionScreen; +begin + pbDrawPaint(Self); // full Orion screen redraw +end; + +procedure TfrmMain.BlankOrionScreen; +begin + ReCreateBitmap(pbDraw.ClientWidth, pbDraw.ClientHeight); +end; + +procedure TfrmMain.FormResize(Sender: TObject); +begin + ReCreateBitmap(pbDraw.ClientWidth, pbDraw.ClientHeight); + pbDraw.Canvas.Draw(0, 0, ScrBitmap); +end; + +procedure TfrmMain.pbDrawPaint(Sender: TObject); +begin + pbDraw.Canvas.Draw(0, 0, ScrBitmap); +end; + +procedure initParity; + var lCounter : integer; j : Byte; p : Boolean; + var powval: integer; +begin + For lCounter := 0 To 255 do + begin + p := True; + For j := 0 To 7 do + begin + PowVal := Trunc(IntPower(2, j)); + If (lCounter And powVal) <> 0 Then p := Not p; + end; + Parity[lCounter] := p; + end; +End; + +procedure TfrmMain.InitEmulator; +var st:string; +begin +// FillChar(MainPort, sizeof(MainPort), 0); + MEDumpAddr.EditMask:=SetMemSize; + OutB($0A, p0A_ROM1_MASK + // ROM window 0000..1FFF + p0A_FIX_F000); // if p0A_FIX_F000 (D6) = 1 then RAM F000..FFFF = 1F segment 4k part always (with any pF9 combinations) + OutB($F8, 0); + OutB($F9, 0); + OutB($08, 0); + OutB($FA, 0); + OutB($FB, pFB_disp_off + // диспетчер 16к выключен (D7=1) + pFB_int50_off + // прерывания выключены (D6=0) + pFB_TopRam_off); // F400..FFFF - порты+ПЗУ (D5=0) + OutB($FC, 0); + OutB($FE, 0); + try + MainPort[$FF]:=0; + PortF400.Reset; + PortF500.Reset; + PortF600.Reset; + FDController.Reset; + F146818.Reset; + FUART.PortName:=ComPortName; + FUART.Exists:=ComPortExists; + FUART.Reset; + if Assigned(FNE2kDevice) then FNE2kDevice.Reset; +{$IFDEF USE_SOUND} + AY8912_init(1773000, WAVE_FREQUENCY, 8); +{$ENDIF} + glInterruptDelay := 20; // from ini ? + initParity; + Z80Reset; + IdeProController.Reset; + SDController.Reset; + finally + timeBeginPeriod(1); + glInterruptTimer := timeGetTime() + 20; +{$IFDEF USE_SOUND} + if SoundEnabled then + SoundEnabled:=SoundEnabled and InitializeWaveOut(); +{$ENDIF} + if Z80CardMode>=Z80_ORIONPRO_v2 then + regPC:=ORIONPRO_ROM1BIOS_ADDR + else + regPC:=ORION_ROMBIOS_ADDR; + st:=MEDumpAddr.EditMask; + chrtrn(st, '9A', '00'); + MEDumpAddr.Text:=st; + end; +end; + +procedure TfrmMain.SetROMBIOS(FName: string); +var FStream: TFileStream; +begin + if trim(FName)='' then exit; + FStream:=TFileStream.Create(FName, fmOpenRead or fmShareDenyWrite); + ROMBIOSlen:=MIN(FStream.Size, $800); + FStream.ReadBuffer(ROMF800[$F800], ROMBIOSlen); + FStream.Free; +end; + +procedure TfrmMain.SetROM1BIOS(FName: string); +var FStream: TFileStream; +begin + FillChar(ROM1BIOS, SizeOf(ROM1BIOS), $FF); + if trim(FName)='' then exit; + FStream:=TFileStream.Create(FName, fmOpenRead or fmShareDenyWrite); + ROM1BIOSlen:=MIN(FStream.Size, $10000); + FStream.ReadBuffer(ROM1BIOS[0], ROM1BIOSlen); + FStream.Free; +end; + +procedure TfrmMain.SetROM2BIOS(FName: string); +var FStream: TFileStream; +begin + FillChar(ROM2BIOS, SizeOf(ROM2BIOS), $FF); + if trim(FName)='' then exit; + FStream:=TFileStream.Create(FName, fmOpenRead or fmShareDenyWrite); + ROM2BIOSlen:=MIN(FStream.Size, $200000); + FStream.ReadBuffer(ROM2BIOS[0], ROM2BIOSlen); + FStream.Free; +end; + +procedure TfrmMain.SetROMDISK(FName: string); +var FStream: TFileStream; +begin + if trim(FName)='' then exit; + FStream:=TFileStream.Create(FName, fmOpenRead or fmShareDenyWrite); + ROMDISKlen:=FStream.Size; + SetLength(ROMDISK, ROMDISKlen+1); + FStream.ReadBuffer(ROMDISK[0], ROMDISKlen); + FStream.Free; +end; + +procedure TfrmMain.BindIniParameters; +begin + Screen.Cursor:=crHourGlass; + with IniManager do + try +{ begin Orion-PRO specific } + BindVariable(btString, @ROM1BIOSfile, stSectionHard, 'PRO_ROM1', 'ROM1.BIN'); + BindVariable(btString, @ROM2BIOSfile, stSectionHard, 'PRO_ROM2', 'ROM2.BIN'); + BindVariable(btInteger, @OrionPRO_DIP_SW, stSectionHard, 'PRO_DIPSW', '161'); +{ end Orion-PRO specific } + BindVariable(btString, @ROMBIOSfile, stSectionHard, 'ROMF800', 'ROMF800.BIN'); + BindVariable(btString, @ROMDISKfile, stSectionHard, 'ROMDISK', 'ROMDISK.BIN'); + BindVariable(btBoolean, @PFEEnabled, stSectionHard, 'PortFErom', '0'); + BindVariable(btString, @MC146818RAM, stSectionHard, 'MC146818RAM', '525443'); + BindVariable(btDouble, @DeltaTime, stSectionHard, 'MC146818DT', '0'); + BindVariable(btDouble, @DeltaDate, stSectionHard, 'MC146818DD', '0'); + BindVariable(btBoolean, @SoundEnabled, stSectionHard, 'SOUNDENABLED', '1'); + BindVariable(btBoolean, @AYEnabled, stSectionHard, 'AYENABLED', '1'); + BindVariable(btBoolean, @RTCmode, stSectionHard, 'RTCMODE', '0'); + BindVariable(btInteger, @CPUSpeedMode, stSectionHard, 'CPUSPEEDMODE', '1'); + BindVariable(btInteger, @MEMSizeMode, stSectionHard, 'MEMSIZEMODE', '2'); + BindVariable(btInteger, @Z80CardMode, stSectionHard, 'Z80CARDMODE', '1'); + BindVariable(btInteger, @KeyRusLat, stSectionHard, 'KEYRUSLAT', '119'); + BindVariable(btInteger, @KeybType, stSectionHard, 'KEYBTYPE', '0'); // RK + BindVariable(btBoolean, @KeyExtender, stSectionHard, 'KEYEXTEND', '0'); + BindVariable(btInteger, @KeyDelay, stSectionParams, 'KEYDELAY', '1'); + BindVariable(btInteger, @HDDPort, stSectionHard, 'HDDPort', '0'); // HDDPortNone + BindVariable(btBoolean, @SDRO, stSectionHard, 'SDcardRO', '1'); + BindVariable(btString, @SDImage, stSectionHard, 'SDcard', ''); + BindVariable(btInteger, @SDScheme, stSectionHard, 'SDScheme', '1'); + BindVariable(btString, @HDDImage[HddDeviceMaster],stSectionHard, 'HDDMaster', ''); + BindVariable(btString, @HDDImage[HddDeviceSlave], stSectionHard, 'HDDSlave', ''); + BindVariable(btString, @ProImage[HddDeviceMaster],stSectionHard, 'ProMaster', ''); + BindVariable(btString, @ProImage[HddDeviceSlave], stSectionHard, 'ProSlave', ''); + BindVariable(btBoolean, @HDDRO[HddDeviceMaster], stSectionHard, 'HDDMasterRO', '1'); + BindVariable(btBoolean, @HDDRO[HddDeviceSlave], stSectionHard, 'HDDSlaveRO', '1'); + BindVariable(btBoolean, @ProRO[HddDeviceMaster], stSectionHard, 'ProMasterRO', '1'); + BindVariable(btBoolean, @ProRO[HddDeviceSlave], stSectionHard, 'ProSlaveRO', '1'); + BindVariable(btBoolean, @FddHd, stSectionHard, 'FDD_HD', '1'); + BindVariable(btInteger, @FMaxRecent, stSectionParams, 'MAXRECENT', '8'); + BindVariable(btBoolean, @FRestoreODI, stSectionParams, 'RESTOREODI', '1'); + BindVariable(btBoolean, @FAutoSnapshot, stSectionParams, 'AUTOSNAPSHOT', '0'); + BindVariable(btString, @FODI_DriveA, stSectionParams, 'ODI_DRIVEA', ''); + BindVariable(btString, @FODI_DriveB, stSectionParams, 'ODI_DRIVEB', ''); + BindVariable(btString, @F600Plugin, stSectionParams, 'F600Plugin', ''); + BindVariable(btInteger, @F600Index, stSectionParams, 'F600Function', '-1'); + BindVariable(btString, @ComPortName, stSectionHard, 'ComPortName', 'CNCB0'); + BindVariable(btBoolean, @ComPortExists, stSectionHard, 'ComPortExists', '0'); + BindVariable(btInteger, @ScrZoom, stSectionParams, 'ScrZoom', '1'); + BindVariable(btInteger, @ScrTop, stSectionParams, 'ScrTop', '1'); + BindVariable(btInteger, @ScrLeft, stSectionParams, 'ScrLeft', '1'); +{Eth} + BindVariable(btInteger, @EthMAC0, stSectionEth, 'MAC0', '255'); + BindVariable(btInteger, @EthMAC1, stSectionEth, 'MAC1', '0'); + BindVariable(btInteger, @EthMAC2, stSectionEth, 'MAC2', '0'); + BindVariable(btInteger, @EthMAC3, stSectionEth, 'MAC3', '0'); + BindVariable(btInteger, @EthMAC4, stSectionEth, 'MAC4', '0'); + BindVariable(btInteger, @EthMAC5, stSectionEth, 'MAC5', '0'); + BindVariable(btString, @EthConnName, stSectionEth, 'EthConnName', ''); + BindVariable(btString, @EthConnGUID, stSectionEth, 'EthConnGUID', ''); + BindVariable(btInteger, @EthMode, stSectionEth, 'EthMode', '0'); +{} + finally + Screen.Cursor:=crDefault; + end; +end; + +procedure OnIdeAccess(Sender: TObject; Drive: byte; Op: char); +var ss: string; +begin + ss:='HDD: '+chr(ord('0')+Drive)+' '+Op; + with frmMain.StatusBar do + begin + Panels[1].Text:=ss; + if Panels[1].Bevel=pbRaised then Panels[1].Bevel:=pbLowered; + Update; + end; + Application.ProcessMessages; +end; + +procedure TfrmMain.FormActivate(Sender: TObject); +begin + OnActivate:=nil; + Application.OnMessage := AppKeyDown; + CreateBitmap(pbDraw.ClientWidth, pbDraw.ClientHeight); + pbDraw.Canvas.Draw(0, 0, ScrBitmap); + Application.Title := Caption; + try + FMainIniFile:=TAsofIniFile.Create(CheckFileExists(ChangeFileExt(System.ParamStr(0),'.INI'))); + IniManager:=TIniManager.Create; + IniManager.IniFileObj:=FMainIniFile; + BindIniParameters; + IniManager.GetAllValues; + IniManager.GetAllProps; +{Eth} + EthMAC[0]:=chr(lo(EthMAC0)); + EthMAC[1]:=chr(lo(EthMAC1)); + EthMAC[2]:=chr(lo(EthMAC2)); + EthMAC[3]:=chr(lo(EthMAC3)); + EthMAC[4]:=chr(lo(EthMAC4)); + EthMAC[5]:=chr(lo(EthMAC5)); +{} + InitEthernet(); +{} + InitEmulator(); + IniManager.RecentFilesMenuItem:=ItemRecent; + IniManager.OnRecentFilesItemClick:=ItemRecentClick; + IniManager.RecentFilesDropDownMax:=FMaxRecent; + IniManager.GetRecentFilesSection; + if ExtractFilePath(ROMBIOSfile)='' then + ROMBIOSfile:=ExtractFilePath(FMainIniFile.Filename)+ROMBIOSfile; + if not FileExists(ROMBIOSfile) then + begin + Application.MessageBox(PChar(ROMBIOSfile), 'File not found', MB_ICONERROR+MB_OK); + Application.Terminate; + exit; + end; + SetROMBIOS(ROMBIOSfile); + SetROM1BIOS(ROM1BIOSfile); + SetROM2BIOS(ROM2BIOSfile); + if ExtractFilePath(ROMDISKfile)='' then + ROMDISKfile:=ExtractFilePath(FMainIniFile.Filename)+ROMDISKfile; + if not FileExists(ROMDISKfile) then + ROMDISKlen:=0 + else + SetROMDISK(ROMDISKfile); + try + F146818.MCRAM:=MC146818RAM; + SDController.Scheme:=SDScheme; + SDController.ImageRO:=SDRO; + SDController.ImageFile:=SDImage; + SDController.OnAccess:=OnIdeAccess; + IdeController.ImageRO[0]:=HDDRO[0]; + IdeController.ImageRO[1]:=HDDRO[1]; + IdeController.ImageFile[0]:=HDDImage[0]; + IdeController.ImageFile[1]:=HDDImage[1]; + IdeController.OnAccess:=OnIdeAccess; + IdeController.Reset; + IdeProController.ImageRO[0]:=ProRO[0]; + IdeProController.ImageRO[1]:=ProRO[1]; + IdeProController.ImageFile[0]:=ProImage[0]; + IdeProController.ImageFile[1]:=ProImage[1]; + IdeProController.OnAccess:=OnIdeAccess; + IdeProController.Reset; + except + on E:Exception do + Application.MessageBox(PChar(E.Message), 'Error', MB_OK+MB_ICONSTOP); + end; + PortF400.KbdType:=TKbdType(KeybType); + PortF600.Plugin:=F600Plugin; + PortF600.FuncIdx:=F600Index; + InitSGRegPort; + Top:=ScrTop; Left:=ScrLeft; + SetZoomChecks; + ShowSGReg; + ShowSGPort; + SetFormSize; //StartScrThread; + ShowMemDump(True); + ShowRusLat; + AutoSnapshot1.Checked:=FAutoSnapshot; + if not ProcessCmdLine() then // allways last init operation (because LoadSnapshot) + if FRestoreODI then + begin + if trim(FODI_DriveA)<>'' then + begin + FDController.Drive[0]:=trim(FODI_DriveA); + ToolButtonFloppyA.Hint:=FODI_DriveA; + end; + if trim(FODI_DriveB)<>'' then + begin + FDController.Drive[1]:=trim(FODI_DriveB); + ToolButtonFloppyB.Hint:=FODI_DriveB; + end; + end; + CPUPaused:=GetKeyState(VK_CONTROL)<0; // initial started PAUSED if CTRL key pressed + if CPUPaused then CPUSuspend; + except + raise // To do + end; +end; + +procedure TfrmMain.FormClose(Sender: TObject; var Action: TCloseAction); +var pch: PChar; +begin + if FAutoSnapshot then + SaveSnapshot(8, ExtractFilePath(FMainIniFile.Filename)+AutoSnapName); + CpuPaused:=True; + CPUSuspend; + StopScrThread; + MC146818RAM:=F146818.MCRAM; + if FRestoreODI then + begin + FODI_DriveA:=FDController.Drive[0]; + FODI_DriveB:=FDController.Drive[1]; + end; + ComPortExists:=FUART.Exists; + ComPortName:=FUART.PortName; + F600Plugin:=PortF600.Plugin; + F600Index:=PortF600.FuncIdx; + PortF600.Plugin:=''; + SDRO :=SDController.ImageRO; + SDImage :=SDController.ImageFile; + HDDRO[0] :=IdeController.ImageRO[0]; + HDDRO[1] :=IdeController.ImageRO[1]; + HDDImage[0]:=IdeController.ImageFile[0]; + HDDImage[1]:=IdeController.ImageFile[1]; + ProRO[0] :=IdeProController.ImageRO[0]; + ProRO[1] :=IdeProController.ImageRO[1]; + ProImage[0]:=IdeProController.ImageFile[0]; + ProImage[1]:=IdeProController.ImageFile[1]; +{Eth} + pch:=@EthMAC[0]; + if Assigned(FNE2kDevice) then + begin + if Assigned(FNE2kDevice.EthThread) then + pch:=FNE2kDevice.EthThread.MACAddr; + end; + EthMAC0:=ord(pch[0]); + EthMAC1:=ord(pch[1]); + EthMAC2:=ord(pch[2]); + EthMAC3:=ord(pch[3]); + EthMAC4:=ord(pch[4]); + EthMAC5:=ord(pch[5]); +{} + if ToolButtonFloppyA.Tag=1 then IniManager.RecentFilesAdd(ToolButtonFloppyA.Hint); + if ToolButtonFloppyB.Tag=1 then IniManager.RecentFilesAdd(ToolButtonFloppyB.Hint); + ScrTop:=Top; ScrLeft:=Left; + IniManager.WriteRecentFilesSection; + IniManager.WriteAll; // Variables and Properties + IniManager.IniFileObj:=nil; + IniManager.Free; + FMainIniFile.Free; + DestroyEthThread; + DisSL.Free; + If glphWaveOut<>-1 Then CloseWaveOut(); +end; + +procedure TfrmMain.InitSGRegPort; +begin + with SGFlags do + begin + Cells[0, 0] := 'S'; + Cells[0, 1] := 'Z'; + Cells[0, 2] := 'H'; + Cells[0, 3] := 'PV'; + Cells[0, 4] := 'N'; + Cells[0, 5] := 'C'; + end; + With SGRegMain do + begin + Cells[0, 0] := 'AF'+ConditionAF; + Cells[0, 1] := 'BC'+ConditionBC; + Cells[0, 2] := 'DE'+ConditionDE; + Cells[0, 3] := 'HL'+ConditionHL; + Cells[0, 4] := 'SP'+ConditionSP; + Cells[0, 5] := 'PC'; + end; + With SGRegAlter do + begin + Cells[0, 0] := 'AF'''+ConditionAF_; + Cells[0, 1] := 'BC'''+ConditionBC_; + Cells[0, 2] := 'DE'''+ConditionDE_; + Cells[0, 3] := 'HL'''+ConditionHL_; + Cells[0, 4] := 'IX'+ConditionIX; + Cells[0, 5] := 'IY'+ConditionIY; + Cells[0, 6] := 'IR'+ConditionIR; + end; + With SGPortDump do + begin + Cells[0, 0] := 'F8'; + Cells[0, 1] := 'F9'; + Cells[0, 2] := 'FA'; + Cells[0, 3] := 'FB'; + Cells[0, 4] := 'FC'; + Cells[0, 5] := 'FE'; + Cells[0, 6] := 'FF'; + end; + With SGPort1Dump do + begin + Cells[0, 0] := '00'; + Cells[0, 1] := '01'; + Cells[0, 2] := '02'; + Cells[0, 3] := '03'; + Cells[0, 4] := '04'; + Cells[0, 5] := '05'; + Cells[0, 6] := '06'; + end; + With SGPort2Dump do + begin + Cells[0, 0] := '07'; + Cells[0, 1] := '08'; + Cells[0, 2] := '09'; + Cells[0, 3] := '0A'; + Cells[0, 4] := '0B'; + Cells[0, 5] := '0C'; + Cells[0, 6] := '0D'; + end; +end; + +procedure TfrmMain.ShowSGReg; +var disPC, deltaPC: integer; + DisStr: string; + function HexStr(PC, delta: integer):string; + begin + Result:=''; + while delta>0 do + begin + Result:=Result+IntToHex(peekb(PC), 2); + inc(PC); + dec(delta); + end; + end; +begin + with SGFlags do + begin + if fS then Cells[1, 0]:='1' else Cells[1, 0]:=' '; + if fZ then Cells[1, 1]:='1' else Cells[1, 1]:=' '; + if fH then Cells[1, 2]:='1' else Cells[1, 2]:=' '; + if fPV then Cells[1, 3]:='1' else Cells[1, 3]:=' '; + if fN then Cells[1, 4]:='1' else Cells[1, 4]:=' '; + if fC then Cells[1, 5]:='1' else Cells[1, 5]:=' '; + end; + With SGRegMain do + begin + Cells[1, 0] := IntToHex(getAF, 4); + Cells[1, 1] := IntToHex(getBC, 4); + Cells[1, 2] := IntToHex(regDE, 4); + Cells[1, 3] := IntToHex(regHL, 4); + Cells[1, 4] := IntToHex(regSP, 4); + Cells[1, 5] := IntToHex(regPC, 4); + end; + With SGRegAlter do + begin + Cells[1, 0] := IntToHex(regAF_, 4); + Cells[1, 1] := IntToHex(regBC_, 4); + Cells[1, 2] := IntToHex(regDE_, 4); + Cells[1, 3] := IntToHex(regHL_, 4); + Cells[1, 4] := IntToHex(regIX, 4); + Cells[1, 5] := IntToHex(regIY, 4); + Cells[1, 6] := IntToHex(word(intI) shl 8 + intR, 4); + end; + With SGHistory do + begin + Cells[0, 0]:=Cells[0, 1]; + Cells[1, 0]:=Cells[1, 1]; + disPC:=RegPC; + + deltaPC:=Disasm(disPC, DisStr)-disPC; + Cells[0, 1]:=IntToHex(disPC, 4)+' '+HexStr(disPC, deltaPC); + Cells[1, 1]:=DisStr; + disPC:=disPC+deltaPC; + + deltaPC:=Disasm(disPC, DisStr)-disPC; + Cells[0, 2]:=IntToHex(disPC, 4)+' '+HexStr(disPC, deltaPC);; + Cells[1, 2]:=DisStr; + disPC:=disPC+deltaPC; + + deltaPC:=Disasm(disPC, DisStr)-disPC; + Cells[0, 3]:=IntToHex(disPC, 4)+' '+HexStr(disPC, deltaPC); + Cells[1, 3]:=DisStr; + Row:=1; + end; + if CpuPaused then + begin + ToolButtonPause.Down:=True; + Update; + Application.ProcessMessages; + end; +end; + +procedure TfrmMain.ShowSGPort; +begin + With SGPortDump do + begin + Cells[1, 0] := IntToHex(MainPort[$F8], 2); + Cells[1, 1] := IntToHex(MainPort[$F9], 2); + Cells[1, 2] := IntToHex(MainPort[$FA], 2); + Cells[1, 3] := IntToHex(MainPort[$FB], 2); + Cells[1, 4] := IntToHex(MainPort[$FC], 2); + Cells[1, 5] := IntToHex(MainPort[$FE], 2); + Cells[1, 6] := IntToHex(MainPort[$FF], 2); + end; + With SGPort1Dump do + begin + Cells[1, 0] := IntToHex(inb($00), 2); + Cells[1, 1] := IntToHex(MainPort[$01], 2); + Cells[1, 2] := IntToHex(MainPort[$02], 2); + Cells[1, 3] := IntToHex(MainPort[$03], 2); + Cells[1, 4] := IntToHex(MainPort[$04], 2); + Cells[1, 5] := IntToHex(MainPort[$05], 2); + Cells[1, 6] := IntToHex(MainPort[$06], 2); + end; + With SGPort2Dump do + begin + Cells[1, 0] := IntToHex(MainPort[$07], 2); + Cells[1, 1] := IntToHex(MainPort[$08], 2); + Cells[1, 2] := IntToHex(MainPort[$09], 2); + Cells[1, 3] := IntToHex(MainPort[$0A], 2); + Cells[1, 4] := IntToHex(MainPort[$0B], 2); + Cells[1, 5] := IntToHex(MainPort[$0C], 2); + Cells[1, 6] := IntToHex(MainPort[$0D], 2); + end; +end; + +procedure TfrmMain.FormCloseQuery(Sender: TObject; var CanClose: Boolean); +begin + Screen.Cursor:=crHourGlass; + frmMain.Update; + CPUPaused:=False; + if Assigned(ScrThread) and ScrThread.Suspended then ScrThread.Resume; +end; + +function padl(stt:string;max:integer;ch:string):string; +begin + if length(stt)>=max then padl:=copy(stt,1,max) + else + begin + while length(stt)+length(ch)<=max do stt:=ch+stt; + if length(stt)0) then + begin + if (xpos<=Length(to_tbl)) then + begin + buf[i]:=to_tbl[xpos]; + inc(i); + end + else delete(buf,i,1); + end + else inc(i); + end; +end; + +procedure TfrmMain.ShowMemDump(PauseCPU: boolean); +var save_pF9, pF9: byte; + Addr, i, j, k, dd: integer; + st, stt, ast: string; +begin +// SetDumpAddr; + k:=pos(':',MEDumpAddr.Text)-1; + pF9:=HexToInt(padl(copy(MEDumpAddr.Text, 1, k),2,'0')); + Addr:=HexToInt(copy(MEDumpAddr.Text, k+2, 4)); + if Addr<0 then exit; + Addr:=Addr and $FFF0; + MemDump.Clear; + st:='00000000 00000000 00000000 00000000 0000000000000000 '; + if PauseCPU then + CPUSuspend; + save_pF9:=MainPort[$F9]; + OutB($F9, pF9); // select memory page + for j:=0 to 15 do + begin + ast:=LongAddressStr(pF9,Addr); + for i:=0 to 15 do + begin + stt:=padl(IntToHex(peekb(Addr), 2), 2, '0'); + case i of + 0..3: dd:=1; + 4..7: dd:=2; + 8..11: dd:=3 + else dd:=4; + end; + st[i*2+dd]:=stt[1]; st[i*2+dd+1]:=stt[2]; + if peekb(Addr)>32 then st[i+38]:=chr(peekb(Addr)) else st[i+38]:='.'; + inc(Addr); + end; + MemDump.Lines.Add(ast+' '+st); + end; + OutB($F9, save_pF9); + if PauseCPU and (not CPUPaused) then CPUResume; { now run the thread } + MemDump.SelStart:=0; + MemDump.SelLength:=1; + MemDump.Update; +end; + +procedure TfrmMain.BtnModyByteClick(Sender: TObject); +var st, stt:string; + save_pF9, pF9, Addr: integer; + xAddr, i, k, dd: integer; + buf: array of byte; +begin + k:=pos(':',MEDumpAddr.Text)-1; + pF9:=HexToInt(padl(copy(MEDumpAddr.Text, 1, k),2,'0')); + Addr:=HexToInt(copy(MEDumpAddr.Text, k+2, 4)); + if Addr<0 then exit; + xAddr:=Addr; + st:=' '; + CPUSuspend; { pause the thread } + save_pF9:=MainPort[$F9]; + OutB($F9, pF9); // select memory page + for i:=(xAddr and $0F) to 15 do + begin + stt:=padl(IntToHex(peekb(xAddr), 2), 2, '0'); + case i of + 0..3: dd:=9; + 4..7: dd:=10; + 8..11: dd:=11 + else dd:=12; + end; + st[i*2+dd]:=stt[1]; st[i*2+dd+1]:=stt[2]; + inc(xAddr); + end; + st:=Trim(st); + stt:=InputBox('Modify bytes beginning from '+MEDumpAddr.Text, + 'Enter bytes sequence with leading zeros:', st); + if stt<>st then + begin + chrtrn(stt, ' ', ''); + if Length(stt)=0 then exit; + i:=Length(stt); + i:=i-(i mod 2); + dd:=0; + SetLength(buf, i); + while i>0 do + begin + st:=copy(stt, dd*2+1, 2); + if HexToInt(st)<0 then + begin + ShowMessage('Wrong byte: `'+st+'`. No modification will be maked at all.'); + OutB($F9, save_pF9); + if not CPUPaused then CPUResume; { now run the thread } + exit; + end; + buf[dd]:=Lo(HexToInt(st)); + dec(i, 2); + inc(dd); + end; + for i:=0 to dd-1 do + pokeb(Addr+i, buf[i]); + end; + OutB($F9, save_pF9); + ShowMemDump(False); + if not CPUPaused then CPUResume; { now run the thread } +end; + +procedure TfrmMain.AppKeyDown(var msg: TMsg; var Handled: Boolean); +begin + case Msg.message of + WM_KEYDOWN: if Msg.wParam=VK_PAUSE then + ActPauseExecute(Self) + else + if (frmSetts=nil) and (AboutBox=nil) and (pnScr.Visible) then + begin + GetKeyboardState(KEYBRD); + Handled:=True; + end; + WM_KEYUP: if (frmSetts=nil) and (AboutBox=nil) and (pnScr.Visible) then + begin + GetKeyboardState(KEYBRD); + if FLcdRusLat<>integer(PortF400.LcdRusLat) then + ShowRusLat(); + Handled:=True; + end; + end; +end; + +procedure TfrmMain.ActPauseExecute(Sender: TObject); +begin + CPUPaused:=not CPUPaused; + if CPUPaused then + CPUSuspend + else + CPUResume; + sleep(50); +end; + +procedure TfrmMain.ActResetExecute(Sender: TObject); +begin + BreakPointPF9:=$FF; + CPUSuspend; + InitEmulator; + InitSGRegPort; + CPUResume; +end; + +procedure Scr480(outbyte: byte); +begin + if (outbyte and $80 = 0) then ScrWidth:=SCR_WIDTH_384 + else begin + if Z80CardMode>=Z80_ORIONPRO_v2 then + ScrWidth:=SCR_WIDTH_512 + else + ScrWidth:=SCR_WIDTH_480; + end; + if PrevScrWidth=ScrWidth then exit; + with frmMain do + begin + StopScrThread; + SetFormSize; + PrevScrWidth:=ScrWidth; + StartScrThread; + end; +end; + +procedure TfrmMain.ActZoomExecute(Sender: TObject); +begin + ZoomPopupMenu.Popup(Left+ToolButtonZoom.Left, Top+pbDraw.Top+46); + Update; + Application.ProcessMessages; +end; + +procedure TfrmMain.SetFloppyHint(FDIndex: integer; isReadOnly: boolean); +var ro:string; + TB: TToolButton; +begin + if FDIndex=0 then + begin + TB:=ToolButtonFloppyA; + ro:='A'; + end + else + begin + TB:=ToolButtonFloppyB; + ro:='B'; + end; + TB.Hint:=FDController.Drive[FDIndex]; + if TB.Hint='' then begin + TB.Hint:='Select '+ODI_EXT+' file as floppy '+ro; + TB.Tag:=0; + end + else begin + if isReadOnly then TB.Hint:=TB.Hint+stReadOnly; + TB.Tag:=1; + end; +end; + +procedure TfrmMain.ItemBrowseClick(Sender: TObject); +var TB: TToolButton; +begin + OpenDialog.Title:='Select file with FDD disk image'; + OpenDialog.DefaultExt:=ODI_EXT; + OpenDialog.Filter:=ODI_FILTER; + OpenDialog.FilterIndex:=1; + if OpenDialog.Execute then + begin + FDController.ReadOnly[FDriveindex]:=ofReadOnly in OpenDialog.Options; + FDController.Drive[FDriveindex]:=OpenDialog.FileName; + if FDriveindex=0 then + TB:=ToolButtonFloppyA + else + TB:=ToolButtonFloppyB; + if TB.Tag=1 then IniManager.RecentFilesAdd(TB.Hint); + SetFloppyHint(FDriveindex, ofReadOnly in OpenDialog.Options); + end; + Update; + Application.ProcessMessages; +end; + +procedure TfrmMain.ToolButtonFloppyAClick(Sender: TObject); +begin + FDriveindex:=0; + OdiPopupMenu.Popup(Left+ToolButtonFloppyA.Left, Top+pbDraw.Top+46); + Update; + Application.ProcessMessages; +end; + +procedure TfrmMain.ToolButtonFloppyBClick(Sender: TObject); +begin + FDriveindex:=1; + OdiPopupMenu.Popup(Left+ToolButtonFloppyB.Left, Top+pbDraw.Top+46); + Update; + Application.ProcessMessages; +end; + +procedure TfrmMain.BtnSaveMemClick(Sender: TObject); +var j, Addr: integer; + save_pF9, pF9, bbb: byte; + FS: TFileStream; +begin + SaveDialog.DefaultExt:='dmp'; + SaveDialog.Title:='Specify file to save memory dump'; + if SaveDialog.Execute then + begin + CPUSuspend; + save_pF9:=MainPort[$F9]; + pF9:=HexToInt(copy(MEDumpAddr.Text, 1, 2)); + Addr:=HexToInt(copy(MEDumpAddr.Text, 4, 4)); + if Addr<0 then exit; + OutB($F9, pF9); // select memory page + FS:=nil; + FS:=TFileStream.Create(SaveDialog.Filename, fmCreate); + try + j:=0; + while (j=$10000 then + begin + Addr:=0; + inc(pF9); + OutB($F9, pF9); // select memory page + end; + end; + except + MESaveCnt.SetFocus; + end; + if Assigned(FS) then FS.Free; + OutB($F9, save_pF9); // select memory page + if not CPUPaused then CPUResume; { now run the thread } + end; +end; + +procedure TfrmMain.ItemClearClick(Sender: TObject); +begin + FDController.Drive[FDriveindex]:=''; + SetFloppyHint(FDriveIndex, False); +end; + +function GetHexMasked4(ch: char; var Mask: byte): byte; +begin + if (ch in [' ','x','X','?','*']) then ch:='_'; + if ch='_' then Mask:=$FF else Mask:=0; + Result:=StrToIntDef(ch,0); +end; + +function GetHexMasked16(st: string; var Mask: integer): integer; +var i, xMask: integer; +begin + Mask:=0; + xMask:=$F; + for i:=length(st) downto 1 do + begin + if (st[i] in [' ','x','X','?','*','_']) then + begin + st[i]:='0'; + Mask:=Mask or xMask; + end; + xMask:=xMask shl 4; + end; + Result:=HexToInt(st); +end; + +procedure TfrmMain.cbBreakPointClick(Sender: TObject); +begin + if cbBreakPoint.Checked then + begin + BreakPointPF9:=GetHexMasked4(MEBreakPoint.Text[1], BreakPointPF9mask); + BreakPointAddr:=GetHexMasked16(copy(MEBreakPoint.Text, 3, 4), BreakPointAddrMask); + end + else begin + BreakPointPF9:=$FF; + BreakPointPF9mask:=0; + end; +end; + +procedure TfrmMain.ItemRecentClick(Sender: TObject); +var pp:integer; +begin + if Assigned(Sender)and(Sender is TMenuItem) then + begin + pp:=pos(stReadOnly, (Sender as TMenuItem).Caption); + FDController.ReadOnly[FDriveindex]:=(pp>0) and (pp=Length((Sender as TMenuItem).Caption)-Length(stReadOnly)+1); + if pp>0 then + FDController.Drive[FDriveindex]:=copy((Sender as TMenuItem).Caption, 1, pp-1) + else + FDController.Drive[FDriveindex]:=(Sender as TMenuItem).Caption; + if FDriveindex=0 then + begin + ToolButtonFloppyA.Hint:=(Sender as TMenuItem).Caption; + ToolButtonFloppyA.Tag:=1; + end + else + begin + ToolButtonFloppyB.Hint:=(Sender as TMenuItem).Caption; + ToolButtonFloppyB.Tag:=1; + end; + Update; + Application.ProcessMessages; + end; +end; + +procedure TfrmMain.CPUResume; +begin + Application.OnIdle:=MyIdleHandler; + StatusBar.Panels[StatusBar.Panels.Count-1].Text:=''; + ToolButtonPause.Down:=CPUPaused; +end; + +procedure TfrmMain.CPUSuspend; +begin + Application.OnIdle:=nil; + StatusBar.Panels[StatusBar.Panels.Count-1].Text:='CPU Paused'; + ToolButtonPause.Down:=CPUPaused; +end; + +procedure OnInstruction; +begin + if CpuPaused then frmMain.CPUSuspend; + if not frmMain.pnDbg.Visible then exit; + frmMain.ShowSGReg; + frmMain.ShowSGPort; + Application.ProcessMessages; +end; + +procedure OnBreakPoint; +begin + CPUPaused:=True; + frmMain.CPUSuspend; + frmMain.ShowSGReg; + frmMain.ShowSGPort; + Application.ProcessMessages; +end; + +procedure CheckHddAccess(Value: integer); +begin + with frmMain.StatusBar.Panels[1] do + if Bevel=pbLowered then + begin + Bevel:=pbRaised; + Text:='HDD:'; + end + else if Length(Text)>4 then + Bevel:=pbLowered; + frmMain.StatusBar.Update; + Application.ProcessMessages; +end; + +procedure ShowEthStat; +begin + if Assigned(EthThread) then + frmMain.StatusBar.Panels[4].Text:='Eth: '+EthThread.GetStat; +end; + +procedure OnCPUAccess(CpuIdlePercent: integer); +begin + frmMain.StatusBar.Panels[3].Text:='Idle: '+IntToStr(CpuIdlePercent)+'%'; +end; + +procedure OnHalfSecond(Value: integer); +begin + CheckHddAccess(Value); +end; + +procedure OnOneSecond(CpuIdlePercent: integer); +begin + OnCPUAccess(CpuIdlePercent); + ShowEthStat(); +end; + +procedure OnFddAccess(Sender: TObject; Op: string; BeginOp: boolean); +begin + if BeginOp then + frmMain.StatusBar.Panels[0].Bevel:=pbLowered // pbNone; + else begin + Op:=''; + sleep(80); + frmMain.StatusBar.Panels[0].Bevel:=pbRaised; + end; + frmMain.StatusBar.Panels[0].Text:='FDD: '+Op; + frmMain.StatusBar.Update; + Application.ProcessMessages; +end; + +procedure TfrmMain.FormCreate(Sender: TObject); + var ThreadHandle: THandle; +begin + ScrThread:=nil; +{$IFDEF USE_DEBUGGING} + AssignFile(debugFile, 'OrionZEmDebug.txt'); + Rewrite(debugFile); + ReportDebugCallCtr:=0; +{$ENDIF} + ThreadHandle := GetCurrentThread; + SetThreadPriority(ThreadHandle, THREAD_PRIORITY_HIGHEST); + z80runstate := Z80RUNNING; + Application.OnIdle:=MyIdleHandler; + AfterInstruction:=OnInstruction; + AfterBreakPoint:=OnBreakPoint; + AfterOneSecond:=OnOneSecond; + AfterHalfSecond:=OnHalfSecond; + FDController.OnAccess:=OnFddAccess; + InitRAMArr(); + InitEmulator(); + DisSL:=TStringList.Create; + InitDezSL(); + Global_TStates := -glTstatesPerInterrupt; +end; + +procedure TfrmMain.ActSettingsExecute(Sender: TObject); +begin + frmSetts:=TfrmSetts.Create(Application); + if (Assigned(frmSetts)) then with frmSetts do + try + ShowModal; + Free; + finally + frmSetts:=nil; + end; +end; + +procedure TfrmMain.InitDezSL; +var i: integer; + ss, sss: string; +begin + DisSL.LoadFromFile(CheckFileExists(ChangeFileExt(System.ParamStr(0),'.DIS'))); + for i:=0 to DisSL.Count-1 do + begin + sss:=DisSL[i]; + ss:=LeftSubstr(sss); + DisSL.Objects[i]:=pointer(HexToInt(LeftSubstr(ss))); + end; +end; + +function TfrmMain.CheckFileExists(FlName: string): string; +begin + If FileExists(FlName) then + Result:=FlName + else if FileExists(ExtractFilePath(ParamStr(0))+FlName) then + Result:=ExtractFilePath(ParamStr(0))+FlName + else + Result:=ExtractFileName(FlName); +end; + +function TfrmMain.disasm(PC: integer; var OP: string): integer; +var idx, ii: integer; + st, st1: string; +begin + Result:=PC+1; + OP:=''; + idx:=DisSL.IndexOfObject(pointer(peekb(PC))); + if idx<0 then + idx:=DisSL.IndexOfObject(pointer(256*peekb(PC)+peekb(PC+1))); + if idx>=0 then + begin + st:=DisSL[idx]; + st1:=trim(copy(LeftSubstr(st), 3, 100)); + OP:=LeftSubstr(st); + while st1<>'' do + begin + st:=LeftSubstr(st1); + if Length(st)=1 then + case st[1] of + 'm': begin + idx:=pos('m', OP); + if idx>0 then + begin + insert(IntToHex(peekb(Result), 2), OP, idx); + insert(IntToHex(peekb(Result+1), 2), OP, idx); + delete(OP, idx+4, 1); + inc(Result, 2); + end; + end; + 'e': begin + idx:=pos('e', OP); + if idx>0 then + begin + ii:=Result+Shortint(peekb(Result))+1; + insert(IntToHex(ii, 4), OP, idx); + delete(OP, idx+4, 1); + inc(Result); + end; + end + else begin // 'n','d' + idx:=pos(st[1], OP); + if idx>0 then + begin + insert(IntToHex(peekb(Result), 2), OP, idx); + delete(OP, idx+2, 1); + inc(Result); + end; + end; + end + else inc(Result); + end; + end; +end; + +procedure TfrmMain.ActHelpExecute(Sender: TObject); +begin + AboutBox:=TAboutBox.Create(Application); + with AboutBox do + try + ShowModal; + Free; + finally + AboutBox:=nil; + end; +end; + +procedure TfrmMain.InitRAMArr; +var ii, kk: integer; +begin + for ii:= 2 to RAMPagesCount-1 do + begin + kk:=0; + while kk<$FFFF do + begin + RAMArr[ii,kk]:=$E5; // TRASH in memory + inc(kk, 32); + end; + end; +end; + +function TfrmMain.DetectFileType(FName: string; var Fsz: integer): TOFileType; +var CRC: integer; + FStream: TFileStream; + FExt: string; +begin + Result:=ftUnknown; + FStream:=nil; + try + FStream:=TFileStream.Create(FName, fmOpenRead or fmShareDenyWrite); + FExt:=AnsiUpperCase(ExtractFileExt(FName)); + Fsz:=FStream.Size; + if (Fsz < RAMDISK_TOP)and(Fsz>31) then // filesize less ORDOS RAMDISK limit + if (FExt='.'+RKO_EXT) then Result:=ftRko else + if (FExt='.'+ORD_EXT) then Result:=ftOrd else + if (FExt='.'+BRU_EXT) then Result:=ftBru; + if (Result=ftUnknown )and + (FSz>sizeof(TOriHeader)+$20000) and // cannot be small + (FSz<100000000) then // cannot be large + with OriHeader do + begin + FStream.Read(OriHeader, sizeof(OriHeader)); // snaphots have a CRC + FStream.Read(CRC, sizeof(CRC)); + if (pos(TAG_STR, _tag)=1) and (CRC=CRC32(OriHeader, 0, sizeof(OriHeader))) then + Result:=ftSnapshot + else + if (FExt='.'+ODI_EXT) and (FSz mod 1024 = 0) // 'ODI' extension, mod sector size + then Result:=ftDiskImage; + end; + finally + if Assigned(FStream) then + FStream.Free; + end; +end; + +function TfrmMain.ProcessCmdLine: boolean; +var ss: string; + autosnap: boolean; + param_n, next_ordos, fsize, datasize: integer; + ft: TOFileType; + FStream: TFileStream; +begin + autosnap:=True; + Result:=True; + next_ordos:=0; + for param_n:=1 to ParamCount() do + begin + ss:=CheckFileExists(ParamStr(param_n)); + ft:=DetectFileType(ss, fsize); + case ft of + ftSnapshot: if param_n=1 then + begin + LoadSnapshot(ss); + autosnap:=False; + end; + ftDiskImage: + if param_n<3 then + begin + FDriveindex:=param_n-1; + FDController.Drive[FDriveindex]:=ss; + SetFloppyHint(FDriveindex, False); + autosnap:=False; + end; + ftRko, ftBru, ftOrd: // ordos_header[10..11] - ORDOS filesize + if (next_ordos+fsize'' then + with OriHeader do // snapshot header + begin + xPaused:=CPUPaused; + CPUPaused:=True; + CPUSuspend; + StrFmt(_tag, TAG_STR+'%dk', [Pages*64]); + _regA:= regA; + _regHL:= regHL; + _regB:= regB; + _regC:= regC; + _regDE:= regDE; + _fS:= fS; + _fZ:= fZ; + _f5:= f5; + _fH:= fH; + _f3:= f3; + _fPV:= fPV; + _fN:= fN; + _fC:= fC; + _regAF_:= regAF_; + _regHL_:= regHL_; + _regBC_:= regBC_; + _regDE_:= regDE_; + _regIX:= regIX; + _regIY:= regIY; + _regID:= regID; + _regSP:= regSP; + _regPC:= regPC; + _intI:= intI; + _intR:= intR; + _intRTemp:= intRTemp; + _intIFF1:= intIFF1; + _intIFF2:= intIFF2; + _intIM:= intIM; + _DeltaDate:= DeltaDate; + _DeltaTime:= DeltaTime; + _KeyDelay:= KeyDelay; + _KeyRusLat:= KeyRusLat; + _MemSizeMode:= MEMSizeMode; + _CPUSpeedMode:= CPUSpeedMode; + _Z80CardMode:= Z80CardMode; +// + _SoundEnabled:= SoundEnabled; + _AyEnabled:= AyEnabled; + _glWavePtr:= glWavePtr; + _glWaveAddTStates:= glWaveAddTStates; + _AYPSG:= AYPSG; + _AY_OutNoise:= AY_OutNoise; + _VolA:= VolA; + _VolB:= VolB; + _VolC:= VolC; + _lOut1:= lOut1; + _lOut2:= lOut2; + _lOut3:= lOut3; + _AY_Left:= AY_Left; + _AY_NextEvent:= AY_NextEvent; +// + _Global_TStates:= Global_TStates; + _z80runstate:= z80runstate; + _glTstatesPerInterrupt:=glTstatesPerInterrupt; + _KeybType:= KeybType; + _KeyExtender:= KeyExtender; + _FddHD:= FddHD; + _HDDPort:= HDDPort; + _ScrZoom:= ScrZoom; + _SDScheme:= SDScheme; + _PFEEnabled:= PFEEnabled; + _ROMBIOSfile:= ROMBIOSfile; + _ROMDISKfile:= ROMDISKfile; + _ROMDISKlen:= ROMDISKlen; + _NPages:= Pages; +// + CRC:=CRC32(OriHeader, 0, sizeof(OriHeader)); +// + FStream:=nil; + try + FStream:=TFileStream.Create(FName, fmCreate); + FStream.Seek(0, soFromBeginning); + FStream.Write(OriHeader, sizeof(OriHeader)); // constant length part + FStream.Write(CRC, sizeof(CRC)); // for filetype autodetect + PortF400.SaveToStream(FStream); // variable length part + PortF500.SaveToStream(FStream); + PortF600.SaveToStream(FStream); + FDController.SaveToStream(FStream); + IdeController.SaveToStream(FStream); + SDController.SaveToStream(FStream); + F146818.SaveToStream(FStream); + FStream.Write(Parity, sizeof(Parity)); + FStream.Write(MainPort, sizeof(MainPort)); + FStream.Write(ROMF800, sizeof(ROMF800)); + FStream.WriteBuffer(ROMDISK[0], _ROMDISKlen); + FStream.Write(RAMARR, Pages*RAM_PAGE_SIZE+1); + finally + if Assigned(FStream) then FStream.Free; + CPUPaused:=xPaused; + if not CPUPaused then + CPUResume; + end; + end; +end; + +procedure TfrmMain.LoadSnapshot(FName: string); +var FStream: TFileStream; + CRC, ii: integer; + xPaused: boolean; + xMainPort: TMainPort; +begin +{$IFDEF FREEWARE} + Application.MessageBox( + 'Snapshots are not allowed in FREEWARE version', + PChar(Application.Title), + MB_OK or MB_ICONEXCLAMATION); + exit; +{$ENDIF} + FStream:=nil; + xPaused:=CPUPaused; + if not FileExists(FName) then exit; + if DetectFileType(FName, ii)<>ftSnapshot then + Application.MessageBox( + PChar('Snapshot file has wrong format:'#13#10#13#10+FName), + PChar(Application.Title), + MB_OK or MB_ICONEXCLAMATION) + else + with OriHeader do // snapshot header + try + CPUPaused:=True; + CPUSuspend; + sleep(50); + FStream:=TFileStream.Create(FName, fmOpenRead or fmShareDenyWrite); + FStream.Seek(0, soFromBeginning); + FStream.Read(OriHeader, sizeof(OriHeader)); + FStream.Read(CRC, sizeof(CRC)); + PortF400.ReadFromStream(FStream); + PortF500.ReadFromStream(FStream); + PortF600.ReadFromStream(FStream); + FDController.Drive[0]:=''; + FDController.Drive[1]:=''; + FDController.ReadFromStream(FStream); + IdeController.ReadFromStream(FStream); //sa + SDController.ReadFromStream(FStream); //sa + SetFloppyHint(0, FDController.ReadOnly[0]); + SetFloppyHint(1, FDController.ReadOnly[1]); + F146818.ReadFromStream(FStream); + FStream.Read(Parity, sizeof(Parity)); + FStream.Read(xMainPort, sizeof(MainPort)); + FStream.Read(ROMF800, sizeof(ROMF800)); + SetLength(ROMDISK, _ROMDISKlen+1); + FStream.ReadBuffer(ROMDISK[0], _ROMDISKlen); + FStream.Read(RAMARR, _NPages*RAM_PAGE_SIZE+1); + regA:= _regA; + regHL:= _regHL; + regB:= _regB; + regC:= _regC; + regDE:= _regDE; + fS:= _fS; + fZ:= _fZ; + f5:= _f5; + fH:= _fH; + f3:= _f3; + fPV:= _fPV; + fN:= _fN; + fC:= _fC; + regAF_:= _regAF_; + regHL_:= _regHL_; + regBC_:= _regBC_; + regDE_:= _regDE_; + regIX:= _regIX; + regIY:= _regIY; + regID:= _regID; + regSP:= _regSP; + regPC:= _regPC; + intI:= _intI; + intR:= _intR; + intRTemp:= _intRTemp; + intIFF1:= _intIFF1; + intIFF2:= _intIFF2; + intIM:= _intIM; + DeltaDate:= _DeltaDate; + DeltaTime:= _DeltaTime; + KeyDelay:= _KeyDelay; + KeyRusLat:= _KeyRusLat; + MEMSizeMode:= _MemSizeMode; + SetMemSize(); + CPUSpeedMode:= _CPUSpeedMode; + Z80CardMode:= _Z80CardMode; +// + SoundEnabled:= _SoundEnabled; + AyEnabled:= _AyEnabled; + glWavePtr:= _glWavePtr; + glWaveAddTStates:= _glWaveAddTStates; + AYPSG:= _AYPSG; + AY_OutNoise:= _AY_OutNoise; + VolA:= _VolA; + VolB:= _VolB; + VolC:= _VolC; + lOut1:= _lOut1; + lOut2:= _lOut2; + lOut3:= _lOut3; + AY_Left:= _AY_Left; + AY_NextEvent:= _AY_NextEvent; +// + Global_TStates:= _Global_TStates; + z80runstate:= _z80runstate; + glTstatesPerInterrupt:=_glTstatesPerInterrupt; + KeybType:= _KeybType; + KeyExtender:= _KeyExtender; + FddHD:= _FddHD; + HDDPort:= _HDDPort; + if ScrZoom<>_ScrZoom then SetFormSize; + SDScheme:= _SDScheme; + PFEEnabled:= _PFEEnabled; + ROMBIOSfile:= _ROMBIOSfile; + ROMDISKfile:= _ROMDISKfile; + ROMDISKlen:= _ROMDISKlen; + for ii:=0 to $FC do + outb(ii, xMainPort[ii]); + finally + if Assigned(FStream) then FStream.Free; +{$IFDEF USE_SOUND} + if SoundEnabled then + SoundEnabled:=SoundEnabled and InitializeWaveOut(); +{$ENDIF} + if not Assigned(ScrThread) then + StartScrThread; + sleep(50); + CPUPaused:=xPaused; + if not CPUPaused then + CPUResume; + SetZoomChecks; + end; +end; + +procedure TfrmMain.Saveshapshot128k1Click(Sender: TObject); +begin + SaveSnapshot(2, ''); +end; + +procedure TfrmMain.Saveshapshot256k1Click(Sender: TObject); +begin + SaveSnapshot(4, ''); +end; + +procedure TfrmMain.Saveshapshot512k1Click(Sender: TObject); +begin + SaveSnapshot(8, ''); +end; + +procedure TfrmMain.Loadsnapshot1Click(Sender: TObject); +begin + OpenDialog.Title:='Select file with Orion snapshot'; + OpenDialog.DefaultExt:='ORI'; + OpenDialog.Filter:='Orion snapshots (*.ori)|*.ori|Any file (*.*)|*.*'; + OpenDialog.FilterIndex:=1; + if OpenDialog.Execute then + LoadSnapshot(OpenDialog.FileName); +end; + +procedure TfrmMain.ToolButtonSnapshotClick(Sender: TObject); +begin + SnapPopupMenu.Popup(Left+ToolButtonSnapshot.Left, Top+pbDraw.Top+46); + Update; + Application.ProcessMessages; +end; + +procedure TfrmMain.AutoSnapshot1Click(Sender: TObject); +begin + FAutoSnapshot:=not FAutoSnapshot; + AutoSnapshot1.Checked:=FAutoSnapshot; +end; + +procedure TfrmMain.ShowRusLat; +begin + if PortF400.LcdRusLat + then StatusBar.Panels[2].Text:='KB: Pyc' + else StatusBar.Panels[2].Text:='KB: Lat'; + FLcdRusLat:=integer(PortF400.LcdRusLat); +end; + +// "main loop" +//It runs spectrum for one interrupt period (50 ms spectrum time) +//and tells then Windows it needs more processor cycles (Done:=False). +//This way it is a definite CPU hog, but should be fast too +//During setting screens, emulation is paused (z80runstate=Z80PAUSED) +procedure TfrmMain.MyIdleHandler(Sender: TObject; var Done: Boolean); +begin + if (z80runstate=Z80RUNNING) then + begin + //Execute some z80 code + execute(Global_TStates); + Done := false; + end + else + begin + Sleep(100); + Done := true; + end; +end; + +procedure TfrmMain.ActScrExecute(Sender: TObject); +begin + pnScr.Visible:=True; + pnDbg.Visible:=False; + ToolButtonScr.Down:=pnScr.Visible; + ToolButtonDbg.Down:=pnDbg.Visible; +end; + +procedure TfrmMain.ActDbgExecute(Sender: TObject); +begin + pnScr.Visible:=False; + pnDbg.Visible:=True; + ToolButtonScr.Down:=pnScr.Visible; + ToolButtonDbg.Down:=pnDbg.Visible; + ShowSGReg; + ShowSGPort; + ShowMemDump(True); + SGHistory.Cells[0, 0]:=''; // why? + SGHistory.Cells[1, 0]:=''; +end; + +procedure TfrmMain.SetFormSize; +var i, m: integer; + b: boolean; + FResize: TNotifyEvent; +begin + StopScrThread; + b:=pnScr.Visible; + if not b then + ActScrExecute(Self); + FResize:=OnResize; + OnResize:=nil; + m:=ScrHeightArr[ScrZoom]+ToolBar.Height+StatusBar.Height+Bevel1.Height; + ClientHeight:=m; + if pbDraw.HeightClientHeight then + raise Exception.Create('Can not resize form Height'); + until pbDraw.Height=ScrHeightArr[ScrZoom]; + m:=ScrWidthArr[ScrWidth, ScrZoom]; + Width:=m; + if pbDraw.WidthWidth then + raise Exception.Create('Can not resize form Width'#13#10'Use lower screen zoom.'); + until pbDraw.Width=m; + OnResize:=FResize; + FormResize(frmMain); + if not b then + ActDbgExecute(Self); + StartScrThread; + Update; + Application.ProcessMessages; +end; + +procedure TfrmMain.x1menuitemClick(Sender: TObject); +begin + if (ScrZoom=TMenuItem(Sender).Tag)or + (ScrHeightArr[TMenuItem(Sender).Tag]>GetDeviceCaps(GetDC(0), VERTRES))or + (ScrWidthArr[ScrWidth, TMenuItem(Sender).Tag]>GetDeviceCaps(GetDC(0), HORZRES)) + then exit; + ScrZoom:=TMenuItem(Sender).Tag; + if pnScr.Visible then + SetFormSize + else begin + pnScr.Visible:=True; + SetFormSize; + pnScr.Visible:=False; + end; + SetZoomChecks; +end; + +procedure TfrmMain.SetZoomChecks; +var i: integer; +begin + for i:=0 to ZoomPopupMenu.Items.Count-1 do + ZoomPopupMenu.Items[i].Checked:=ZoomPopupMenu.Items[i].Tag=ScrZoom; +end; + +procedure TfrmMain.ActOpenSaveExecute(Sender: TObject); +begin + OpenPopupMenu.Popup(Left+ToolButtonOpen.Left, Top+pbDraw.Top+46); + Update; + Application.ProcessMessages; +end; + +function GetOrdosFileList(list:TStrings): integer; +var ii: integer; + ss: string; + function IsFLeter(ch: byte):boolean; + begin + IsFLeter:=(ch>=32)and(ch<127); + end; +begin + Result:=0; + if IsFLeter(RAMArr[1, 1]) and IsFLeter(RAMArr[1, 2]) and IsFLeter(RAMArr[1, 3]) then + repeat + ss:=''; + for ii:=0 to 7 do + if IsFLeter(RAMArr[1, Result+ii]) then ss:=ss+chr(RAMArr[1, Result+ii]); + if trim(ss)<>'' then list.AddObject(ss, pointer(Result)); + Result:=Result + 16 + PWord(@RAMArr[1, Result+10])^; + until (Result>RAMDISK_TOP)or(not IsFLeter(RAMArr[1, Result])); +end; + +procedure TfrmMain.ItemLoadClick(Sender: TObject); +var param_n, next_ordos, fsize, datasize, ii: integer; + FL: TStringList; + ss: string; + ft: TOFileType; + FStream: TFileStream; +begin + ii:=0; + FL:=TStringList.Create; + next_ordos:=GetOrdosFileList(FL); + OpenDialog.Title:='Select ORDOS file(s) to load (ctrl+mouse)'; + OpenDialog.Options:=OpenDialog.Options + [ofAllowMultiSelect]; + OpenDialog.DefaultExt:=ORD_EXT; + OpenDialog.Filter:=ORD_FILTER; + OpenDialog.FilterIndex:=1; + try + if (next_ordos>=0) and (next_ordos0 then + begin + for ii:=0 to lbOrdFiles.Items.Count-1 do + lbOrdFiles.Items[ii]:=lbOrdFiles.Items[ii]+ + format(' (%d bytes)', + [integer(PWord(@RAMArr[1, integer(pointer(lbOrdFiles.Items.Objects[ii]))+10])^)]); + if (ShowModal=mrOk)and(lbOrdFiles.SelCount>0) then + begin + SaveDialog.Title:='Select catalog for ORDOS file(s)'; + SaveDialog.DefaultExt:=ORD_EXT; + SaveDialog.Filter:='ORDOS file (*.ord)|*.ord|Any file (*.*)|*.*'; + SaveDialog.FilterIndex:=1; + ii:=0; + while not lbOrdFiles.Selected[ii] do inc(ii); + ss:=lbOrdFiles.Items[ii]; + SaveDialog.FileName:=ChangeFileExt(LeftSubstr(ss), '.'+ORD_EXT); + if SaveDialog.Execute then + for ii:=0 to lbOrdFiles.Items.Count-1 do + if lbOrdFiles.Selected[ii] then + try + FStream:=nil; + if (lbOrdFiles.SelCount=1) then + FStream:=TFileStream.Create(ChangeFileExt(SaveDialog.FileName, '.'+ORD_EXT), fmCreate) + else + begin + ss:=lbOrdFiles.Items[ii]; + FStream:=TFileStream.Create(ChangeFileExt(LeftSubstr(ss), '.'+ORD_EXT), fmCreate); + end; + FStream.Write(PByte(@RAMArr[1, integer(pointer(lbOrdFiles.Items.Objects[ii])) ])^, + integer(PWord(@RAMArr[1, integer(pointer(lbOrdFiles.Items.Objects[ii]))+10])^)+16); + finally + if Assigned(FStream) then FStream.Free; + end; + end; + end + else + Application.MessageBox('No files in RAM-DISK B.', 'Information', MB_OK+MB_ICONINFORMATION); + finally + Free; + FrmSave:=nil; + end; +end; + +procedure TfrmMain.Savescreenpicture1Click(Sender: TObject); +var FS: TFileStream; + TmpBitmap: TBitmap; +begin + SaveDialog.DefaultExt:='bmp'; + SaveDialog.Title:='Specify file to save screenshot'; + if not SaveDialog.Execute then exit; + TmpBitmap:=TBitmap.Create; + TmpBitmap.Assign(ScrBitmap); + TmpBitmap.PixelFormat:=pf8bit; + FS:=TFileStream.Create(SaveDialog.Filename, fmCreate); + try + TmpBitmap.SaveToStream(FS); + finally + if Assigned(FS) then FS.Free; + if Assigned(TmpBitmap) then TmpBitmap.Free; + end; +end; + +procedure TfrmMain.DebuggerMenuPopup(Sender: TObject); +begin + ItemPause.Enabled:=not CPUPaused; + ItemModify.Enabled:=CPUPaused; + ItemSetCondition.Enabled:=CPUPaused and (not SGPortDump.Focused) and + (not SGPort1Dump.Focused) and (not SGPort2Dump.Focused); + ItemClearCondition.Enabled:=CPUPaused and (not SGPortDump.Focused) and + (not SGPort1Dump.Focused) and (not SGPort2Dump.Focused); +end; + +procedure TfrmMain.ActDbgStepIntoExecute(Sender: TObject); +begin + if CpuPaused then + CpuResume + else + begin + CPUPaused:=True; + CPUSuspend; + end; +end; + +procedure TfrmMain.ActDbgStepOverExecute(Sender: TObject); +begin + if CpuPaused then + begin + if (peekb(RegPC) in [$C4, $CC, $CD, $D4, $DC, $E4, $EC, $F4, $FC]) then // if CALL + begin + BreakPointRetPF9:=MainPort[$F9]; + BreakPointRetAddr:=RegPC+3; + CPUPaused:=False; + end + else if (peekb(RegPC)=$ED)and((peekb(RegPC+1) in [$B0..$B3, $B8..$BB])) then // LDIR&etc + begin + BreakPointRetPF9:=MainPort[$F9]; + BreakPointRetAddr:=RegPC+2; + CPUPaused:=False; + end; + CpuResume; + end + else + begin + CPUPaused:=True; + CPUSuspend; + end; +end; + +procedure TfrmMain.ItemModifyClick(Sender: TObject); +var st: string; + ii, kk: integer; +begin + if SGRegMain.Focused then + begin + st:=strictMask16; + case SGRegMain.Row of + 0: setAF(GetValue16('AF', getAF, st, kk)); + 1: setBC(GetValue16('BC', getBC, st, kk)); + 2: regDE:=GetValue16('DE', regDE, st, kk); + 3: regHL:=GetValue16('HL', regHL, st, kk); + 4: regSP:=GetValue16('SP', regSP, st, kk); + 5: regPC:=GetValue16('PC', regPC, st, kk); + end; + ShowSGReg; + end + else if SGRegAlter.Focused then + begin + st:=strictMask16; + case SGRegAlter.Row of + 0: regAF_:=GetValue16('AF''', regAF_, st, kk); + 1: regBC_:=GetValue16('BC''', regBC_, st, kk); + 2: regDE_:=GetValue16('DE''', regDE_, st, kk); + 3: regHL_:=GetValue16('HL''', regHL_, st, kk); + 4: regIX:=GetValue16('IX', regIX, st, kk); + 5: regIY:=GetValue16('IY', regIY, st, kk); + 6: begin + ii:=GetValue16('IR', getIR, st, kk); + intI := (ii and $FFFF) shr 8; + intR := ii and $FF; + end; + end; + ShowSGReg; + end + else if SGPortDump.Focused then + begin + st:=strictMask8; + case SGPortDump.Row of + 0: outb($F8, GetValue16('port F8', MainPort[$F8], st, kk)); + 1: outb($F9, GetValue16('port F9', MainPort[$F9], st, kk)); + 2: outb($FA, GetValue16('port FA', MainPort[$FA], st, kk)); + 3: outb($FB, GetValue16('port FB', MainPort[$FB], st, kk)); + 4: outb($FC, GetValue16('port FC', MainPort[$FC], st, kk)); + 5: outb($FE, GetValue16('port FE', MainPort[$FE], st, kk)); + 6: outb($FF, GetValue16('port FF', MainPort[$FF], st, kk)); + end; + ShowSGPort; + end + else if SGPort1Dump.Focused then + begin + st:=strictMask8; + case SGPort1Dump.Row of + 0: outb($00, GetValue16('port 00', MainPort[$00], st, kk)); + 1: outb($01, GetValue16('port 01', MainPort[$01], st, kk)); + 2: outb($02, GetValue16('port 02', MainPort[$02], st, kk)); + 3: outb($03, GetValue16('port 03', MainPort[$03], st, kk)); + 4: outb($04, GetValue16('port 04', MainPort[$04], st, kk)); + 5: outb($05, GetValue16('port 05', MainPort[$05], st, kk)); + 6: outb($06, GetValue16('port 06', MainPort[$06], st, kk)); + end; + ShowSGPort; + end + else if SGPort2Dump.Focused then + begin + st:=strictMask8; + case SGPort2Dump.Row of + 0: outb($07, GetValue16('port 07', MainPort[$07], st, kk)); + 1: outb($08, GetValue16('port 08', MainPort[$08], st, kk)); + 2: outb($09, GetValue16('port 09', MainPort[$09], st, kk)); + 3: outb($0A, GetValue16('port 0A', MainPort[$0A], st, kk)); + 4: outb($0B, GetValue16('port 0B', MainPort[$0B], st, kk)); + 5: outb($0C, GetValue16('port 0C', MainPort[$0C], st, kk)); + 6: outb($0D, GetValue16('port 0D', MainPort[$0D], st, kk)); + end; + ShowSGPort; + end; +end; + +procedure TfrmMain.ItemSetConditionClick(Sender: TObject); +var ii: integer; + st: string; +begin + st:=freeMask16; + if SGRegMain.Focused then + case SGRegMain.Row of + 0: begin + ii:=GetValue16('AF condition', ConditionAFvalue, st, ConditionAFmask); + if st<>'' then begin + ConditionAF:=' ='+st; + ConditionAFvalue:=ii; + end; + end; + 1: begin + ii:=GetValue16('BC condition', ConditionBCvalue, st, ConditionBCmask); + if st<>'' then begin + ConditionBC:=' ='+st; + ConditionBCvalue:=ii; + end; + end; + 2: begin + ii:=GetValue16('DE condition', ConditionDEvalue, st, ConditionDEmask); + if st<>'' then begin + ConditionDE:=' ='+st; + ConditionDEvalue:=ii; + end; + end; + 3: begin + ii:=GetValue16('HL condition', ConditionHLvalue, st, ConditionHLmask); + if st<>'' then begin + ConditionHL:=' ='+st; + ConditionHLvalue:=ii; + end; + end; + 4: begin + ii:=GetValue16('SP condition', ConditionSPvalue, st, ConditionSPmask); + if st<>'' then begin + ConditionSP:=' ='+st; + ConditionSPvalue:=ii; + end; + end; + end + else if SGRegAlter.Focused then + case SGRegAlter.Row of + 0: begin + ii:=GetValue16('AF'' condition', ConditionAF_value, st, ConditionAF_mask); + if st<>'' then begin + ConditionAF_:=' ='+st; + ConditionAF_value:=ii; + end; + end; + 1: begin + ii:=GetValue16('BC'' condition', ConditionBC_value, st, ConditionBC_mask); + if st<>'' then begin + ConditionBC_:=' ='+st; + ConditionBC_value:=ii; + end; + end; + 2: begin + ii:=GetValue16('DE'' condition', ConditionDE_value, st, ConditionDE_mask); + if st<>'' then begin + ConditionDE_:=' ='+st; + ConditionDE_value:=ii; + end; + end; + 3: begin + ii:=GetValue16('HL'' condition', ConditionHL_value, st, ConditionHL_mask); + if st<>'' then begin + ConditionHL_:=' ='+st; + ConditionHL_value:=ii; + end; + end; + 4: begin + ii:=GetValue16('IX condition', ConditionIXvalue, st, ConditionIXmask); + if st<>'' then begin + ConditionIX:=' ='+st; + ConditionIXvalue:=ii; + end; + end; + 5: begin + ii:=GetValue16('IY condition', ConditionIYvalue, st, ConditionIYmask); + if st<>'' then begin + ConditionIY:=' ='+st; + ConditionIYvalue:=ii; + end; + end; + 6: begin + ii:=GetValue16('IR condition', ConditionIRvalue, st, ConditionIRmask); + if st<>'' then begin + ConditionIR:=' ='+st; + ConditionIRvalue:=ii; + end; + end; + end; + InitSGRegPort; +end; + +procedure TfrmMain.ItemClearConditionClick(Sender: TObject); +begin + if SGRegMain.Focused then + case SGRegMain.Row of + 0: ConditionAF:=''; + 1: ConditionBC:=''; + 2: ConditionDE:=''; + 3: ConditionHL:=''; + 4: ConditionSP:=''; + end + else if SGRegAlter.Focused then + case SGRegAlter.Row of + 0: ConditionAF_:=''; + 1: ConditionBC_:=''; + 2: ConditionDE_:=''; + 3: ConditionHL_:=''; + 4: ConditionIX:=''; + 5: ConditionIY:=''; + 6: ConditionIR:=''; + end; + InitSGRegPort; +end; + +procedure TfrmMain.cbConditionsClick(Sender: TObject); +begin + AnalyzeConditions:=cbConditions.Checked; +end; + +procedure TfrmMain.F9Click(Sender: TObject); + procedure SetAddr(page:byte; addr:word); + begin + MEDumpAddr.Text:=padl(IntToHex(Page, 2), 2, '0')+':'+padl(IntToHex(Addr, 4), 4, '0'); + end; +begin + case (Sender as TMenuItem).Tag of + 0: SetAddr(MainPort[$F9], regHL); // (F9):(HL) + 1: SetAddr(MainPort[$F9], regDE); // (F9):(DE) + 2: SetAddr(MainPort[$F9], getBC); // (F9):(BC) + 3: SetAddr(MainPort[$F9], regIX); // (F9):(IX) + 4: SetAddr(MainPort[$F9], regIY); // (F9):(IY) + 5: SetAddr(MainPort[$F9], regSP); // (F9):(SP) + 6: SetAddr(MainPort[$F9], regPC); // (F9):(PC) + 7: SetAddr(MainPort[$F9], getIR and $FF00); // (F9):(Ix) + end; + ShowMemDump(True); +end; + +procedure TfrmMain.btnPageAddressClick(Sender: TObject); +var pt: TPoint; +begin + pt.x:=1; + pt.y:=(Sender as TControl).Height+1; + pt:=(Sender as TControl).ClientToScreen(pt); + PageAddressMenu.Popup(pt.x, pt.y); +{Left+(Sender as TControl).Left+(Sender as TControl).Width, + Top+(Sender as TControl).Top+(Sender as TControl).Height} +end; + +procedure TfrmMain.InitEthernet; +begin + if EthMode>0 then begin + CreateEthThread; + if EthMAC[0]=#$FF then // not defined in INI-file at startup + CopyMemory(@EthMAC[0], EthThread.MACAddr, 6) + else + EthThread.MACAddr:=@EthMAC[0]; + case EthMode of + 1: begin + F8019AS:=T8019AS.Create; + FNE2kDevice:=F8019AS; + end + else raise Exception.CreateFmt('Wrong EthMode: %d', [EthMode]); + end; + if Assigned(EthThread) then + begin + FNE2kDevice.EthThread:=EthThread; + EthThread.TAPguid:=EthConnGUID; + end; + end + else + DestroyEthThread; +end; + +procedure TfrmMain.MEDumpAddrChange(Sender: TObject); +begin + ShowMemDump(True); +end; + +initialization + FNE2kDevice:=nil; + GUIDList:=TStringList.Create; + +finalization + GUIDList.Free; + +end. + + diff --git a/mod146818.pas b/mod146818.pas new file mode 100644 index 0000000..7af4a90 --- /dev/null +++ b/mod146818.pas @@ -0,0 +1,516 @@ +///////////////////////////////////////////////////////////////////////// +// // +// Orion/Z (Orion-128 + Z80-CARD-II) emulator, version 1.9 // +// // +// Author: Sergey A. // +// // +// Copyright (C) 2006-2016 Sergey A. // +// // +// This program is free software; you can redistribute it and/or // +// modify it in any ways. // +// This program is distributed "AS IS" 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 mod146818; + +{*********************************************** + + MC146818A (512ВИ1) emulation + + ***********************************************} + +interface + + +{$I 'OrionZEm.inc'} + + +Uses Windows, Messages, SysUtils, Classes; + +const + FMC_ADDR60 = $F760; // addres 512vi1 - Orion-128 + FMC_DATA61 = $F761; // data CMOS - Orion-128 + FMC_DATA50 = $50; // data CMOS - Orion-Pro + FMC_ADDR51 = $51; // addres CMOS - Orion-Pro + K512viF760 = 1; + K512vi50 = 2; + DS1302F760 = 3; + DS1302_50 = 4; + + last_day: array[0..11] of byte = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31); + +type + TFCReg = packed record + FAddr: byte; // index of current internal register operating (0..63) + FDate: TDateTime; + FUseSysTime: boolean; + second, minute, hour: word; + al_second, al_minute, al_hour: byte; + weekday, day, month, year: word; + A, B, C, D: byte; + ram: array [$0E..$3F] of byte; + end; + + T146818 = class(TObject) + FCReg: TFCReg; + private + function GetData(Index: Integer): byte; // emulate CPU reading from internal registers + procedure SetData(Index: Integer; const Val: byte); // emulate CPU writing to internal registers + function convert(val: Byte): byte; + function convert_hour(val: Byte): byte; + function convert_bin(val: Byte): byte; + function increment(var reg: word; min, max: Byte): boolean; + function increment_hour(var reg: word): boolean; + function increment_day(var day: word; month, year: word): boolean; + procedure SetSysTime; + function GetRAM: string; + procedure SetRAM(const Value: string); + public + constructor Create; virtual; + procedure Reset; + procedure SaveToStream(Stream: TStream); + procedure ReadFromStream(Stream: TStream); + procedure update_1_second; + property Reg[Index: Integer]:byte read GetData write SetData; default; // interface with CPU + property UseSysTime:boolean read FCReg.FUseSysTime write FCReg.FUseSysTime; + property Addr:byte read FCReg.FAddr write FCReg.FAddr; + property MCRAM:string read GetRAM write SetRAM; + end; + +var + F146818: T146818; + MC146818RAM: string; + DeltaDate: TDateTime = 0.0; // delta (shift value) from system time + DeltaTime: TDateTime = 0.0; + +function MIN(x,y: integer):integer; +function HexToInt(ss: string):integer; + +implementation + +function MIN(x,y: integer):integer; +begin + if x>y then Result:=y else Result:=x; +end; + +function HexToInt(ss: string):integer; +var k,l,m: integer; +begin + Result:=-1; + ss:=UpperCase(trim(ss)); + k:=Length(ss); + if (k=0)or(k mod 2<>0) then exit; + l:=1; Result:=0; + repeat + case ss[k] of + '0'..'9': m:=StrToInt(ss[k]); + 'A'..'F': m:=ord(ss[k])-ord('A')+10; + else m:=-1 + end; + Result:=Result+m*l; + l:=l*16; + dec(k); + until (k=0) or (Result<0); +end; + +{ T146818 } + +function BTST7(const Val: integer):boolean; +begin + Result:=Val and $80 <> 0; +end; + +function BTST0(const Val: integer):boolean; +begin + Result:=Val and 1 <> 0; +end; + +function BTST4(const Val: integer):boolean; +begin + Result:=Val and $10 <> 0; +end; + +function BTST5(const Val: integer):boolean; +begin + Result:=Val and $40 <> 0; +end; + +procedure BSET4(var Val: byte); +begin + Val:=Val or $10; +end; + +procedure BSET5(var Val: byte); +begin + Val:=Val or $20; +end; + +procedure BSET7(var Val: byte); +begin + Val:=Val or $80; +end; + +function T146818.convert(val: Byte): byte; +begin + with FCReg do + begin + if (B and $04 <> 0) then + Result:=val + else + Result:=((val div 10) shl 4) or (val mod 10); + end; +end; + +function T146818.convert_bin(val: Byte): byte; +begin + with FCReg do + begin + if (B and $04 <> 0) then + result:=val + else + result:=((val shr 4) * 10) or (val and $0f); + end; +end; + +function T146818.convert_hour(val: Byte): byte; +begin + with FCReg do + begin + case (B and $06) of + $00: //12 hour, BCD + if (val >= 12) then + result:=$80 or (((val-12) div 10) shl 4) or ((val-12) mod 10) + else + result:=((val div 10) shl 4) or (val mod 10); + $02: //24 hour, BCD + result:=((val div 10) shl 4) or (val mod 10); + $04: //12 hour, binary + if (val >= 12) then + result:=(val - 12) or $80 + else + result:=val; + $06: //24 hour, binary + result:=val + else result:=1; // this should NEVER happen + end; + end; +end; + +constructor T146818.Create; +begin + inherited; + with FCReg do + begin + FUseSysTime:=True; + A:=0; + B:=$06; + end; + Reset; +end; + +function T146818.GetData(Index: Integer): byte; +begin + with FCReg do + begin + Index:=Index and $3F; + case Index of + $00: Result:=second; + $01: Result:=al_second; + $02: Result:=minute; + $03: Result:=al_minute; + $04: Result:=hour; + $05: Result:=al_hour; + $06: Result:=weekday; + $07: Result:=day; + $08: Result:=month; + $09: Result:=year; + $0a: Result:=A; + $0b: Result:=B; + $0c: begin + Result:=C; C:=0; + end; + $0d: Result:=D + else Result:=ram[Index]; + end; + end; +end; + +function T146818.GetRAM: string; +var i: integer; +begin + Result:=''; + for i:=$0e to $3F do + Result:=Result+IntToHex(FCReg.ram[i],2); +end; + +function T146818.increment(var reg: word; min, max: Byte): boolean; +begin + result:=False; + with FCReg do + begin + if (B and $04 <> 0) then begin +// binary calculation + inc(reg); + if (reg > max) then begin + reg := min; + result:=True; + end + end + else begin +// bcd calculation + if ((reg and $0f) = 9) then + reg := (reg and $f0) + $10 + else + inc(reg); + if (reg > convert(max)) then begin + reg := min; + result:=True; + end + end; + end; +end; + +function T146818.increment_day(var day: word; month, year: word): boolean; +var binmonth: byte; +begin + binmonth := convert_bin(month); + if (binmonth < 1) then + binmonth := 1; + if (binmonth > 12) then + binmonth := 12; +// if February leap year + if ((binmonth = 2) and (convert_bin(year) mod 4 = 0)) then begin + if (convert_bin(day) = 29) then begin // switch to next month on 29. Febr. + day := 1; + result:=True; + exit; + end; + end + else if (convert_bin(day) = last_day[binmonth - 1]) then begin + day := 1; + result:=True; + exit; + end; + with FCReg do + begin + if (B and $04 <> 0) then begin // binary calculation + inc(day); + end + else begin // bcd calculation + if ((day and $0f) = 9) then + day := (day and $f0) + $10 + else + inc(day); + end; + end; + Result:=False; +end; + +function T146818.increment_hour(var reg: word): boolean; +begin + Result:=False; + with FCReg do + begin + case (B and $06) of + $00: //12 hour, BCD + if (reg = $12) then begin + reg := $81; + end + else if (reg = $92) then begin + reg := $01; + result:=True; +// exit; + end + else if ((reg and $0f) = 9) then begin + reg := (reg and $f0) + $10 + end + else + inc(reg); + $02: //24 hour, BCD + if ((reg and $0f) = 9) then begin + reg := (reg and $f0) + $10; + end + else if (reg = $23) then begin + reg := $00; + result:=True; +// exit; + end + else + inc(reg); + $04: //12 hour, binary + if (reg = $0C) then begin + reg := $81; + end + else if (reg = $8C) then begin + reg := $01; + result:=True; +// exit; + end else + inc(reg); + $06: //24 hour, binary + if (reg = $17) then begin + reg := $00; + result:=True; +// exit; + end + else + inc(reg) + end; + end; +end; + +procedure T146818.Reset; +begin + with FCReg do + begin + A := A and $7f; + B := B and $87; + C := 0; + D := $80; + FAddr := 0; + end; + SetSysTime(); +end; + +procedure T146818.SetSysTime; +var MSec: Word; +begin +// initialize clock registers with system time + with FCReg do + begin + DecodeTime(Time()-DeltaTime, Hour, minute, second, MSec); + minute:=convert(minute); + second:=convert(second); + Hour:=convert_hour(Hour); + FDate:=Date(); + DecodeDate(FDate-DeltaDate, Year, Month, Day); + weekday:=DayOfWeek(FDate); + day:=convert(day); + month:=convert(month{+1}); + year:=convert(year mod 100); + end; +end; + +procedure T146818.SetData(Index: Integer; const Val: byte); +var yy: word; +begin + with FCReg do + begin + Index:=Index and $3F; + case Index of + $00: second := val and 63; + $01: al_second := val and 63; + $02: minute := val and 63; + $03: al_minute := val and 63; + $04: hour := val and 31; + $05: al_hour := val and 31; + $06: weekday := val and 7; + $07: day := val and 31; + $08: month := val and 15; + $09: year := val and 127; + $0a: A := val and $7f; + $0b: B := val; + else ram[Index]:= val; + end; + if Index<5 then + DeltaTime:=Time()-EncodeTime(hour, minute, second, 0) + else if Index<10 then + begin + if year<50 then yy:=2000+year else yy:=1900+year; + DeltaDate:=Date()-EncodeDate(yy, month, day); + end; + end; +end; + +procedure T146818.SetRAM(const Value: string); +var i: integer; +begin + for i:=$0e to MIN($3F, (length(Value) div 2)+$0d) do + FCReg.ram[i]:=HexToInt(copy(Value, (i-$0e)*2+1, 2)); +end; + +procedure T146818.update_1_second; +var dse_october: Byte; +begin + with FCReg do + begin + if FCReg.FUseSysTime then begin + SetSysTime(); + exit; + end; + dse_october:=0; + // update only if SET bit is 0 + if (not BTST7(B)) then begin // check for last sunday in april 1:59:59 + if (BTST0(B) and (hour = 1) and + (convert_bin(minute) = 59) and + (convert_bin(second) = 59) and + (month = 4) and + (weekday = 1) and + (convert_bin(day) >= 24)) then + begin + hour := 3; + minute := 0; + second := 0; + end + // check for last sunday in october 1:59:59 + else if (BTST0(B) and (hour = 1) and + (convert_bin(minute) = 59) and + (convert_bin(second) = 59) and + (convert_bin(month) = 10) and + (weekday = 1) and + (convert_bin(day) >= 25) and (dse_october=0)) then + begin + dse_october := 1; + hour := 1; + minute := 0; + second := 0; + end + else begin // do a normal update + if (increment(second, 0, 59)) then + if (increment(minute, 0, 59)) then + if (increment_hour(hour)) then begin + increment(weekday, 1, 7); + if (increment_day(day, month, year)) then + if (increment(month, 1, 12)) then + increment(year, 0, 99); + end; + end; + BSET4(C); // set update ended interrupt flag + if (BTST4(B)) then begin + BSET7(C); + end; + // now check for an alarm + if ((((al_second and $c0) = $c0) or (al_second = second)) and + (((al_minute and $c0) = $c0) or (al_minute = minute)) and + (((al_hour and $c0) = $c0) or (al_hour = hour))) then begin + BSET5(C); // set alarm interrupt flag + if (BTST5(B)) then begin + BSET7(C); + end; + end; + end; + end; +end; + +procedure T146818.ReadFromStream(Stream: TStream); +begin + Stream.Read(FCReg, sizeof(FCReg)); +end; + +procedure T146818.SaveToStream(Stream: TStream); +begin + Stream.Write(FCReg, sizeof(FCReg)); +end; + +initialization + F146818:=T146818.Create; + +finalization + F146818.Free; + +end. + diff --git a/mod1793.pas b/mod1793.pas new file mode 100644 index 0000000..1f7608a --- /dev/null +++ b/mod1793.pas @@ -0,0 +1,729 @@ +///////////////////////////////////////////////////////////////////////// +// // +// Orion/Z (Orion-128 + Z80-CARD-II) emulator, version 1.9 // +// // +// Author: Sergey A. // +// // +// Copyright (C) 2006-2016 Sergey A. // +// // +// This program is free software; you can redistribute it and/or // +// modify it in any ways. // +// This program is distributed "AS IS" 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. // +// // +///////////////////////////////////////////////////////////////////////// + + +{*********************************************** + + WD1793 (1818ВГ93) emulation + + ***********************************************} + +unit mod1793; + +interface + +Uses Windows, SysUtils, classes; + + +{$I 'OrionZEm.inc'} + + +const + FDC_ADDR1 = $F700; + FDC_ADDR2 = $F710; + RGU_ADDR1 = $F720; + RGU_ADDR2 = $F714; + SECTOR_SIZE = 1024; // only 1024 implemented + ERR_READ_ONLY = -1; + ERR_SEEK = -2; + ERR_NOT_READY = -3; + ERR_SEEK_1793 = 255; + ERR_SEC_1793 = 254; + + DISK_SIZE_5x2x80 = 819200; // non-HD defaults + _MAX_SECTORS = 5; + _MAX_TRACKS = 80; + + +// only Type I, II commands emulated +// 1793 Commands b7 b6 b5 b4 b3 b2 b1 b0 + + CmdRestore = $00; // 0 0 0 0 h V r1 r0 + CmdSeek = $10; // 0 0 0 1 h V r1 r0 + CmdStep = $20; // 0 0 1 T h V r1 r0 + CmdStepUpdTrk = $30; + CmdStepIn = $40; // 0 1 0 T h V r1 r0 + CmdStepInUpdTrk = $50; + CmdStepOut = $60; // 0 1 1 T h V r1 r0 + CmdStepOutUpdTrk = $70; + CmdReadSector = $80; // 1 0 0 m S E C 0 + CmdReadSectorMul = $90; + CmdWriteSector = $A0; // 1 0 1 m S E C a0 + CmdWriteSectorMul = $B0; +{ +Flag Summary + r1 r0 Stepping Motor Rate + V Track Number Verify Flag (0: no verify, 1: verify on dest track) + h Head Load Flag (1: load head at beginning, 0: unload head) + T Track Update Flag (0: no update, 1: update Track Register) + a0 Data Address Mark (0: FB, 1: F8 (deleted DAM)) + C Side Compare Flag (0: disable side compare, 1: enable side comp) + E 15 ms delay (0: no 15ms delay, 1: 15 ms delay) + S Side Compare Flag (0: compare for side 0, 1: compare for side 1) + m Multiple Record Flag (0: single record, 1: multiple records) +} +type + TOnAccess=procedure(Sender: TObject; Op: string; BeginOp: boolean); + +// Internal registers: +// +// dr data register (r/w) +// tr track register (r/w) +// sr sector register (r/w) +// cr command register (w) +// str status register (r) +// isStepIn flag indicating that previous step command was STEP IN +// side side of floppy to read/write on, changeable by subclass +// drq status of drq pin +// irq status of irq pin +// byteCount byte counter during read/write +// strRead count read access to command register, reset by read from dr + + TFDCReg = packed record + dr, tr, sr, cr, str: Byte; + isStepIn, drq, irq, side: Byte; + byteCount, strRead: integer; + end; + + T1793 = class(TObject) + private + FDCReg: TFDCReg; +// + procedure do_seek(new_track: byte); + function readIO(offset: word): byte; + procedure writeIo(offset: word; val: Byte); +// + procedure setIrq; virtual; + procedure resetIrq; virtual; + function driveReady: boolean; virtual; + function seekError(new_track: byte): byte; virtual; + function writeProtect: boolean; virtual; + function recordNotFound: byte; virtual; + function MaxSectors: integer; virtual; + function MaxTracks: integer; virtual; + procedure command(command:byte); virtual; + procedure SaveToStream(Stream: TStream); virtual; + procedure ReadFromStream(Stream: TStream); virtual; + function readByte(index: integer): byte; virtual; abstract; + procedure writeByte(index: integer); virtual; abstract; + public + constructor Create; virtual; + procedure Reset; virtual; + property Reg[offset: word]:byte read readIO write writeIO; default; // interface with CPU + end; + + TSectorBuffer = array[0..SECTOR_SIZE] of byte; + TDriveArray = array[0..1] of ShortString; + + TFDController = class(T1793) + FRGU: byte; // регистр управления: D0,D1=drive, D4=!side, плотность всегда двойная + FOnAccess: TOnAccess; + FDrive: TDriveArray; + FStream: array[0..1] of TFileStream; + FReadOnly: array [0..1] of boolean; + FHD: array [0..1] of boolean; + FMaxSectors: array [0..1] of integer; + FMaxTracks: array [0..1] of integer; + sector_buffer: TSectorBuffer; + private + procedure SetRGU(const Value: byte); + function GetRGU: byte; + procedure SetDrive(Index: Integer; const Value: String); + function GetDrive(Index: Integer): string; + procedure SetReadOnly(Index: Integer; const Value: boolean); + function GetReadOnly(Index: Integer): boolean; + function writeProtect: boolean; override; + function recordNotFound: byte; override; + function driveReady: boolean; override; + function readByte(index: integer): byte; override; + procedure writeByte(index: integer); override; + function MaxSectors: integer; override; + function MaxTracks: integer; override; + function ReadSector(Tr, Sec: byte):integer; // read sector from "floppy" + function WriteSector(Tr, Sec: byte):integer; // write sector to "floppy" + public + constructor Create; override; + destructor Destroy; override; + procedure Reset; override; + procedure SaveToStream(Stream: TStream); override; + procedure ReadFromStream(Stream: TStream); override; + property Drive[Index: Integer]:string read GetDrive write SetDrive; + property ReadOnly[Index: Integer]:boolean read GetReadOnly write SetReadOnly; + property RGU:byte read GetRGU write SetRGU; + property OnAccess:TOnAccess read FOnAccess write FOnAccess; + end; + +var + FDController: TFDController; + FddHd: boolean; + +implementation + +Uses uPackOdi; + +{ T1793 } + +constructor T1793.Create; +begin + inherited; + Reset; +end; + +procedure T1793.command(command: byte); +var + type1, index: byte; +begin + with FDCReg do + begin + index := 0; // for simulating INDEX bit + type1 := 0; + if (str and $01 = 0) or (command and $f0 = $d0) then + begin + cr := command; + byteCount := 0; + case (cr and $f0) of + $00: begin + tr := 0; // RESTORE + type1 := 1; + setIrq(); + end; + $10: begin + do_seek(dr); // SEEK + type1 := 1; + end; + $30: if (isStepIn<>0) then // STEP with update + do_seek(tr + 1) + else + do_seek(tr - 1); + $20: begin + type1 := 1; // STEP + setIrq(); + end; + $50: begin + do_seek(tr + 1); // STEP IN with update + isStepIn := 1; + type1 := 1; + end; + $40: begin + isStepIn := 1; + setIrq(); + type1 := 1; + end; + $70: begin + if (tr<>0) then // STEP OUT with update + do_seek(tr - 1); + isStepIn := 0; + type1 := 1; + end; + $60: begin + isStepIn := 0; // STEP OUT + setIrq(); + type1 := 1; + end; + $80: begin + strRead := 0; + if (recordNotFound()<>0) then // READ SECTOR + str := $10 + else + begin + byteCount := SECTOR_SIZE; + drq := 1; + str := $03; + end; + end; + $e0, // READ TRACK + $90: begin + byteCount := SECTOR_SIZE*MaxSectors(); // READ SECTOR mult. + drq := 1; + str := $03; + end; + $a0: begin + if (writeProtect()) then // WRITE SECTOR + str := $40 + else + if (recordNotFound()<>0) then + str := $10 + else + begin + byteCount := SECTOR_SIZE; + drq := 1; + str := $03; //$02; + end; + end; + $f0, // WRITE TRACK + $b0: begin + if (writeProtect()) then // WRITE SECTOR mult. + str := $40 + else + begin + byteCount := SECTOR_SIZE*MaxSectors(); + drq := 1; + str := $03; + end; + end; + $c0: if (recordNotFound()<>0) then // READ ADDRESS + str := $10 + else + begin + byteCount := 6; + drq := 1; + str := $03; + end; + $d0: begin + drq := 0; // FORCE INTERRUPT + str := str and $fc; + byteCount := 0; + setIrq(); + end; + end; + if (type1<>0) then + begin + if (driveReady()) then + begin // set index every MAX_SECTORS reads + index := (index + 1 ) mod MaxSectors(); + if writeProtect() then + str := $64 + else + str := $24; + if (index=0) then + str := str or $02 + end + else + begin + tr := 1; // ALWAYS SET TRACK TO 1 + // so system info sector never will be found + str := $80; + end; + end; + end; + end; +end; + +procedure T1793.do_seek(new_track: byte); +begin + with FDCReg do + begin + str := $20; // SEEK + if (seekError(new_track)<>0) then + str := str or $10 + else + tr := new_track; + if (tr=0) then + str := str or $04; + setIrq(); + end; +end; + +function T1793.driveReady: boolean; +begin + result:=True; +end; + +function T1793.readIO(offset: word): byte; +var index: integer; +begin + with FDCReg do + begin + index:=0; // emulate index hole of floppy disc + case (offset and $03) of + 0: begin + resetIrq(); + if ((cr and $e0) = $80) then + begin + inc(strRead); + if (strRead = 32) then + begin + drq := 0; + str := str and $fc; // read finished reset drq and busy + end; + end; +// set index every MAX_SECTORS reads + if (str and $80 <> 0) then + result:=str + else + begin + index:=(index + 1 ) mod MaxSectors(); + if ((index=0) and (cr and $80 = 0)) then + result:=str or $02 + else + result:=str; + end; + end; + 1: result:=tr; + 2: result:=sr; + 3: begin + if (cr and $f0 = $c0) then + begin + case (byteCount) of + 6: dr := tr; + 5: dr := side; + 4: dr := 1; // sector + 3: dr := 3; // sector length + 2: dr := $55; + 1: dr := $55 + else dr := 0; + end; + dec(byteCount); + end + else + begin + strRead := 0; + if (byteCount<>0) then + begin + dr := readByte(byteCount); + dec(byteCount); + end; + end; + if (byteCount=0) then + begin + drq := 0; + str := str and $fc; // read finished reset drq and busy + end; + result:=dr; + end; + else result:=0; // default, should never be used! + end; + end; +end; + +function T1793.recordNotFound: byte; +begin + result:=0; +end; + +procedure T1793.Reset; +begin + with FDCReg do + begin + resetIrq(); + isStepIn := 1; + drq := 0; + side := 0; + byteCount := 0; + strRead := 0; + str := 0; + cr := 0; // clear previous command + command(0); // execute RESTORE after a reset + end; +end; + +procedure T1793.resetIrq; +begin + FDCReg.irq:=0; +end; + +function T1793.seekError(new_track: byte): byte; +begin + if new_track0) then + begin + writeByte(byteCount); + dec(byteCount); + end; + if (byteCount=0) then + begin + drq:=0; + str:=str and $fc; // write finished reset drq and busy + end; + end; + end; + end; +end; + +function T1793.writeProtect: boolean; // should be reimplemented by subclass, return $40 if wp, otherwise 0 +begin + Result:=False; +end; + +procedure T1793.SaveToStream(Stream: TStream); +begin + Stream.Write(FDCReg, sizeof(FDCReg)); +end; + +procedure T1793.ReadFromStream(Stream: TStream); +begin + Stream.Read(FDCReg, sizeof(FDCReg)); +end; + +function T1793.MaxSectors: integer; +begin + Result:=_MAX_SECTORS; +end; + +function T1793.MaxTracks: integer; +begin + Result:=_MAX_TRACKS; +end; + +{ TFDController } + +constructor TFDController.Create; +begin + inherited; + FStream[0]:=nil; FStream[1]:=nil; + FDrive[0]:=''; FDrive[1]:=''; + FOnAccess:=nil; + Reset; + USE_DPBLESS_DISKS:=0; {added for HD-formats support} + FMaxSectors[0]:=_MAX_SECTORS; FMaxSectors[1]:=_MAX_SECTORS; + FMaxTracks[0]:=_MAX_TRACKS; FMaxTracks[1]:=_MAX_TRACKS; +end; + +destructor TFDController.Destroy; +begin + if Assigned(FStream[0]) then FStream[0].Free; + if Assigned(FStream[1]) then FStream[1].Free; +end; + +procedure TFDController.SetDrive(Index: Integer; const Value: String); + procedure ClearDrive; + begin + FDrive[Index]:=''; + if Assigned(FStream[Index]) then + FStream[Index].Free; + FStream[Index]:=nil; + end; +begin + if (FRGU and 3)>1 then exit; + if trim(Value)='' then + ClearDrive() + else if FileExists(AnsiUpperCase(trim(Value))) and + (FDrive[Index]<>AnsiUpperCase(trim(Value))) then + begin + FDrive[Index]:=''; + if Assigned(FStream[Index]) then + FStream[Index].Free; + FStream[Index]:=nil; + try + FReadOnly[Index]:=FReadOnly[Index] or (FileGetAttr(trim(Value)) and faReadOnly <> 0); + if FReadOnly[Index] then + FStream[Index]:=TFileStream.Create(trim(Value), fmOpenRead or fmShareDenyWrite) + else + FStream[Index]:=TFileStream.Create(trim(Value), fmOpenReadWrite or fmShareDenyWrite); + FDrive[Index]:=AnsiUpperCase(trim(Value)); +{added for HD-formats support} + FHD[Index]:=FStream[Index].Size>DISK_SIZE_5x2x80; + if FHD[Index] then + begin + GetBOOT(FDrive[Index], FStream[Index], -1); + if not BOOT.BOOTvalid then // wrong CRC + ClearDrive + else begin + FMaxSectors[Index]:=BOOT.DPB.SEC; + FMaxTracks[Index]:=BOOT.DPB.TRK; + end; + end; +{} + except + end; + end; +end; + +procedure TFDController.Reset; +begin + inherited; + FRGU:=0; +end; + +function TFDController.GetDrive(Index: Integer): string; +begin + Result:=FDrive[Index]; +end; + +procedure TFDController.SetReadOnly(Index: Integer; const Value: boolean); +begin + FReadOnly[Index]:=Value; +end; + +function TFDController.GetReadOnly(Index: Integer): boolean; +begin + Result:=FReadOnly[Index]; +end; + +function TFDController.ReadSector(Tr, Sec: byte):integer; // read SEC_SIZE bytes from floppy +var side: integer; + offset: integer; + cc: char; +begin + if FHD[FRGU and 1] then cc:='h' else cc:=' '; + If Assigned(FOnAccess) then + FOnAccess(Self, format('%s %s %s', [chr(ord('A')+(FRGU and 3)), 'r', cc]), True); + Result:=ERR_NOT_READY; // Failed + if not Assigned(FStream[FRGU and 1]) then exit; + Result:=ERR_SEEK; + side:=((FRGU and 16) shr 4) xor 1; // 0 or 1 + offset:=((side + Tr*2)*MaxSectors() + Sec-1)*SECTOR_SIZE; + if FStream[FRGU and 1].Seek(offset , soFromBeginning)=offset then + Result:=FStream[FRGU and 1].Read(sector_buffer, SECTOR_SIZE)-SECTOR_SIZE; + If Assigned(FOnAccess) then + FOnAccess(Self, format('%s %s %s', [chr(ord('A')+(FRGU and 3)), 'r', cc]), False); +end; + +function TFDController.readByte(index: integer): byte; +begin + result:=0; + if not Assigned(FStream[FRGU and 1]) then exit; + if (index = SECTOR_SIZE) then + begin + if (ReadSector(FDCReg.tr, FDCReg.sr)<>0) then + begin + FDCReg.drq := 0; + FDCReg.str := $10; + FDCReg.byteCount := 0; + end; + end; + result:=sector_buffer[SECTOR_SIZE - index]; +end; + +function TFDController.WriteSector(Tr, Sec: byte):integer; // write SEC_SIZE bytes to floppy +var side: integer; + offset: integer; + cc: char; +begin + if FHD[FRGU and 1] then cc:='h' else cc:=' '; + If Assigned(FOnAccess) then + FOnAccess(Self, format('%s %s %s', [chr(ord('A')+(FRGU and 3)), 'w', cc]), True); + Result:=ERR_NOT_READY; // Failed + if not Assigned(FStream[FRGU and 1]) then exit; + Result:=ERR_READ_ONLY; // Failed + if not FReadOnly[FRGU and 1] then + begin + Result:=ERR_SEEK; + side:=((FRGU and 16) shr 4) xor 1; // 0 or 1 + offset:=((side + Tr*2)*MaxSectors() + Sec-1)*SECTOR_SIZE; + if FStream[FRGU and 1].Seek(offset, soFromBeginning)=offset then + Result:=FStream[FRGU and 1].Write(sector_buffer, SECTOR_SIZE)-SECTOR_SIZE; + end; + If Assigned(FOnAccess) then + FOnAccess(Self, format('%s %s %s', [chr(ord('A')+(FRGU and 3)), 'w', cc]), False); +end; + +procedure TFDController.writeByte(index: integer); +begin + sector_buffer[SECTOR_SIZE - index] := FDCReg.dr; + if (index = 1) then + begin + WriteSector(FDCReg.tr, FDCReg.sr); + end; +end; + +function TFDController.GetRGU: byte; +begin + Result:=$FF; // недоступен на чтение +end; + +procedure TFDController.SetRGU(const Value: byte); +begin + FRGU:=Value; +end; + +function TFDController.driveReady: boolean; +begin + Result:=Assigned(FStream[FRGU and 1]); +end; + +function TFDController.writeProtect: boolean; +begin + Result:=FReadOnly[FRGU and 1]; +end; + +procedure TFDController.ReadFromStream(Stream: TStream); +var l:Longint; + xDrive: TDriveArray; +begin + inherited; + Stream.Read(FRGU, sizeof(FRGU)); + Stream.Read(FReadOnly, sizeof(FReadOnly)); + Stream.Read(FHD, sizeof(FHD)); + Stream.Read(xDrive, sizeof(TDriveArray)); + Stream.Read(sector_buffer, sizeof(sector_buffer)); + SetDrive(0, xDrive[0]); + SetDrive(1, xDrive[1]); + Stream.Read(l, sizeof(l)); + if Assigned(FStream[0]) and (l>=0) then + FStream[0].Position:=l; + Stream.Read(l, sizeof(l)); + if Assigned(FStream[1]) and (l>=0) then + FStream[1].Position:=l; +end; + +procedure TFDController.SaveToStream(Stream: TStream); +var l:Longint; +begin + inherited; + Stream.Write(FRGU, sizeof(FRGU)); + Stream.Write(FReadOnly, sizeof(FReadOnly)); + Stream.Write(FHD, sizeof(FHD)); + Stream.Write(FDrive, sizeof(TDriveArray)); + Stream.Write(sector_buffer, sizeof(sector_buffer)); + l:=-1; + if Assigned(FStream[0]) then + l:=FStream[0].Position; + Stream.Write(l, sizeof(l)); + l:=-1; + if Assigned(FStream[1]) then + l:=FStream[1].Position; + Stream.Write(l, sizeof(l)); +end; + +function TFDController.recordNotFound: byte; +begin + if FHD[FRGU and 1] and ((FRGU and 8 = 0) or (not FddHd)) then + result:=ERR_SEC_1793 + else + result:=0; +end; + +function TFDController.MaxSectors: integer; +begin + Result:=FMaxSectors[FRGU and 1]; +end; + +function TFDController.MaxTracks: integer; +begin + Result:=FMaxTracks[FRGU and 1]; +end; + +initialization + FDController:=TFDController.Create; + +finalization + FDController.Free; + +end. diff --git a/mod232.pas b/mod232.pas new file mode 100644 index 0000000..6e118bc --- /dev/null +++ b/mod232.pas @@ -0,0 +1,296 @@ +///////////////////////////////////////////////////////////////////////// +// // +// Orion/Z (Orion-128 + Z80-CARD-II) emulator, version 1.9 // +// // +// Author: Sergey A. // +// // +// Copyright (C) 2006-2016 Sergey A. // +// // +// This program is free software; you can redistribute it and/or // +// modify it in any ways. // +// This program is distributed "AS IS" 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. // +// // +///////////////////////////////////////////////////////////////////////// + + +{*********************************************** + + Serial port (RS-232) emulation + + ***********************************************} + +{ +Отправка байта - запись в порт F764. + +Прием байта - чтение порта F764. + +Контроль состояния передачи - порт F765 на чтение: +D7 - TX_Ready (0 = идет отправка байта, порт не готов. 1 = можно записывать следующий байт для отправки) +D6 - RX_Status (0 = нет нового принятого байта. 1 = принят новый байт. После считывания байта из F764 этот бит сбрасывается в 0). + +Управление режимами - порт F765 на запись: + +D6 - "1" = разрешает прерывание по приему байта. На ШД ставится 0FDh. +D0, D1 порта F765 - Скорости UART: +"00" - 4800 (по умолчанию после сброса) +"01" - 9600 +"10" - 19200 +"11" - 38400 + +8-N-2, flow control - off. +} + +unit mod232; + +interface + +Uses Windows, SysUtils, classes, CPDrv {ComDrv32 unit}, Forms; + +{$I 'OrionZEm.inc'} + +const + UART_ADDR0 = $F764; // data register + UART_ADDR1 = $F765; // status register + RX_MAX = 2048; // RX Buffer size + arrbr: array[0..3] of TBaudRate = (br4800, br9600, br19200, br38400); + +Type + TUART = class(TObject) + RXBuffer: array[0..RX_MAX] of byte; + FCPDrv: TCommPortDriver; + FPortName: string; + FExists: boolean; + FIntCount: integer; + FIntMode: boolean; + FRXCount: integer; + FIntDataReaded: integer; + private + function GetPort0: byte; + function GetPort1: byte; + procedure SetPort0(const Value: byte); + procedure SetPort1(const Value: byte); + function GetPortName: string; + procedure SetPortName(const Value: string); + procedure ReceiveDataEvent( Sender: TObject; DataPtr: pointer; DataSize: DWORD ); + procedure SetIntCount(const Value: integer); + public + constructor Create; + destructor Destroy; override; + procedure Reset; + procedure EnumComPorts(Ports: TStrings); + property CPDrv:TCommPortDriver read FCPDrv; + property IntCount:integer read FIntCount write SetIntCount; // True then generate Z80 interrupt (0FDh IM2 vector) + property Exists:boolean read FExists write FExists; + property IntMode:boolean read FIntMode; + property IntDataReaded:integer read FIntDataReaded; + property PortName:string read GetPortName write SetPortName; // ComPort Name + property Port0:byte read GetPort0 write SetPort0; // F764 - data register + property Port1:byte read GetPort1 write SetPort1; // F765 - control register + end; + +var + FUART: TUART; + ComPortName: string; + ComPortExists: boolean; + +implementation + +{ TUART } + +procedure TUART.EnumComPorts(Ports: TStrings); +var + KeyHandle: HKEY; + ErrCode, Index: Integer; + ValueName, Data: string; + ValueLen, DataLen, ValueType: DWORD; + TmpPorts: TStringList; +begin + ErrCode := RegOpenKeyEx( + HKEY_LOCAL_MACHINE, + 'HARDWARE\DEVICEMAP\SERIALCOMM', + 0, + KEY_READ, + KeyHandle); + if ErrCode <> ERROR_SUCCESS then + raise Exception.Create('Error: registry read'); + TmpPorts := TStringList.Create; + try + Index := 0; + repeat + ValueLen := 256; + DataLen := 256; + SetLength(ValueName, ValueLen); + SetLength(Data, DataLen); + ErrCode := RegEnumValue( + KeyHandle, + Index, + PChar(ValueName), + Cardinal(ValueLen), + nil, + @ValueType, + PByte(PChar(Data)), + @DataLen); + if ErrCode = ERROR_SUCCESS then + begin + SetLength(Data, DataLen); + TmpPorts.Add(Data); + Inc(Index); + end + else + if ErrCode <> ERROR_NO_MORE_ITEMS then + raise Exception.Create('Error: registry read'); + until (ErrCode <> ERROR_SUCCESS) ; + TmpPorts.Sort; + Ports.Assign(TmpPorts); + finally + RegCloseKey(KeyHandle); + TmpPorts.Free; + end; +end; + +constructor TUART.Create; +begin + FCPDrv:=nil; + FCPDrv:=TCommPortDriver.Create(Application); + FPortName:=''; + FRXCount:=0; + FExists:=False; + FIntCount:=0; + FIntMode:=False; + FIntDataReaded:=0; + FCPDrv.OnReceiveData:=ReceiveDataEvent; + Reset; +end; + +destructor TUART.Destroy; +begin + if Assigned(FCPDrv) then begin + FCPDrv.Disconnect; +// FCPDrv.Free; // Destroy controlled by Application + end; + inherited; +end; + +function TUART.GetPort0: byte; // Get DATA register +begin + if (not FExists) or (FRXCount=0) then + result:=$FF + else + begin + if not FCPDrv.Connected then FCPDrv.Connect; // because do not operating on COM-port until emulated code attempt + Result:=RXBuffer[0]; + FRXCount:=FRXCount-1; + CopyMemory( @RXBuffer[0], @RXBuffer[1], FRXCount ); + if (IntCount>0) then + IntCount:=IntCount-1; + if (FIntDataReaded>0)and(FIntDataReaded>IntCount) then + FIntDataReaded:=FIntDataReaded-1; + end; +end; + +function TUART.GetPort1: byte; // Get STATUS register +begin + result:=$FF; + if FExists then + begin + if not FCPDrv.Connected then FCPDrv.Connect; // because do not operating on COM-port until emulated code attempt + if FRXCount=0 then + result:=result and $BF; // D6=0 if no incoming data + if FCPDrv.OutFreeSpace=0 then + result:=result and $7F; // D7=0 if still sending output byte + end; +end; + +function TUART.GetPortName: string; +begin + Result:=ExtractFileName(FPortName); +end; + +procedure TUART.Reset; +begin + with FCPDrv do + begin + BaudRate:=br4800; // 0=4800, 1=9600, 2=19200, 3=38400 + CheckLineStatus:=True; // True; + DataBits:=db8BITS; + HwFlow:=hfNONE; + PacketMode:=pmDiscard; + Parity:=ptNONE; + Port:=pnCustom; + PortName:=FPortName; + StopBits:=sb2BITS; + SwFlow:=sfNONE; + if Connected and (not FlushBuffers(True, True)) then + MessageBox(0, 'Can not flush RS-232 buffers', 'Error', MB_ICONERROR+MB_OK); + end; +end; + +procedure TUART.SetPort0(const Value: byte); // set DATA register +begin + if FExists then + begin + if not FCPDrv.Connected then FCPDrv.Connect; // because do not operating on COM-port until emulated code attempt + if (FCPDrv.OutFreeSpace>0) and + (FCPDrv.OutFreeSpace<=FCPDrv.OutBufSize) then + FCPDrv.SendByte(Value); // otherwise data sent to /dev/null :) + end; +end; + +procedure TUART.SetPort1(const Value: byte); // Set STATUS register +begin + if FExists then + begin + if FCPDrv.BaudRate<>arrbr[Value and 3] then + begin + if FCPDrv.Connected then FCPDrv.Disconnect; + FCPDrv.BaudRate:=arrbr[Value and 3]; + FCPDrv.Connect; + end; + FIntMode:=(Value and $40)<>0; + end; +end; + +procedure TUART.SetPortName(const Value: string); +begin + if trim(Value)<>FPortName then + begin + FPortName:=trim(Value); + if FPortName<>'' then + begin + if FPortName<>'\\.\'+ExtractFileName(FPortName) then + FPortName:='\\.\'+ExtractFileName(FPortName); + end; + if FCPDrv.Connected then FCPDrv.Disconnect; + FCPDrv.PortName:=FPortName; + end; +end; + +procedure TUART.ReceiveDataEvent(Sender: TObject; DataPtr: pointer; DataSize: DWORD); +begin + FIntDataReaded:=FIntCount; + if DataSize>=RX_MAX then + DataSize:=RX_MAX; + if DataSize+FRXCount>=RX_MAX then + FRXCount:=RX_MAX-DataSize; // temporary solution for buffer overflow resolving + CopyMemory( @RXBuffer[FRXCount], DataPtr, DataSize ); + FRXCount:=FRXCount+DataSize; + FIntCount:=FRXCount; + FIntDataReaded:=FIntCount; +end; + +procedure TUART.SetIntCount(const Value: integer); +begin + if Value>=0 then + FIntCount := Value; +end; + +initialization + FUART:=nil; + FUART:=TUART.Create; + +finalization + if Assigned(FUART) then FUART.Free; + +end. diff --git a/mod8019as.pas b/mod8019as.pas new file mode 100644 index 0000000..017450d --- /dev/null +++ b/mod8019as.pas @@ -0,0 +1,737 @@ +///////////////////////////////////////////////////////////////////////// +// // +// Orion/Z (Orion-128 + Z80-CARD-II) emulator, version 1.9 // +// // +// Author: Sergey A. // +// // +// Copyright (C) 2006-2016 Sergey A. // +// // +// This program is free software; you can redistribute it and/or // +// modify it in any ways. // +// This program is distributed "AS IS" 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 mod8019as; + +{*********************************************** + + RTL8019AS (Ethernet MAC+PHY) emulation + + simplefied version (no ints, no loopback) + + ***********************************************} + +interface + +{$I 'OrionZEm.inc'} + +Uses Windows, SysUtils, classes, EthThrd; + +const + MEM_PAGE_SIZE = 256; + MEM_PAGE_MAX = $40; + MEM_TOT_SIZE = MEM_PAGE_SIZE*MEM_PAGE_MAX; + ETHERDEV_RESET= $FD; // also hardware reset if $FD writing to CR register (0F770h) + +type + TWORD2BYTE = packed record + low: BYTE; + hig: BYTE + end; + PWORD2BYTE = ^TWORD2BYTE; + + TNe2kReg = packed record + CR: BYTE; + RPAGE: integer; +{} + CLDA: WORD; + PSTART:WORD; + PSTOP: WORD; + BNRY: WORD; // Boundary Pointer, points to the next frame to be unloaded from the Buffer Ring (to client) + TSR: BYTE; + TPSR: WORD; + NCR: BYTE; + TBC: WORD; + FIFO: BYTE; + ISR: BYTE; + CRDA: WORD; + RSA: WORD; + RBC: WORD; + RSR: BYTE; + RCR: BYTE; + CNTR0: BYTE; + TCR: BYTE; + CNTR1: BYTE; + DCR: BYTE; + CNTR2: BYTE; + IMR: BYTE; +{} + PAR0: BYTE; + PAR1: BYTE; + PAR2: BYTE; + PAR3: BYTE; + PAR4: BYTE; + PAR5: BYTE; + CURR: WORD; // Current Page Pointer, points to the next available buffer area for the next incoming frame + MAR0: BYTE; + MAR1: BYTE; + MAR2: BYTE; + MAR3: BYTE; + MAR4: BYTE; + MAR5: BYTE; + MAR6: BYTE; + MAR7: BYTE; +{} + FReadDMABufAddr: integer; + FWriteDMABufAddr: integer; + FDMAWordSize: integer; + end; + + T8019Reg = packed record + ID8019: WORD; // Page0_R + CR9346: BYTE; // Page2 + BPAGE: BYTE; + CONFIG0:BYTE; + CONFIG1:BYTE; + CONFIG2:BYTE; + CONFIG3:BYTE; + TEST: BYTE; + CSNSAV: BYTE; + HLTCLK: BYTE; + INTR: BYTE; + FMWP: BYTE; + CONFIG4:BYTE; + end; + + TNE2kDevice = class(TObject) + RR: TNe2kReg; // internal registers: ne2000 standard + FEthThread: TEthThread; + FTmpDMABuf: TFrame; + FReadDMABuf: TFrame; + FWriteDMABuf: TFrame; + FBuffer: array[0..MEM_TOT_SIZE] of BYTE; // internal 16384 bytes buffer + function GetData(Index: Integer): byte; virtual; // emulate CPU reading from internal registers + procedure SetData(Index: Integer; const Value: byte); virtual; // emulate CPU writing to internal registers + private + procedure StartOperation(CR:byte); + procedure StopOperation(CR:byte); + procedure CheckIncomingFrame; + function GetNextBuffPage: pointer; + public + constructor Create; virtual; + destructor Destroy; virtual; + procedure Reset; virtual; // hardware reset (pin reset) + procedure SaveToStream(Stream: TStream); virtual; + procedure ReadFromStream(Stream: TStream); virtual; + property EthThread: TEthThread read FEthThread write FEthThread; + property Registers[Index: Integer]:byte read GetData write SetData; default; // interface with CPU + end; + + T8019AS = class(TNE2kDevice) + RRR: T8019Reg; // internal registers: rtl8019 specific + private + function GetData(Index: Integer): byte; override; + procedure SetData(Index: Integer; const Value: byte); override; + public + constructor Create; override; + procedure Reset; override; + procedure SaveToStream(Stream: TStream); override; + procedure ReadFromStream(Stream: TStream); override; + end; + +var + F8019AS: T8019AS; + +implementation + +const +// NIC Page 0 read register assignments + + CR = $00; // Command + CLDA0 = $01; // Current Local DMA Address 0 + CLDA1 = $02; // Current Local DMA Address 1 + BNDRY = $03; // Boundary Pointer + TSR = $04; // Transmit Status Register + NCR = $05; // Number of Collisions Register + FIFO = $06; // FIFO + ISR = $07; // Interupt Status Register + CRDA0 = $08; // Current Remote DMA Address 0 + CRDA1 = $09; // Current Remote DMA Address 1 + RES1 = $0A; // Reserved + RES2 = $0B; // Reserved + RSR = $0C; // Receive Status Register + CNTR0 = $0D; // Tally Counter 0 (Frame Alignment Errors) + CNTR1 = $0E; // Tally Counter 1 (CRC Errors) + CNTR2 = $0F; // Tally Counter 2 (Missed Packet Errors) + +// NIC Page 0 write register assignments + + PSTART= $01; // Page Start Register + PSTOP = $02; // Page Stop Register + TPSR = $04; // Transmit Page Start Address + TBCR0 = $05; // Transmit Byte Count Register 0 + TBCR1 = $06; // Transmit Byte Count Register 1 + RSAR0 = $08; // Remote Start Address Register 0 + RSAR1 = $09; // Remote Start Address Register 1 + RBCR0 = $0A; // Remote Byte Count Register 0 + RBCR1 = $0B; // Remote Byte Count Register 1 + RCR = $0C; // Receive Configuration Register + TCR = $0D; // Transmit Configuration Register + DCR = $0E; // Data Configuration Register + IMR = $0F; // Interrupt Mask Register + +// NIC Page 1 register assignments (R/W) + + PAR0 = $01; // Physical Address Register 0 [R] PSTART + PAR1 = $02; // Physical Address Register 1 [R] PSTOP + PAR2 = $03; // Physical Address Register 2 + PAR3 = $04; // Physical Address Register 3 [R] TPSR + PAR4 = $05; // Physical Address Register 4 + PAR5 = $06; // Physical Address Register 5 + CURR = $07; // Current Page Register + MAR0 = $08; // Multicast Address Register 0 + MAR1 = $09; // Multicast Address Register 1 + MAR2 = $0A; // Multicast Address Register 2 + MAR3 = $0B; // Multicast Address Register 3 + MAR4 = $0C; // Multicast Address Register 4 [R] RCR + MAR5 = $0D; // Multicast Address Register 5 [R] TCR + MAR6 = $0E; // Multicast Address Register 6 [R] DCR + MAR7 = $0F; // Multicast Address Register 7 [R] IMR + +// NIC Page 3 (rtl8019 specific) + CR9346 = $01; + BPAGE = $02; + CONFIG0 = $03; + CONFIG1 = $04; + CONFIG2 = $05; + CONFIG3 = $06; + TEST = $07; + CSNSAV = $08; + HLTCLK = $09; + INTR = $0B; + FMWP = $0C; + CONFIG4 = $0D; + +// NIC Other registers + + NIC_DATA = $10; // Data Register for I/O port mode + NIC_RESET = $18; // Reset Register - not implemented, use hardware reset only + + PAGE0_R = 0; + PAGE0_W = 1; + PAGE1_RW = 2; + PAGE2_R = 3; + PAGE3_RW = 4; + +// RTL8019/NE2000 CR Register Bit Definitions + PS1 = $80; + PS0 = $40; + RD2 = $20; + RD1 = $10; + RD0 = $08; + TXP = $04; + STA = $02; // START + STP = $01; // STOP +// RTL8019/NE2000 ISR Register Bit Definitions + RST = $80; + RDC = $40; + CNT = $20; + OVW = $10; + RXE = $08; + TXE = $04; + PTX = $02; + TPTX = $01; // at TSR register +// PRX = $01; // see RSR bit0 +// RTL8019/NE2000 DCR Register Bit Definitions + FT1 = $40; + FT0 = $20; + ARM = $10; + LS = $08; + LAS = $04; + BOS = $02; + WTS = $01; +// RTL8019/NE2000 RCR Register Bit Definitions + MON = $20; + PRO = $10; + AM = $08; + AB = $04; + AR = $02; + SEP = $01; +// RTL8019/NE2000 RSR Register Bit Definitions + DFR = $80; + DIS = $40; + PHY = $20; + MPA = $10; + FAE = $04; + CRC = $02; + PRX = $01; +// RTL8019/NE2000 TCR Register Bit Definitions + FDU = $80; // full duplex + PD = $40; // pad disable + RLO = $20; // retry of late collisions + LB1 = $04; // loopback 1 + LB0 = $02; // loopback 0 + CRCG = $01; // generate CRC +// RTL8019 EECR Register Bit Definitions + EEM1 = $80; + EEM0 = $40; + EECS = $08; + EESK = $04; + EEDI = $02; + EEDO = $01; + +function min(a,b:integer):integer; begin if aMEM_PAGE_MAX then + bb:=bb and (MEM_PAGE_MAX-1); { do boundary check at FBuffer access } + Result:=bb shl 8; + end; +begin + if Index=CR then + begin + RR.CR:=Value or (RR.CR and TXP); + RR.RPage:=Value shr 6; + case Value and 3 of + 2: StartOperation(Value); + 1: StopOperation(Value); + end; + end + else if Index=NIC_DATA then + begin + if (RR.CR and (RD1 or STA))<>0 then + begin + if RR.FWriteDMABufAddr=0 then + RR.ISR:=RR.ISR and (not RDC); + if (RR.FWriteDMABufAddr=RR.RBC) then // transfer from DMA to send buffer + begin + tps:=RR.TPSR mod MEM_TOT_SIZE; + ii:=min(RR.FWriteDMABufAddr, RR.RBC); + CopyMemory(@FBuffer[tps], @FWriteDMABuf[0], min(ii, MEM_TOT_SIZE-tps)); + if ii > MEM_TOT_SIZE-tps then + CopyMemory(@FBuffer[0], @FWriteDMABuf[MEM_TOT_SIZE-tps], ii-(MEM_TOT_SIZE-tps)); + RR.ISR:=RR.ISR or RDC; + end; + end; + end; + end + else + case RR.RPage of + 0: case Index of + $01: RR.PSTART:=MemAddr(Value); // Current Local DMA Address beg PSTART PAR0 CR9346 + $02: RR.PSTOP:=MemAddr(Value); // Current Local DMA Address end PSTOP PAR1 BPAGE + $03: RR.BNRY:=MemAddr(Value); // Boundary Pointer BNDRY PAR2 + $04: RR.TPSR:=MemAddr(Value); // Transmit Page Start Register TPSR PAR3 CONFIG1 + $05: PWORD2BYTE(pointer(@RR.TBC))^.low:=Value; // Number of Collisions Register TBCR0 PAR4 CONFIG2 + $06: PWORD2BYTE(pointer(@RR.TBC))^.hig:=Value; // TBCR1 PAR5 CONFIG3 + $07: begin + RR.ISR:=RR.ISR and (not Value); // Interupt Status Register ISR CURR TEST + end; + $08: PWORD2BYTE(pointer(@RR.RSA))^.low:=Value; // Current Remote DMA Address 0 RSAR0 MAR0 + $09: PWORD2BYTE(pointer(@RR.RSA))^.hig:=Value; // Current Remote DMA Address 1 RSAR1 MAR1 HLTCLK + $0A: PWORD2BYTE(pointer(@RR.RBC))^.low:=Value; // Reserved RBCR0 MAR2 + $0B: PWORD2BYTE(pointer(@RR.RBC))^.hig:=Value; // Reserved RBCR1 MAR3 + $0C: begin + RR.RCR:=Value; // Receive Configuration Register RCR MAR4 FMWP + if Assigned(FEthThread) then + begin + FEthThread.Promiscuous:=(RR.RCR and PRO)<>0; + FEthThread.AcceptMulticast:=(RR.RCR and AM)<>0; + FEthThread.AcceptBroadcast:=(RR.RCR and AB)<>0; + FEthThread.AcceptRunt:=(RR.RCR and AR)<>0; + end; + end; + $0D: RR.TCR:=Value; // Transmit configuration register TCR MAR5 + $0E: begin + RR.DCR:=Value; // Data Configuration Register DCR MAR6 + if (RR.DCR and WTS)=0 then + RR.FDMAWordSize:=1 + else + RR.FDMAWordSize:=2; + end; + $0F: RR.IMR:=Value; // Interrupt Mask Register IMR MAR7 + end; + 1:begin + case Index of + $01: RR.PAR0:=Value; // Physical Address Register 0 CLDA0 PAR0 PSTART CR9346 + $02: RR.PAR1:=Value; // Physical Address Register 1 CLDA1 PAR1 PSTOP BPAGE + $03: RR.PAR2:=Value; // Physical Address Register 2 BNDRY PAR2 CONFIG0 + $04: RR.PAR3:=Value; // Physical Address Register 3 TSR PAR3 TPSR CONFIG1 + $05: RR.PAR4:=Value; // Physical Address Register 4 NCR PAR4 CONFIG2 + $06: RR.PAR5:=Value; // Physical Address Register 5 FIFO PAR5 CONFIG3 + $07: RR.CURR:=MemAddr(Value); // Current Page Register ISR CURR + $08: RR.MAR0:=Value; // Multicast Address Register 0 CRDA0 MAR0 CSNSAV + $09: RR.MAR1:=Value; // Multicast Address Register 1 CRDA1 MAR1 + $0A: RR.MAR2:=Value; // Multicast Address Register 2 RES1 MAR2 + $0B: RR.MAR3:=Value; // Multicast Address Register 3 RES2 MAR3 INTR + $0C: RR.MAR4:=Value; // Multicast Address Register 4 RSR MAR4 RCR + $0D: RR.MAR5:=Value; // Multicast Address Register 5 CNTR0 MAR5 TCT CONFIG4 + $0E: RR.MAR6:=Value; // Multicast Address Register 6 CNTR1 MAR6 DCR + $0F: RR.MAR7:=Value; // Multicast Address Register 7 CNTR2 MAR7 IMR + end; + if (index<$07) and Assigned(FEthThread) then + FEthThread.MACAddr:=pointer(@RR.PAR0); + end; + end; +end; + +procedure TNE2kDevice.ReadFromStream(Stream: TStream); +begin + inherited; + Stream.Read(RR, sizeof(RR)); +end; + +procedure TNE2kDevice.SaveToStream(Stream: TStream); +begin + inherited; + Stream.Write(RR, sizeof(RR)); +end; + +procedure TNE2kDevice.StartOperation(CR: byte); +var pc: PChar; + sz: integer; +begin + CheckIncomingFrame; + RR.ISR:=RR.ISR and (not RST); + if (CR and RD0)<>0 then // remote read + begin + if (CR and STA)<>0 then + begin + RR.FReadDMABufAddr:=0; + pc:=@FBuffer[RR.RSA mod MEM_TOT_SIZE]; + sz:=min(sizeof(FReadDMABuf)-1, RR.RBC); + if (RR.PSTOP>RR.RSA) then // do not read out of buffer + begin + CopyMemory(@FReadDMABuf[0], pc, min(sz, RR.PSTOP-RR.RSA)); + if sz>(RR.PSTOP-RR.RSA) then + CopyMemory(@FReadDMABuf[RR.PSTOP-RR.RSA], @FBuffer[RR.PSTART mod MEM_TOT_SIZE], sz-(RR.PSTOP-RR.RSA)); + RR.ISR:=RR.ISR or RDC; + end; + end; + end + else if (CR and RD1)<>0 then // remote write + begin + if (CR and STA)<>0 then + RR.FWriteDMABufAddr:=0; + end + else if (CR and STA)<>0 then // complete DMA operation or transmit + begin + if ((CR and RD2)<>0) then + RR.FReadDMABufAddr:=0; + if (CR and TXP)<>0 then // send + begin +// pc:=@FBuffer[RR.TPSR mod MEM_TOT_SIZE]; + if Assigned(FEthThread) and + FEthThread.PutPacket({pc^}FWriteDMABuf, min(RR.TBC, sizeof(TFrame))) then // actually send packet + begin + RR.ISR:=RR.ISR or PTX; + RR.TSR:=RR.TSR or TPTX; + end + else + begin + RR.ISR:=RR.ISR and (not PTX); + RR.TSR:=RR.TSR and (not TPTX); + end; + RR.CR:=RR.CR and (not TXP); + end; + RR.ISR:=RR.ISR or RDC; + end; +end; + +procedure TNE2kDevice.StopOperation(CR: byte); +begin +// RR.ISR:=RR.ISR and (not RST); +end; + +procedure TNE2kDevice.CheckIncomingFrame; +var + len, adr: integer; + RRCURR: WORD; + pb, pc: PBYTE; + procedure IncCntr(var Cntr:byte); begin if Cntr=255 then RR.ISR:=RR.ISR or CNT; Cntr:=Cntr+1; end; +begin + if Assigned(FEthThread) then + with FEthThread do + begin + Start; + pc:=nil; + adr:=0; + RRCURR:=RR.CURR; + len:=GetPacket(FTmpDMABuf); + if len>0 then begin + // TODO: check frame CRC here, setup RSR^CRC, RR.CNTR1, ISR^RXE + if IsPhysical(@FTmpDMABuf[0]) then + RR.RSR:=RR.RSR and (not PHY) + else + RR.RSR:=RR.RSR or PHY; + if (RR.RCR and MON)<>0 then + RR.RSR:=RR.RSR or DIS + else + begin // write to receive buffer + RR.RSR:=RR.RSR and (not DIS); + pb:=GetNextBuffPage; // get address and move buffer pointer (RR.CURR) + if Assigned(pb) then + begin // When all the bytes are loaded, + pc:=pb; + inc(pb); // the RSR (Receive Status Register) status, + inc(pb); // a pointer to the next frame + PWORD(pointer(pb))^:=WORD(len+4); + inc(pb); // and the byte count of the current frame are written into the 4-byte offset. + inc(pb); + CopyMemory(pb, @FTmpDMABuf[adr], MEM_PAGE_SIZE-4); + end + else + len:=-1; + adr:=adr+MEM_PAGE_SIZE-4; + while adr0) then // are some errors? - ToVerify: MPA bit processing = how to ??? + begin + RR.RSR:=RR.RSR and (not PRX); // reseived with errors + RR.ISR:=RR.ISR and (not PRX); + end + else + begin + RR.RSR:=RR.RSR or PRX; // reseived with no errors + if len>0 then + RR.ISR:=RR.ISR or PRX; + end; + if Assigned(pc) then + begin + pc^:=RR.RSR; + inc(pc); + pc^:=hi(RR.CURR); + end; + end; +end; + +function TNE2kDevice.GetNextBuffPage: pointer; + function IncCURR(CUR:WORD):WORD; + begin + Result:=CUR+MEM_PAGE_SIZE; + if Result>=RR.PSTOP then + Result:=RR.PSTART; + end; +begin + Result:=nil; + if hi(IncCURR(RR.CURR))=hi(RR.BNRY) then + exit; + Result:=@FBuffer[RR.CURR mod MEM_TOT_SIZE]; + RR.CURR:=IncCURR(RR.CURR); +end; + +{ T8019AS } + +constructor T8019AS.Create; +begin + inherited; +end; + +procedure T8019AS.Reset; +begin + inherited; + FillChar(RRR, sizeof(RRR), 0); + RRR.ID8019:=$7050; + RRR.CONFIG1:=$80; + RRR.CONFIG3:=$01; + RRR.HLTCLK:=$FF; +end; + +procedure T8019AS.ReadFromStream(Stream: TStream); +begin + inherited; + Stream.Read(RRR, sizeof(RRR)); +end; + +procedure T8019AS.SaveToStream(Stream: TStream); +begin + inherited; + Stream.Write(RRR, sizeof(RRR)); +end; + +function T8019AS.GetData(Index: Integer): byte; +begin + if (RR.RPAGE=0) and (Index=$0A) then + Result:=lo(RRR.ID8019) // Reserved RES1 MAR2 + else if (RR.RPAGE=0) and (Index=$0B) then + Result:=hi(RRR.ID8019) // Reserved RES2 MAR3 INTR + else if (RR.RPAGE=3) and (Index>0) then + case Index of + $01: Result:=RRR.CR9346; // CLDA0 PAR0 PSTART CR9346 + $02: Result:=RRR.BPAGE; // CLDA1 PAR1 PSTOP BPAGE + $03: Result:=RRR.CONFIG0; // BNDRY PAR2 CONFIG0 + $04: Result:=RRR.CONFIG1; // TSR PAR3 TPSR CONFIG1 + $05: Result:=RRR.CONFIG2; // NCR PAR4 CONFIG2 + $06: Result:=RRR.CONFIG3; // FIFO PAR5 CONFIG3 + $07: Result:=RRR.TEST; // ISR CURR + $08: Result:=RRR.CSNSAV; // CRDA0 MAR0 CSNSAV + $0B: Result:=RRR.INTR; // RES2 MAR3 INTR + $0D: Result:=RRR.CONFIG4; // CNTR0 MAR5 TCT CONFIG4 + end + else Result:=inherited GetData(Index); +end; + +procedure T8019AS.SetData(Index: Integer; const Value: byte); +begin + if (RR.RPAGE=3) and (Index>0) then + case Index of + $01: RRR.CR9346:=(RRR.CR9346 and 1)or(Value and $FE); // CLDA0 PAR0 PSTART CR9346 + $02: RRR.BPAGE := Value; // CLDA1 PAR1 PSTOP BPAGE + $04: if (RRR.CR9346 and $C0)=$C0 then + RRR.CONFIG1:=(RRR.CONFIG1 and $7F)or(Value and $80); // TSR PAR3 TPSR CONFIG1 + $05: if (RRR.CR9346 and $C0)=$C0 then + RRR.CONFIG2:=(RRR.CONFIG2 and $1F)or(Value and $E0); // TSR PAR3 TPSR CONFIG2 + $06: if (RRR.CR9346 and $C0)=$C0 then + RRR.CONFIG3:=(RRR.CONFIG3 and $06)or(Value and $F9); // TSR PAR3 TPSR CONFIG3 + $07: RRR.TEST := Value; // ISR CURR + $09: RRR.HLTCLK := Value; // CRDA0 MAR0 HLTCLK + $0C: if (RRR.CR9346 and $C0)=$C0 then + RRR.FMWP := Value; // RES2 MAR3 FMWP + end + else inherited SetData(Index, Value); +end; + +initialization + F8019AS:=nil; + +finalization + if Assigned(F8019AS) then F8019AS.Free; + +end. + diff --git a/mod8255.pas b/mod8255.pas new file mode 100644 index 0000000..e9d8c35 --- /dev/null +++ b/mod8255.pas @@ -0,0 +1,753 @@ +///////////////////////////////////////////////////////////////////////// +// // +// Orion/Z (Orion-128 + Z80-CARD-II) emulator, version 1.9 // +// // +// Author: Sergey A. // +// // +// Copyright (C) 2006-2016 Sergey A. // +// // +// This program is free software; you can redistribute it and/or // +// modify it in any ways. // +// This program is distributed "AS IS" 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 mod8255; + +{*********************************************** + + i8255 (580ВB55) emulation + + ***********************************************} + +interface + +{$I 'OrionZEm.inc'} + +Uses Windows, SysUtils, classes, modF600, Forms, mainwin; + +type + TKbdType = (RK86, MS7007spb, MS7007msk); +// RK86: PA(0)=out, PB(1)=in, hi(PC(2))=in: CC=D5, УС=D6, Р/Л=D7; D3=out=инд.Р/Л +// MS7007spb: PA(0)=out, PB(1)=in, hi(PC(2))=in +// MS7007msk: PA(0)=in, PB(1)=out, lo(PC(2))=out + +const +// PC scan codes are in WinAPI GetKeyboardState routine format + +KeyMatrixMCspb: array[0..7, 0..10] of byte = +{s D0} (( ord('0'),ord('9'),VK_NUMPAD6,VK_INSERT, VK_END, {?} $BF, {-} $BD, {:} $BA, VK_NUMPAD9,VK_RETURN,VK_NUMPAD3), +{c D1} ( ord('7'),ord('8'), VK_F1, VK_F2, VK_F3, VK_F4, VK_F5,ord('4'), {num*}$6A, VK_ESCAPE, {+} $BB ), +{a D2} ( {[} $DB, {]} $DD, ord('1'), ord('2'), ord('3'), ord('5'), ord('6'),ord('E'),VK_SUBTRACT, VK_TAB, ord('J')), +{n D3} ( ord('L'),ord('D'), ord('C'), ord('U'), ord('K'), ord('N'), ord('G'),ord('P'), 0, VK_CAPITAL,ord('F')), +{c D4} ( ord('B'),{Ю@} $C0, ord('Y'), ord('W'), ord('A'), ord('R'), ord('O'),ord('I'), 0, 0, ord('Q')), +{o D5} ( VK_LEFT, {<} $BC, {'} $DE, ord('S'), ord('M'), ord('T'), ord('X'),VK_SPACE, VK_SHIFT,VK_CONTROL,{фикс=РусLat}0), +{d D6} ( {\} $DC,ord('V'),VK_NUMPAD4, VK_ADD, VK_BACK, VK_DOWN, {>}$BE, VK_RIGHT,VK_NUMPAD7,VK_NUMPAD0,VK_NUMPAD1), +{e D7} ( ord('H'),ord('Z'),VK_NUMPAD5,{ИСП}VK_F6, VK_HOME, VK_UP, VK_DIVIDE,VK_RETURN,VK_NUMPAD8, {num.}$6E,VK_NUMPAD2)); +{result D0 D1 D2 D3 D4 D5 D6 D7 CD5 CD6 CD7 } + +KeyMatrixMCmsk: array[0..7, 0..10] of byte = // true MC7007 layout +{r D0} (( {num*}$6A, VK_ESCAPE, {+} $BB , VK_F1, VK_F2, VK_F3, ord('4'), VK_F4, VK_F5, ord('7'),ord('8')), +{e D1} (VK_SUBTRACT, VK_TAB, ord('J') , ord('1'), ord('2'), ord('3'), ord('E'), ord('5'), ord('6'), {[} $DB, {]} $DD), +{s D2} ( 0, VK_CAPITAL, ord('F') , ord('C'), ord('U'), ord('K'), ord('P'), ord('N'), ord('G'), ord('L'),ord('D')), +{u D3} ( 0, 0, ord('Q') , ord('Y'), ord('W'), ord('A'), ord('I'), ord('R'), ord('O'), ord('B'),{Ю@} $C0), +{l D4} ( VK_SHIFT, VK_CONTROL,{фикс=RL}0, {'} $DE, ord('S'), ord('M'), VK_SPACE, ord('T'), ord('X'), VK_LEFT, {<} $BC), +{t D5} ( VK_NUMPAD7, VK_NUMPAD0,VK_NUMPAD1,VK_NUMPAD4, VK_ADD, VK_BACK, VK_RIGHT, VK_DOWN, {>}$BE, {\} $DC,ord('V')), +{ D6} ( VK_NUMPAD8, {num.}$6E,VK_NUMPAD2,VK_NUMPAD5,{ИСП}VK_F6, VK_HOME,VK_RETURN, VK_UP,VK_DIVIDE, ord('H'),ord('Z')), +{ D7} ( VK_NUMPAD9, VK_RETURN,VK_NUMPAD3,VK_NUMPAD6,VK_INSERT, VK_END, {:} $BA, {?} $BF, {-} $BD, ord('0'),ord('9'))); +{scancode D0 D1 D2 D3 D4 D5 D6 D7 CD0 CD1 CD2 } + + KeyMatrixRK86: array [0..1, 0..7, 0..7] of byte = + (((VK_HOME,VK_INSERT, VK_ESCAPE, VK_F1, VK_F2, VK_F3, VK_F4, VK_F5), // D0 - + (VK_TAB, VK_END, VK_RETURN, VK_BACK, VK_LEFT, VK_UP, VK_RIGHT, VK_DOWN), // D1 \ + (ord('0'), ord('1'), ord('2'), ord('3'), ord('4'), ord('5'), ord('6'), ord('7')), // D2 \ + (ord('8'), ord('9'), {:} $BA, {+} $BB, {<} $BC, {-} $BD, {>} $BE, {?} $BF), // D3 \ + ({Ю@} $C0, ord('A'), ord('B'), ord('C'), ord('D'), ord('E'), ord('F'), ord('G')), // D4 / scan code + (ord('H'), ord('I'), ord('J'), ord('K'), ord('L'), ord('M'), ord('N'), ord('O')), // D5 / + (ord('P'), ord('Q'), ord('R'), ord('S'), ord('T'), ord('U'), ord('V'), ord('W')), // D6 / + (ord('X'), ord('Y'), ord('Z'),{ [ } $DB, {\} $DC, { ] } $DD, {'} $DE, VK_SPACE)), // D7 - +// D0 D1 D2 D3 D4 D5 D6 D7 -------------------> result + (( 0, 0, 0, 0, 0, 0, VK_NEXT, 0), + ( 0, 0, 0, 0, 0, 0, 0, 0), + (VK_NUMPAD0,VK_NUMPAD1,VK_NUMPAD2,VK_NUMPAD3,VK_NUMPAD4,VK_NUMPAD5,VK_NUMPAD6,VK_NUMPAD7), + (VK_NUMPAD8,VK_NUMPAD9,VK_MULTIPLY,VK_ADD, 0, VK_SUBTRACT, 0, VK_DIVIDE), + ( 0, 0, 0, 0, 0, 0, 0, 0), + ( 0, 0, 0, 0, 0, 0, 0, 0), + ( 0, 0, 0, 0, 0, 0, 0, 0), + ( 0, 0, 0, 0, 0, 0, 0, 0))); + +type + TRusLat = packed record + name: string; + code: integer; + end; + +const + KBD_ADDR0 = $F400; + ROMD_ADDR0 = $F500; + ROM_PAGES_PORT = $FE; // $FC d0..d3 bits selects 16 ROM pages + MaxRusLat = 2; + KeyRusLatArr: array [0..MaxRusLat] of TRusLat = + ((name: 'VK_F8'; code: VK_F8), + (name: 'VK_F9'; code: VK_F9), + (name: 'VK_SCROLL'; code: VK_SCROLL)); + +type + T8255 = class(TObject) + R: array [0..3] of byte; // Registers + function GetData(Index: Integer): byte; // emulate CPU reading from internal registers + procedure SetData(Index: Integer; const Value: byte); // emulate CPU writing to internal registers + protected + function GetPort(Index: Integer): byte; virtual; abstract; // interface with device + procedure SetPort(Index: Integer; const Value: byte); virtual; abstract; // interface with device + property Port[Index: Integer]:byte read GetPort write SetPort; + public + constructor Create; virtual; + procedure Reset; + procedure SaveToStream(Stream: TStream); virtual; + procedure ReadFromStream(Stream: TStream); virtual; + property Registers[Index: Integer]:byte read GetData write SetData; default; // interface with CPU + end; + + TPortF400 = class(T8255) // keyboard + FPA, FPB, FPC: byte; + private + FKbdType: TKbdType; + FLcdRusLat: boolean; + procedure SetKbdType(const Value: TKbdType); + protected + function GetPort(Index: Integer): byte; override; // interface with device + procedure SetPort(Index: Integer; const Value: byte); override; // interface with device + public + constructor Create; override; + procedure SaveToStream(Stream: TStream); override; + procedure ReadFromStream(Stream: TStream); override; + property KbdType:TKbdType read FKbdType write SetKbdType; + property LcdRusLat:boolean read FLcdRusLat; + end; + + TPortF500 = class(T8255) + FAddrLo, FAddrHi: byte; // PB, PC - address in ROMDISK + protected + function GetPort(Index: Integer): byte; override; // interface with device + procedure SetPort(Index: Integer; const Value: byte); override; // interface with device + public + constructor Create; override; + procedure SaveToStream(Stream: TStream); override; + procedure ReadFromStream(Stream: TStream); override; + end; + + TPortF600 = class(T8255) + private + function GetPluginStr: string; + procedure SetPluginStr(St: string); + protected + FIndex: integer; + FPluginName: string; + FPluginFunc: TF600Function; + FDll: HMODULE; + FAppParams: TApplicationParams; + PAppParams: PApplicationParams; + function GetPort(Index: Integer): byte; override; // interface with device + procedure SetPort(Index: Integer; const Value: byte); override; // interface with device + procedure FreePluginLibrary; + function MyAppParams:PApplicationParams; + public + constructor Create; override; + destructor Destroy; override; + procedure ConfigurePlugin; + procedure Flush; + property Plugin: string read GetPluginStr write SetPluginStr; // '"Plugin_full_file_name","Plugin_Function_Index" + property FuncIdx: integer read FIndex write FIndex; + end; + +var + PortF400: TPortF400; + PortF500: TPortF500; + PortF600: TPortF600; + + KEYBRD: TKeyboardState; // array[0..255] of byte + KeyDelay: integer; + ROMDISK: array of byte; + ROMDISKlen: integer; + PFEEnabled: boolean = False; // ROM-disk paging register + KeyRusLat: integer = VK_F8; + KeybType: integer = 0; + KeyExtender: Boolean = False; + F600Plugin: String; // '"Plugin_full_file_name","Plugin_Function_Index" + F600Index: integer; + + InkeyQueue: string; + +implementation + +Uses modOrion; + +{ T8255 } + +function T8255.GetData(Index: Integer): byte; +var b1, b2: byte; +begin + case Index of + 0: if (R[3] and $10 <>0) + then Result:=Port[0] + else Result:=R[0]; + 1: if (R[3] and 2 <>0) + then Result:=Port[1] + else Result:=R[1]; + 2: begin + if (R[3] and 1 <>0) + then b1:=Port[2] and $0F + else b1:=R[2] and $0F; + if (R[3] and 8 <>0) + then b2:=Port[2] and $F0 + else b2:=R[2] and $F0; + Result:=b1 or b2; + end; + 3: Result:=R[3]; + else Result:=0; // Invalid address + end; +end; + +procedure T8255.Reset; // Initialize all registers and ports +begin + R[0]:=0; Port[0]:=0; + R[1]:=0; Port[1]:=0; + R[2]:=0; Port[2]:=0; + R[3]:=$9B; +end; + +procedure T8255.SetData(Index: Integer; const Value: byte); +var b1, b2, V: byte; +begin + case Index of + 0, 1, 2: R[Index]:=Value; // Data registers + 3: if (Value and $80 <>0) // Control register + then R[Index]:=Value // mode2 + else begin // mode1 + b1 := 1 shl ((Value and $0E) shr 1); + if (Value and $01 <>0) + then R[2] := R[2] or b1 + else R[2] := R[2] and (not b1); + end + else raise Exception.CreateFmt('Wrong i8255 register address: %d', [Index]); + end; +{ Set output ports } + V:=R[3]; + if (V and $10 <>0) + then Port[0]:=0 + else Port[0]:=R[0]; + if (V and 2 <>0) + then Port[1]:=0 + else Port[1]:=R[1]; + if (V and 1 <>0) then b1:=0 else b1:=R[2] and $0F; + if (V and 8 <>0) then b2:=0 else b2:=R[2] and $F0; + Port[2] := b1 or b2; +end; + +constructor T8255.Create; +begin + inherited; +end; + +procedure T8255.ReadFromStream(Stream: TStream); +begin + Stream.Read(R, sizeof(R)); +end; + +procedure T8255.SaveToStream(Stream: TStream); +begin + Stream.Write(R, sizeof(R)); +end; + +{ TPortF400 } + +constructor TPortF400.Create; // PA(0)=out, PB(1)=in, hi(PC(2))=in +begin + inherited; + Reset; + FKbdType := RK86; +end; + +function TPortF400.GetPort(Index: Integer): byte; +var i, j: integer; + xPA: byte; + xPB: word; + ctrl: byte; + procedure KeyOn(scan: byte); + begin + KEYBRD[scan]:=(KEYBRD[scan] xor 1) or $80; + end; + procedure KeyOff(scan: byte); + begin + KEYBRD[scan]:=(KEYBRD[scan] {xor 1}) and 1; + end; + procedure CtrlQ(scan: byte; key: char); + begin +// KeyOff(scan); KeyOn(ord('Q')); KeyOn(VK_CONTROL); +// insert(#31, InkeyQueue, 1); // delay +// insert(key, InkeyQueue, 1); +// insert(#31, InkeyQueue, 1); // delay + end; +begin + Result:=0; + ctrl:=KEYBRD[VK_CONTROL]; + if Length(InkeyQueue)>0 then + begin + for i:=0 to sizeof(KEYBRD)-1 do KeyOff(KEYBRD[i]); + if InkeyQueue[1]>=' ' then + KeyOn(ord(InkeyQueue[1])) + else + if InkeyQueue[1]<#31 then begin + KeyOn(VK_CONTROL); + KeyOn(ord(InkeyQueue[1])+$40); + end; + delete(InkeyQueue, 1, 1); + exit; + end; + if (KEYBRD[VK_PRIOR] and $80 <>0) then + begin + KeyOn(VK_CONTROL); + KeyOn(ord('R')); {PgUp=^R - for TurboPascal-style editors} + end; + if (KEYBRD[VK_DELETE] and $80 <>0) then + begin + KeyOn(VK_CONTROL); + KeyOn(ord('G')); {^G - delete symbol for TurboPascal-style editors} + end; + if KeyExtender then begin + if (ctrl and $80 <>0) then begin // CTRL pressed + if (KEYBRD[VK_LEFT] and $80 <>0) then begin // КУРСОР НА СЛОВО ВЛЕВО: CTRL-А + KeyOff(VK_LEFT); KeyOn(ord('A')); + end; + if (KEYBRD[VK_RIGHT] and $80 <>0) then begin // КУРСОР НА СЛОВО ВПРАВО: CTRL-F + KeyOff(VK_RIGHT); KeyOn(ord('F')); + end; + if (KEYBRD[VK_UP] and $80 <>0) then begin // ТЕКСТ НА СТРОКУ ВВЕРХ: CTRL-Z + KeyOff(VK_UP); KeyOn(ord('Z')); + end; + if (KEYBRD[VK_DOWN] and $80 <>0) then begin // ТЕКСТ НА СТРОКУ ВНИЗ: CTRL-W + KeyOff(VK_DOWN); KeyOn(ord('W')); + end; + if (KEYBRD[VK_PRIOR] and $80 <>0) then // КУРСОР В НАЧАЛО СТРАНИЦЫ: CTRL-Q-E + CtrlQ(VK_PRIOR, 'E'); + if (KEYBRD[VK_NEXT] and $80 <>0) then // КУРСОР В КОНЕЦ СТРАНИЦЫ: CTRL-Q-Х + CtrlQ(VK_NEXT, 'X'); + if (KEYBRD[VK_HOME] and $80 <>0) then // КУРСОР В НАЧАЛО ФАЙЛА: CTRL-Q-R + CtrlQ(VK_HOME, 'R'); + if (KEYBRD[VK_END] and $80 <>0) then // КУРСОР В КОНЕЦ ФАЙЛА: CTRL-Q-С + CtrlQ(VK_END, 'C'); + end + else + begin + if (KEYBRD[VK_INSERT] and $80 <>0) then begin // РЕЖИМ ВСТАВКИ (вкл./выкл.): CTRL-V + KeyOff(VK_INSERT); KeyOn(ord('V')); + KeyOn(VK_CONTROL); + end; + if (KEYBRD[VK_HOME] and $80 <>0) then // КУРСОР В НАЧАЛО СТРОКИ: CTRL-Q-S + CtrlQ(VK_HOME, 'S'); + if (KEYBRD[VK_END] and $80 <>0) then // КУРСОР В КОНЕЦ СТРОКИ: CTRL-Q-D + CtrlQ(VK_END, 'D'); + end; + end; {KeyExtender} + case FKbdType of + RK86: begin + case Index of + 1: begin + Result:=$FF; + xPA:=FPA; + for i:=0 to 7 do + if (xPA and (1 shl i) =0) then + for j:=0 to 7 do + if (KEYBRD[KeyMatrixRK86[0, i, j]] and $80 <>0) or // if main key pressed + (KEYBRD[KeyMatrixRK86[1, i, j]] and $80 <>0) then // or numpad key pressed + begin + Result:=Result and (not (1 shl j)); + if (KeyDelay>0) then sleep(KeyDelay); + end; + end; + 2: begin //CC=D5=0, УС=D6=0, Р/Л=D7=0 ; Р/Л=F12(tunable) + Result:=$FF; + if (KEYBRD[KeyRusLat] and $80 <>0) then + Result:=Result and $7F; // 01111111 + if (KEYBRD[VK_SHIFT] and $80 <>0) + then Result:=Result and $DF; // 11011111 + if (ctrl and $80 <>0) + then Result:=Result and $BF; // 10111111 + end; + end; + end; + MS7007spb: + begin + KeyMatrixMCspb[5,10]:=KeyRusLat; {"ФИКС"=РусLat} + if (KEYBRD[VK_NEXT] and $80 <>0) then KEYBRD[VK_F4]:=$81; {PgDn=^C - for TurboPascal-style editors} + Result:=$FF; + xPA:=FPA; + for i:=0 to 7 do + if (xPA and (1 shl i) =0) then + begin + if Index=1 then + begin + for j:=0 to 7 do + if (KEYBRD[KeyMatrixMCspb[i, j]] and $80 <>0) then // key pressed + begin + Result:=Result and (not (1 shl j)); + if (KeyDelay>0) then sleep(KeyDelay); + end; + end + else if Index=2 then + for j:=5 to 7 do + if (KEYBRD[KeyMatrixMCspb[i, j+3]] and $80 <>0) then // key pressed + begin + Result:=Result and (not (1 shl j)); + if (KeyDelay>0) then sleep(KeyDelay); + end + + end; + end; + MS7007msk: + if Index=0 then + begin + KeyMatrixMCmsk[4,2]:=KeyRusLat; {"ФИКС"=РусLat} + Result:=$FF; + xPB:=word(FPB) or (word(FPC and 7)shl 8); + for j:=0 to 10 do + if (xPB and (1 shl j) =0) then + begin + for i:=0 to 7 do + if (KEYBRD[KeyMatrixMCmsk[i, j]] and $80 <>0) then // key pressed + begin + Result:=Result and (not (1 shl i)); + if (KeyDelay>0) then sleep(KeyDelay); + end; + end; + end; + end; +// KEYBRD[VK_CONTROL]:=ctrl; +end; + +procedure TPortF400.ReadFromStream(Stream: TStream); +begin + inherited; + Stream.Read(FPA, sizeof(FPA)); + Stream.Read(FPB, sizeof(FPB)); + Stream.Read(FPC, sizeof(FPC)); + Stream.Read(FKbdType, sizeof(FKbdType)); + Stream.Read(FLcdRusLat, sizeof(FLcdRusLat)); +end; + +procedure TPortF400.SaveToStream(Stream: TStream); +begin + inherited; + Stream.Write(FPA, sizeof(FPA)); + Stream.Write(FPB, sizeof(FPB)); + Stream.Write(FPC, sizeof(FPC)); + Stream.Write(FKbdType, sizeof(FKbdType)); + Stream.Write(FLcdRusLat, sizeof(FLcdRusLat)); +end; + +procedure TPortF400.SetKbdType(const Value: TKbdType); +begin + FKbdType := Value; +end; + +procedure TPortF400.SetPort(Index: Integer; const Value: byte); +begin + case Index of + 0: FPA:=Value; + 1: FPB:=Value; + 2: begin + FLcdRusLat:=(Value and 8)<>0; + FPC:=Value; + end; + end; +end; + +{ TPortF500 } + +constructor TPortF500.Create; // PB(1), PC(2) - out (address:lo,hi), PA(0) - in (data) +begin + inherited; + Reset; +end; + +function TPortF500.GetPort(Index: Integer): byte; +var Addr: integer; +begin + case Index of + 0: begin + Addr:=FAddrHi * $100 + FAddrLo; + if PFEEnabled and (Z80CardMode<>Z80_ORIONPRO_v2) and (Z80CardMode<>Z80_ORIONPRO_v3) then + Addr:=Addr + ($10000 * MainPort[ROM_PAGES_PORT]); + if (Addr>=Length(ROMDISK)-1) then Result:=$FF + else Result:=ROMDISK[Addr]; + end; + else Result:=0; + end; +end; + +procedure TPortF500.ReadFromStream(Stream: TStream); +begin + inherited; + Stream.Read(FAddrLo, sizeof(FAddrLo)); + Stream.Read(FAddrHi, sizeof(FAddrHi)); +end; + +procedure TPortF500.SaveToStream(Stream: TStream); +begin + inherited; + Stream.Write(FAddrLo, sizeof(FAddrLo)); + Stream.Write(FAddrHi, sizeof(FAddrHi)); +end; + +procedure TPortF500.SetPort(Index: Integer; const Value: byte); +begin + case Index of + 1: FAddrLo:=Value; + 2: FAddrHi:=Value; + end; +end; + +{ TPortF600 } // customized port (based on plugin selected by user ) + +constructor TPortF600.Create; +begin + inherited; + Reset; + FDll:=0; + FIndex:=-1; + FPluginName:=''; + FPluginFunc:=nil; +end; + +destructor TPortF600.Destroy; +begin + inherited; + FPluginFunc:=nil; + FreePluginLibrary; +end; + +procedure TPortF600.FreePluginLibrary; +begin + If FDll=0 then exit; + if Assigned(FPluginFunc) then begin + MyAppParams; + FPluginFunc(FIndex, F600Func_UnLoad, pointer(PAppParams)); + end; + FreeLibrary(FDll); + FDll:=0; + FIndex:=-1; + FPluginName:=''; + FPluginFunc:=nil; +end; + +function TPortF600.GetPort(Index: Integer): byte; +begin + if not Assigned(FPluginFunc) then + Result:=0 + else begin + MyAppParams; + case Index of + 0: Result:=lo(FPluginFunc(FIndex, F600Func_PA_in, pointer(PAppParams))); + 1: Result:=lo(FPluginFunc(FIndex, F600Func_PB_in, pointer(PAppParams))); + 2: Result:=lo(FPluginFunc(FIndex, F600Func_PC_in, pointer(PAppParams))); + else Result:=0; + end; + end; +end; + +function TPortF600.MyAppParams: PApplicationParams; +begin + with FAppParams do begin + AppHandle:=Application.Handle; + aIcon:=Application.Icon.Handle; + MainInstance:=hInstance; + Wnd:=frmMain.Handle; + end; + PAppParams:=@FAppParams; +end; + +procedure TPortF600.ConfigurePlugin; +begin + MyAppParams; + if Assigned(FPluginFunc) and (FIndex>=0) then + FPluginFunc(FIndex, F600Func_Configure, pointer(PAppParams)); +end; + +procedure TPortF600.SetPluginStr(St: string); // '"Plugin_full_file_name","Plugin_Function_Index" +var + xDll: HMODULE; + xPluginFunc: TF600Function; +begin + st:=AnsiUpperCase(trim(st)); + if st=FPluginName then + exit + else if st='' then + begin + FreePluginLibrary; + exit; + end; + if not FileExists(st) then + raise Exception.CreateFmt('Plugin file not found:'#13#10#10'`%s`', [st]) + else begin + xDll:=LoadLibrary(PChar(st)); + if xDll=0 then + raise Exception.CreateFmt('Error during loading Plugin:'#13#10#10'`%s`', [st]) + else begin + xPluginFunc:=GetProcAddress(xDll, F600FuncName); + if not Assigned(xPluginFunc) then begin + FreeLibrary(xDll); + raise Exception.CreateFmt('Error obtainig entry point `%s` in Plugin:'#13#10#10'`%s`', [F600FuncName, st]) + end + else begin + FreePluginLibrary; + FDll:=xDll; + FPluginFunc:=xPluginFunc; + FPluginName:=st; + MyAppParams; + FPluginFunc(FIndex, F600Func_Load, pointer(PAppParams)); + end; + end; + end; +end; + +procedure TPortF600.SetPort(Index: Integer; const Value: byte); +var pch: PChar; +begin + if not Assigned(FPluginFunc) then + exit + else begin + pch:=@Value; + case Index of + 0: FPluginFunc(FIndex, F600Func_PA_out, pointer(pch)); + 1: FPluginFunc(FIndex, F600Func_PB_out, pointer(pch)); + 2: FPluginFunc(FIndex, F600Func_PC_out, pointer(pch)); + 3: FPluginFunc(FIndex, F600Func_PD_out, pointer(pch)); + end; + end; +end; + +function TPortF600.GetPluginStr: string; +begin + Result:=FPluginName; +end; + +procedure TPortF600.Flush; +begin + if Assigned(FPluginFunc) then begin + MyAppParams; + FPluginFunc(FIndex, F600Func_Flush, pointer(PAppParams)); + end; +end; + +initialization + InkeyQueue:=''; + PortF400:=TPortF400.Create; + PortF500:=TPortF500.Create; + PortF600:=TPortF600.Create; + +finalization + PortF400.Free; + PortF500.Free; + PortF600.Free; + +end. + + +{ + TURBO PASCAL KEYSTROKES + ----------------------- + + КУРСОР НА СИМВОЛ ВЛЕВО <-- CTRL-S + Перемещает курсор на символ влево в пределах строки. + КУРСОР НА СИМВОЛ ВПРАВО --> CTRL-D + Перемещает курсор на символ вправо в пределах строки. + КУРСОР НА СЛОВО ВЛЕВО ESC <-- CTRL-А + Перемещает курсор влево к началу предыдущего слова. Под словом + понимается последовательность символов, ограниченная пробелом + или любым из следующих символов: < > , ; . ( ) ^ ' * + - / $ + и пробелом. + КУРСОР НА СЛОВО ВПРАВО ESC --> CTRL-F + Перемещает курсор вправо к началу следующего слова (смотри + предыдущую команду). + КУРСОР НА СТРОКУ ВВЕРХ | CTRL-Е + Перемещает курсор на одну строку вверх. Если курсор находится + в верхней строке экрана, весь текст сдвигается вниз на одну + строку. + КУРСОР НА СТРОКУ ВНИЗ | CTRL-Х + Перемещает курсор на одну строку вниз. Если курсор находится в + нижней строке экрана, весь текст сдвигается вверх на одну + строку. + КУРСОР В НАЧАЛО СТРОКИ CTRL-Q-S + Перемещает курсор в первую позицию текущей строки. + КУРСОР В КОНЕЦ СТРОКИ CTRL-Q-D + Перемещает курсор в позицию, следующую за последним значащим + символом в строке (пробелы в конце строки всегда удаляются для + экономии памяти). + КУРСОР В НАЧАЛО СТРАНИЦЫ CTRL-Q-E + Перемещает курсор в верхнюю строку экрана. + КУРСОР В КОНЕЦ СТРАНИЦЫ CTRL-Q-Х + Перемещает курсор в нижнюю строку экрана. + КУРСОР В НАЧАЛО ФАЙЛА ESC - | CTRL-Q-R + Перемещает курсор к первому символу текста. + КУРСОР В КОНЕЦ ФАЙЛА ESC - | CTRL-Q-С + + Перемещает курсор к последнему символу текста. + КУРСОР В НАЧАЛО БЛОКА CTRL-Q-B + Перемещает курсор в позицию, отмеченную как "начало блока" + командой ОТМЕТИТЬ НАЧАЛО БЛОКА. Команда выполняется и в том + случае, когда индикация блока отключена или когда не определена + позиция "конец блока". + КУРСОР В КОНЕЦ БЛОКА CTRL-Q-K + Перемещает курсор в позицию, отмеченную как "конец блока" + командой ОТМЕТИТЬ КОНЕЦ БЛОКА. Команда выполняется и в том + случае, когда индикация блока отключена, или когда не определена + позиция "начало блока". + КУРСОР В ПРЕДЫДУЩУЮ ПОЗИЦИЮ CTRL-Q-Р + Перемещает курсор в позицию, занимаемую им до выполнения + предыдущей операции. Этой командой в частности, удобно + пользоваться после выполнения команды НАЙТИ, (НАЙТИ И ЗАМЕНИТЬ), + команды ЗАПИСЬ НА ДИСК основного меню и т.д. + ТЕКСТ НА СТРОКУ ВВЕРХ CTRL-Z + Текст на экране сдвигается на одну строку вверх. Курсор + остается на той же строке текста. + ТЕКСТ НА СТРОКУ ВНИЗ CTRL-W + Текст на экране сдвигается на одну строку вниз. Курсор + остается на той же строке текста. + ТЕКСТ НА СТРАНИЦУ ВВЕРХ CTRL-C + Текст файла сдвигается на страницу вверх относительно + фрагмента, отображенного на экране. Размер страницы на единицу + меньше, чем количество информационных строк на экране. Таким + образом, после выполнения команды на экране остается одна строка + от предыдущего фрагмента текста. + ТЕКСТ НА СТРАНИЦУ ВНИЗ CTRL-R + Текст файла сдвигается на страницу вниз относительно + фрагмента, отображенного на экране. Размер страницы на единицу + меньше, чем количество информационных строк на экране. Таким + образом, после выполнения команды на экране остается одна строка + от предыдущего фрагмента текста. + + 2. КОМАНДЫ ВСТАВКИ И УДАЛЕНИЯ + + 2.1 В эту группу входят команды, обеспечивающие вставку и + удаление символов, слов и строк. Кроме того, сюда отнесена + команда управления режимом вставки и команда, позволяющая + восстановить скорректированную строку, отменив сделанные в ней + изменения. + + РЕЖИМ ВСТАВКИ (вкл./выкд.) INS CTRL-V + Ввод текста при работе с редактором может осуществляться в + одном из двух режимов: режиме вставки или режиме замещения + текста. Если установлен режим вставки, очередной вводимый символ + помещается в позицию, на которую указывает курсор, а символ, + который находился в этой позиции, и все символы в строке справа + от него сдвигаются на одну позицию вправо. В режиме замещения + очередной вводимый символ замещает символ, находящийся в той же + позиции, на которую указывает курсор. + В строке состояния присутствует индикация установленного режима. + При вызове редактора по умолчанию устанавливается режим + вставки. +} diff --git a/modAY8912.pas b/modAY8912.pas new file mode 100644 index 0000000..806da68 --- /dev/null +++ b/modAY8912.pas @@ -0,0 +1,739 @@ +unit modAY8912; + + +{******************************************************************************* +' modAY8912.bas within DelphiSpec.dpr +' +' Routines for emulating the 128K Spectrum's AY-3-8912 sound generator +' +' Author: James Bagg +' +' With minor optimisations and mods by +' Chris Cowley +' +' Translation to Delphi Object Pascal by +' Jari Korhonen +' +' +' Copyright (C)1999-2000 Grok Developments Ltd and James Bagg +' http://www.grok.co.uk/ http://www.chipmunks-corner.co.uk +' +' This program is free software; you can redistribute it and/or +' modify it under the terms of the GNU General Public License +' as published by the Free Software Foundation; either version 2 +' of the License, or (at your option) any later version. +' This program is distributed in the hope that it will be useful, +' but WITHOUT ANY WARRANTY; without even the implied warranty of +' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +' GNU General Public License for more details. +' +' You should have received a copy of the GNU General Public License +' along with this program; if not, write to the Free Software +' Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +' +' *******************************************************************************/ +} + + +interface + + +{$I 'OrionZEm.inc'} + + +const + MAX_OUTPUT = 63; + AY_STEP: integer = 32768; + MAXVOL = $1F; + + // AY register ID's + AY_AFINE = 0; + AY_ACOARSE = 1; + AY_BFINE = 2; + AY_BCOARSE = 3; + AY_CFINE = 4; + AY_CCOARSE = 5; + AY_NOISEPER = 6; + AY_ENABLE = 7; + AY_AVOL = 8; + AY_BVOL = 9; + AY_CVOL = 10; + AY_EFINE = 11; + AY_ECOARSE = 12; + AY_ESHAPE = 13; + AY_PORTA = 14; + AY_PORTB = 15; + +type + RegArray = array[0..15] of integer; + VolTableArray = array[0..63] of integer; + + AY8912 = packed record + sampleRate: integer; + register_latch: integer; + Regs: RegArray; + UpdateStep: Double; + PeriodA: integer; + PeriodB: integer; + PeriodC: integer; + PeriodN: integer; + PeriodE: integer; + CountA: integer; + CountB: integer; + CountC: integer; + CountN: integer; + CountE: integer; + VolA: integer; + VolB: integer; + VolC: integer; + VolE: integer; + EnvelopeA: integer; + EnvelopeB: integer; + EnvelopeC: integer; + OutputA: integer; + OutputB: integer; + OutputC: integer; + OutputN: integer; + CountEnv: integer; + Hold: integer; + Alternate: integer; + Attack: integer; + Holding: integer; + VolTable2: VolTableArray; + end; + +var + AYPSG: AY8912; + AY_OutNoise: integer; + VolA: integer; + VolB: integer; + VolC: integer; + lOut1: integer; + lOut2: integer; + lOut3: integer; + AY_Left: integer; + AY_NextEvent: integer; +// Buffer_Length: integer; + + +procedure AY8912Update_8; +procedure AYWriteReg(r: integer; v: integer); +procedure AY8912_reset; +procedure AY8912_set_clock(clock: Double); +procedure AY8912_set_volume(volume: integer; gain: integer); + +function AYReadReg(r: integer): Byte; +function AY8912_init(clock: Double; sample_rate: integer; + sample_bits: integer): integer; +function RenderByte: integer; + + +implementation + +procedure AY8912_reset; + var i: integer; +begin + with AYPSG do + begin + register_latch := 0; + OutputA := 0; + OutputB := 0; + OutputC := 0; + OutputN := $FF; + PeriodA := 0; + PeriodB := 0; + PeriodC := 0; + PeriodN := 0; + PeriodE := 0; + CountA := 0; + CountB := 0; + CountC := 0; + CountN := 0; + CountE := 0; + VolA := 0; + VolB := 0; + VolC := 0; + VolE := 0; + EnvelopeA := 0; + EnvelopeB := 0; + EnvelopeC := 0; + CountEnv := 0; + Hold := 0; + Alternate := 0; + Holding := 0; + Attack := 0; + end; + + Randomize; + For i := 0 To AY_PORTA do + begin + AYWriteReg(i, 0); //* AYWriteReg() uses the timer system; we cannot + end; //* call it at this time because the timer system + //* has not been initialized. +end; + +procedure AY8912_set_clock(clock: Double); + var t1: Double; +begin + + {' /* the AY_STEP clock for the tone and noise generators is the chip clock */ + ' /* divided by 8; for the envelope generator of the AY-3-8912, it is half */ + ' /* that much (clock/16), but the envelope of the YM2149 goes twice as */ + ' /* fast, therefore again clock/8. */ + ' /* Here we calculate the number of AY_STEPs which happen during one sample */ + ' /* at the given sample rate. No. of events = sample rate / (clock/8). */ + ' /* AY_STEP is a multiplier used to turn the fraction into a fixed point */ + ' /* number.} + t1 := AY_STEP * AYPSG.sampleRate * 8.0; + AYPSG.UpdateStep := t1 / clock +end; + + +{' /* +' ** set output gain +' ** +' ** The gain is expressed in 0.2dB increments, e.g. a gain of 10 is an increase +' ** of 2dB. Note that the gain only affects sounds not playing at full volume, +' ** since the ones at full volume are already played at the maximum intensity +' ** allowed by the sound card. +' ** 0x00 is the default. +' ** 0xff is the maximum allowed value. +' */ } +procedure AY8912_set_volume(volume: integer; gain: integer); + var + i: integer; + out1: Double; + out2: Double; +begin + gain := gain and $FF; + + // increase max output basing on gain (0.2 dB per AY_STEP) */ + out1 := MAX_OUTPUT; + out2 := MAX_OUTPUT; + + while (gain > 0) do + begin + gain := gain - 1; + out1 := out1 * 1.023292992; ///* = (10 ^ (0.2/20)) */ + out2 := out2 * 1.023292992; + end; + + {' /* calculate the volume.voltage conversion table */ + ' /* The AY-3-8912 has 16 levels, in a logarithmic scale (3dB per AY_STEP) */ + ' /* The YM2149 still has 16 levels for the tone generators, but 32 for */ + ' /* the envelope generator (1.5dB per AY_STEP). */} + for i := 31 downto 0 do + begin + //* limit volume to avoid clipping */ + if (out2 > MAX_OUTPUT) then + AYPSG.VolTable2[i] := MAX_OUTPUT + else + AYPSG.VolTable2[i] := Round(out2); + + out1 := out1 / 1.188502227; // .188502227 '/* = 10 ^ (1.5/20) = 1.5dB */ + out2 := out2 / 1.188502227 // .188502227 + end; + AYPSG.VolTable2[63] := MAX_OUTPUT; +end; + +procedure AYWriteReg(r: integer; v: integer); + var + old: integer; +begin + AYPSG.Regs[r] := v; + + {'/* A note about the period of tones, noise and envelope: for speed reasons,*/ + '/* we count down from the period to 0, but careful studies of the chip */ + '/* output prove that it instead counts up from 0 until the counter becomes */ + '/* greater or equal to the period. This is an important difference when the*/ + '/* program is rapidly changing the period to modulate the sound. */ + '/* To compensate for the difference, when the period is changed we adjust */ + '/* our internal counter. */ + '/* Also, note that period = 0 is the same as period = 1. This is mentioned */ + '/* in the YM2203 data sheets. However, this does NOT apply to the Envelope */ + '/* period. In that case, period = 0 is half as period = 1. */} + case r of + AY_AFINE, AY_ACOARSE: + begin + AYPSG.Regs[AY_ACOARSE] := AYPSG.Regs[AY_ACOARSE] and $F; + + old := AYPSG.PeriodA; + + AYPSG.PeriodA := Round((AYPSG.Regs[AY_AFINE] + (256 * AYPSG.Regs[AY_ACOARSE])) + *AYPSG.UpdateStep); + + if (AYPSG.PeriodA = 0) then + AYPSG.PeriodA := Round(AYPSG.UpdateStep); + + AYPSG.CountA := AYPSG.CountA + (AYPSG.PeriodA - old); + + if (AYPSG.CountA <= 0) then + AYPSG.CountA := 1; + end; + AY_BFINE, AY_BCOARSE: + begin + AYPSG.Regs[AY_BCOARSE] := AYPSG.Regs[AY_BCOARSE] and $F; + + old := AYPSG.PeriodB; + + AYPSG.PeriodB := Round((AYPSG.Regs[AY_BFINE] + (256 * AYPSG.Regs[AY_BCOARSE])) + * AYPSG.UpdateStep); + + if (AYPSG.PeriodB = 0) then + AYPSG.PeriodB := Round(AYPSG.UpdateStep); + + AYPSG.CountB := AYPSG.CountB + AYPSG.PeriodB - old; + + if (AYPSG.CountB <= 0) then + AYPSG.CountB := 1 + end; + + AY_CFINE, AY_CCOARSE: + begin + AYPSG.Regs[AY_CCOARSE] := AYPSG.Regs[AY_CCOARSE] and $F; + + old := AYPSG.PeriodC; + + AYPSG.PeriodC := Round((AYPSG.Regs[AY_CFINE] + (256 * AYPSG.Regs[AY_CCOARSE])) + * AYPSG.UpdateStep); + + if (AYPSG.PeriodC = 0) then + AYPSG.PeriodC := Round(AYPSG.UpdateStep); + + AYPSG.CountC := AYPSG.CountC + (AYPSG.PeriodC - old); + + if (AYPSG.CountC <= 0) then + AYPSG.CountC := 1; + end; + + AY_NOISEPER: + begin + AYPSG.Regs[AY_NOISEPER] := AYPSG.Regs[AY_NOISEPER] and $1F; + + old := AYPSG.PeriodN; + + AYPSG.PeriodN := Round(AYPSG.Regs[AY_NOISEPER] * AYPSG.UpdateStep); + + if (AYPSG.PeriodN = 0) then + AYPSG.PeriodN := Round(AYPSG.UpdateStep); + + AYPSG.CountN := AYPSG.CountN + (AYPSG.PeriodN - old); + + if (AYPSG.CountN <= 0) then + AYPSG.CountN := 1; + end; + + AY_AVOL: + begin + AYPSG.Regs[AY_AVOL] := AYPSG.Regs[AY_AVOL] and $1F; + + AYPSG.EnvelopeA := AYPSG.Regs[AY_AVOL] and $10; + + if AYPSG.EnvelopeA <> 0 then + AYPSG.VolA := AYPSG.VolE + else + begin + if AYPSG.Regs[AY_AVOL] <> 0 then + AYPSG.VolA := AYPSG.VolTable2[AYPSG.Regs[AY_AVOL] * 2 + 1] + else + AYPSG.VolA := AYPSG.VolTable2[0]; + end; + end; + + AY_BVOL: + begin + AYPSG.Regs[AY_BVOL] := AYPSG.Regs[AY_BVOL] and $1F; + + AYPSG.EnvelopeB := AYPSG.Regs[AY_BVOL] and $10; + + if AYPSG.EnvelopeB <> 0 then + AYPSG.VolB := AYPSG.VolE + else + begin + if AYPSG.Regs[AY_BVOL] <> 0 then + AYPSG.VolB := AYPSG.VolTable2[AYPSG.Regs[AY_BVOL] * 2 + 1] + else + AYPSG.VolB := AYPSG.VolTable2[0]; + end; + end; + + AY_CVOL: + begin + AYPSG.Regs[AY_CVOL] := AYPSG.Regs[AY_CVOL] and $1F; + + AYPSG.EnvelopeC := AYPSG.Regs[AY_CVOL] and $10; + + if AYPSG.EnvelopeC <> 0 then + AYPSG.VolC := AYPSG.VolE + else + begin + if AYPSG.Regs[AY_CVOL] <> 0 then + AYPSG.VolC := AYPSG.VolTable2[AYPSG.Regs[AY_CVOL] * 2 + 1] + else + AYPSG.VolC := AYPSG.VolTable2[0]; + end; + end; + + AY_EFINE, AY_ECOARSE: + begin + old := AYPSG.PeriodE; + + AYPSG.PeriodE := Round(((AYPSG.Regs[AY_EFINE] + (256 * AYPSG.Regs[AY_ECOARSE]))) + * AYPSG.UpdateStep); + + if (AYPSG.PeriodE = 0) then + AYPSG.PeriodE := Round(AYPSG.UpdateStep / 2); + + AYPSG.CountE := AYPSG.CountE + (AYPSG.PeriodE - old); + + if (AYPSG.CountE <= 0) then + AYPSG.CountE := 1 + end; + + AY_ESHAPE: + begin + {'/* envelope shapes: + 'C AtAlH + '0 0 x x \___ + ' + '0 1 x x /___ + ' + '1 0 0 0 \\\\ + ' + '1 0 0 1 \___ + ' + '1 0 1 0 \/\/ + ' ___ + '1 0 1 1 \ + ' + '1 1 0 0 //// + ' ___ + '1 1 0 1 / + ' + '1 1 1 0 /\/\ + ' + '1 1 1 1 /___ + ' + 'The envelope counter on the AY-3-8910 has 16 AY_STEPs. On the YM2149 it + 'has twice the AY_STEPs, happening twice as fast. Since the end result is + 'just a smoother curve, we always use the YM2149 behaviour. + '*/} + if (AYPSG.Regs[AY_ESHAPE] <> $FF) then + begin + AYPSG.Regs[AY_ESHAPE] := AYPSG.Regs[AY_ESHAPE] and $F; + + if ((AYPSG.Regs[AY_ESHAPE] and $4) = $4) then + AYPSG.Attack := MAXVOL + else + AYPSG.Attack := $0; + + AYPSG.Hold := AYPSG.Regs[AY_ESHAPE] and $1; + + AYPSG.Alternate := AYPSG.Regs[AY_ESHAPE] and $2; + + AYPSG.CountE := AYPSG.PeriodE; + + AYPSG.CountEnv := MAXVOL; // &h1f + + AYPSG.Holding := 0; + + AYPSG.VolE := AYPSG.VolTable2[AYPSG.CountEnv xor AYPSG.Attack]; + + if (AYPSG.EnvelopeA <> 0) then + AYPSG.VolA := AYPSG.VolE; + + if (AYPSG.EnvelopeB <> 0) then + AYPSG.VolB := AYPSG.VolE; + + if (AYPSG.EnvelopeC <> 0) then + AYPSG.VolC := AYPSG.VolE; + end; + end; + end; //case +end; + +function AYReadReg(r: integer): Byte; +begin + AYReadReg := AYPSG.Regs[r]; +end; + +function AY8912_init(clock: Double; sample_rate: integer; sample_bits: integer): integer; +begin + AYPSG.sampleRate := sample_rate; + AY8912_set_clock(clock); + AY8912_set_volume(255, 12); + AY8912_reset; + AY8912_init := 0; +end; + +procedure AY8912Update_8; + var Buffer_Length: integer; +begin + + Buffer_Length := 400; + + { /* The 8910 has three outputs, each output is the mix of one of the three */ + ' /* tone generators and of the (single) noise generator. The two are mixed */ + ' /* BEFORE going into the DAC. The formula to mix each channel is: */ + ' /* (ToneOn | ToneDisable) & (NoiseOn | NoiseDisable). */ + ' /* Note that this means that if both tone and noise are disabled, the output */ + ' /* is 1, not 0, and can be modulated changing the volume. */ + + ' /* if the channels are disabled, set their output to 1, and increase the */ + ' /* counter, if necessary, so they will not be inverted during this update. */ + ' /* Setting the output to 1 is necessary because a disabled channel is locked */ + ' /* into the ON state (see above); and it has no effect if the volume is 0. */ + ' /* if the volume is 0, increase the counter, but don't touch the output. */} + + if (AYPSG.Regs[AY_ENABLE] and $1) = $1 then + begin + if AYPSG.CountA <= (Buffer_Length * AY_STEP) then + AYPSG.CountA := AYPSG.CountA + (Buffer_Length * AY_STEP); + + AYPSG.OutputA := 1; + end + else if (AYPSG.Regs[AY_AVOL] = 0) then + begin + {' /* note that I do count += Buffer_Length, NOT count = Buffer_Length + 1. You might think */ + ' /* it's the same since the volume is 0, but doing the latter could cause */ + ' /* interferencies when the program is rapidly modulating the volume. */} + if AYPSG.CountA <= (Buffer_Length * AY_STEP) then + AYPSG.CountA := AYPSG.CountA + (Buffer_Length * AY_STEP); + end; + + if (AYPSG.Regs[AY_ENABLE] and $2) = $2 then + begin + if AYPSG.CountB <= (Buffer_Length * AY_STEP) then + AYPSG.CountB := AYPSG.CountB + (Buffer_Length * AY_STEP); + + AYPSG.OutputB := 1; + end + else if AYPSG.Regs[AY_BVOL] = 0 then + begin + if AYPSG.CountB <= (Buffer_Length * AY_STEP) then + AYPSG.CountB := AYPSG.CountB + (Buffer_Length * AY_STEP); + end; + + if (AYPSG.Regs[AY_ENABLE] and $4) = $4 then + begin + if AYPSG.CountC <= (Buffer_Length * AY_STEP) then + AYPSG.CountC := AYPSG.CountC + (Buffer_Length * AY_STEP); + + AYPSG.OutputC := 1; + end + else if (AYPSG.Regs[AY_CVOL] = 0) then + begin + if AYPSG.CountC <= (Buffer_Length * AY_STEP) then + AYPSG.CountC := AYPSG.CountC + (Buffer_Length * AY_STEP); + end; + + {'/* for the noise channel we must not touch OutputN - it's also not necessary */ + '/* since we use AY_OutNoise. */} + if ((AYPSG.Regs[AY_ENABLE] and $38) = $38) then //* all off */ + begin + if AYPSG.CountN <= (Buffer_Length * AY_STEP) then + AYPSG.CountN := AYPSG.CountN + (Buffer_Length * AY_STEP); + end; + + AY_OutNoise := (AYPSG.OutputN Or AYPSG.Regs[AY_ENABLE]); +end; + + +function RenderByte: integer; +begin + VolA := 0; VolB := 0; VolC := 0; + + //vola, volb and volc keep track of how long each square wave stays + //in the 1 position during the sample period. + + AY_Left := AY_STEP; + + repeat + AY_NextEvent := 0; + + If (AYPSG.CountN < AY_Left) Then + AY_NextEvent := AYPSG.CountN + Else + AY_NextEvent := AY_Left; + + If (AY_OutNoise And $8) = $8 Then + begin + If (AYPSG.OutputA = 1) Then VolA := VolA + AYPSG.CountA; + + AYPSG.CountA := AYPSG.CountA - AY_NextEvent; + + {PeriodA is the half period of the square wave. Here, in each + loop I add PeriodA twice, so that at the end of the loop the + square wave is in the same status (0 or 1) it was at the start. + vola is also incremented by PeriodA, since the wave has been 1 + exactly half of the time, regardless of the initial position. + If we exit the loop in the middle, OutputA has to be inverted + and vola incremented only if the exit status of the square + wave is 1. } + + While (AYPSG.CountA <= 0) do + begin + AYPSG.CountA := AYPSG.CountA + AYPSG.PeriodA; + If (AYPSG.CountA > 0) Then + begin + If (AYPSG.Regs[AY_ENABLE] And 1) = 0 Then AYPSG.OutputA := AYPSG.OutputA Xor 1; + If (AYPSG.OutputA<>0) Then VolA := VolA + AYPSG.PeriodA; + break; + end; + + AYPSG.CountA := AYPSG.CountA + AYPSG.PeriodA; + VolA := VolA + AYPSG.PeriodA; + end; + If (AYPSG.OutputA = 1) Then VolA := VolA - AYPSG.CountA; + end + Else + begin + AYPSG.CountA := AYPSG.CountA - AY_NextEvent; + + While (AYPSG.CountA <= 0) do + begin + AYPSG.CountA := AYPSG.CountA + AYPSG.PeriodA; + If (AYPSG.CountA > 0) Then + begin + AYPSG.OutputA := AYPSG.OutputA Xor 1; + break; + end; + AYPSG.CountA := AYPSG.CountA + AYPSG.PeriodA; + end; + end; + + If (AY_OutNoise And $10) = $10 Then + begin + If (AYPSG.OutputB = 1) Then VolB := VolB + AYPSG.CountB; + AYPSG.CountB := AYPSG.CountB - AY_NextEvent; + + While (AYPSG.CountB <= 0) do + begin + AYPSG.CountB := AYPSG.CountB + AYPSG.PeriodB; + If (AYPSG.CountB > 0) Then + begin + If (AYPSG.Regs[AY_ENABLE] And 2) = 0 Then AYPSG.OutputB := AYPSG.OutputB Xor 1; + If (AYPSG.OutputB<>0) Then VolB := VolB + AYPSG.PeriodB; + break; + end; + AYPSG.CountB := AYPSG.CountB + AYPSG.PeriodB; + VolB := VolB + AYPSG.PeriodB; + end; + If (AYPSG.OutputB = 1) Then VolB := VolB - AYPSG.CountB; + end + Else + begin + AYPSG.CountB := AYPSG.CountB - AY_NextEvent; + + While (AYPSG.CountB <= 0) do + begin + AYPSG.CountB := AYPSG.CountB + AYPSG.PeriodB; + If (AYPSG.CountB > 0) Then + begin + AYPSG.OutputB := AYPSG.OutputB Xor 1; + break; + end; + AYPSG.CountB := AYPSG.CountB + AYPSG.PeriodB; + end; + end; + + If (AY_OutNoise And $20) = $20 Then + begin + If (AYPSG.OutputC = 1) Then VolC := VolC + AYPSG.CountC; + AYPSG.CountC := AYPSG.CountC - AY_NextEvent; + While (AYPSG.CountC <= 0) do + begin + AYPSG.CountC := AYPSG.CountC + AYPSG.PeriodC; + If (AYPSG.CountC > 0) Then + begin + If (AYPSG.Regs[AY_ENABLE] And 4) = 0 Then AYPSG.OutputC := AYPSG.OutputC Xor 1; + If (AYPSG.OutputC<>0) Then VolC := VolC + AYPSG.PeriodC; + break; + end; + + AYPSG.CountC := AYPSG.CountC + AYPSG.PeriodC; + VolC := VolC + AYPSG.PeriodC; + end; + If (AYPSG.OutputC = 1) Then VolC := VolC - AYPSG.CountC; + end + Else + begin + AYPSG.CountC := AYPSG.CountC - AY_NextEvent; + While (AYPSG.CountC <= 0) do + begin + AYPSG.CountC := AYPSG.CountC + AYPSG.PeriodC; + If (AYPSG.CountC > 0) Then + begin + AYPSG.OutputC := AYPSG.OutputC Xor 1; + break; + end; + AYPSG.CountC := AYPSG.CountC + AYPSG.PeriodC; + end; + end; + + AYPSG.CountN := AYPSG.CountN - AY_NextEvent; + If (AYPSG.CountN <= 0) Then + begin + //Is noise output going to change? + AYPSG.OutputN := Round(random(510)); + AY_OutNoise := (AYPSG.OutputN Or AYPSG.Regs[AY_ENABLE]); + AYPSG.CountN := AYPSG.CountN + AYPSG.PeriodN; + end; + + AY_Left := AY_Left - AY_NextEvent; + until (AY_Left <= 0); + + + if (AYPSG.Holding = 0) then + begin + AYPSG.CountE := AYPSG.CountE - AY_STEP; + If (AYPSG.CountE <= 0) then + begin + repeat + AYPSG.CountEnv := AYPSG.CountEnv - 1; + AYPSG.CountE := AYPSG.CountE + AYPSG.PeriodE; + until (AYPSG.CountE > 0); + + //check envelope current position + if (AYPSG.CountEnv < 0) then + begin + if (AYPSG.Hold<>0) then + begin + if (AYPSG.Alternate<>0) then + begin + AYPSG.Attack := AYPSG.Attack xor MAXVOL; //$1f + end; + AYPSG.Holding := 1; + AYPSG.CountEnv := 0; + end + else + begin + //if CountEnv has looped an odd number of times (usually 1), + //invert the output. + If (AYPSG.Alternate<>0) and ((AYPSG.CountEnv and $20) = $20) then + begin + AYPSG.Attack := AYPSG.Attack xor MAXVOL; //$1f + end; + + AYPSG.CountEnv := AYPSG.CountEnv and MAXVOL; //$1f + end; + end; + + AYPSG.VolE := AYPSG.VolTable2[AYPSG.CountEnv xor AYPSG.Attack]; + + //reload volume + If (AYPSG.EnvelopeA <> 0) then AYPSG.VolA := AYPSG.VolE; + If (AYPSG.EnvelopeB <> 0) then AYPSG.VolB := AYPSG.VolE; + If (AYPSG.EnvelopeC <> 0) then AYPSG.VolC := AYPSG.VolE; + end; + end; + + lOut1 := (VolA * AYPSG.VolA) div 65535; + lOut2 := (VolB * AYPSG.VolB) div 65535; + lOut3 := (VolC * AYPSG.VolC) div 65535; + + RenderByte := lOut1 + lOut2 + lOut3; +end; + + +end. diff --git a/modF600.pas b/modF600.pas new file mode 100644 index 0000000..c66a2b7 --- /dev/null +++ b/modF600.pas @@ -0,0 +1,53 @@ +///////////////////////////////////////////////////////////////////////// +// // +// Orion/Z (Orion-128 + Z80-CARD-II) emulator, version 1.9 // +// // +// Author: Sergey A. // +// // +// Copyright (C) 2006-2016 Sergey A. // +// // +// This program is free software; you can redistribute it and/or // +// modify it in any ways. // +// This program is distributed "AS IS" 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 modF600; + +{ interface definitions for plugins emulating devices at extension port F600 } + +interface + +Uses Windows, Sysutils, Forms; + +const + F600FuncName='MainFunc'; // dll common entry point function name + F600Func_Load =0; // when module loaded + F600Func_UnLoad =1; // when module unloaded + F600Func_Configure=2; // when user press 'configure plugin' button + F600Func_Enumerate=3; // when OrionZEm read plugin for content (functions list - comma separated pairs "Title","index",...) + F600Func_Flush =4; // executed every second + F600Func_PA_in =5; // Port A signal read + F600Func_PA_out =6; // Port A signal write + F600Func_PB_in =7; // Port B signal read + F600Func_PB_out =8; // Port B signal write + F600Func_PC_in =9; // Port C signal read + F600Func_PC_out =10; // Port C signal write + F600Func_PD_out =11; // Port D signal out (8255 cfg register) + +type + TF600Function=function(fIndex:LongInt; fType:LongInt; var fDataPtr: pointer): LongInt; stdcall; // dll common entry point type function type + + TApplicationParams=packed record + AppHandle:THandle; + aIcon:HIcon; + MainInstance:LongInt; + Wnd:HWND; + end; + PApplicationParams=^TApplicationParams; + +implementation + +end. diff --git a/modHDD.pas b/modHDD.pas new file mode 100644 index 0000000..86fb753 --- /dev/null +++ b/modHDD.pas @@ -0,0 +1,1147 @@ +///////////////////////////////////////////////////////////////////////// +// // +// Orion/Z (Orion-128 + Z80-CARD-II) emulator, version 1.9 // +// // +// Author: Sergey A. // +// // +// Copyright (C) 2006-2016 Sergey A. // +// // +// This program is free software; you can redistribute it and/or // +// modify it in any ways. // +// This program is distributed "AS IS" 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. // +// // +///////////////////////////////////////////////////////////////////////// + + +{*********************************************** + + IDE (ATA) emulation + + ***********************************************} + +unit modHDD; + +interface + +Uses Windows, SysUtils, classes, mod8255, HDDUtils; + + +{$I 'OrionZEm.inc'} + +// +// C,B-data (inout), A-ctl (out) +// (because if ORDOS exists, its treat ROM-DISK on the same port +// and must not send dummy "random" signals into IDE) +// + +const + cfg_8255 = 3; // $F503; //8255 configuration register + ide_8255_lsb = 2; // $F502; //pC - lower 8 bits + ide_8255_msb = 1; // $F501; //pB - upper 8 bits + ide_8255_ctl = 0; // $F500; //pA - control lines + rd_ide_8255 = $8B; //ide_8255_ctl out, ide_8255_lsb/msb input + wr_ide_8255 = $80; //all three ports output + +//ide control lines for use with ide_8255_ctl. Change these 8 +//constants to reflect where each signal of the 8255 each of the +//ide control signals is connected. All the control signals must +//be on the same port, but these 8 lines let you connect them to +//whichever pins on that port. + + ide_a0_line = $01; //direct from 8255 to ide interface + ide_a1_line = $02; //direct from 8255 to ide interface + ide_a2_line = $04; //direct from 8255 to ide interface + ide_cs0_line = $08; //inverter between 8255 and ide interface + ide_cs1_line = $10; //inverter between 8255 and ide interface + ide_wr_line = $20; //inverter between 8255 and ide interface + ide_rd_line = $40; //inverter between 8255 and ide interface + ide_rst_line = $80; //inverter between 8255 and ide interface + +//------------------------------------------------------------------ +// More symbolic constants... these should not be changed, unless of +// course the IDE drive interface changes, perhaps when drives get +// to 128G and the PC industry will do yet another kludge. + +// Orion-PRO HDD-RTC card: +// 50H ; dannye CMOS +// 51H ; adres CMOS + pro_astatus = $56; // alxt.registr sostoqniq - R + pro_control = $56; // registr uprawleniq - W + pro_data_h = $57; // st.bajt registra dannyh - WR + pro_data_l = $58; // ml.bajt registra dannyh - WR // adr=0 + pro_err = $59; // registr oshibok - R // adr=1 + pro_sec_cnt = $5A; // s4et4ik seektorow - W // adr=2 + pro_sector = $5B; // registr sektora - W // adr=3 + pro_cyl_lsb = $5C; // ml.bajt nom.cilindra - W // adr=4 + pro_cyl_msb = $5D; // st.bajt nom.cilindra - W // adr=5 + pro_head = $5E; // registr golowki/ustrojstwa - W // adr=6 + pro_command = $5F; // registr komand - W // adr=7 + pro_status = $5F; // registr sostoqniq - R // adr=7 + +//some symbolic constants for the ide registers, which makes the +//code more readable than always specifying the address pins +// + ide_data_h = pro_data_h; + ide_data_l = pro_data_l; + ide_data = ide_cs0_line; // 8 // adr=0 + ide_err = ide_cs0_line + ide_a0_line; // adr=1 + ide_sec_cnt = ide_cs0_line + ide_a1_line; // adr=2 + ide_sector = ide_cs0_line + ide_a1_line + ide_a0_line; // adr=3 + ide_cyl_lsb = ide_cs0_line + ide_a2_line; // adr=4 + ide_cyl_msb = ide_cs0_line + ide_a2_line + ide_a0_line; // adr=5 + ide_head = ide_cs0_line + ide_a2_line + ide_a1_line; // 14 // adr=6 + ide_command = ide_cs0_line + ide_a2_line + ide_a1_line + ide_a0_line; // adr=7 + ide_status = ide_cs0_line + ide_a2_line + ide_a1_line + ide_a0_line; // 15 // adr=7 + ide_control = ide_cs1_line + ide_a2_line + ide_a1_line; // adr=6 + ide_astatus = ide_cs1_line + ide_a2_line + ide_a1_line + ide_a0_line; // adr=7 + +// +//IDE Command Constants. These should never change. +// + ide_cmd_recal = $10; + ide_cmd_read = $20; + ide_cmd_write = $30; + ide_cmd_seek = $70; + ide_cmd_init = $90; + ide_cmd_id = $EC; + ide_cmd_spindown = $E0; + ide_cmd_spinup = $E1; + ide_cmd_flush = $E7; +// +// IDE status register bits +// + ide_sts_ERR = 1; // If this bit is set then an error has occurred while executing the latest command + ide_sts_IDX = $02; // index pulse. Each revolution of the disk this bit is pulsed to '1' once. + ide_sts_ECC = $04; // ECC bit. if this bit is set then an ECC correction on the data was executed + ide_sts_DRQ = $08; // If this bit is set then the disk either wants data (disk write) or has data (disk read) + ide_sts_SKC = $10; // Indicates that a seek has been executed with success + ide_sts_WFT = $20; // indicates a write error has happened. + ide_sts_RDY = $40; // indicates that the disk has finished its power-up. Allways wait for this bit to be active + ide_sts_BSY = $80; // This bit is set when the disk is doing something +// + ERR_BBK = $80; + ERR_UNC = $40; + ERR_MC = $20; + ERR_IDNF = $10; + ERR_MCR = $08; + ERR_ABRT = $04; + ERR_TK0NF = $02; + ERR_AMNF = $01; +// +// head and device register: bit 4 : 0=master,1=slave +// + ide_dev_master = 0; + ide_dev_slave = $10; + HddDeviceMaster = 0; + HddDeviceSlave = 1; + + HDDPortNone = 0; + HDDPortF500 = 1; + HDDPortF600 = 2; + +type + TIdeAccess=procedure(Sender: TObject; Drive: byte; Op: char); + TDevAccess=procedure(Sender: TObject; Op: char) of object; + + TIdeReg = packed record + reg_data: word; + reg_err: byte; + reg_cnt: byte; + reg_sec: byte; + reg_cyl: word; + reg_head: byte; + reg_command: byte; + reg_status: byte; + reg_control: byte; + reg_astatus: byte; + end; + + TIdeParams = packed record + FBufSize: integer; + FBufPtr: integer; + FMaster: boolean; + FReadOnly: boolean; + FLastOp: char; + FPrevCtl: byte; + FCtl:byte; + FLsb:byte; + FLsbr:byte; + FMsb:byte; + FMsbr:byte; + c, h, s: word; + Reserved: array[0..7] of integer; + end; + + THdcTmp = packed record + ImgMaster, ImgSlave: ShortString; + end; + + TIdType = (idFile, idDrive, idPartition); + + TIdeDevice = class(TObject) + FHandle: THANDLE; + FMaxLBA: integer; + FImgFile: ShortString; + FIdfFile: ShortString; + FReg: TIdeReg; + FIDBuf: array[0..BLOCK_SIZE] of byte; + FBuf: PChar; + FParams: TIdeParams; + FOnAccess: TDevAccess; + private + function GetLSB: byte; + function GetMSB: byte; + procedure SetCtl(const Value: byte); + procedure SetLSB(const Value: byte); + procedure SetMSB(const Value: byte); + procedure IdeCommandOk; + procedure IdeRead; + procedure IdeWrite; + procedure IdeReset; + procedure IdeIdentify; + procedure IdeIdentifyGen(IdType: TIdType; Buffer: PChar; ImageSize: int64; ImageFile, IdentifyFile: string; c,h,s: word); + procedure IdeReadSectors; + procedure IdeWriteSectors; + procedure IdeNextSector; + procedure CheckFBuf; + procedure IdeCHSGen(Size: int64; var c,h,s: word); + function IdeFlush:boolean; + function IdeSeek:boolean; + function GetActive: boolean; + function GetImgFile(Index: Integer): ShortString; + function GetIdeReg(Index: Integer): byte; // interface with IDE device + procedure SetIdeReg(Index: Integer; const Value: byte); // interface with IDE device + public + constructor Create(IsMaster, IsReadOnly: boolean; ImageFile:String); virtual; + destructor Destroy; override; + procedure SaveToStream(Stream: TStream); + procedure ReadFromStream(Stream: TStream); + property IdeReg[Index:Integer]:byte read GetIdeReg write SetIdeReg; + property CTL:byte read FParams.FCtl write SetCtl; + property LSB:byte read GetLSB write SetLSB; + property MSB:byte read GetMSB write SetMSB; + property Active: boolean read GetActive; + property LastOp: char read FParams.FLastOp; + property ImgFile:ShortString read FImgFile; + property ImgRO:boolean read FParams.FReadOnly write FParams.FReadOnly; + property OnAccess:TDevAccess read FOnAccess write FOnAccess; + end; + + TIdeController = class(T8255) + FDevice: array[HddDeviceMaster..HddDeviceSlave] of TIdeDevice; + FImageRO: array[HddDeviceMaster..HddDeviceSlave] of boolean; + FReserved: array[0..7] of integer; + FOnAccess: TIdeAccess; + private + function GetImageFile(Index: Integer): String; + procedure SetImageFile(Index: Integer; const Value: String); + procedure Dev0Access(Sender: TObject; Op: char); + procedure Dev1Access(Sender: TObject; Op: char); + procedure SetOnAccess(const Value: TIdeAccess); + function GetImageRO(Index: Integer): boolean; + procedure SetImageRO(Index: Integer; const Value: boolean); + protected + function GetPort(Index: Integer): byte; override; // interface with device + procedure SetPort(Index: Integer; const Value: byte); override; // interface with device + public + constructor Create; override; + destructor Destroy; override; + procedure SaveToStream(Stream: TStream); override; + procedure ReadFromStream(Stream: TStream); override; + property ImageFile[Index: Integer]:String read GetImageFile write SetImageFile; + property ImageRO[Index: Integer]:boolean read GetImageRO write SetImageRO; + property OnAccess:TIdeAccess read FOnAccess write SetOnAccess; + end; + + TIdeProController = class(TObject) + FDevice: array[HddDeviceMaster..HddDeviceSlave] of TIdeDevice; + FImageRO: array[HddDeviceMaster..HddDeviceSlave] of boolean; + FReserved: array[0..7] of integer; + FOnAccess: TIdeAccess; + private + function GetImageFile(Index: Integer): String; + procedure SetImageFile(Index: Integer; const Value: String); + procedure Dev0Access(Sender: TObject; Op: char); + procedure Dev1Access(Sender: TObject; Op: char); + procedure SetOnAccess(const Value: TIdeAccess); + function GetImageRO(Index: Integer): boolean; + procedure SetImageRO(Index: Integer; const Value: boolean); + function GetIdeReg(Index: Integer): byte; + procedure SetIdeReg(Index: Integer; const Value: byte); + public + constructor Create; + destructor Destroy; override; + procedure Reset; + procedure SaveToStream(Stream: TStream); + procedure ReadFromStream(Stream: TStream); + property IdeReg[Index:Integer]:byte read GetIdeReg write SetIdeReg; + property ImageFile[Index: Integer]:String read GetImageFile write SetImageFile; + property ImageRO[Index: Integer]:boolean read GetImageRO write SetImageRO; + property OnAccess:TIdeAccess read FOnAccess write SetOnAccess; + end; + +var + HDDPort: integer; + HDDImage: array [HddDeviceMaster..HddDeviceSlave] of String; + HDDRO: array [HddDeviceMaster..HddDeviceSlave] of boolean; + ProImage: array [HddDeviceMaster..HddDeviceSlave] of String; + ProRO: array [HddDeviceMaster..HddDeviceSlave] of boolean; + IdeController: TIdeController; + IdeProController: TIdeProController; + +implementation + +constructor TIdeController.Create; +begin + inherited; + Reset; + FOnAccess:=nil; + FDevice[HddDeviceMaster]:=nil; + FDevice[HddDeviceSlave]:=nil; +end; + +destructor TIdeController.Destroy; +begin + inherited; + if Assigned(FDevice[HddDeviceMaster]) then FDevice[HddDeviceMaster].Free; + if Assigned(FDevice[HddDeviceSlave]) then FDevice[HddDeviceSlave].Free; +end; + +procedure TIdeController.Dev0Access(Sender: TObject; Op: char); +begin + if Assigned(FOnAccess) then + FOnAccess(Self, 0, Op); +end; + +procedure TIdeController.Dev1Access(Sender: TObject; Op: char); +begin + if Assigned(FOnAccess) then + FOnAccess(Self, 1, Op); +end; + +function TIdeController.GetImageFile(Index: Integer): String; +begin + if Assigned(FDevice[Index and 1]) then + Result:=FDevice[Index and 1].ImgFile + else + Result:=''; +end; + +function TIdeController.GetImageRO(Index: Integer): boolean; +begin + if Assigned(FDevice[Index and 1]) then + Result:=FDevice[Index and 1].ImgRO + else + Result:=False; +end; + +function TIdeController.GetPort(Index: Integer): byte; +begin + Result:=$FF; + if Assigned(FDevice[HddDeviceMaster]) and FDevice[HddDeviceMaster].Active then + case Index of + ide_8255_ctl: Result:=FDevice[HddDeviceMaster].CTL; + ide_8255_msb: Result:=FDevice[HddDeviceMaster].MSB; + ide_8255_lsb: Result:=FDevice[HddDeviceMaster].LSB; + end + else if Assigned(FDevice[HddDeviceSlave]) and FDevice[HddDeviceSlave].Active then + case Index of + ide_8255_ctl: Result:=FDevice[HddDeviceSlave].CTL; + ide_8255_msb: Result:=FDevice[HddDeviceSlave].MSB; + ide_8255_lsb: Result:=FDevice[HddDeviceSlave].LSB; + end; +end; + +procedure TIdeController.ReadFromStream(Stream: TStream); +var HdcTmp: THdcTmp; +begin + inherited; + Stream.Read(FImageRO, sizeof(FImageRO)); + Stream.Read(HdcTmp, sizeof(HdcTmp)); + Stream.Read(FReserved, sizeof(FReserved)); + ImageFile[HddDeviceMaster]:=HdcTmp.ImgMaster; + if Assigned(FDevice[HddDeviceMaster]) then + FDevice[HddDeviceMaster].ReadFromStream(Stream); + ImageFile[HddDeviceSlave]:=HdcTmp.ImgSlave; + if Assigned(FDevice[HddDeviceSlave]) then + FDevice[HddDeviceSlave].ReadFromStream(Stream); + OnAccess:=FOnAccess; +end; + +procedure TIdeController.SaveToStream(Stream: TStream); +var HdcTmp: THdcTmp; +begin + inherited; + HdcTmp.ImgMaster:=''; + HdcTmp.ImgSlave:=''; + if Assigned(FDevice[HddDeviceMaster]) then + HdcTmp.ImgMaster:=FDevice[HddDeviceMaster].ImgFile; + if Assigned(FDevice[HddDeviceSlave]) then + HdcTmp.ImgSlave:=FDevice[HddDeviceSlave].ImgFile; + Stream.Write(FImageRO, sizeof(FImageRO)); + Stream.Write(HdcTmp, sizeof(HdcTmp)); + Stream.Write(FReserved, sizeof(FReserved)); + if Assigned(FDevice[HddDeviceMaster]) then + FDevice[HddDeviceMaster].SaveToStream(Stream); + if Assigned(FDevice[HddDeviceSlave]) then + FDevice[HddDeviceSlave].SaveToStream(Stream); +end; + +procedure TIdeController.SetImageFile(Index: Integer; const Value: String); +var ss: string; +begin + if Assigned(FDevice[Index and 1]) and + (FDevice[Index and 1].ImgFile=Value) then + exit; + begin + if Assigned(FDevice[Index and 1]) then FDevice[Index and 1].Free; + FDevice[Index and 1]:=nil; + if trim(Value)='' then FImageRO[Index and 1]:=True + else + try + FDevice[Index and 1]:=TIdeDevice.Create((Index and 1)=0, FImageRO[Index and 1], Value); + except + on E:Exception do + begin + FDevice[Index and 1]:=nil; + ss:=E.Message; OemToCharBuff(@ss[1], @ss[1], Length(ss)); + MessageBox(0, PChar(Format('IDE Device %d not created: '#13#10#13#10'%s', + [Index and 1, ss])), + 'IdeDevice Error', MB_OK+MB_ICONSTOP); + end; + end; + end; +end; + +procedure TIdeController.SetImageRO(Index: Integer; const Value: boolean); +begin + FImageRO[Index and 1]:=Value; + if Assigned(FDevice[Index and 1]) then + FDevice[Index and 1].ImgRO:=Value; +end; + +procedure TIdeController.SetOnAccess(const Value: TIdeAccess); +begin + FOnAccess := Value; + if Assigned(FDevice[HddDeviceMaster]) then + begin + if Assigned(Value) then + FDevice[HddDeviceMaster].OnAccess:=Dev0Access + else + FDevice[HddDeviceMaster].OnAccess:=nil; + end; + if Assigned(FDevice[HddDeviceSlave]) then + begin + if Assigned(Value) then + FDevice[HddDeviceSlave].OnAccess:=Dev1Access + else + FDevice[HddDeviceSlave].OnAccess:=nil; + end; +end; + +procedure TIdeController.SetPort(Index: Integer; const Value: byte); +begin + if Assigned(FDevice[HddDeviceMaster]) then + case Index of + ide_8255_ctl: FDevice[HddDeviceMaster].CTL:=Value; + ide_8255_msb: FDevice[HddDeviceMaster].MSB:=Value; + ide_8255_lsb: FDevice[HddDeviceMaster].LSB:=Value; + end; + if Assigned(FDevice[HddDeviceSlave]) then + case Index of + ide_8255_ctl: FDevice[HddDeviceSlave].CTL:=Value; + ide_8255_msb: FDevice[HddDeviceSlave].MSB:=Value; + ide_8255_lsb: FDevice[HddDeviceSlave].LSB:=Value; + end; +end; + +{ TIdeDevice } + +constructor TIdeDevice.Create(IsMaster, IsReadOnly: boolean; ImageFile:String); +var cDrive: char; + Geometry: TDISKGEOMETRY; + phis, IdeOK: boolean; + dwSizeLow, dwSizeHigh: DWORD; + FDiskSize, FFreeSize: int64; +// li: LARGE_INTEGER; +begin + inherited Create; + IdeReset; + FBuf:=nil; + FOnAccess:=nil; + FHandle:=INVALID_HANDLE_VALUE; + with FParams do + begin + FBufSize:=0; + FPrevCtl:=0; + FImgFile:=''; + FIdfFile:=''; + FMaster:=IsMaster; + FReadOnly:=IsReadOnly; + FImgFile:=ImageFile; + FIdfFile:=ChangeFileExt(ImageFile, '.IDE'); + end; + FillChar(FIdBuf, 512, 0); + if IsDrive(ImageFile, @cDrive) then + begin + IdeOK:=(cDrive in ['0'..'9'])and + GetIdeDiskIdentify(cDrive, @FIdBuf[0]); + if not HDDOpen(cDrive, (cDrive='0') or IsReadOnly {18.06.2012 was:True}, FHandle, phis, FDiskSize, FFreeSize, @Geometry) then // ReadOnly Allways + raise Exception.Create(LastError); + if IdeOK then + begin +{ li.QuadPart:=FDiskSize; + li.QuadPart:=li.QuadPart shr 9; // /512 + PLongWord(@FIdBuf[2*60])^ := li.LowPart; // lba + PLongWord(@FIdBuf[2*57])^ := PLongWord(@FIdBuf[2*60])^; , + PWord(@FIdBuf[2*7])^ := PWord(@FIdBuf[2*61])^; + PWord(@FIdBuf[2*8])^ := PWord(@FIdBuf[2*60])^; +} end + else + begin + if phis then IdeIdentifyGen(idDrive, @FIdBuf[0], FDiskSize, cDrive+':', FIdfFile, + (Geometry.Cylinders * Geometry.TracksPerCylinder) div 16, + 16, + Geometry.SectorsPerTrack) + else begin + IdeCHSGen(FDiskSize, FParams.c, FParams.h, FParams.s); + IdeIdentifyGen(idPartition, @FIdBuf[0], FDiskSize, cDrive+':', + FIdfFile, FParams.c, FParams.h, FParams.s); + end; + end; + end + else + begin + if not FileExists(ImageFile) then + raise Exception.CreateFmt('File not found: %s', [ImageFile]) + else + begin + if FParams.FReadOnly then + FHandle:=CreateFile(PChar(ImageFile), GENERIC_READ, 0, nil, OPEN_EXISTING, 0, 0) + else + FHandle:=CreateFile(PChar(ImageFile), GENERIC_READ or GENERIC_WRITE, 0, nil, OPEN_EXISTING, 0, 0); + if (FHandle=INVALID_HANDLE_VALUE) then + raise Exception.Create(LastError); + end; + dwSizeLow := GetFileSize(FHandle, @dwSizeHigh); + if (dwSizeLow = $FFFFFFFF) and (GetLastError() <> NO_ERROR ) then + raise Exception.Create(LastError); + FDiskSize:=dwSizeHigh; + FDiskSize:=(FDiskSize shl 32) + dwSizeLow; + IdeCHSGen(FDiskSize, FParams.c, FParams.h, FParams.s); + IdeIdentifyGen(idFile, @FIdBuf[0], FDiskSize, FImgFile, + FIdfFile, FParams.c, FParams.h, FParams.s); + end; + FMaxLBA:=FDiskSize div BLOCK_SIZE; +end; + +destructor TIdeDevice.Destroy; +begin + inherited; + if FHandle<>INVALID_HANDLE_VALUE then + CloseHandle(FHandle); + if Assigned(FBuf) then FreeMem(FBuf); +end; + +function TIdeDevice.GetLSB: byte; +begin + Result:=FParams.FLsbr; +end; + +function TIdeDevice.GetMSB: byte; +begin + Result:=FParams.FMsbr; +end; + +procedure TIdeDevice.IdeCommandOk; +begin + FReg.reg_err := 0; + FReg.reg_status := ide_sts_RDY or ide_sts_SKC; +end; + +procedure TIdeDevice.IdeReset; +begin + FParams.FCtl:=0; + FParams.FPrevCtl:=0; + FParams.FBufPtr:=-1; + FReg.reg_control:=0; + IdeCommandOk; + FReg.reg_cnt:=1; + FReg.reg_sec:=1; + FReg.reg_cyl:=0; + FReg.reg_head:=ide_dev_master; + FReg.reg_status:=ide_sts_RDY; +end; + +procedure TIdeDevice.IdeRead; +begin + if Active then with FParams do + Case FCtl of + ide_data : if FBufPtr>=0 then + begin + FLsbr:=byte(FBuf[FBufPtr]); + inc(FBufPtr); + FMsbr:=byte(FBuf[FBufPtr]); + inc(FBufPtr); + if FBufPtr>=BLOCK_SIZE*FReg.reg_cnt then + IdeCommandOk; + end; + ide_err : FLsbr:=FReg.reg_err; + ide_sec_cnt : FLsbr:=FReg.reg_cnt; + ide_sector : FLsbr:=FReg.reg_sec; + ide_cyl_lsb : FLsbr:=lo(FReg.reg_cyl); + ide_cyl_msb : FLsbr:=hi(FReg.reg_cyl); + ide_head : FLsbr:=FReg.reg_head; + ide_status, ide_astatus : FLsbr:=FReg.reg_status + else raise Exception.CreateFmt('IdeRead: not supported register address: %d', [FCtl]); + end; +end; + +procedure TIdeDevice.IdeWrite; +begin + with FParams do + Case FCtl of + ide_data : if Active and (FBufPtr>=0) then + begin + byte(FBuf[FBufPtr]):=FLsb; + inc(FBufPtr); + byte(FBuf[FBufPtr]):=FMsb; + inc(FBufPtr); + if FBufPtr>=BLOCK_SIZE*FReg.reg_cnt then + IdeWriteSectors(); + end; + ide_sec_cnt : FReg.reg_cnt := FLsb; + ide_sector : FReg.reg_sec := FLsb; + ide_cyl_lsb : FReg.reg_cyl := (FReg.reg_cyl and $FF00) + FLsb; + ide_cyl_msb : FReg.reg_cyl := (FReg.reg_cyl and $FF) + 256*FLsb; + ide_head : begin + if (FLsb and $A0)<>$A0 then + raise Exception.Create('Only 512 bytes sectors supported!'); + FReg.reg_head := FLsb; + IdeCommandOk; + end; + ide_command : if Active then + begin + FReg.reg_command:=FLsb; + if (FLsb and $FE)=ide_cmd_init then + IdeReset() + else if (FLsb and $FE)=ide_cmd_read then + IdeReadSectors() + else if ((FLsb and $FE)=ide_cmd_write)and(not FReadOnly) then + begin + if IdeSeek() then + begin + FReg.reg_status := ide_sts_DRQ or ide_sts_SKC; + FBufPtr:=0; + CheckFBuf(); + end; + end + else if (FLsb=ide_cmd_id) then + IdeIdentify() + else if (FLsb=ide_cmd_flush) then // FLUSH CACHE + begin + if IdeFlush() then + IdeCommandOk() + else + FReg.reg_status := ide_sts_RDY or ide_sts_WFT or ide_sts_SKC or ide_sts_ERR; // 0x71 + end + else if (FLsb=ide_cmd_recal) then + IdeCommandOk() + else if (FLsb=ide_cmd_seek) and IdeSeek() then + IdeCommandOk(); + end; + else raise Exception.CreateFmt('IdeWrite: not supported register address: %d', [FCtl]); + end; +end; + +procedure TIdeDevice.ReadFromStream(Stream: TStream); +begin + Stream.Read(FReg, sizeof(FReg)); + Stream.Read(FParams, sizeof(FParams)); + FParams.FBufSize:=-1; // + CheckFBuf(); // reallocate FBuf array + Stream.Read(FBuf^, FParams.FBufSize); +end; + +procedure TIdeDevice.SaveToStream(Stream: TStream); +begin + Stream.Write(FReg, sizeof(FReg)); + CheckFBuf(); // allocate FBuf array if FBuf=nil + Stream.Write(FParams, sizeof(FParams)); + Stream.Write(FBuf^, FParams.FBufSize); +end; + +procedure TIdeDevice.SetCtl(const Value: byte); +begin + with FParams do + If FPrevCtl<>Value then + begin + if ((FPrevCtl and ide_wr_line)<>(Value and ide_wr_line)) and + (Value and ide_wr_line <> 0) then // по фронту импульса WRITE + begin + FCtl := Value and (not (ide_wr_line or ide_rd_line or ide_rst_line)); // register address + IdeWrite(); + end + else + if ((FPrevCtl and ide_rd_line)<>(Value and ide_rd_line)) and + (Value and ide_rd_line <> 0) then // по фронту импульса READ + begin + FCtl := Value and (not (ide_wr_line or ide_rd_line or ide_rst_line)); // register address + IdeRead() + end + else + if ((FPrevCtl and ide_rst_line)<>(Value and ide_rst_line)) and + (Value and ide_rst_line = 0) then // по спаду импульса RESET + IdeReset(); + FPrevCtl:=Value; + end +end; + +procedure TIdeDevice.SetLSB(const Value: byte); +begin + FParams.FLsb:=Value; +end; + +procedure TIdeDevice.SetMSB(const Value: byte); +begin + FParams.FMsb:=Value; +end; + +procedure TIdeDevice.IdeIdentify; +begin + if Assigned(FOnAccess) then FOnAccess(Self, 'r'); + if not Assigned(FBuf) then + GetMem(FBuf, BLOCK_SIZE*FReg.reg_cnt); + CopyMemory(FBuf, @FIdBuf[0], BLOCK_SIZE); + FParams.FBufPtr:=0; + IdeCommandOk; + FReg.reg_status := ide_sts_RDY or ide_sts_DRQ or ide_sts_SKC; +end; + +function TIdeDevice.IdeFlush:boolean; +var writed: cardinal; +begin + Result:=False; + if FParams.FBufPtr<=0 then exit; + Result:=IdeSeek() and WriteFile(FHandle, FBuf, FParams.FBufPtr, writed, nil); + if Result then + begin + FReg.reg_status := ide_sts_RDY or ide_sts_SKC or ide_sts_ERR; + FReg.reg_err := ERR_UNC; + end + else + begin + FReg.reg_err := 0; + FReg.reg_status := ide_sts_RDY or ide_sts_SKC; + end; +end; + +procedure TIdeDevice.IdeReadSectors; +var bytesread: cardinal; + cnt: byte; + ptr: pointer; +begin + CheckFBuf(); + cnt:=FReg.reg_cnt; + ptr:=FBuf; + if Assigned(FOnAccess) then FOnAccess(Self, 'r'); + while (cnt>0) and IdeSeek() do + begin + if not (ReadFile(FHandle, ptr^, BLOCK_SIZE, bytesread, nil)) then + begin + FReg.reg_status := ide_sts_RDY or ide_sts_ERR or ide_sts_SKC; (* $51; *) + FReg.reg_err := ERR_UNC; + end + else + begin + FReg.reg_err := 0; + FReg.reg_status := ide_sts_RDY or ide_sts_DRQ or ide_sts_SKC; + end; + dec(cnt); + if cnt>0 then IdeNextSector(); + ptr:=pointer(integer(ptr)+BLOCK_SIZE); + end; + FParams.FBufPtr:=0; +end; + +function TIdeDevice.IdeSeek: boolean; +var ii, jj:integer; +begin + ii:=0; + Result:=True; + if (FReg.reg_head and $40 <>0) then // LBA + begin + ii:=FReg.reg_head and $0F; ii:=ii shl 24; + jj:=FReg.reg_cyl; ii:=ii+(jj shl 8)+FReg.reg_sec; + if (ii >= FMaxLBA) then + begin + FReg.reg_status := ide_sts_RDY or ide_sts_ERR; + FReg.reg_err := ERR_IDNF; + Result:=False; + end; + end + else + begin + if (FReg.reg_cyl >= FParams.c) or + ((FReg.reg_head and $0F) >= FParams.h) or + (FReg.reg_sec > FParams.s) then + begin + FReg.reg_status := ide_sts_RDY or ide_sts_ERR; + FReg.reg_err := ERR_IDNF; + Result:=False; + end + else + ii := (FReg.reg_cyl * FParams.h + (FReg.reg_head and $0F)) * FParams.s + FReg.reg_sec - 1; + end; + if Result then + begin + Result:=DiskFileSeek(FHandle, ii, FILE_BEGIN); + if not Result then + begin + FReg.reg_status := ide_sts_ERR or ide_sts_WFT or ide_sts_RDY; + FReg.reg_err := ERR_IDNF; + end; + end; +end; + +procedure TIdeDevice.IdeIdentifyGen(IdType: TIdType; Buffer: PChar; ImageSize: int64; ImageFile, IdentifyFile: string; c, h, s: word); +var FS: TFileStream; + cs: byte; + i: integer; + li: LARGE_INTEGER; +begin + FS:=nil; + if (IdType=idFile) and FileExists(IdentifyFile) then + begin + try + FS:=TFileStream.Create(IdentifyFile, fmOpenRead or fmShareDenyWrite); + FS.Read(Buffer^, BLOCK_SIZE); + finally + if Assigned(FS) then FS.Free; + end; + end + else + begin + if Length(ImageFile)>=IDE_MAX_MODEL then + delete(ImageFile, 1, Length(ImageFile)-IDE_MAX_MODEL); + StrLCopy(pointer(integer(Buffer)+54), PChar(ImageFile), 40); // model + ChangeByteOrder(pointer(integer(Buffer)+54), 40); + case IdType of + idFile: ImageFile:='DRIVE IMAGE (FILE)'; + idDrive: ImageFile:='LOCAL DRIVE (HDD)'; + idPartition: ImageFile:='LOCAL PARTITION'; + end; + li.QuadPart:=ImageSize; + li.QuadPart:=li.QuadPart shr 9; // /512 + StrLCopy(pointer(integer(Buffer)+20), PChar(ImageFile), 20); // serial + ChangeByteOrder(pointer(integer(Buffer)+20), 20); + StrLCopy(pointer(integer(Buffer)+46), '0999', 8); // firmware + ChangeByteOrder(pointer(integer(Buffer)+46), 8); + PWord(Buffer)^ := $045A; + PWord(@Buffer[2*1])^ := c; + PWord(@Buffer[2*3])^ := h; + PWord(@Buffer[2*6])^ := s; + PLongWord(@Buffer[2*60])^ := li.LowPart; // lba + PLongWord(@Buffer[2*57])^ := PLongWord(@Buffer[2*60])^; + PWord(@Buffer[2*7])^ := PWord(@Buffer[2*61])^; + PWord(@Buffer[2*8])^ := PWord(@Buffer[2*60])^; + PWord(@Buffer[2*20])^ := 3; // a dual ported multi-sector buffer capable of simultaneous transfers with a read caching capability + PWord(@Buffer[2*21])^ := 512; // cache size=256k + PWord(@Buffer[2*22])^ := 4; // ECC bytes + PWord(@Buffer[2*49])^ := $200; // LBA supported + PWord(@Buffer[2*80])^ := $3E; // support specifications up to ATA-5 + PWord(@Buffer[2*81])^ := $13; // ATA/ATAPI-5 T13 1321D revision 3 + PWord(@Buffer[2*82])^ := $60; // supported look-ahead and write cache +// make checksum + Buffer[510] := #$A5; + cs := 0; + for i:=0 to 511 do + cs:=cs + PByte(@Buffer[i])^; + Buffer[511] := chr(0-cs); + end; +end; + +procedure TIdeDevice.IdeCHSGen(Size: int64; var c, h, s: word); +begin + Size:=Size div BLOCK_SIZE; + h:=16; + s:=127; + while (Size mod (h*s)<>0) and (s>16) and (Size div (h*s) < 60000) do + s:=s-1; + c:=Size div (h*s); +end; + +function TIdeDevice.GetActive: boolean; +begin + Result:=FParams.FMaster=((FReg.reg_head and ide_dev_slave)=0); +end; + +procedure TIdeDevice.IdeWriteSectors; +var writed: cardinal; + cnt: byte; + ptr: pointer; +begin + CheckFBuf(); + cnt:=FReg.reg_cnt; + ptr:=FBuf; + if Assigned(FOnAccess) then FOnAccess(Self, 'w'); + while IdeSeek() and (cnt>0) do + begin + if not (WriteFile(FHandle, ptr^, BLOCK_SIZE, writed, nil)) then + begin + FReg.reg_status := ide_sts_RDY or ide_sts_SKC or ide_sts_ERR; + FReg.reg_err := ERR_UNC; + end + else + IdeCommandOk; + dec(cnt); + if cnt>0 then IdeNextSector(); + ptr:=pointer(integer(ptr)+BLOCK_SIZE); + end; + FParams.FBufPtr:=0; +end; + +procedure TIdeDevice.CheckFBuf; +begin + if FParams.FBufSize 0) then // LBA + begin + ii:=FReg.reg_head and $0F; ii:=ii shl 24; + jj:=FReg.reg_cyl; ii:=ii+(jj shl 8)+FReg.reg_sec; + inc(ii); + FReg.reg_head:=(ii shr 24) and $0F; + FReg.reg_cyl:=(ii shr 8) and $FFFF; + FReg.reg_sec:=ii and $FF; + end + else + begin + if (FReg.reg_sec < FParams.s) then + inc(FReg.reg_sec) + else + begin + FReg.reg_sec := 1; + head := (FReg.reg_head and $0F) + 1; + if (head < FParams.h) then + FReg.reg_head := (FReg.reg_head and $F0)+head + else + begin + FReg.reg_head := FReg.reg_head and $F0; + inc(FReg.reg_cyl); + end; + end; + end; +end; + +function TIdeDevice.GetImgFile(Index: Integer): ShortString; +begin + Result:=FImgFile; +end; + +function TIdeDevice.GetIdeReg(Index: Integer): byte; +begin + with FParams do begin + if Index=ide_data then raise Exception.Create('Wrong IDE register: ide_data') + else if Index=pro_data_h then Result:=FMsbr + else + begin + case Index of + pro_data_l: Index:=ide_data; +// pro_control: Index:=ide_control; + pro_astatus: Index:=ide_astatus; + pro_err : Index:=ide_err; + pro_sec_cnt: Index:=ide_sec_cnt; + pro_sector : Index:=ide_sector; + pro_cyl_lsb: Index:=ide_cyl_lsb; + pro_cyl_msb: Index:=ide_cyl_msb; + pro_head : Index:=ide_head; +// pro_command: Index:=ide_command; + pro_status : Index:=ide_status; + end; + FCtl:=Index; + IdeRead; + Result:=FLsbr; + end; + end; +end; + +procedure TIdeDevice.SetIdeReg(Index: Integer; const Value: byte); +begin + with FParams do begin + if Index=ide_data then raise Exception.Create('Wrong IDE register: ide_data') + else if Index=pro_data_h then FMsb:=Value + else + begin + FLsb:=Value; + case Index of + pro_data_l: Index:=ide_data; + pro_control: Index:=ide_control; +// pro_astatus: Index:=ide_astatus; + pro_err : Index:=ide_err; + pro_sec_cnt: Index:=ide_sec_cnt; + pro_sector : Index:=ide_sector; + pro_cyl_lsb: Index:=ide_cyl_lsb; + pro_cyl_msb: Index:=ide_cyl_msb; + pro_head : Index:=ide_head; + pro_command: Index:=ide_command; +// pro_status : Index:=ide_status; + end; + FCtl:=Index; + IdeWrite; + end; + end; +end; + +{ TIdeProController } + +constructor TIdeProController.Create; +begin + inherited; + FOnAccess:=nil; + FDevice[HddDeviceMaster]:=nil; + FDevice[HddDeviceSlave]:=nil; +end; + +destructor TIdeProController.Destroy; +begin + inherited; + if Assigned(FDevice[HddDeviceMaster]) then FDevice[HddDeviceMaster].Free; + if Assigned(FDevice[HddDeviceSlave]) then FDevice[HddDeviceSlave].Free; +end; + +procedure TIdeProController.Dev0Access(Sender: TObject; Op: char); +begin + if Assigned(FOnAccess) then + FOnAccess(Self, 2, Op); +end; + +procedure TIdeProController.Dev1Access(Sender: TObject; Op: char); +begin + if Assigned(FOnAccess) then + FOnAccess(Self, 3, Op); +end; + +function TIdeProController.GetIdeReg(Index: Integer): byte; +begin + Result:=$FF; + if Assigned(FDevice[HddDeviceMaster]) and FDevice[HddDeviceMaster].Active then + Result:=FDevice[HddDeviceMaster].IdeReg[Index] + else if Assigned(FDevice[HddDeviceSlave]) and FDevice[HddDeviceSlave].Active then + Result:=FDevice[HddDeviceSlave].IdeReg[Index]; +end; + +function TIdeProController.GetImageFile(Index: Integer): String; +begin + if Assigned(FDevice[Index and 1]) then + Result:=FDevice[Index and 1].ImgFile + else + Result:=''; +end; + +function TIdeProController.GetImageRO(Index: Integer): boolean; +begin + if Assigned(FDevice[Index and 1]) then + Result:=FDevice[Index and 1].ImgRO + else + Result:=False; +end; + +procedure TIdeProController.ReadFromStream(Stream: TStream); +begin +; +end; + +procedure TIdeProController.Reset; +begin + if Assigned(FDevice[HddDeviceMaster]) then FDevice[HddDeviceMaster].IdeReset; + if Assigned(FDevice[HddDeviceSlave]) then FDevice[HddDeviceSlave].IdeReset; +end; + +procedure TIdeProController.SaveToStream(Stream: TStream); +begin +; +end; + +procedure TIdeProController.SetIdeReg(Index: Integer; const Value: byte); +begin + if Assigned(FDevice[HddDeviceMaster]) then + FDevice[HddDeviceMaster].IdeReg[Index]:=Value; + if Assigned(FDevice[HddDeviceSlave]) then + FDevice[HddDeviceSlave].IdeReg[Index]:=Value; +end; + +procedure TIdeProController.SetImageFile(Index: Integer; + const Value: String); +var ss: string; +begin + if Assigned(FDevice[Index and 1]) and + (FDevice[Index and 1].ImgFile=Value) then + exit; + begin + if Assigned(FDevice[Index and 1]) then FDevice[Index and 1].Free; + FDevice[Index and 1]:=nil; + if trim(Value)='' then FImageRO[Index and 1]:=True + else + try + FDevice[Index and 1]:=TIdeDevice.Create((Index and 1)=0, FImageRO[Index and 1], Value); + except + on E:Exception do + begin + FDevice[Index and 1]:=nil; + ss:=E.Message; OemToCharBuff(@ss[1], @ss[1], Length(ss)); + MessageBox(0, PChar(Format('IDE Device %d not created: '#13#10#13#10'%s', + [Index and 1, ss])), + 'IdeDevice Error', MB_OK+MB_ICONSTOP); + end; + end; + end; +end; + +procedure TIdeProController.SetImageRO(Index: Integer; + const Value: boolean); +begin + FImageRO[Index and 1]:=Value; + if Assigned(FDevice[Index and 1]) then + FDevice[Index and 1].ImgRO:=Value; +end; + +procedure TIdeProController.SetOnAccess(const Value: TIdeAccess); +begin + FOnAccess := Value; + if Assigned(FDevice[HddDeviceMaster]) then + begin + if Assigned(Value) then + FDevice[HddDeviceMaster].OnAccess:=Dev0Access + else + FDevice[HddDeviceMaster].OnAccess:=nil; + end; + if Assigned(FDevice[HddDeviceSlave]) then + begin + if Assigned(Value) then + FDevice[HddDeviceSlave].OnAccess:=Dev1Access + else + FDevice[HddDeviceSlave].OnAccess:=nil; + end; +end; + +initialization + IdeController:=TIdeController.Create; + IdeProController:=TIdeProController.Create; + +finalization + IdeController.Free; + IdeProController.Free; + +end. diff --git a/modOrion.pas b/modOrion.pas new file mode 100644 index 0000000..79dffb5 --- /dev/null +++ b/modOrion.pas @@ -0,0 +1,1069 @@ +///////////////////////////////////////////////////////////////////////// +// // +// Orion/Z (Orion-128 + Z80-CARD-II) emulator, version 1.9 // +// // +// Author: Sergey A. // +// // +// Copyright (C) 2006-2016 Sergey A. // +// // +// This program is free software; you can redistribute it and/or // +// modify it in any ways. // +// This program is distributed "AS IS" 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 modOrion; + +{ ******************************************************************************* + + O R I O N S P E C I F I C + + *******************************************************************************} + +interface + + +{$I 'OrionZEm.inc'} + + +uses windows, classes, sysutils, modAY8912, EthThrd; + +const + TSTATES_2M5=49920; SPEED_2M5=0; SIZE_128=0; + TSTATES_3M5=69888; SPEED_3M5=1; SIZE_256=1; + TSTATES_5M0=99840; SPEED_5M0=2; SIZE_512=2; + TSTATES_7M0=139776; SPEED_7M0=3; SIZE_1024=3; + TSTATES_10M=199680; SPEED_10M=4; SIZE_2048=4; + TSTATES_20M=199680*2; SPEED_20M=5; SIZE_4096=5; + TSTATES_inf=TSTATES_20M; SPEED_INF=6; + + Z80CARD_MOSCOW=0; + Z80CARD_MINIMAL=1; + Z80CARD_USUAL=2; + Z80CARD_MAXIMAL=3; + Z80_ORIONPRO_v2=4; + Z80_ORIONPRO_v3=5; + Z80_ORIONPRO_v320=6; + + ORION_ROMBIOS_ADDR = $F800; + ORIONPRO_ROM1BIOS_ADDR = $0; + ORIONPRO_ROM2BIOS_ADDR = $2000; + RAM_PAGES_CNT = 64; // количество 64к-страниц ОЗУ в пределе + RAM_PAGE_SIZE = 65536; + + pFB_disp_off = $80; // диспетчер 16к выключен (D7=1) + pFB_int50_off = 0; // прерывания выключены (D6=0) + pFB_TopRam_off = 0; // F400..FFFF - порты+ПЗУ (D5=0) + + pFB_disp_on = 0; // диспетчер 16к включен (D7=1) + pFB_int50_on = $40; // прерывания включены (D6=0) + pFB_TopRam_on = $20; // F400..FFFF - OЗУ (D5=0) + + pFB_disp_mask = $80; // D7 + pFB_int50_mask = $40; // D6 + pFB_TopRam_mask = $20; // D5 + + p0A_RAM0_MASK = $01; // RAM window 0000..3FFF + p0A_RAM1_MASK = $02; // RAM window 4000..7FFF + p0A_RAM2_MASK = $04; // RAM window 8000..BFFF + p0A_ROM2_MASK = $08; // ROM window 2000..3FFF + p0A_ROM1_MASK = $10; // ROM window 0000..1FFF + p0A_FIX_F000 = $40; // if p0A_FIX_F000 (D6) = 1 then RAM F000..FFFF = 1F segment 4k part always (with any pF9 combinations) + p0A_ORION_128 = $80; // if p0A_ORION_128 (D7=1) then RAM F000..FFFF = 1F segment 4k part always (with any p0A_FIX_F000, pF9 combinations) + + F_C = 1; + F_N = 2; + F_PV = 4; + F_3 = 8; + F_H = 16; + F_5 = 32; + F_Z = 64; + F_S = 128; + Z80RUNNING=1; //Normally + Z80PAUSED=2; //When in setting screens + Z80STOPPED=3; //When losing focus + + CPUTstates: array [0..6] of integer = + (TSTATES_2M5, TSTATES_3M5, TSTATES_5M0, TSTATES_7M0, TSTATES_10M, TSTATES_20M, TSTATES_inf); + + ScrBase: array [0..3] of integer = ($C000, $8000, $4000, 0); + + SCR_WIDTH_384 = 0; + SCR_WIDTH_400 = 1; + SCR_WIDTH_480 = 2; + SCR_WIDTH_512 = 3; { Orion-Pro wide screen } + + SCR_ZOOM_X1 = 0; + SCR_ZOOM_X2 = 1; + SCR_ZOOM_X25 = 2; + SCR_ZOOM_X3 = 3; + + ScrWidthArr: array [0..3, 0..3] of integer = ((384, 384*2, 960, 384*3), + (400, 400*2, 1000, 400*3), + (480, 480*2, 1200, 480*3), + { Orion-Pro wide screen } (512, 512*2, 1280, 512*3)); + ScrHeightArr: array [0..3] of integer = (256, 256*2, 640, 256*3); + SzRAMarr: array [SIZE_128..SIZE_4096] of integer = (65536*2, 65536*4, 65536*8, 65536*16, 65536*32, 65536*64); +type + TScrWidth = (w384, w400, w480); + + WordPointer=^Word; + TMainPort = array [0..$FF] of byte; + TROMF800 = array [$F800..$10000] of byte; + TROM1BIOS = array [$0..$10000] of byte; + TROM2BIOS = array [$0..$200000] of byte; + TRamArr = array [0..RAM_PAGES_CNT-1, 0..RAM_PAGE_SIZE] of byte; + + TOriHeader = packed record // snapshot header + _tag: array[0..22] of char; + _regA: integer; + _regHL: integer; + _regB: integer; + _regC: integer; + _regDE: integer; + // Z80 Flags + _fS: Boolean; + _fZ: Boolean; + _f5: Boolean; + _fH: Boolean; + _f3: Boolean; + _fPV: Boolean; + _fN: Boolean; + _fC: Boolean; + // Alternate registers + _regAF_: integer; + _regHL_: integer; + _regBC_: integer; + _regDE_: integer; + // Index registers - ID used as temp for ix/iy + _regIX: integer; + _regIY: integer; + _regID: integer; + // Stack pointer and program counter + _regSP: integer; + _regPC: integer; + // Interrupt registers and flip-flops, and refresh registers + _intI: integer; + _intR: integer; + _intRTemp: integer; + _intIFF1: Boolean; + _intIFF2: Boolean; + _intIM: integer; + // 512ви1 + _DeltaDate: TDateTime; + _DeltaTime: TDateTime; + // keyboard + _KeyDelay: integer; + _KeyRusLat: integer; +// sound + _SoundEnabled: boolean; + _AyEnabled: boolean; + _Global_TStates: integer; + _glWavePtr: integer; + _glWaveAddTStates: integer; + _AYPSG: AY8912; + _AY_OutNoise: integer; + _VolA: integer; + _VolB: integer; + _VolC: integer; + _lOut1: integer; + _lOut2: integer; + _lOut3: integer; + _AY_Left: integer; + _AY_NextEvent: integer; +// other + _CPUSpeedMode: integer; + _MEMSizeMode: integer; + _Z80CardMode:integer; + _z80runstate: integer; + _glTstatesPerInterrupt: integer; + _KeybType: integer; //sa + _KeyExtender: Boolean; + _FddHD: Boolean; + _HDDPort: integer; + _PFEEnabled:boolean; + _ROMBIOSfile: ShortString; + _ROMDISKfile: ShortString; + _ROMDISKlen: integer; // ROM disk size in bytes + _NPages: integer; // quantity of 64k RAM pages + _ScrZoom: integer; + _SDScheme: integer; + _Reserved: array[0..5] of integer; + end; +// CRC: integer; // CRC32 of OriHeader +// _FDController.SaveToStream; +// _PortF400.SaveToStream; +// _PortF500.SaveToStream; +// _PortF600.SaveToStream; +// _F146818.SaveToStream; +// _Parity: array[0..256] of Boolean; +// _MainPort: TMainPort; +// _ROMF800: TROMF800; +// _ROMDISK: array of byte; [0.._ROMDISKlen-1] +// _RAMARR: array [0.._NPages-1, 0..65536] of byte + + +var +{$IFDEF DEBUG} + PrevLocalTstates:integer = 0; + TicksFromPrevSD:integer = 0; +{$ENDIF} + DoNotUpdateScr:boolean = False; + RAMPagesCount: integer = 8; + RAMSegmCount: integer = 32; + RAMarr: TRamArr; + ROMF800: TROMF800; + ROM1BIOS: TROM1BIOS; + ROM2BIOS: TROM2BIOS; + ROMBIOSlen, ROM1BIOSlen, ROM2BIOSlen: integer; + ROMBIOSfile, ROM1BIOSfile, ROM2BIOSfile, ROMDISKfile: AnsiString; + OrionPRO_DIP_SW: integer; + + MainPort: TMainPort; + + ScrWidth: integer = SCR_WIDTH_384; // 0=SCR_WIDTH_384, 1=SCR_WIDTH_400, 2=SCR_WIDTH_480, 3=SCR_WIDTH_512 + ScrZoom: integer = SCR_ZOOM_X2; // 0=SCR_ZOOM_X1, 1=SCR_ZOOM_X2, 3=SCR_ZOOM_X25, 4=SCR_ZOOM_X3 + PrevScrWidth: integer = SCR_WIDTH_384; + CpuPaused:boolean = False; + DoShowReg:boolean = True; + Do_Loop:boolean = False; + + BreakPointPF9:byte = $FF; + BreakPointPF9mask: byte = 0; + BreakPointAddr:integer = $FFFF; + BreakPointAddrMask:integer = 0; + BreakPointRetPF9:byte = $FF; + BreakPointRetAddr:integer = $FFFF; + + AnalyzeConditions: boolean = False; + + ConditionSP:ShortString=''; + ConditionSPvalue:integer=0; + ConditionSPmask:integer=0; + + ConditionAF:ShortString=''; + ConditionAFvalue:integer=0; + ConditionAFmask:integer=0; + ConditionBC:ShortString=''; + ConditionBCvalue:integer=0; + ConditionBCmask:integer=0; + ConditionDE:ShortString=''; + ConditionDEvalue:integer=0; + ConditionDEmask:integer=0; + ConditionHL:ShortString=''; + ConditionHLvalue:integer=0; + ConditionHLmask:integer=0; + + ConditionAF_:ShortString=''; + ConditionAF_value:integer=0; + ConditionAF_mask:integer=0; + ConditionBC_:ShortString=''; + ConditionBC_value:integer=0; + ConditionBC_mask:integer=0; + ConditionDE_:ShortString=''; + ConditionDE_value:integer=0; + ConditionDE_mask:integer=0; + ConditionHL_:ShortString=''; + ConditionHL_value:integer=0; + ConditionHL_mask:integer=0; + + ConditionIX:ShortString=''; + ConditionIXvalue:integer=0; + ConditionIXmask:integer=0; + ConditionIY:ShortString=''; + ConditionIYvalue:integer=0; + ConditionIYmask:integer=0; + ConditionIR:ShortString=''; + ConditionIRvalue:integer=0; + ConditionIRmask:integer=0; + + Global_TStates: integer; + z80runstate: integer; + glTstatesPerInterrupt: integer; + Parity: array[0..256] of Boolean; + glInterruptTimer: integer; + interruptCounter: integer = 0; + glInterruptDelay: integer; + glDelayOverage: integer; + xSleep: integer = 0; // сколько милисекунд проспали в IDLE в течении секунды +{$IFDEF USE_SOUND} + glBeeperCounter: integer = 0; + glBeeperVal: integer = 128; + glSoundRegister: integer; // Contains currently indexed AY-3-8912 sound register + glBufNum: integer; // ID of the last Wave buffer used +{$ENDIF} + + CPUSpeedMode:integer = SPEED_10M; { 0=2M5, 1=3M5, 2=5M0, 3=7M0, 4=10M, 5=infinity } + MEMSizeMode:integer = SIZE_512; + Z80CardMode:integer = Z80CARD_MINIMAL; + SoundEnabled: boolean = True; + AyEnabled: boolean = True; + RTCmode: integer=0; + + EthMode: integer; { 0=None, 1=RTL8019AS } + EthConnName: string; { TAP Connection name } + EthConnGUID: string; { TAP Connection GUID } + EthMAC: TMacAddr; { Adapter MAC address } + EthMAC0, EthMAC1, EthMAC2, EthMAC3, EthMAC4, EthMAC5: integer; + + // Main Z80 registers + regA: integer; + regHL: integer; + regB: integer; + regC: integer; + regDE: integer; + + // Z80 Flags + fS: Boolean; + fZ: Boolean; + f5: Boolean; + fH: Boolean; + f3: Boolean; + fPV: Boolean; + fN: Boolean; + fC: Boolean; + + + // Alternate registers + regAF_: integer; + regHL_: integer; + regBC_: integer; + regDE_: integer; + + // Index registers - ID used as temp for ix/iy + regIX: integer; + regIY: integer; + regID: integer; + + // Stack pointer and program counter + regSP: integer; + regPC: integer; + + // Interrupt registers and flip-flops, and refresh registers + intI: integer; + intR: integer; + intRTemp: integer; + intIFF1: Boolean; + intIFF2: Boolean; + intIM: integer; + +procedure SetBeeper0; +procedure SetBeeper1; +function SetMemSize:string; +function LongAddressStr(page,addr:integer):string; +function LongAddressParse(ast:string; var page,addr:integer):integer; +function GetBeeper:integer; +function inb(port : integer) : integer; +procedure outb(port : integer; outbyte : integer); +function RAMPortGet(Index: Integer): byte; +procedure RAMPortSet(Index: Integer; const Value: byte); +function peekb(Index: Integer): byte; +function peekw(Index: Integer): word; +procedure pokew(Index: Integer; const Value: word); +procedure pokeb(Index: Integer; const Value: byte); +procedure DebugInfo(str: string; mode:integer); +function GetCPUTstates: integer; + +implementation + +uses mod1793, mod8255, mod146818, modHDD, modSD, mod232, mod8019as, MainWin; + +{ + Порт F9 (F900) - Упр.страницами ОЗУ для режима "Орион-128". + + Порт FB - УПРАВЛЕНИЕ ПРЕРЫВАНИЯМИ И ДИСПЕТЧЕРОМ: + + D7 D6 D5 D4 D3 D2 D1 D0 + ! ! ! ! ! ! ! ! + MZ INT XMEM RZRV BS1 BS0 SS1 SS0 + ! ! ! ! ! ! ! ! + ! ! ! ! ! ! !______!____ SEGMENT SELECT + ! ! ! ! !______!__________________ BANK SELECT + ! ! ! ! + ! ! ! !________ РЕЗЕРВ ДЛЯ BANK SELECT (ВСЕГДА = 0) + ! ! !_______________ FULL RAM MEMORY (ПРИ D5=1 0-FFFF - ОЗУ) + ! !______________________ INT ENABLE (ПРИ D6=0 ЗАПРЕЩЕНЫ) + !_____________________________ DISPATCHER OFF (ПРИ D7=1 ОТКЛЮЧЕН !) + + +=================================== ORION - PRO ================================ + +Для выбора номера рабочей (текущей) страницы +используется порт с адресом 08H (для режима "Орион-128" - +0F900H). Все страницы равносильны, и нет необходимости работать +именно в нулевой (только для режима Pro). В режиме "Орион-128" +для переключения страниц ОЗУ можно использовать порт с адресом +0F9H. + + Распределение сегментов по страницам основного ОЗУ: + + Стр.0 Стр.1 Стр.2 Стр.3 Стр.4 Стр.5 Стр.6 Стр.7 +FFFFH -------T------T------T------T------T------T------T------¬ + ¦ 3 ¦ 7 ¦ 11 ¦ 15 ¦ 19 ¦ 23 ¦ 27 ¦ 31 ¦ +C000H +------+------+------+------+------+------+------+------+ + ¦ 2 ¦ 6 ¦ 10 ¦ 14 ¦ 18 ¦ 22 ¦ 26 ¦ 30 ¦ +8000H +------+------+------+------+------+------+------+------+ + ¦ 1 ¦ 5 ¦ 9 ¦ 13 ¦ 17 ¦ 21 ¦ 25 ¦ 29 ¦ +4000H +------+------+------+------+------+------+------+------+ + ¦ 0 ¦ 4 ¦ 8 ¦ 12 ¦ 16 ¦ 20 ¦ 24 ¦ 28 ¦ +0000H L------¦------¦------¦------¦------¦------¦------¦------- + + + Доступ к сегментам ОЗУ осуществляется через три независи- +мых окна, которые можно "открыть" в адресном пространстве про- +цессора в пределах рабочей страницы ОЗУ: + + Окно ОЗУ "RAM2" - 8000-BFFFH + Окно ОЗУ "RAM1" - 4000-7FFFH + Окно ОЗУ "RAM0" - 0000-3FFFH + + Назначение разрядов порта 0AH следующее: + + D0 - 1 = включить окно ОЗУ "RAM0" + D1 - 1 = включить окно ОЗУ "RAM1" + D2 - 1 = включить окно ОЗУ "RAM2" + D3 - включить окно ПЗУ "ROM2-BIOS" + D4 - включить окно ПЗУ "ROM1-BIOS" + D5 - включить тактовую частоту процессора 2.5 МГц + D6 - отключить переключение ОЗУ 0F000H..0FFFFH (в режиме + "Orion-128" игнорируется) + D7 - включить режим "Orion-128" (область 0F000H..0FFFFH + недоступна для записи). + + Для выбора сегментов в каждом из окон "RAM0", "RAM1", +"RAM2" в компьютере предусмотрены три порта с адресами соот- +ветственно 04H, 05H, 06H, в которые могут быть записаны номера +сегментов ОЗУ. Порты диспетчера 04H, 05H, 06H, 08H, 0AH доступны +как для записи, так и для чтения. + + Область памяти 0F000H..0FFFFH в режиме "Orion-Pro" (разряд +D7 порта 0AH установлен в 0) доступна как для чтения, так и для записи. +Кроме того, программно можно установить режим, при котором указанная область +или переключается вместе с переключением страниц (D6=0), или не переключается +(D6=1) и проецирует "верхние" 4к сегмента 31 (1Fh). + В режиме "Orion-128" (разряд D7 порта 0AH установлен в 1) +указанная область памяти является не переключаемой независимо +от значения разряда D6, к тому же ячейки с адресами +0F400H..0FA00H доступны как порты (причем порты 0F800H..0FA00H +доступны только на запись, так как при чтении по адресам +0F800H..0FFFFH включается ОЗУ). + + Постоянная память, расположенная на основной плате, состоит +из двух частей: + + "ROM1-BIOS" - стартовое ПЗУ объемом 8 Кбайт; + "ROM2-BIOS" - ПЗУ пользователя объемом 8-64 Кбайт. + + Для доступа к постоянной памяти в адресном пространстве +процессора предусмотрено включение соответственно двух ROM-окон +ПЗУ. + Окно для "ROM1-BIOS" включается по адресам 0000H..1FFFH +при аппаратном сбросе компьютера, тем самым обеспечивая доступ +к стартовым и другим подпрограммам. + Для управления включением и выключением окна "ROM1-BIOS" +предназначен бит D4 порта диспетчера 0AH. + Включением окна "ROM2-BIOS" по адресам 2000H..3FFFH управ- +ляет бит D3 порта 0AH (независимо от окна "ROM1-BIOS"), причем +доступ к ПЗУ в этом окне осуществляется по сегментам размером +8Кбайт (отсюда и минимальный размер ПЗУ). Номер сегмента +"ROM2-BIOS" записывается в специальный порт с адресом 09H, +допускающий как запись, так и чтение информации. + Окна ПЗУ имеют самый высокий приоритет: если окно +"ROM1-BIOS" и/или "ROM2-BIOS" включено, то доступ к нему обес- +печивается из любой текущей страницы, в том числе при "откры- +том" окне ОЗУ "RAM0". + + 3. ПОРТЫ ВВОДА-ВЫВОДА + --------------------- + + В режиме "Orion-128" (бит D7 порта 0AH установлен в 1) +разрешен доступ к портам 0F400H..0FA00H, адресуемым через об- +ласть памяти, и к портам 10H..14H, 18H..1BH, 0F8H..0FFH, а так- +же портам периферии - с помощью команд процессора IN, OUT. + В режиме "Orion-Pro" (бит D7 порта 0AH установлен в 0) +доступ к портам как к ячейкам ОЗУ запрещен. + + Назначение портов: + + 00H - состояние DIP-переключателей (SW), определяющих + конфигурацию системы; + 01H - данные принтера "Centronics"; + 02H - сигналы управления принтером; + 03H - регистр настройки портов 00H..02H; + 04H - регистр сегментов для окна "RAM0"; + 05H - регистр сегментов для окна "RAM1"; + 06H - регистр сегментов для окна "RAM2"; + 07H - регистр настройки портов 04H..06H; + 08H - регистр страниц ОЗУ; + 09H - регистр сегментов "ROM2-BIOS"; + 0AH - диспетчер управления конфигурацией памяти; + 0BH - регистр настройки портов 08H..0AH; + 0CH..0FH - системный резерв; + 10H..13H - порты контроллера дисковода КР1818ВГ93 (в режи- + ме "Orion-128" доступны также через ячейки па- + мяти 0F700H..0F703H, 0F710H..0F714H, 0F720H): + 10H - регистр команд; + 11H - регистр дорожек; + 12H - регистр секторов; + 13H - регистр данных; + 14H - регистр управления контроллером дисковода; + в режиме "Orion-128" доступен также через ячей- + ки 0F704H, 0F714H, 0F720H; + 18H..1BH - универсальный порт, используемый как порт кла- + виатуры; в режиме "Orion-128" может быть перек- + лючен (параллельно с обращением 18-1BH) на ад- + реса одного из портов 0F4XXH, 0F5XXH, 0F6XXH по + выбору пользователя; + + 0F8H - регистр управления цветовым режимом дисплея; + в режиме "Orion-128" доступен также как ячейка + 0F800H; + 0F9H - регистр страниц; для режима "Orion-128" досту- + пен также как ячейка 0F900H; + 0FAH - регистр номера и размера экрана; в режиме + "Orion-128" доступен также как ячейка 0FA00H; + 0FBH - регистр включения прерываний от таймера (D6); + 0FCH - регистр цвета для псевдоцветного режима; + 0FFH - порт звука. +} + +{ + p0A_RAM0_MASK = $01; // RAM window 0000..3FFF + p0A_RAM1_MASK = $02; // RAM window 4000..7FFF + p0A_RAM2_MASK = $04; // RAM window 8000..BFFF + p0A_ROM2_MASK = $08; // ROM window 2000..3FFF + p0A_ROM1_MASK = $10; // ROM window 0000..1FFF + p0A_FIX_F000 = $40; // if p0A_FIX_F000 (D6) = 1 then RAM F000..FFFF = 1F segment 4k part always (with any pF9 combinations) + p0A_ORION_128 = $80; // if p0A_ORION_128 (D7=1) then RAM F000..FFFF = 1F segment 4k part always (with any p0A_FIX_F000, pF9 combinations) +} + +{$IFDEF DEBUG} +const tmpRet:integer=$FFFF; + tmpStart:boolean=False; + tmpStop:integer=$FFFF; + +function ByteToStrBin(bb:byte):string; + var i: integer; +begin + Result:=''; + for i:=1 to 8 do + begin + if (bb mod 2)=0 + then Result:='0'+Result + else Result:='1'+Result; + bb:=bb div 2; + end; +end; + +{$ENDIF} + +procedure DebugInfo(str: string; mode:integer); +{$IFDEF DEBUG} +var ff: system.text; + st, stt: string; + ii: integer; + bb: byte; + cc: array[0..20] of char; +{$ENDIF} +begin +{$IFDEF DEBUG} + cc[19]:=#0; + AssignFile(ff, 'c:\OrionZEm.debug'); + if FileExists('c:\OrionZEm.debug') then + Append(ff) + else + Rewrite(ff); + stt:=''; + st:=''; + if mode=1 then + for ii:=1 to 11 do + begin + bb:=RAMArr[MainPort[$F9], regDE+ii]; + if (bb<32)or(bb>126) then bb:=ord('.'); + stt:=stt+chr(bb); + end; + case mode of + 0,1: + begin + st:=Format(' - A=%d,B=%d,C=%d,DE=%d(%s),HL=%d(%s), fZ=%d,fC=%d, PC=%d(%s), (DE)=`%s`', + [regA, regB, regC, regDE, inttohex(regDE,4), regHL, inttohex(regHL,4), integer(fZ), integer(fC), regPC, inttohex(regPC,4), stt]); + end; + 2:begin + st:=IntToStr(TicksFromPrevSD); + end; + end; + writeln(ff, str+' '+st); + CloseFile(ff); +{$ENDIF} +end; + +procedure SetBeeper0; +begin + glBeeperVal:=128; +end; + +procedure SetBeeper1; +begin + glBeeperVal:=159; + glBeeperCounter:=Global_TStates; // interruptCounter; +end; + +function SetMemSize:string; +begin + RAMPagesCount:=SzRAMarr[MEMSizeMode] div 65536; + RAMSegmCount:=RAMPagesCount * 4; + case MEMSizeMode of + SIZE_4096, SIZE_2048: Result:='9A:AAAA;1;_'; + SIZE_1024: Result:='A:AAAA;1;_' + else Result:='9:AAAA;1;_'; + end; +end; + +function LongAddressStr(page,addr:integer):string; +begin + Result:=padl(IntToHex(page, 2), 2, '0')+':'+padl(IntToHex(addr, 4), 4, '0'); +end; + +function LongAddressParse(ast:string; var page,addr:integer):integer; +begin + Result:=pos(':',ast)-1; + page:=HexToInt(padl(copy(ast, 1, Result),2,'0')); + addr:=HexToInt(copy(ast, Result+2, 4)); +end; + +function GetBeeper:integer; +begin + if glBeeperVal=128 then Result:=0 else Result:=1; +end; + +function peekb(Index: Integer): byte; // читаем байт +var pFB, p0A, pPage, fPage: byte; + addr: integer; + o128: boolean; // true if Orion-128 mode of PRO +begin + pFB:=MainPort[$FB]; + if Z80CardMode>=Z80_ORIONPRO_v2 then begin // Orion-PRO + p0A:=MainPort[$0A]; + o128:=p0A and p0A_ORION_128 <> 0; + if Z80CardMode=Z80_ORIONPRO_v2 then fPage:=0 else fPage:=7; // segment 3 or 31 + if o128 then pPage:=MainPort[$F9] mod RAMPagesCount + else pPage:=MainPort[$08] mod RAMPagesCount; + if (Index<$4000) then begin + if (o128 and ((Z80CardMode>Z80_ORIONPRO_v3)and(pFB and $80 = 0))) then begin // if V3.20.pFB.Disp16k + addr:=(pFB and 3); + Result:=RAMarr[(pFB and $0C) shr 2, (addr shl 14) or (Index and $3FFF)]; // $OC or $1C ? + end + else begin + if p0A and p0A_RAM0_MASK = 0 then + Result:=RAMarr[pPage, Index] + else begin + addr:=(MainPort[$04] and 3); + Result:=RAMarr[(MainPort[$04] mod RAMSegmCount) shr 2, (addr shl 14) or (Index and $3FFF)]; + end; + end; + if (Index<$2000) then begin // 0000...1FFF + if p0A and p0A_ROM1_MASK <> 0 then + Result:=ROM1BIOS[Index]; // TODO: ROM1BIOS of 64kb size + end + else // 2000...3FFF + if p0A and p0A_ROM2_MASK <> 0 then + Result:=ROM2BIOS[MainPort[$09]*$2000+(Index-$2000)]; + end + else if (Index<$8000) then begin + if p0A and p0A_RAM1_MASK = 0 then + Result:=RAMarr[pPage, Index] + else begin + addr:=(MainPort[$05] and 3); + Result:=RAMarr[(MainPort[$05] mod RAMSegmCount) shr 2, (addr shl 14) or (Index and $3FFF)]; + end; + end + else if (Index<$C000) then begin + if p0A and p0A_RAM2_MASK = 0 then + Result:=RAMarr[pPage, Index] + else begin + addr:=(MainPort[$06] and 3); + Result:=RAMarr[(MainPort[$06] mod RAMSegmCount) shr 2, (addr shl 14) or (Index and $3FFF)]; + end; + end + else begin + Result:=RAMarr[pPage, Index]; + if o128 and(Index>=$F400)and(Index<$F800) then + Result:=RAMPORTGet(Index) + else if (Index>=$F000)and((o128 and ((Z80CardMode0))) then + Result:=RAMarr[fPage, Index] + end; + end + else begin // Orion-128 + if (Index<$F000) or + ((Z80CardMode>Z80CARD_MINIMAL) and (pFB and $20 <> 0)) then // "несклеенное" ОЗУ + begin + if (Index<$4000) and + (Z80CardMode>Z80CARD_MINIMAL) and + (pFB and $80 = 0) then + begin // диспетчер 16к + addr:=(pFB and 3); + Result:=RAMarr[(pFB and $0C) shr 2, (addr shl 14) or (Index and $3FFF)]; // $OC or $1C ? + end + else if MainPort[$F9]=$F800 then // в стандартном Орионе - RomBIOS + Result:=ROMF800[Index] + else if Index<$F400 then // "склеенное" ОЗУ + Result:=RAMarr[0, Index] + else // внешние порты (маппированные на ОЗУ) + Result:=RAMPORTGet(Index); + end; +end; + +function peekw(Index: Integer): word; //читаем слово +begin + Result := peekb(Index) Or (peekb(Index + 1) shl 8); +end; + +procedure pokeb(Index: Integer; const Value: byte); // пишем байт +var pF9, pFB: byte; + p0A, pPage, fPage: byte; + addr: integer; + o128: boolean; // true if Orion-128 mode of PRO +begin + pFB:=MainPort[$FB]; + if Z80CardMode>=Z80_ORIONPRO_v2 then begin // Orion-PRO + p0A:=MainPort[$0A]; + o128:=p0A and p0A_ORION_128 <> 0; + if Z80CardMode=Z80_ORIONPRO_v2 then fPage:=0 else fPage:=7; // segment 3 or 31 + if o128 then pPage:=MainPort[$F9]mod RAMPagesCount + else pPage:=MainPort[$08]mod RAMPagesCount; + if (Index<$4000) then begin + if ((Index<$2000)and(p0A and p0A_ROM1_MASK <> 0))or // 0000...1FFF ROM1 + ((Index>=$2000)and(p0A and p0A_ROM2_MASK <> 0)) // 2000...3FFF ROM2 + then exit; // read only + if (o128 and ((Z80CardMode>Z80_ORIONPRO_v3)and(pFB and $80 = 0))) then begin // if V3.20.pFB.Disp16k + addr:=(pFB and 3); + RAMarr[(pFB and $0C) shr 2, (addr shl 14) or (Index and $3FFF)]:=Value; + end + else begin + if p0A and p0A_RAM0_MASK = 0 then + RAMarr[pPage, Index]:=Value + else begin + addr:=(MainPort[$04] and 3); + RAMarr[(MainPort[$04] mod RAMSegmCount) shr 2, (addr shl 14) or (Index and $3FFF)]:=Value; + end; + end; + end + else if (Index<$8000) then begin + if p0A and p0A_RAM1_MASK = 0 then + RAMarr[pPage, Index]:=Value + else begin + addr:=(MainPort[$05] and 3); + RAMarr[(MainPort[$05] mod RAMSegmCount) shr 2, (addr shl 14) or (Index and $3FFF)]:=Value; + end; + end + else if (Index<$C000) then begin + if p0A and p0A_RAM2_MASK = 0 then + RAMarr[pPage, Index]:=Value + else begin + addr:=(MainPort[$06] and 3); + RAMarr[(MainPort[$06] mod RAMSegmCount) shr 2, (addr shl 14) or (Index and $3FFF)]:=Value; + end; + end + else if (Index<$F000) then + RAMarr[pPage, Index]:=Value + else begin + if o128 then begin + if (Index>=$F400) then + RAMPORTSet(Index, Value) + else + if (Z80CardMode0) then + RAMarr[fPage, Index]:=Value + else + RAMarr[pPage, Index]:=Value; + end; + end + else begin // Orion-128 + if (Index<$F000) or + ((Z80CardMode>Z80CARD_MINIMAL) and (pFB and $20 <> 0)) then // "несклеенное" ОЗУ + begin + pF9:=MainPort[$F9]; + if (Index<$4000) and + (Z80CardMode>Z80CARD_MINIMAL) and + (pFB and $80 = 0) then + begin // диспетчер 16к + addr:=(pFB and 3) shl 6; + RAMarr[(pFB and $0C) shr 2, (addr shl 8) or (Index and $3FFF)]:=Value; // $OC or $1C ? + end + else if (pF9 Value)} then + RAMarr[pF9, Index] := Value; + end + else if Index<$F400 then // "склеенное" ОЗУ + begin + RAMarr[0, Index] := Value; + end + else // порты + begin + if Z80CardMode<>Z80CARD_MAXIMAL then + RAMArr[0, Index] := Value; // в стандартном Орионе портится ОЗУ под портами + RAMPortSet(Index, Value); + end; + end; +end; + +procedure pokew(Index: Integer; const Value: word); // пишем слово +begin + pokeb(Index, Value And $FF); + pokeb(Index + 1, (Value And $FF00) shr 8); +end; + +{ TPORTS } + +function RAMPORTGet(Index: Integer): byte; +var addr: byte; +begin + Result:=$FF; + case hi(Index) of + $F8..$FA: Result:=InB(Index); + $F4: Result:=PortF400[lo(Index) and 3]; // BB55 (i8255) - keyboard + $F5: if HDDPort=HDDPortF500 then + Result:=IdeController[lo(Index) and 3] // BB55 (i8255) - IDE + else + Result:=PortF500[lo(Index) and 3]; // BB55 (i8255) - ROMDISK + $F6: if HDDPort=HDDPortF600 then + Result:=IdeController[lo(Index) and 3] // BB55 (i8255) - IDE + else + Result:=PortF600[lo(Index) and 3]; // BB55 (i8255) - Printer + $F7: begin // expansion ports + addr:=lo(Index); + if (addr>=$70) then // F770..F77F mapped to rtl8019as[reg0...reg15], F780..F7FF mapped to rtl8019as[reg16] + begin + if Assigned(FNE2kDevice) then + begin + if (addr>=$80) then + Result:=FNE2kDevice[16] + else + Result:=FNE2kDevice[addr and $0F]; + end; + end + else + case (addr and $FC) of // неполная дешифрация + lo(FDC_ADDR1), lo(FDC_ADDR2): Result:=FDController[Index and 3]; + lo(RGU_ADDR1), lo(RGU_ADDR2): Result:=FDController.RGU; + lo(FMC_ADDR60), lo(SD_ADDR0), lo(SD_ADDR1), lo(UART_ADDR0), lo(UART_ADDR1): + if (Z80CardMode=$70) then // F770..F77F mapped to rtl8019as[reg0...reg15], F780..F7FF mapped to rtl8019as[reg16] + begin + if Assigned(FNE2kDevice) then + begin + if (addr>=$80) then // F780..F7FF - data register (BASE+10h) + FNE2kDevice[16]:=Value + else begin // F770..F77F + if (addr=$70)and(Value=ETHERDEV_RESET) then + FNE2kDevice.Reset // pulse down on reset pin (pin 33 for rtl8019) + else + FNE2kDevice[addr and $0F]:=Value; + end; + end; + end + else + case (addr and $FC) of + lo(FDC_ADDR1), lo(FDC_ADDR2): FDController.Reg[Index and 3]:=Value; + lo(RGU_ADDR1), lo(RGU_ADDR2): FDController.RGU:=Value; + lo(FMC_ADDR60), lo(SD_ADDR0), lo(SD_ADDR1), lo(UART_ADDR0), lo(UART_ADDR1): + if (Z80CardMode=Z80_ORIONPRO_v2 then begin // Orion-PRO + case Lo(Port) of + $08: if outbyte>=RAMPagesCount then outbyte:=outbyte mod RAMPagesCount; + $10..$14: RAMPORTSet(FDC_ADDR1+Lo(Port), outbyte); // FDD + $18..$1B: RAMPORTSet(KBD_ADDR0+Lo(Port)-$18, outbyte); // BB55 (i8255) - keyboard + $28..$2B: RAMPORTSet(ROMD_ADDR0+Lo(Port)-$28, outbyte); // BB55 (i8255) - Rom-Disk + $3E: AYWriteReg(glSoundRegister, outbyte); // запись данных муз. процессора + $3F: glSoundRegister := outbyte And $F; // запись номера регистра муз. процессора + FMC_DATA50: case RTCmode of + K512vi50: F146818[F146818.Addr]:=outbyte; + DS1302_50: ; + end; + FMC_ADDR51: case RTCmode of + K512vi50: F146818.Addr:=outbyte; + DS1302_50: ; + end; + pro_control, // registr uprawleniq - W + pro_data_h, // st.bajt registra dannyh - WR + pro_data_l, // ml.bajt registra dannyh - WR // adr=0 + pro_err, // registr oshibok - R // adr=1 + pro_sec_cnt, // s4et4ik seektorow - W // adr=2 + pro_sector, // registr sektora - W // adr=3 + pro_cyl_lsb, // ml.bajt nom.cilindra - W // adr=4 + pro_cyl_msb, // st.bajt nom.cilindra - W // adr=5 + pro_head, // registr golowki/ustrojstwa - W // adr=6 + pro_command: // registr komand - W // adr=7 + IdeProController.IdeReg[Lo(Port)]:=outbyte; + end; + end + else if Z80CardMode=Z80CARD_MOSCOW then + begin + loport:=Lo(port); + if loport>=$F0 then pF9:=0 + else pF9:=MainPort[$F9]; + RAMArr[pF9, loport*256+loport] := outbyte; // в стандартном Орионе портится ОЗУ под портами + end; // Orion-128, Orion-PRO + case Lo(Port) of + $F8: begin + bb:=MainPort[$F8]; + if bb<>outbyte then + begin + DoNotUpdateScr:=False; + if (bb and $80<>outbyte and $80) then Scr480(outbyte); + end; + end; + $F9: if outbyte>=RAMPagesCount then outbyte:=outbyte mod RAMPagesCount; + $FA: if (MainPort[$FA] and $80<>outbyte and $80) then Scr480(outbyte); +{$IFDEF USE_SOUND} + $FE: if Z80CardMode<>Z80CARD_MOSCOW then + begin + if (outbyte and 16 = 0) + then SetBeeper0 + else SetBeeper1; + end; + $FF: if Z80CardMode<>Z80CARD_MOSCOW then + begin + if GetBeeper=1 + then SetBeeper0 + else SetBeeper1; + end; +{$ENDIF} + end; + MainPort[Lo(Port)]:=outbyte; +{$IFDEF USE_SOUND} + case port of + $FFFD: glSoundRegister := outbyte And $F; + $BFFD: AYWriteReg(glSoundRegister, outbyte); + $BEFD: AYWriteReg(glSoundRegister, outbyte); + end; +{$ENDIF} +End; + +Function inb(port : integer) : integer; +var loport, pF9: integer; +begin + Result := $FF; + if Z80CardMode>=Z80_ORIONPRO_v2 then begin // Orion-PRO + case Lo(Port) of + $0: Result:=lo(OrionPRO_DIP_SW); + $01..$0B: Result:=MainPort[Lo(Port)]; + $10..$14: Result:=RAMPORTGet(FDC_ADDR1+Lo(Port)); // FDD + $18..$1B: Result:=RAMPORTGet(KBD_ADDR0+Lo(Port)); // BB55 (i8255) - keyboard + $28..$2B: Result:=RAMPORTGet(ROMD_ADDR0+Lo(Port)); // BB55 (i8255) - Rom-Disk + $3F: Result := AYPSG.Regs[glSoundRegister]; // чтение данных муз. процессора + FMC_DATA50: case RTCmode of + K512vi50: Result:=F146818[F146818.Addr]; + DS1302_50: ; + end; + FMC_ADDR51: case RTCmode of + K512vi50: Result:=F146818.Addr; + DS1302_50: ; + end; + pro_astatus, // alxt.registr sostoqniq - R + pro_data_h, // st.bajt registra dannyh - WR + pro_data_l, // ml.bajt registra dannyh - WR // adr=0 + pro_err, // registr oshibok - R // adr=1 + pro_sec_cnt, // s4et4ik seektorow - W // adr=2 + pro_sector, // registr sektora - W // adr=3 + pro_cyl_lsb, // ml.bajt nom.cilindra - W // adr=4 + pro_cyl_msb, // st.bajt nom.cilindra - W // adr=5 + pro_head, // registr golowki/ustrojstwa - W // adr=6 + pro_status: // registr sostoqniq - R // adr=7 + Result:=IdeProController.IdeReg[Lo(Port)]; + end; + end + else if Z80CardMode=Z80CARD_MOSCOW then + begin + loport:=Lo(port); + if loport>=$F0 then pF9:=0 + else pF9:=MainPort[$F9]; + Result:=RAMArr[pF9, loport*256+loport]; // в стандартном Орионе портится ОЗУ под портами + end; // Orion-128, Orion-PRO + // Orion-128, Orion-PRO +{$IFDEF USE_SOUND} + If port = $FFFD Then + Result := AYPSG.Regs[glSoundRegister] +{$ENDIF} +End; + +function GetCPUTstates: integer; +begin + if (Z80CardMode>=Z80_ORIONPRO_v2) and ((MainPort[$0A] and $20)<>0) then + Result:=TSTATES_2M5 + else + Result:=CPUTstates[MIN(CPUSpeedMode, SPEED_INF)]; +end; + +end. diff --git a/modSD.pas b/modSD.pas new file mode 100644 index 0000000..7f4c483 --- /dev/null +++ b/modSD.pas @@ -0,0 +1,978 @@ +///////////////////////////////////////////////////////////////////////// +// // +// Orion/Z (Orion-128 + Z80-CARD-II) emulator, version 1.9 // +// // +// Author: Sergey A. // +// // +// Copyright (C) 2006-2016 Sergey A. // +// // +// This program is free software; you can redistribute it and/or // +// modify it in any ways. // +// This program is distributed "AS IS" 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. // +// // +///////////////////////////////////////////////////////////////////////// + + +{***************************************************************** + + SD-card (SPI) emulation: SDC V1 or MMC (CMD8 rejected), non-SDHC + + Issue CMD8 prior to first ACMD41 for initialization of HCSD + makes the cards realize that the host supports the Physical + Layer Version 2.00 and the card can enable new functions. + + *****************************************************************} + +unit modSD; + +interface + + +{$I 'OrionZEm.inc'} + + +Uses Windows, SysUtils, classes, Forms, HDDUtils; + +const +{ HARDWARE - RTC/SD port $F762} +{ + RTC_DOUT equ 80h 74574 RTC/SD output bits + RTC_CLK equ 40h + RTC_DIR equ 20h + RTC_CE equ 10h + RTC_DIN equ 01h 74125 RTC/SD input bits +N8VEM: + SD_PWR equ 08h reserved - SD poweron/poweroff + SD_CS equ 04h NPN inverter, positive logic. + SD_CLK equ 02h + SD_DOUT equ 01h + SD_DIN equ 80h +MSX: + MSXSD_PWR = F602.D3.WR reserved - SD poweron/poweroff + MSXSD_CS = F602.D2.WR + MSXSD_CLK = F603.WR + MSXSD_RD = F603.RD + MSXSD_WR = F603.D7.WR +} + SD_ADDR0 = $F762; + SD_ADDR1 = $F763; + SD_PWR = 8; // SD_ADDR0.D3 - positive logic, both schemes + SD_CS = 4; // SD_ADDR0.D2 - positive logic (because NPN inverter before /CS), both schemes + SD_CLK = 2; // SD_ADDR0.D1 - N8VEM + SD_DOUT = 1; // SD_ADDR0.D0 - N8VEM + SD_DIN = $80; // SD_ADDR0.D7 - N8VEM + MSXSD_WR = $80; // SD_ADDR1.D7 - MSX SD + SD_BLOCK_SIZE = 512; + +{ SPI } + SPI_START_TOKEN = $FE; + +{ R1 Responses, D7=0 allways } + R1_IN_IDLE = 1; + R1_ERASE_RESET = 2; + R1_ILLEGAL_CMD = 4; + R1_CMD_CRC_ERR = 8; + R1_ERA_SEQ_ERR = 16; + R1_ADDRESS_ERR = 32; + R1_PARAM_ERR = 64; + +{ ErrorToken [appears after R1 response if transfer error ] bits, D7:D5=0 allways } + ERT_ERROR = 1; + ERT_CARD_CONTR = 2; + ERT_MEDIA_ECC = 4; + ERT_OUTOFRANGE = 8; + ERT_CARD_LOCK = 16; + +{ Write Responses, D7:D4=0 allways } + WRITE_ACCEPTED = $05; // Data Accepted + WRITE_CRCERROR = $0b; // Transmission CRC Error + WRITE_DATAERROR= $0d; // Data Write Error + +{ Implemented commands } + CMD0 = $40; // GO_IDLE_STATE + CMD1 = $41; // SEND_OP_COND + CMD9 = $49; // SEND_CSD + CMD10 = $4A; // SEND_CID + CMD16 = $50; // SET_BLOCKLEN + CMD17 = $51; // READ_BLOCK + CMD18 = $52; // MULTI_READ_BLOCK + CMD24 = $58; // WRITE_BLOCK + ACMD41 = $69; // SDC init + CMD55 = $77; // APP_CMD + CMD58 = $7A; // READ_OCR + CMD59 = $7B; // CRC_ON_OFF +// +// TODO: CMD8 & HCSD + +type + TSpiState = ( + SPI_PWR_STATE, + SPI_IDLE_STATE, + SPI_ARG_X_LO, + SPI_ARG_X_HI, + SPI_ARG_Y_LO, + SPI_ARG_Y_HI, + SPI_ARG_CRC, + SPI_RESPOND_SINGLE, + SPI_RESPOND_MULTI, + SPI_READ_SINGLE_BLOCK, + SPI_READ_MULTIPLE_BLOCK, + SPI_WRITE_SINGLE, + SPI_WRITE_SINGLE_BLOCK, + SPI_WRITE_SINGLE_CRC + ); + + TspiArgW = packed record // for WORD-wide addressing inside (spiArg:DWORD) + spiArgY: word; + spiArgX: word; + end; + PspiArgW = ^TspiArgW; + + TspiArgB = packed record // for BYTE-wide addressing inside (spiArg:DWORD) + spiArgYlo: byte; + spiArgYhi: byte; + spiArgXlo: byte; + spiArgXhi: byte; + end; + PspiArgB = ^TspiArgB; + + TCardIDRegister = packed record + MID: byte; // Manufacturer ID [binary] + OID: word; // OEM/Application ID [ACSII] + PNM: array[0..4] of char; // Product Name [ACSII] + PRV: byte; // Product Revision [BCD] + PSN: DWORD; // Serial Number [binary] + MDT: word; // Manufacturer Date [BCD] + CRC: byte; // CRC-7 checksum, D0=1 [binary] + end; + PCardIDRegister = ^TCardIDRegister; + + TCardSDRegister = packed record + ZERO: byte; // D7=D6=00 D5:D0=reserved=00000 + TAAC: byte; // D7:D0=TAAC[7:0] + NSAC: byte; // D7:D0=NSAC[7:0] + TRAN_SPEED: byte; // D7:D0=TRAN_SPEED[7:0] + CCC: byte; // D7:D0=CCC[11:4] + CCC_READ_BL_LEN: byte; // D7:D4=CCC[3:0] D3:D0=READ_BL_LEN[3:0] + BITFIELD1_CSIZE: byte; // D7=RD_BL_PARTIAL D6=WR_BL_MISALIGN D5=RD_BL_MISALIGN D4=DSR_IMP D3:D2=reserved=00 D1:D0=CSIZE[11:10] + CSIZE: byte; // D7:D0=C_SIZE[9:2] + CSIZE_VDD: byte; // D7:D6=C_SIZE[1:0] D5:D3=VDD_R_CURR_MIN[2:0] D2:D0=VDD_R_CURR_MAX[2:0] + VDD_CSIZE_MULT: byte; // D7:D5=VDD_W_CURR_MIN[2:0] D4:D2=VDD_W_CURR_MAX[2:0] D2:D0=C_SIZE_MULT[2:1] + CSIZE_MULT_SECSIZE:byte; // D7=C_SIZE_MULT[0] D6=ERASE_BLK_EN D5:D0=SECTOR_SIZE[6:1] + SECSIZE_WPGRP_SIZE:byte; // D7=SECTOR_SIZE[0] D6:D0=WP_GRP_SIZE[6:0] + WPGRP_ENA_WRBL_LEN:byte; // D7=WP_GRP_ENABLE D6:D5=reserved=00 D4:D2=R2W_FACTOR[2:0] D1:D0=WRITE_BL_LEN[3:2] + WRBL_LEN__ZERO: byte; // D7:D6=WRITE_BL_LEN[1:0] D5=0 D4:D0=reserved=00000 + BITFIELD2: byte; // D7=FILE_FORMAT_GRP D6=COPY D5=PERM_WRITE_PROTECT D4=TMP_WRITE_PROTECT D3:D2=FILE_FORMAT[1:0] D1:D0=reserved=00 + CRC: byte; // D7:D1= CRC-7 checksum D0=1 + end; + PCardSDRegister = ^TCardSDRegister; + + TSdAccess=procedure(Sender: TObject; Drive: byte; Op: char); + + TSDParams = packed record + // hardware + Scheme: integer; // 0=N8VEM (only software bit-by-bit) 1=MSX (bit->byte register on input, /CLK formed by /WR/RD) + RDout: byte; // MSX scheme input 8-bit register + // SD + SPDR: byte; // SD Card DATA REGISTER (out) + PrevR0: byte; // Port F762 register in N8VEM + R0, R1: byte; // Port F762, F763 registers (both schemes) + InpBitCount: integer; // variable for 8bit->1bit shift conversion + // SPI Emulation + spiArg: DWORD; // SPI command argument + spiByte: byte; // SD Card DATA REGISTER (in) + spiState: TSpiState; + spiCommand: byte; + spiByteCount: DWORD; + spiResponseBuffer: array [0..20] of byte; + spiResponsePtr: PByte; + spiResponseEnd: PByte; + // SD image emulation + FileOffset: DWORD; // offset inside file (0..MaxLBA-1) + SectorIndex: DWORD; // offset inside sector (0..SectorSize-1) + sectorSize: DWORD; + FReserved: array[0..7] of integer; + end; + + TSDController = class(TObject) + SDHC: boolean; // allways False (TODO) + FImgFile: String; + FImageRO: boolean; + FHandle: THANDLE; + FMaxLBA: integer; + FOnAccess: TSdAccess; + FBuf: PChar; // SdSector: array[0..SD_BLOCK_SIZE] of byte; + FParams: TSDParams; + private + procedure SetImageFile(const Value: String); + procedure SetOnAccess(const Value: TSdAccess); + procedure SetImageRO(const Value: boolean); + // SPI + procedure SDCheckFBuf; + procedure rl(var bb:byte); // rotate left + procedure UpdateSpi; // SPI StateMachine next step + procedure SDSeekToOffset(offset: DWORD; + DoRead: boolean); // seek file to offset, read 'sectorSize' bytes to 'SdSector' buffer + function SDCommit():boolean; // write 'sectorSize' bytes from 'SdSector' buffer to file + procedure SDWriteByte(value: byte); // write byte to SdSector[SectorIndex] + function SDReadByte():byte; // read byte from SdSector[SectorIndex] + function SDEnabled():boolean; + procedure SDPowerOn; + function GetPort1: byte; // interface with device + procedure SetPort1(const Value: byte); // interface with device + function GetPort0: byte; // interface with device + procedure SetPort0(const Value: byte); // interface with device + procedure SetScheme(const Value: integer); + public + constructor Create; + destructor Destroy; override; + procedure Reset; + procedure SaveToStream(Stream: TStream); + procedure ReadFromStream(Stream: TStream); + property ImageFile:String read FImgFile write SetImageFile; + property ImageRO:boolean read FImageRO write SetImageRO; + property OnAccess:TSdAccess read FOnAccess write SetOnAccess; + property Port0:byte read GetPort0 write SetPort0; // F762 + property Port1:byte read GetPort1 write SetPort1; // F763 + property Scheme:integer read FParams.Scheme write SetScheme; // 0=N8VEM, 1=MSX + end; + +var SDController: TSDController; + SDScheme: integer; + SDImage: String; + SDRO: boolean; + FIDBuf: array[0..SD_BLOCK_SIZE] of byte; + +implementation + +Uses modOrion; + +{$IFDEF SD_DEBUG} +function ascii(ch:byte):char; +begin + if (ch >= 32)and(ch<=127) then + Resyult:=ch + else + Result:='.'; +end; +{$ENDIF} + +procedure SPI_DEBUG(fmt: string; const arr: array of const); +begin +{$IFDEF SD_DEBUG} + modOrion.DebugInfo(Format(Fmt, arr),2); +{$ENDIF} +end; + +function TSDController.SDEnabled():boolean; +begin + Result:=FHandle<>INVALID_HANDLE_VALUE; +end; + +function TSDController.GetPort0: byte; // interface with device, port F762, SD Output +begin + if SDEnabled() then + case FParams.Scheme of + 0: Result:=FParams.SPDR or (not SD_DIN); // N8VEM mask to "1" all bits except SD_DIN=128=80h + 1: Result:=$FF; // MSX + end + else + Result:=$FF; +end; + +procedure TSDController.SetPort0(const Value: byte); // interface with device, port F762, SD input (bit->byte convertor), mode "SPI 0" +begin + with Fparams do + begin + if ((Value and SD_PWR)<>(R0 and SD_PWR)) then // power off or on + begin + SDPowerOn; + if Assigned(FOnAccess) then begin + if ((Value and SD_PWR)=0) then + FOnAccess(Self, 4, 'd') // display (d)own - power off + else + FOnAccess(Self, 4, 'u'); // display (u)p - power on + end; + end; + case Scheme of + 0: // N8VEM + if Value<>R0 then + begin + PrevR0:=R0; + R0:=Value; + if ((R0 and SD_CLK)<>(PrevR0 and SD_CLK))and // SD_CLK changing + ((R0 and SD_PWR)<>0)and // питание на карту подано + SDEnabled() then + begin // clock pin state changing + if (PrevR0 and SD_CLK)=0 then + begin // фронт импульса CLK + inc(InpBitCount); + if (spiState<>SPI_PWR_STATE) then // карта проинициализирована + begin + if ((R0 and SD_CS)<>0) then // карта выбрана + begin + if (R0 and SD_DOUT)=0 then + spiByte:=spiByte and $FE // защелкивание "0" по фронту (SPI 0) + else + spiByte:=spiByte or 1; // защелкивание "1" по фронту (SPI 0) + if (spiState=SPI_IDLE_STATE) and + ((spiByte and $C0)=$40) then // пришла команда + begin + UpdateSpi; + InpBitCount:=0; + end; + end + else // карта не выбрана -> передача следующему в кольце (т.е. на выход) + begin + if (R0 and SD_DOUT)=0 then + SPDR:=SPDR and $FE + else + SPDR:=SPDR or 1; + end; + end + else UpdateSpi; // wait for initial 74 more clocks + end + else + begin // спад импульса CLK + rl(SPDR); + if (spiState<>SPI_PWR_STATE) and (InpBitCount=8) then + begin + InpBitCount:=0; // идем побайтно + if ((R0 and SD_CS)<>0) then UpdateSpi; + end; + rl(spiByte); // сдвиг по спаду (SPI 0) + end; + end; + end; {if} + 1: if Value<>R0 then + begin + PrevR0:=R0; + R0:=Value; // D1 = /CS + end; + end; {case} + end; {with do} +end; + +function TSDController.GetPort1: byte; // ld reg, (0F763h) ; reg <- (0F763h) +begin + with FParams do + case Scheme of + 0: Result:=Port0; // N8VEM + 1: Result:=RDout; //SPDR; // MSX + end; +end; + +procedure TSDController.SetPort1(const Value: byte); // ld (0F763h), reg ; (0F763h) <- reg +begin + with FParams do + case Scheme of + 0: Port0:=Value; // N8VEM + 1: if ((R0 and SD_PWR)<>0) then // питание на карту подано + begin // MSX - и фронт и спад CLK формируются автоматически по сигналам /WR, /RD (в пределах одной команды CPU) +// фронт + R1:=Value; + inc(InpBitCount); + if (spiState<>SPI_PWR_STATE) then // карта проинициализирована + begin + if ((R0 and SD_CS)<>0) then // карта выбрана + begin + if ((R1 and MSXSD_WR)=0) then + spiByte:=spiByte and $FE // защелкивание "0" + else + spiByte:=spiByte or 1; // защелкивание "1" + if (spiState=SPI_IDLE_STATE) and + ((spiByte and $C0)=$40) then // пришла команда + InpBitCount:=8; + end + else // карта не выбрана -> передача следующему в кольце (т.е. на выход) + begin + if ((R1 and MSXSD_WR)=0) then + SPDR:=SPDR and $FE + else + SPDR:=SPDR or 1; + end; + end + else UpdateSpi; // wait for initial 74 more clocks +// спад + rl(SPDR); + RDout:=SPDR; + if (spiState<>SPI_PWR_STATE) and (InpBitCount=8) then + begin + if ((R0 and SD_CS)<>0) then UpdateSpi; + InpBitCount:=0; // идем побайтно + end; + rl(spiByte); // сдвиг по спаду (SPI 0) + end; {case MSX} + end; {case} +end; + +procedure TSDController.SetScheme(const Value: integer); +begin + FParams.Scheme := Value; +end; + +procedure TSDController.UpdateSpi; +var +{$IFDEF SD_DEBUG} + i, ofs: integer; + buf: array [0..16] of byte; +{$ENDIF} + C_Size, CSize_Mult: integer; + CardSDRegister:TCardSDRegister; +begin + with Fparams do + begin + // SPI state machine + SPI_DEBUG('byte: %0.2x\n',[spiByte]); + SPI_DEBUG('state: %d\n', [ord(spiState)]); + case (spiState) of + SPI_PWR_STATE: + if ((R0 and SD_CS)=0) and (InpBitCount>=74) then + spiState := SPI_IDLE_STATE; + SPI_IDLE_STATE: + if(spiByte = $0ff) then begin + SPDR := $01; // echo back that we're ready + end + else begin + spiCommand := spiByte; + SPDR := $FF; + spiState := SPI_ARG_X_HI; + end; + SPI_ARG_X_HI: + begin + SPI_DEBUG('x hi: %0.2X\n',[spiByte]); + PspiArgB(@spiArg)^.spiArgXhi := spiByte; + SPDR := $FF; + spiState := SPI_ARG_X_LO; + end; + SPI_ARG_X_LO: + begin + SPI_DEBUG('x lo: %0.2X\n', [spiByte]); + PspiArgB(@spiArg)^.spiArgXlo := spiByte; + SPDR := $FF; + spiState := SPI_ARG_Y_HI; + end; + SPI_ARG_Y_HI: + begin + SPI_DEBUG('y hi: %0.2X\n', [spiByte]); + PspiArgB(@spiArg)^.spiArgYhi := spiByte; + SPDR := $FF; + spiState := SPI_ARG_Y_LO; + end; + SPI_ARG_Y_LO: + begin + SPI_DEBUG('y lo: %0.2X\n', [spiByte]); + PspiArgB(@spiArg)^.spiArgYlo := spiByte; + SPDR := $FF; + spiState := SPI_ARG_CRC; + end; + SPI_ARG_CRC: + begin + SPI_DEBUG('SPI - CMD%d (%0.2X) X:%0.4X Y:%0.4X CRC: %0.2X\n', + [spiCommand xor $40, spiCommand, PspiArgW(@spiArg)^.spiArgX, PspiArgW(@spiArg)^.spiArgY, spiByte]); + // ignore CRC and process commands + case (spiCommand) of + CMD0: begin // $40 = GO_IDLE_STATE (reset) + SPDR := $FF; // does 8-bit NCR on next clock period (8-clock wait) + spiState := SPI_RESPOND_SINGLE; + spiResponseBuffer[0] := $01; // no errors, going idle + spiResponsePtr := @spiResponseBuffer[0]; + spiResponseEnd := pointer(integer(spiResponsePtr)+1); + spiByteCount := 0; + end; + CMD1: begin // $41 = SEND_OP_COND (init) + SPDR := $FF; // does 8-bit NCR on next clock period (8-clock wait) + spiState := SPI_RESPOND_SINGLE; + spiResponseBuffer[0] := $00; // no error + spiResponsePtr := @spiResponseBuffer[0]; + spiResponseEnd := pointer(integer(spiResponsePtr)+1); + spiByteCount := 0; + end; + CMD17: begin // $51 = READ_BLOCK + SPDR := $FF; // does 8-bit NCR on next clock period + spiState := SPI_RESPOND_SINGLE; + spiResponseBuffer[0] := $00; // no error + spiResponseBuffer[1] := SPI_START_TOKEN; // start block + spiResponsePtr := @spiResponseBuffer[0]; + spiResponseEnd := pointer(integer(spiResponsePtr)+2); + SDSeekToOffset(spiArg, True); + spiByteCount := sectorSize; // SD_BLOCK_SIZE; + end; + CMD18: begin // $52 = MULTI_READ_BLOCK + SPDR := $FF; // does 8-bit NCR on next clock period + spiState := SPI_RESPOND_MULTI; + spiResponseBuffer[0] := $00; // no error + spiResponseBuffer[1] := SPI_START_TOKEN; // start block + spiResponsePtr := @spiResponseBuffer[0]; + spiResponseEnd := pointer(integer(spiResponsePtr)+2); + SDSeekToOffset(spiArg, true); + spiByteCount := sectorSize; // SD_BLOCK_SIZE; + end; + CMD24: begin // $58= WRITE_BLOCK + SPDR := $FF; // does 8-bit NCR on next clock period + spiState := SPI_WRITE_SINGLE; + spiResponseBuffer[0] := $00; // no error + spiResponsePtr := @spiResponseBuffer[0]; + spiResponseEnd := pointer(integer(spiResponsePtr)+1); + SDSeekToOffset(spiArg, False); + spiByteCount := sectorSize; // SD_BLOCK_SIZE; + end; + CMD9: begin // $49 = SEND_CSD + SPDR:=$FF; // does 8-bit NCR on next clock period (8-clock wait) + spiState := SPI_RESPOND_SINGLE; + fillchar(spiResponseBuffer, sizeof(spiResponseBuffer), 0); + spiResponseBuffer[0] := $00; // R1 = no error, no idle + spiResponseBuffer[1] := $FF; // does 8-bit NCR on next clock period (8-clock wait) + spiResponseBuffer[2] := SPI_START_TOKEN; + with PCardSDRegister(@spiResponseBuffer[3])^ do + begin + ZERO:=0; + TAAC:=8; // D7:D0=TAAC[7:0] time unit=0=1ns timevalue=1=1.0 + NSAC:=1; // D7:D0=NSAC[7:0] 1=100 clock cycles + TRAN_SPEED:=$32; // is equal to 25 MHz + CCC:=$11; // D7:D0=CCC[11:4] ccc(4,8) - supported commands classes + CCC_READ_BL_LEN:=$59; // D7:D4=CCC[3:0] ccc(0,2) - supported commands classes D3:D0=READ_BL_LEN[3:0] 9=2^9=512bytes +{} C_Size:=FMaxLBA div 16384; + CSize_Mult:=0; + while (C_Size<>0) do begin + inc(CSize_Mult); + C_Size:=C_Size shr 1; + end; + C_Size:=FMaxLBA div (1 shl (CSize_Mult+2)) - 1; + C_Size:=C_Size shl 6; +{} CSize_Mult:=CSize_Mult shl 7; + BITFIELD1_CSIZE:=PspiArgB(@C_Size)^.spiArgXlo+$80; // D7=RD_BL_PARTIAL=1 D6=WR_BL_MISALIGN=0 D5=RD_BL_MISALIGN=0 D4=DSR_IMP=0 D3:D2=reserved=00 D1:D0=CSIZE[11:10] + CSIZE:=PspiArgB(@C_Size)^.spiArgYhi; // D7:D0=C_SIZE[9:2] + CSIZE_VDD:=PspiArgB(@C_Size)^.spiArgYlo; // D7:D6=C_SIZE[1:0] D5:D3=VDD_R_CURR_MIN[2:0]=0=0.5mA D2:D0=VDD_R_CURR_MAX[2:0]=0=1mA + VDD_CSIZE_MULT:=PspiArgB(@CSize_Mult)^.spiArgYhi; // D7:D5=VDD_W_CURR_MIN[2:0]=0=0.5mA D4:D2=VDD_W_CURR_MAX[2:0]=0=1mA D2:D0=C_SIZE_MULT[2:1] + CSIZE_MULT_SECSIZE:=PspiArgB(@CSize_Mult)^.spiArgYlo; // D7=C_SIZE_MULT[0] D6=ERASE_BLK_EN=0 D5:D0=SECTOR_SIZE[6:1]=0= 1 sector + SECSIZE_WPGRP_SIZE:=0; // D7=SECTOR_SIZE[0] D6:D0=WP_GRP_SIZE[6:0]=0= 1 sector + WPGRP_ENA_WRBL_LEN:=2; {000000 10} // D7=WP_GRP_ENABLE=0 D6:D5=reserved=00 D4:D2=R2W_FACTOR[2:0]=0 D1:D0=WRITE_BL_LEN[3:2] =10 {9} = 512bytes + WRBL_LEN__ZERO:=$40; {01 000000} // D7:D6=WRITE_BL_LEN[1:0] =01 {9} = 512bytes D5=0 D4:D0=reserved=00000 + BITFIELD2:=$40; // D7=FILE_FORMAT_GRP D6=COPY D5=PERM_WRITE_PROTECT D4=TMP_WRITE_PROTECT D3:D2=FILE_FORMAT[1:0] D1:D0=reserved=00 + CRC:=1; // D7:D1= CRC-7 checksum D0=1 + end; + spiResponseBuffer[20] := 1; // CRC=0 (0000000000000001) + spiResponsePtr := @spiResponseBuffer[0]; + spiResponseEnd := pointer(integer(spiResponsePtr)+3+16+2); // R1+NCR+START_TOKEN+CSD+CRC + spiByteCount := 0; + end; + CMD10: begin // $4A = SEND_CID + SPDR:=$FF; // does 8-bit NCR on next clock period (8-clock wait) + spiState := SPI_RESPOND_SINGLE; + fillchar(spiResponseBuffer, sizeof(spiResponseBuffer), 0); + spiResponseBuffer[0] := $00; // R1 = no error, no idle + spiResponseBuffer[1] := $FF; // does 8-bit NCR on next clock period (8-clock wait) + spiResponseBuffer[2] := SPI_START_TOKEN; + with PCardIDRegister(@spiResponseBuffer[3])^ do + begin + MID:=1; // Manufacturer ID [binary] + OID:= ord('S')*256+ord('D'); // OEM/Application ID [ACSII] + StrPCopy(@PNM[0], 'FILE'); // Product Name [ACSII] + PRV:=$10; // Product Revision [BCD] "1.0" + PSN:=$12345678; // Serial Number [binary] + MDT:=$1001; // Manufacturer Date [BCD] "Jan 2010" + CRC:=1; // D7:D1= CRC-7 checksum D0=1 + end; + spiResponseBuffer[20] := 1; // CRC=0 (0000000000000001) + spiResponsePtr := @spiResponseBuffer[0]; + spiResponseEnd := pointer(integer(spiResponsePtr)+3+16+2); // R1+NCR+START_TOKEN+CID+CRC + spiByteCount := 0; + end; + CMD58: begin // $7A = READ_OCR +{R3 response. Returns OCR:} +{ R1[39:32] 32bit_OCR[31:0] } +{‘00000001’ '1 0 00000000001000 00000000 00000000'} +{‘00000001’ Ready, nonSDHC, 3.3V} + SPDR:=$FF; // does 8-bit NCR on next clock period + spiState := SPI_RESPOND_SINGLE; + spiResponseBuffer[0] := $00; // no errors, no idle // $01 + spiResponseBuffer[1] := $80; + spiResponseBuffer[2] := $08; + spiResponseBuffer[3] := $00; + spiResponseBuffer[4] := $00; + spiResponsePtr := @spiResponseBuffer[0]; + spiResponseEnd := pointer(integer(spiResponsePtr)+5); + spiByteCount := 0; + end; + CMD59: begin // $7B = CRC_ON_OFF (D0=1/0) // in emulation CRC never calculated/checked + SPDR := $FF; // does 8-bit NCR on next clock period (8-clock wait) + spiState := SPI_RESPOND_SINGLE; + spiResponseBuffer[0] := $00; // no error + spiResponsePtr := @spiResponseBuffer[0]; + spiResponseEnd := pointer(integer(spiResponsePtr)+1); + spiByteCount := 0; + end; + ACMD41: begin // $69 = SDC card init + SPDR:=$FF; // does 8-bit NCR on next clock period + spiState := SPI_RESPOND_SINGLE; + spiResponseBuffer[0] := $00; // no errors, no idle - so, next command in ACMD chain + spiResponsePtr := @spiResponseBuffer[0]; + spiResponseEnd := pointer(integer(spiResponsePtr)+1); + spiByteCount := 0; + end; + CMD55: begin // $77 = APP_CMD + SPDR := $FF; // does 8-bit NCR on next clock period (8-clock wait) + spiState := SPI_RESPOND_SINGLE; + spiResponseBuffer[0] := $00; // no errors, no idle - so, next command in ACMD chain + spiResponsePtr := @spiResponseBuffer[0]; + spiResponseEnd := pointer(integer(spiResponsePtr)+1); + spiByteCount := 0; + end; + CMD16: begin // $50 = SET_BLOCKLEN + SPDR := $FF; // does 8-bit NCR on next clock period (8-clock wait) + spiState := SPI_RESPOND_SINGLE; + if PspiArgW(@spiArg)^.spiArgY>SD_BLOCK_SIZE then + spiResponseBuffer[0] := R1_PARAM_ERR+R1_IN_IDLE // error + else begin + spiResponseBuffer[0] := $00; // no errors, no idle + sectorSize:=PspiArgW(@spiArg)^.spiArgY; + end; + spiResponsePtr := @spiResponseBuffer[0]; + spiResponseEnd := pointer(integer(spiResponsePtr)+1); + spiByteCount := 0; + end + else begin + SPDR := $FF; // does 8-bit NCR on next clock period + spiState := SPI_RESPOND_SINGLE; + spiResponseBuffer[0] := R1_ILLEGAL_CMD+R1_IN_IDLE; // illegal command + spiResponsePtr := @spiResponseBuffer[0]; + spiResponseEnd := pointer(integer(spiResponsePtr)+1); + spiByteCount := 0; + end; + end; {case} + end; + SPI_RESPOND_SINGLE: + begin + SPDR := spiResponsePtr^; + SPI_DEBUG('SPI - Respond: %0.2X\n', [SPDR]); + inc(spiResponsePtr); + if (spiResponsePtr = spiResponseEnd) then + begin + if (spiByteCount <> 0) then + spiState := SPI_READ_SINGLE_BLOCK + else + spiState := SPI_IDLE_STATE; + end; + end; + SPI_READ_SINGLE_BLOCK: + begin + SPDR := SDReadByte(); + dec(spiByteCount); + if(spiByteCount = 0) then begin + spiResponseBuffer[0] := $00; //CRC + spiResponseBuffer[1] := $00; //CRC + spiResponsePtr := @spiResponseBuffer[0]; + spiResponseEnd := pointer(integer(spiResponsePtr)+2); + spiState := SPI_RESPOND_SINGLE; + end; + end; + SPI_RESPOND_MULTI: + begin + SPDR := spiResponsePtr^; + SPI_DEBUG('SPI - Respond: %0.2X\n', [SPDR]); + inc(spiResponsePtr); + if (spiResponsePtr = spiResponseEnd) then + spiState := SPI_READ_MULTIPLE_BLOCK; + end; + SPI_READ_MULTIPLE_BLOCK: + begin + if (spiByte = $4C) then //CMD12 + begin + SPDR := SDReadByte(); + fillchar(spiResponseBuffer,9,$FF); // Q&D - return garbage in response to the whole command + spiResponsePtr := @spiResponseBuffer[0]; + spiResponseEnd := pointer(integer(spiResponsePtr)+9); + spiState := SPI_RESPOND_SINGLE; + spiByteCount := 0; + end + else + begin + SPDR := SDReadByte(); + SPI_DEBUG('SPI - Data[%d]: %0.2X\n', [sectorSize {SD_BLOCK_SIZE} -spiByteCount, SPDR]); + dec(spiByteCount); + if (spiByteCount = 0) then + begin + spiResponseBuffer[0] := $00; //CRC + spiResponseBuffer[1] := $00; //CRC + spiResponseBuffer[2] := SPI_START_TOKEN; // start block + spiResponsePtr := @spiResponseBuffer[0]; + spiResponseEnd := pointer(integer(spiResponsePtr)+3); + spiArg:=spiArg+sectorSize; // SD_BLOCK_SIZE; // automatically move to next block + SDSeekToOffset(spiArg, True); + spiByteCount := sectorSize; // SD_BLOCK_SIZE; + spiState := SPI_RESPOND_MULTI; + end; + end; + end; + SPI_WRITE_SINGLE: + begin + SPDR := spiResponsePtr^; + SPI_DEBUG('SPI - Respond: %0.2X\n', [SPDR]); + if (spiResponsePtr <> spiResponseEnd) then + inc(spiResponsePtr) + else begin + if spiByte<>SPI_START_TOKEN then + spiResponsePtr^:=$FF + else + begin + if (spiByteCount <> 0) then + spiState := SPI_WRITE_SINGLE_BLOCK + else + spiState := SPI_IDLE_STATE; + end; + end; + end; + SPI_WRITE_SINGLE_BLOCK: + begin + SDWriteByte(spiByte); // SPDR + SPI_DEBUG('SPI - Data[%d]: %0.2X\n', [spiByteCount,SPDR]); + SPDR := $FF; + dec(spiByteCount); + if (spiByteCount = 0) then + begin + spiResponseBuffer[0] := $FF; //NCR + spiResponseBuffer[1] := WRITE_ACCEPTED; + spiResponsePtr := @spiResponseBuffer[0]; + spiResponseEnd := pointer(integer(spiResponsePtr)+2); + spiByteCount := 2; + spiState := SPI_WRITE_SINGLE_CRC; + if not SDCommit() then + spiResponseBuffer[1]:=WRITE_DATAERROR; + end; + end; + SPI_WRITE_SINGLE_CRC: + begin + dec(spiByteCount); + if (spiByteCount = 0) then // just skip crc + spiState := SPI_RESPOND_SINGLE; + end; + end; {case} + end {with} +end; {update_spi} + +constructor TSDController.Create; +begin + SDPowerOn; + SDHC:=False; + FMaxLBA:=0; + FOnAccess:=nil; + FHandle:=INVALID_HANDLE_VALUE; + Reset; + SDCheckFBuf; +end; + +destructor TSDController.Destroy; +begin + inherited; + if Assigned(FBuf) then + FreeMem(FBuf); + if FHandle<>INVALID_HANDLE_VALUE then + CloseHandle(FHandle); +end; + +procedure TSDController.ReadFromStream(Stream: TStream); +var TmpFName: ShortString; +begin + Stream.Read(FImageRO, sizeof(FImageRO)); + Stream.Read(TmpFName, sizeof(TmpFName)); + ImageFile:=TmpFName; + Stream.Read(FParams, sizeof(FParams)); + SDCheckFBuf(); + Stream.Read(FBuf^, SD_BLOCK_SIZE); +end; + +procedure TSDController.SaveToStream(Stream: TStream); +var TmpFName: ShortString; +begin + TmpFName:=FImgFile; + Stream.Write(FImageRO, sizeof(FImageRO)); + Stream.Write(TmpFName, sizeof(TmpFName)); + Stream.Write(FParams, sizeof(FParams)); + Stream.Write(FBuf^, SD_BLOCK_SIZE); +end; + +function TSDController.SDCommit: boolean; +var writed: cardinal; + ptr: pointer; +begin + with Fparams do begin + SDCheckFBuf(); + ptr:=FBuf; + if Assigned(FOnAccess) then FOnAccess(Self, 4, 'w'); + Result:=(WriteFile(FHandle, ptr^, sectorSize, writed, nil)); +{ if not Result then + Application.MessageBox(PChar('File write error: ' + FImgFile), + PChar(Application.Title), + MB_OK or MB_ICONEXCLAMATION); } + SectorIndex:=0; + end; +end; + +function TSDController.SDReadByte: byte; +begin + Result:=0; + with Fparams do begin + if SectorIndexFMaxLBA*SD_BLOCK_SIZE-sectorSize) then + raise Exception.CreateFmt('Error: offset (%d) > FileSize (%d) in file %s', + [offset, FMaxLBA*SD_BLOCK_SIZE, FImgFile]); + SDCheckFBuf(); + ptr:=FBuf; + if Assigned(FOnAccess) then FOnAccess(Self, 4, 'r'); + if SDHC then + bb:=DiskFileSeek(FHandle, offset, FILE_BEGIN) + else + bb:=DiskFileSeekAbs(FHandle, offset, FILE_BEGIN); + if not bb then + raise Exception.CreateFmt('File seek error: %s', [FImgFile]); + FParams.FileOffset:=offset; + if DoRead and + (not (ReadFile(FHandle, ptr^, sectorSize, bytesread, nil))) then + raise Exception.CreateFmt('File read error: %s', [FImgFile]); + SectorIndex:=0; + end; +end; + +procedure TSDController.SDWriteByte(value: byte); +begin + with Fparams do + if SectorIndextrim(Value) then + begin + FImgFile:=trim(Value); + if FImgFile='' then begin + if FHandle<>INVALID_HANDLE_VALUE then + CloseHandle(FHandle); + FHandle:=INVALID_HANDLE_VALUE; + end + else + begin + if FHandle<>INVALID_HANDLE_VALUE then + CloseHandle(FHandle); + FHandle:=INVALID_HANDLE_VALUE; + if IsDrive(FImgFile, @cDrive) then + begin + IdeOK:=(cDrive in ['0'..'9'])and + GetIdeDiskIdentify(cDrive, @FIdBuf[0]); + if not HDDOpen(cDrive, (cDrive='0') or ImageRO {18.06.2012 was:True}, FHandle, phis, FDiskSize, FFreeSize, @Geometry) then // ReadOnly Allways + raise Exception.Create(LastError); + end + else + begin + if not FileExists(FImgFile) then + raise Exception.CreateFmt('File not found: %s', [FImgFile]) + else + begin + if FImageRO then + FHandle:=CreateFile(PChar(FImgFile), GENERIC_READ, 0, nil, OPEN_EXISTING, 0, 0) + else + FHandle:=CreateFile(PChar(FImgFile), GENERIC_READ or GENERIC_WRITE, 0, nil, OPEN_EXISTING, 0, 0); + if (FHandle=INVALID_HANDLE_VALUE) then + raise Exception.Create(LastError); + end; + dwSizeLow := GetFileSize(FHandle, @dwSizeHigh); + if (dwSizeLow = $FFFFFFFF) and (GetLastError() <> NO_ERROR ) then + raise Exception.Create(LastError); + FDiskSize:=dwSizeHigh; + FDiskSize:=(FDiskSize shl 32) + dwSizeLow; + end; + FMaxLBA:=FDiskSize div SD_BLOCK_SIZE; // sectorSize + if FMaxLBA>=2097152 then begin // TODO: init SDHC value + FMaxLBA:=2097152-1; + Application.MessageBox('Only non-SDHC cards emulated!'#13#10#13#10'Image file will be processed in beginner 1G only.', + PChar(Application.Title), + MB_OK); + end; + end; + end; +end; + +procedure TSDController.SetImageRO(const Value: boolean); +var str: string; +begin + if FImageRO<>Value then with Fparams do + begin + FImageRO:=Value; + str:=FImgFile; + SetImageFile(''); + SetImageFile(str); + SDSeekToOffset(FileOffset, True); + end; +end; + +procedure TSDController.SetOnAccess(const Value: TSdAccess); +begin + FOnAccess := Value; +end; + +procedure TSDController.rl(var bb: byte); // сдвиг влево с циклическим переносом +begin + if (bb and $80)=0 then + bb:=(bb shl 1) + else + bb:=(bb shl 1) or 1; +end; + +procedure TSDController.SDCheckFBuf; +begin + if not Assigned(FBuf) then + GetMem(FBuf, SD_BLOCK_SIZE+1); // sectorSize+1 +end; + +procedure TSDController.Reset; +begin + FParams.R0:=0; // MSX feature $FF +end; + +procedure TSDController.SDPowerOn; +begin + with Fparams do + begin + SPDR:=$FF; + RDout:=$FF; + spiByte:=$FF; + spiState:=SPI_PWR_STATE; + InpBitCount:=0; + sectorSize:=SD_BLOCK_SIZE; + SectorIndex:=0; + FileOffset:=0; + end; +end; + +initialization + SdController:=TSdController.Create; + +finalization + SdController.Free; + +end. + diff --git a/modWaveOut.pas b/modWaveOut.pas new file mode 100644 index 0000000..8f00d72 --- /dev/null +++ b/modWaveOut.pas @@ -0,0 +1,96 @@ +unit modWaveOut; +{' /******************************************************************************* +' modWaveOut.bas within vbSpec.vbp +' +' API declarations and support routines for proving beeper emulation using +' the Windows waveOut* API fucntions. +' +' Author: Chris Cowley +' +' Copyright (C)1999-2000 Grok Developments Ltd. +' http://www.grok.co.uk/ +' +' This program is free software; you can redistribute it and/or +' modify it under the terms of the GNU General Public License +' as published by the Free Software Foundation; either version 2 +' of the License, or (at your option) any later version. +' This program is distributed in the hope that it will be useful, +' but WITHOUT ANY WARRANTY; without even the implied warranty of +' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +' GNU General Public License for more details. +' +' You should have received a copy of the GNU General Public License +' along with this program; if not, write to the Free Software +' Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +' +' *******************************************************************************/} + +interface + +uses windows, mmsystem; + +{$I 'OrionZEm.inc'} + +{$IFDEF USE_SOUND} + // We can only have beeper emulation in the USE_SOUND build + // Function for moving waveform data from a VB byte array into a block of memory + // allocated by GlobalAlloc() + //This was not declared in Delphi RTL at all ? Odd.. + procedure RtlMoveMemory(Dest: POINTER; Source:POINTER; Length:integer);external 'kernel32.dll'; + +const + NUM_WAV_BUFFERS = 50; + WAVE_FREQUENCY = 22050; + WAV_BUFFER_SIZE = 441; //(WAVE_FREQUENCY \ NUM_WAV_BUFFERS) + + // Variables and constants used by the beeper emulation +var + glphWaveOut : integer = -1; + ghMem: array[1..NUM_WAV_BUFFERS+1] of HGLOBAL; + gpMem: array[1..NUM_WAV_BUFFERS+1] of Pointer; + gtWavFormat: TWAVEFORMATEX; + gtWavHdr: array[1..NUM_WAV_BUFFERS+1] of WAVEHDR; + gcWaveOut: array[0..48000] of Byte; + glWavePtr: integer; + glWaveAddTStates: integer; +{$ENDIF} + + +procedure AddSoundWave(ts : integer); + +implementation + +uses modAY8912, modOrion, MainWin; + +var + WCount : integer = 0; + lCounter : integer = 0; + +procedure AddSoundWave(ts : integer); +begin +{$IFDEF USE_SOUND} + + WCount := WCount + 1; + If WCount = 800 Then + begin + AY8912Update_8; + WCount := 0; + End; + + lCounter := lCounter + ts; + While lCounter >= glWaveAddTStates do + begin + If AYEnabled Then + gcWaveOut[glWavePtr] := glBeeperVal + RenderByte() + else + gcWaveOut[glWavePtr] := glBeeperVal; + glWavePtr := glWavePtr + 1; + lCounter := lCounter - glWaveAddTStates; + end; +{$ENDIF} +End; + + + + +end. diff --git a/modZ80.pas b/modZ80.pas new file mode 100644 index 0000000..f642772 --- /dev/null +++ b/modZ80.pas @@ -0,0 +1,6047 @@ +unit modZ80; + +{ +' /******************************************************************************* +' +' Complete Z80 emulation, including (as far as I know) the +' correct emulation of bits 3 and 5 of F, and undocumented ops. +' Please mail me if you find any bugs in the emulation! +' +' Author: Chris Cowley +' +' Copyright (C)1999-2000 Grok Developments Ltd. +' http://www.grok.co.uk/ +' +' Translation to Delphi Object Pascal by +' Jari Korhonen +' +' This program is free software; you can redistribute it and/or +' modify it under the terms of the GNU General Public License +' as published by the Free Software Foundation; either version 2 +' of the License, or (at your option) any later version. +' This program is distributed in the hope that it will be useful, +' but WITHOUT ANY WARRANTY; without even the implied warranty of +' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +' GNU General Public License for more details. +' +' You should have received a copy of the GNU General Public License +' along with this program; if not, write to the Free Software +' Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +' +' *******************************************************************************/} + + +interface + + +{$I 'OrionZEm.inc'} + + +type + TAfterInstruction=procedure(); + TAfterBreakPoint=procedure(); + TAfterOneSecond=procedure(CpuIdlePercent:integer); + +var + AfterInstruction:TAfterInstruction = nil; + AfterBreakPoint:TAfterInstruction = nil; + AfterOneSecond: TAfterOneSecond = nil; + AfterHalfSecond: TAfterOneSecond = nil; + +function getAF: integer; +function getBC: integer; +function getIR: integer; +function bitSet(bit : integer; val : integer): integer; +function getF: integer; + +procedure cp_a(b : integer); +procedure setAF(v : integer); +procedure setF(b : integer); +procedure setBC(nn : integer); +procedure poppc; +procedure pushpc; +procedure Z80Reset; +procedure execute(var local_tstates: integer); + +implementation + +uses Windows, Forms, Sysutils, mmsystem, modOrion, modWaveout, modAY8912, mod146818, mod8255, mod232 {!!! mainwin}; + +procedure adc_a(b: integer); + var + wans: integer; + ans: integer; + c: integer; +begin + + If fC Then c := 1 + else c := 0; + + wans := regA + b + c; + ans := wans And $FF; + + fS := (ans And F_S) <> 0; + f3 := (ans And F_3) <> 0; + f5 := (ans And F_5) <> 0; + fZ := (ans = 0); + fC := (wans And $100) <> 0; + fPV := ((regA Xor ((Not b) And $FFFF)) And (regA Xor ans) And $80) <> 0; + + fH := (((regA And $F) + (b And $F) + c) And F_H) <> 0; + fN := False; + + regA := ans; +end; + + +function adc16(a : integer; b : integer): integer; + var c : integer; lans : integer; ans : integer; +begin + + If fC Then c := 1 + else c := 0; + + lans := a + b + c; + ans := lans And $FFFF; + + fS := (ans And (F_S {* 256} shl 8)) <> 0; // 20061220 + f3 := (ans And (F_3 {* 256} shl 8)) <> 0; + f5 := (ans And (F_5 {* 256} shl 8)) <> 0; + fZ := (ans = 0); + fC := (lans And $10000) <> 0; + fPV := ((a Xor ((Not b) And $FFFF)) And (a Xor ans) And $8000) <> 0; + fH := (((a And $FFF) + (b And $FFF) + c) And $1000) <> 0; + fN := False; + + adc16 := ans; +end; + +procedure add_a(b : integer); + var wans : integer; ans : integer; +begin + + wans := regA + b; + ans := wans And $FF; + + fS := (ans And F_S) <> 0; + f3 := (ans And F_3) <> 0; + f5 := (ans And F_5) <> 0; + fZ := (ans = 0); + fC := (wans And $100) <> 0; + fPV := ((regA Xor ((Not (b)) And $FFFF)) And (regA Xor ans) And $80) <> 0; + fH := (((regA And $F) + (b And $F)) And F_H) <> 0; + fN := False; + + regA := ans; +end; + +function add16(a : integer; b : integer):integer; + var lans : integer; + ans : integer; +begin + + lans := a + b; + ans := lans And $FFFF; + + f3 := (ans And (F_3 {* 256} shl 8)) <> 0; // 20061220 + f5 := (ans And (F_5 {* 256} shl 8)) <> 0; + fC := (lans And $10000) <> 0; + fH := (((a And $FFF) + (b And $FFF)) And $1000) <> 0; + fN := False; + + add16 := ans; +end; + +procedure and_a(b : integer); +begin + regA := (regA And b); + + fS := (regA And F_S) <> 0; + f3 := (regA And F_3) <> 0; + f5 := (regA And F_5) <> 0; + fH := True; + fPV := Parity[regA]; + fZ := (regA = 0); + fN := False; + fC := False; +end; + +{ 20090118 } + +procedure bit(b : integer; r : integer); + var IsbitSet : Boolean; +begin + IsbitSet := (r And b) <> 0; + fN := False; + fH := True; + fS := IsbitSet And (b = F_S); + f3 := (r and F_3) <> 0; + f5 := (r and F_5) <> 0; + fZ := Not IsbitSet; + fPV := fZ; +end; + +procedure bit_hl(b : integer; r : integer); + var IsbitSet : Boolean; + rr : integer; +begin + IsbitSet := (r And b) <> 0; + fN := False; + fH := True; + fS := IsbitSet And (b = F_S); + rr:= (regHL shr 8) and $FF; + f3 := (rr and F_3) <> 0; + f5 := (rr and F_5) <> 0; + fZ := Not IsbitSet; + fPV := fZ; +end; + +procedure bit_id(b : integer; r : integer; id : Integer); + var IsbitSet : Boolean; +begin + IsbitSet := (r And b) <> 0; + fN := False; + fH := True; + fS := IsbitSet And (b = F_S); + f3 := ((id shr 8) and F_3) <> 0; + f5 := ((id shr 8) and F_5) <> 0; + fZ := Not IsbitSet; + fPV := fZ; +end; + +{ / 20090118 } + +function bitRes(bit : integer; val : integer): integer; +begin +// bitRes := val And (Not (bit) And $FFFF); // 20061220 + bitRes := val And (bit Xor $FFFF); +end; + +function bitSet(bit : integer; val : integer): integer; +begin + bitSet := val Or bit; +end; + +procedure ccf(); +begin + f3 := (regA And F_3) <> 0; + f5 := (regA And F_5) <> 0; + fH := fC; + fN := False; + fC := Not fC; +end; + +procedure cp_a(b : integer); + var a : integer; wans : integer; ans : integer; +begin + + a := regA; + wans := a - b; + ans := wans And $FF; + + fS := (ans And F_S) <> 0; + f3 := (b And F_3) <> 0; + f5 := (b And F_5) <> 0; + fN := True; + fZ := (ans = 0); + fC := (wans And $100) <> 0; + fH := (((a And $F) - (b And $F)) And F_H) <> 0; + fPV := ((a Xor b) And (a Xor ans) And $80) <> 0; +end; + +procedure cpl_a; +begin + regA := (regA Xor $FF) And $FF; + + f3 := (regA And F_3) <> 0; + f5 := (regA And F_5) <> 0; + fH := True; + fN := True; +end; + +procedure sub_a(b : integer); + var a : integer; wans : integer; ans : integer; +begin + + a := regA; + wans := a - b; + ans := wans And $FF; + + fS := (ans And F_S) <> 0; + f3 := (ans And F_3) <> 0; + f5 := (ans And F_5) <> 0; + fZ := (ans = 0); + fC := (wans And $100) <> 0; + fPV := ((a Xor b) And (a Xor ans) And $80) <> 0; + fH := (((a And $F) - (b And $F)) And F_H) <> 0; + fN := True; + + regA := ans; +end; + + +procedure daa_a; + var ans : integer; incr : integer; carry : Boolean; +begin + + incr := 0; + ans := regA; + carry := fC; + + If (fH = True) Or ((ans And $F) > $9) Then + incr := incr Or $6; + + If (carry = True) Or (ans > $9F) Then + incr := incr Or $60; + + If ((ans > $8F) And ((ans And $F) > 9)) Then + incr := incr Or $60; + + If (ans > $99) Then + carry := True; + + If (fN = True) Then + sub_a(incr) + Else + add_a(incr); + + ans := regA; + fC := carry; + fPV := Parity[ans]; +end; + +function dec16(a : integer) : integer; +begin + dec16 := (a - 1) And $FFFF; +end; + +procedure ex_af_af; + var t : integer; +begin + t := getAF; + setAF(regAF_); + regAF_ := t; +end; + +function rlc(ans : integer) : integer; + var c : Boolean; +begin + + c := (ans And $80) <> 0; + + If c Then + ans := (ans * 2) Or $1 + Else + ans := (ans * 2); + + ans := ans And $FF; + + fS := (ans And F_S) <> 0; + f3 := (ans And F_3) <> 0; + f5 := (ans And F_5) <> 0; + fZ := (ans = 0); + fPV := Parity[ans]; + fH := False; + fN := False; + fC := c; + + rlc := ans; +end; + +function nxtpcb: integer; + var dummy: integer; +begin + dummy := peekb(regPC); + nxtpcb := dummy; +{$IFDEF USE_DEBUGGING} + ReportDebug('nxtpcb', dummy, false); +{$ENDIF} + regPC := (regPC + 1); +end; + +procedure setD(l : integer); +begin + regDE := (l {* 256} shl 8) Or (regDE And $FF); // 20061220 +end; + +function getD: integer; +begin + getD := regDE shr 8; +end; + +procedure setE(l : integer); +begin + regDE := (regDE And $FF00) Or l; +end; + +function getE: integer; +begin + getE := regDE And $FF; +end; + +procedure setF(b : integer); +begin + fS := (b And F_S) <> 0; + fZ := (b And F_Z) <> 0; + f5 := (b And F_5) <> 0; + fH := (b And F_H) <> 0; + f3 := (b And F_3) <> 0; + fPV := (b And F_PV) <> 0; + fN := (b And F_N) <> 0; + fC := (b And F_C) <> 0; +end; + +procedure setH(l : integer); +begin + regHL := (l {* 256} shl 8) Or (regHL And $FF); // 20061220 +end; + + +procedure setL(l : integer); +begin + regHL := (regHL And $FF00) Or l; +end; + + +function getF: integer; +var res: integer; +begin + res := 0; + If fS Then res := res + F_S; + If fZ Then res := res + F_Z; + If f5 Then res := res + F_5; + If fH Then res := res + F_H; + If f3 Then res := res + F_3; + If fPV Then res := res + F_PV; + If fN Then res := res + F_N; + If fC Then res := res + F_C; + getF := res; +end; + + +function getAF: integer; +begin + getAF := (regA {* 256} shl 8) Or getF; // 20061220 +end; + +function getBC: integer; +begin + getBC := (regB {* 256} shl 8) Or regC; // 20061220 +end; + +function getIR: integer; +begin + getIR := (intI {* 256} shl 8) Or intR; // 20061220 +end; + +function getH: integer; +begin + getH := regHL shr 8; +end; + +function getIDH: integer; +begin + getIDH := (regID shr 8) And $FF; +end; + +function getIDL: integer; +begin + getIDL := regID And $FF; +end; + + +function getL: integer; +begin + getL := regHL And $FF; +end; + +procedure rrc_a; + var c : Boolean; +begin + c := (regA And $1) <> 0; + + If c Then + regA := (regA shr 1) Or $80 + Else + regA := regA shr 1; + + f3 := (regA And F_3) <> 0; + f5 := (regA And F_5) <> 0; + fN := False; + fH := False; + fC := c; +end; + + +function rl(ans : integer) : integer; + var c : Boolean; +begin + + c := (ans And $80) <> 0; + + If fC Then + ans := (ans * 2) Or $1 + Else + ans := ans * 2; + + ans := ans And $FF; + + fS := (ans And F_S) <> 0; + f3 := (ans And F_3) <> 0; + f5 := (ans And F_5) <> 0; + fZ := (ans = 0); + fPV := Parity[ans]; + fH := False; + fN := False; + fC := c; + + rl := ans; +end; + +procedure rl_a; + var ans : integer; c : Boolean; +begin + + ans := regA; + c := (ans And $80) <> 0; + + If fC Then + ans := (ans * 2) Or $1 + Else + ans := (ans * 2); + + ans := ans And $FF; + + f3 := (ans And F_3) <> 0; + f5 := (ans And F_5) <> 0; + fN := False; + fH := False; + fC := c; + + regA := ans; +end; + + +procedure rlc_a; + var c : Boolean; +begin + c := (regA And $80) <> 0; + + If c Then + regA := (regA * 2) Or 1 + Else + regA := (regA * 2); + + regA := regA And $FF; + + f3 := (regA And F_3) <> 0; + f5 := (regA And F_5) <> 0; + fN := False; + fH := False; + fC := c; +end; + +function rr(ans : integer) : integer; + var c : Boolean; +begin + c := (ans And $1) <> 0; + + If fC Then + ans := (ans shr 1) Or $80 + Else + ans := (ans shr 1); + + fS := (ans And F_S) <> 0; + f3 := (ans And F_3) <> 0; + f5 := (ans And F_5) <> 0; + fZ := (ans = 0); + fPV := Parity[ans]; + fH := False; + fN := False; + fC := c; + + rr := ans; +end; + +procedure rr_a; + var ans : integer; c : Boolean; +begin + ans := regA; + c := (ans And $1) <> 0; + + If fC Then + ans := (ans shr 1) Or $80 + Else + ans := (ans shr 1); + + f3 := (ans And F_3) <> 0; + f5 := (ans And F_5) <> 0; + fN := False; + fH := False; + fC := c; + + regA := ans; +end; + +function rrc(ans : integer) : integer; + var c : Boolean; +begin + c := (ans And $1) <> 0; + + If c Then + ans := (ans shr 1) Or $80 + Else + ans := (ans shr 1); + + fS := (ans And F_S) <> 0; + f3 := (ans And F_3) <> 0; + f5 := (ans And F_5) <> 0; + fZ := (ans = 0); + fPV := Parity[ans]; + fH := False; + fN := False; + fC := c; + + rrc := ans; +end; + +procedure rrd_a; + var ans : integer; t : integer; q : integer; +begin + ans := regA; + t := peekb(regHL); + q := t; + + t := (t shr 4) Or (ans * 16); + ans := (ans And $F0) Or (q And $F); + pokeb(regHL, t); + + fS := (ans And F_S) <> 0; + f3 := (ans And F_3) <> 0; + f5 := (ans And F_5) <> 0; + fZ := (ans = 0); + fPV := Parity[ans]; + fH := False; + fN := False; + + regA := ans; +end; + + + +procedure sbc_a(b : integer); + var a : integer; wans : integer; ans : integer; c : integer; +begin + + a := regA; + + If fC Then c := 1 + else c:=0; + + wans := a - b - c; + ans := wans And $FF; + + fS := (ans And F_S) <> 0; + f3 := (ans And F_3) <> 0; + f5 := (ans And F_5) <> 0; + fZ := (ans = 0); + fC := (wans And $100) <> 0; + fPV := ((a Xor b) And (a Xor ans) And $80) <> 0; + fH := (((a And $F) - (b And $F) - c) And F_H) <> 0; + fN := True; + + regA := ans; +end; + +function sbc16(a : integer; b : integer) : integer; + var c : integer; lans : integer; ans : integer; +begin + + If fC Then c := 1 + else c:=0; + + lans := a - b - c; + ans := lans And $FFFF; + + fS := (ans And (F_S {* 256} shl 8)) <> 0; // 20061220 + f3 := (ans And (F_3 {* 256} shl 8)) <> 0; + f5 := (ans And (F_5 {* 256} shl 8)) <> 0; + fZ := (ans = 0); + fC := (lans And $10000) <> 0; + fPV := ((a Xor b) And (a Xor ans) And $8000) <> 0; + fH := (((a And $FFF) - (b And $FFF) - c) And $1000) <> 0; + fN := True; + + sbc16 := ans; +end; + +procedure scf; +begin + f3 := (regA And F_3) <> 0; + f5 := (regA And F_5) <> 0; + fN := False; + fH := False; + fC := True; +end; + +procedure setAF(v : integer); +begin + regA := (v And $FF00) shr 8; + setF(v And $FF); +end; + +procedure setBC(nn : integer); +begin + regB := (nn And $FF00) shr 8; + regC := nn And $FF; +end; + +function inc16(a : integer) : integer; +begin + inc16 := (a + 1) And $FFFF; +end; + +function nxtpcw : integer; + var dummy: integer; +begin + dummy := peekb(regPC) + (peekb(regPC + 1) {* 256} shl 8); // 20061220 + nxtpcw := dummy; +{$IFDEF USE_DEBUGGING} + ReportDebug('nxtpcw', dummy, false); +{$ENDIF} + + regPC := regPC + 2; +end; + +function sla(ans : integer) : integer; + var c : Boolean; +begin + c := (ans And $80) <> 0; + ans := (ans * 2) And $FF; + + fS := (ans And F_S) <> 0; + f3 := (ans And F_3) <> 0; + f5 := (ans And F_5) <> 0; + fZ := (ans = 0); + fPV := Parity[ans]; + fH := False; + fN := False; + fC := c; + sla := ans; +end; + +function sls(ans : integer) : integer; + var c : Boolean; +begin + c := (ans And $80) <> 0; + ans := ((ans * 2) Or $1) And $FF; + + fS := (ans And F_S) <> 0; + f3 := (ans And F_3) <> 0; + f5 := (ans And F_5) <> 0; + fZ := (ans = 0); + fPV := Parity[ans]; + fH := False; + fN := False; + fC := c; + + sls := ans; +end; + +function sra(ans : integer) : integer; + var c : Boolean; +begin + c := (ans And $1) <> 0; + ans := (ans shr 1) Or (ans And $80); + + fS := (ans And F_S) <> 0; + f3 := (ans And F_3) <> 0; + f5 := (ans And F_5) <> 0; + fZ := (ans = 0); + fPV := Parity[ans]; + fH := False; + fN := False; + fC := c; + + sra := ans; +end; + +function srl(ans : integer) : integer; + var c : Boolean; +begin + c := (ans And $1) <> 0; + ans := ans shr 1; + + fS := (ans And F_S) <> 0; + f3 := (ans And F_3) <> 0; + f5 := (ans And F_5) <> 0; + fZ := (ans = 0); + fPV := Parity[ans]; + fH := False; + fN := False; + fC := c; + + srl := ans; +end; + + + +procedure xor_a(b : integer); +begin + regA := (regA Xor b) And $FF; + + fS := (regA And F_S) <> 0; + f3 := (regA And F_3) <> 0; + f5 := (regA And F_5) <> 0; + fH := False; + fPV := Parity[regA]; + fZ := (regA = 0); + fN := False; + fC := False; +end; + +function execute_cb: integer; + var xxx : integer; +begin + + intRTemp := intRTemp + 1; + + xxx := nxtpcb; + Case xxx of + 0: //RLC B + begin + regB := rlc(regB); + execute_cb := 8; + end; + 1: //RLC C + begin + regC := rlc(regC); + execute_cb := 8; + end; + 2: //RLC D + begin + setD(rlc(getD)); + execute_cb := 8; + end; + 3: //RLC E + begin + setE(rlc(getE)); + execute_cb := 8; + end; + 4: //RLC H + begin + setH(rlc(getH)); + execute_cb := 8; + end; + 5: //RLC L + begin + setL(rlc(getL)); + execute_cb := 8; + end; + 6: //RLC (HL) + begin + pokeb(regHL, rlc(peekb(regHL))); + execute_cb := 15; + end; + 7: //RLC A + begin + regA := rlc(regA); + execute_cb := 8; + end; + 8: //RRC B + begin + regB := rrc(regB); + execute_cb := 8; + end; + 9: //RRC C + begin + regC := rrc(regC); + execute_cb := 8; + end; + 10: //RRC D + begin + setD(rrc(getD)); + execute_cb := 8; + end; + 11: //RRC E + begin + setE(rrc(getE)); + execute_cb := 8; + end; + 12: //RRC H + begin + setH(rrc(getH)); + execute_cb := 8; + end; + 13: //RRC L + begin + setL(rrc(getL)); + execute_cb := 8; + end; + 14: //RRC (HL) + begin + pokeb(regHL, rrc(peekb(regHL))); + execute_cb := 15; + end; + 15: //RRC A + begin + regA := rrc(regA); + execute_cb := 8; + end; + 16: //RL B + begin + regB := rl(regB); + execute_cb := 8; + end; + 17: //RL C + begin + regC := rl(regC); + execute_cb := 8; + end; + 18: //RL D + begin + setD(rl(getD)); + execute_cb := 8; + end; + 19: //RL E + begin + setE(rl(getE)); + execute_cb := 8; + end; + 20: //RL H + begin + setH(rl(getH)); + execute_cb := 8; + end; + 21: //RL L + begin + setL(rl(getL)); + execute_cb := 8; + end; + 22: //RL (HL) + begin + pokeb(regHL, rl(peekb(regHL))); + execute_cb := 15; + end; + 23: //RL A + begin + regA := rl(regA); + execute_cb := 8; + end; + 24: //RR B + begin + regB := rr(regB); + execute_cb := 8; + end; + 25: //RR C + begin + regC := rr(regC); + execute_cb := 8; + end; + 26: //RR D + begin + setD(rr(getD)); + execute_cb := 8; + end; + 27: //RR E + begin + setE(rr(getE)); + execute_cb := 8; + end; + 28: //RR H + begin + setH(rr(getH)); + execute_cb := 8; + end; + 29: //RR L + begin + setL(rr(getL)); + execute_cb := 8; + end; + 30: //RR (HL) + begin + pokeb(regHL, rr(peekb(regHL))); + execute_cb := 15; + end; + 31: //RR A + begin + regA := rr(regA); + execute_cb := 8; + end; + 32: //SLA B + begin + regB := sla(regB); + execute_cb := 8; + end; + 33: //SLA C + begin + regC := sla(regC); + execute_cb := 8; + end; + 34: //SLA D + begin + setD(sla(getD)); + execute_cb := 8; + end; + 35: //SLA E + begin + setE(sla(getE)); + execute_cb := 8; + end; + 36: //SLA H + begin + setH(sla(getH)); + execute_cb := 8; + end; + 37: //SLA L + begin + setL(sla(getL)); + execute_cb := 8 + end; + 38: //SLA (HL) + begin + pokeb(regHL, sla(peekb(regHL))); + execute_cb := 15; + end; + 39: //SLA A + begin + regA := sla(regA); + execute_cb := 8; + end; + 40: //SRA B + begin + regB := sra(regB); + execute_cb := 8; + end; + 41: //SRA C + begin + regC := sra(regC); + execute_cb := 8; + end; + 42: //SRA D + begin + setD(sra(getD)); + execute_cb := 8; + end; + 43: //SRA E + begin + setE(sra(getE)); + execute_cb := 8; + end; + 44: //SRA H + begin + setH(sra(getH)); + execute_cb := 8; + end; + 45: //SRA L + begin + setL(sra(getL)); + execute_cb := 8; + end; + 46: //SRA (HL) + begin + pokeb(regHL, sra(peekb(regHL))); + execute_cb := 15; + end; + 47: //SRA A + begin + regA := sra(regA); + execute_cb := 8; + end; + 48: //SLS B + begin + regB := sls(regB); + execute_cb := 8; + end; + 49: //SLS C + begin + regC := sls(regC); + execute_cb := 8; + end; + 50: //SLS D + begin + setD(sls(getD)); + execute_cb := 8; + end; + 51: //SLS E + begin + setE(sls(getE)); + execute_cb := 8; + end; + 52: //SLS H + begin + setH(sls(getH)); + execute_cb := 8; + end; + 53: //SLS L + begin + setL(sls(getL)); + execute_cb := 8; + end; + 54: //SLS (HL) + begin + pokeb(regHL, sls(peekb(regHL))); + execute_cb := 15; + end; + 55: //SLS A + begin + regA := sls(regA); + execute_cb := 8; + end; + 56: //SRL B + begin + regB := srl(regB); + execute_cb := 8; + end; + 57: //SRL C + begin + regC := srl(regC); + execute_cb := 8; + end; + 58: //SRL D + begin + setD(srl(getD)); + execute_cb := 8; + end; + 59: //SRL E + begin + setE(srl(getE)); + execute_cb := 8; + end; + 60: //SRL H + begin + setH(srl(getH)); + execute_cb := 8; + end; + 61: //SRL L + begin + setL(srl(getL)); + execute_cb := 8; + end; + 62: //SRL (HL) + begin + pokeb(regHL, srl(peekb(regHL))); + execute_cb := 15; + end; + 63: //SRL A + begin + regA := srl(regA); + execute_cb := 8; + end; + 64: //BIT 0,B + begin + bit($1, regB); + execute_cb := 8; + end; + 65: //BIT 0,C + begin + bit(1, regC); + execute_cb := 8; + end; + 66: //BIT 0,D + begin + bit(1, getD); + execute_cb := 8; + end; + 67: //BIT 0,E + begin + bit(1, getE); + execute_cb := 8; + end; + 68: //BIT 0,H + begin + bit(1, getH); + execute_cb := 8; + end; + 69: //BIT 0,L + begin + bit(1, getL); + execute_cb := 8; + end; + 70: //BIT 0,(HL) + begin + bit_hl(1, peekb(regHL)); //20090118 + execute_cb := 12; + end; + 71: //BIT 0,A + begin + bit(1, regA); + execute_cb := 8; + end; + 72: //BIT 1,B + begin + bit(2, regB); + execute_cb := 8; + end; + 73: //BIT 1,C + begin + bit(2, regC); + execute_cb := 8; + end; + 74: //BIT 1,D + begin + bit(2, getD); + execute_cb := 8; + end; + 75: //BIT 1,E + begin + bit(2, getE); + execute_cb := 8; + end; + 76: //BIT 1,H + begin + bit(2, getH); + execute_cb := 8; + end; + 77: //BIT 1,L + begin + bit(2, getL); + execute_cb := 8; + end; + 78: //BIT 1,(HL) + begin + bit_hl(2, peekb(regHL)); //20090118 + execute_cb := 12; + end; + 79: //BIT 1,A + begin + bit(2, regA); + execute_cb := 8; + end; + 80: //BIT 2,B + begin + bit(4, regB); + execute_cb := 8; + end; + 81: //BIT 2,C + begin + bit(4, regC); + execute_cb := 8; + end; + 82: //BIT 2,D + begin + bit(4, getD); + execute_cb := 8; + end; + 83: //BIT 2,E + begin + bit(4, getE); + execute_cb := 8; + end; + 84: //BIT 2,H + begin + bit(4, getH); + execute_cb := 8; + end; + 85: //BIT 2,L + begin + bit(4, getL); + execute_cb := 8; + end; + 86: //BIT 2,(HL) + begin + bit_hl(4, peekb(regHL)); //20090118 + execute_cb := 12; + end; + 87: //BIT 2,A + begin + bit(4, regA); + execute_cb := 8; + end; + 88: //BIT 3,B + begin + bit(8, regB); + execute_cb := 8; + end; + 89: //BIT 3,C + begin + bit(8, regC); + execute_cb := 8; + end; + 90: //BIT 3,D + begin + bit(8, getD); + execute_cb := 8; + end; + 91: //BIT 3,E + begin + bit(8, getE); + execute_cb := 8; + end; + 92: //BIT 3,H + begin + bit(8, getH); + execute_cb := 8; + end; + 93: //BIT 3,L + begin + bit(8, getL); + execute_cb := 8; + end; + 94: //BIT 3,(HL) + begin + bit_hl(8, peekb(regHL)); //20090118 + execute_cb := 12; + end; + 95: //BIT 3,A + begin + bit(8, regA); + execute_cb := 8; + end; + 96: //BIT 4,B + begin + bit($10, regB); + execute_cb := 8; + end; + 97: //BIT 4,C + begin + bit($10, regC); + execute_cb := 8; + end; + 98: //BIT 4,D + begin + bit($10, getD); + execute_cb := 8; + end; + 99: //BIT 4,E + begin + bit($10, getE); + execute_cb := 8; + end; + 100: //BIT 4,H + begin + bit($10, getH); + execute_cb := 8; + end; + 101: //BIT 4,L + begin + bit($10, getL); + execute_cb := 8; + end; + 102: //BIT 4,(HL) + begin + bit_hl($10, peekb(regHL)); //20090118 + execute_cb := 12; + end; + 103: //BIT 4,A + begin + bit($10, regA); + execute_cb := 8; + end; + 104: //BIT 5,B + begin + bit($20, regB); + execute_cb := 8; + end; + 105: //BIT 5,C + begin + bit($20, regC); + execute_cb := 8; + end; + 106: //BIT 5,D + begin + bit($20, getD); + execute_cb := 8; + end; + 107: //BIT 5,E + begin + bit($20, getE); + execute_cb := 8; + end; + 108: //BIT 5,H + begin + bit($20, getH); + execute_cb := 8; + end; + 109: //BIT 5,L + begin + bit($20, getL); + execute_cb := 8; + end; + 110: //BIT 5,(HL) + begin + bit_hl($20, peekb(regHL)); //20090118 + execute_cb := 12; + end; + 111: //BIT 5,A + begin + bit($20, regA); + execute_cb := 8; + end; + 112: //BIT 6,B + begin + bit($40, regB); + execute_cb := 8; + end; + 113: //BIT 6,C + begin + bit($40, regC); + execute_cb := 8; + end; + 114: //BIT 6,D + begin + bit($40, getD); + execute_cb := 8; + end; + 115: //BIT 6,E + begin + bit($40, getE); + execute_cb := 8; + end; + 116: //BIT 6,H + begin + bit($40, getH); + execute_cb := 8; + end; + 117: //BIT 6,L + begin + bit($40, getL); + execute_cb := 8; + end; + 118: //BIT 6,(HL) + begin + bit_hl($40, peekb(regHL)); //20090118 + execute_cb := 12; + end; + 119: //BIT 6,A + begin + bit($40, regA); + execute_cb := 8; + end; + 120: //BIT 7,B + begin + bit($80, regB); + execute_cb := 8; + end; + 121: //BIT 7,C + begin + bit($80, regC); + execute_cb := 8; + end; + 122: //BIT 7,D + begin + bit($80, getD); + execute_cb := 8; + end; + 123: //BIT 7,E + begin + bit($80, getE); + execute_cb := 8; + end; + 124: //BIT 7,H + begin + bit($80, getH); + execute_cb := 8; + end; + 125: //BIT 7,L + begin + bit($80, getL); + execute_cb := 8; + end; + 126: //BIT 7,(HL) + begin + bit_hl($80, peekb(regHL)); //20090118 + execute_cb := 12; + end; + 127: //BIT 7,A + begin + bit($80, regA); + execute_cb := 8; + end; + 128: //RES 0,B + begin + regB := bitRes(1, regB); + execute_cb := 8; + end; + 129: //RES 0,C + begin + regC := bitRes(1, regC); + execute_cb := 8; + end; + 130: //RES 0,D + begin + setD(bitRes(1, getD)); + execute_cb := 8; + end; + 131: //RES 0,E + begin + setE(bitRes(1, getE)); + execute_cb := 8; + end; + 132: //RES 0,H + begin + setH(bitRes(1, getH)); + execute_cb := 8; + end; + 133: //RES 0,L + begin + setL(bitRes(1, getL)); + execute_cb := 8; + end; + 134: //RES 0,(HL) + begin + pokeb(regHL, bitRes($1, peekb(regHL))); + execute_cb := 15; + end; + 135: //RES 0,A + begin + regA := bitRes(1, regA); + execute_cb := 8; + end; + 136: //RES 1,B + begin + regB := bitRes(2, regB); + execute_cb := 8; + end; + 137: //RES 1,C + begin + regC := bitRes(2, regC); + execute_cb := 8; + end; + 138: //RES 1,D + begin + setD(bitRes(2, getD)); + execute_cb := 8; + end; + 139: //RES 1,E + begin + setE(bitRes(2, getE)); + execute_cb := 8; + end; + 140: //RES 1,H + begin + setH(bitRes(2, getH)); + execute_cb := 8; + end; + 141: //RES 1,L + begin + setL(bitRes(2, getL)); + execute_cb := 8; + end; + 142: //RES 1,(HL) + begin + pokeb(regHL, bitRes(2, peekb(regHL))); + execute_cb := 15; + end; + 143: //RES 1,A + begin + regA := bitRes(2, regA); + execute_cb := 8; + end; + 144: //RES 2,B + begin + regB := bitRes(4, regB); + execute_cb := 8; + end; + 145: //RES 2,C + begin + regC := bitRes(4, regC); + execute_cb := 8; + end; + 146: //RES 2,D + begin + setD(bitRes(4, getD)); + execute_cb := 8; + end; + 147: //RES 2,E + begin + setE(bitRes(4, getE)); + execute_cb := 8; + end; + 148: //RES 2,H + begin + setH(bitRes(4, getH)); + execute_cb := 8; + end; + 149: //RES 2,L + begin + setL(bitRes(4, getL)); + execute_cb := 8; + end; + 150: //RES 2,(HL) + begin + pokeb(regHL, bitRes(4, peekb(regHL))); + execute_cb := 15; + end; + 151: //RES 2,A + begin + regA := bitRes(4, regA); + execute_cb := 8; + end; + 152: //RES 3,B + begin + regB := bitRes(8, regB); + execute_cb := 8; + end; + 153: //RES 3,C + begin + regC := bitRes(8, regC); + execute_cb := 8; + end; + 154: //RES 3,D + begin + setD(bitRes(8, getD)); + execute_cb := 8; + end; + 155: //RES 3,E + begin + setE(bitRes(8, getE)); + execute_cb := 8; + end; + 156: //RES 3,H + begin + setH(bitRes(8, getH)); + execute_cb := 8; + end; + 157: //RES 3,L + begin + setL(bitRes(8, getL)); + execute_cb := 8; + end; + 158: //RES 3,(HL) + begin + pokeb(regHL, bitRes(8, peekb(regHL))); + execute_cb := 15; + end; + 159: //RES 3,A + begin + regA := bitRes(8, regA); + execute_cb := 8; + end; + 160: //RES 4,B + begin + regB := bitRes($10, regB); + execute_cb := 8; + end; + 161: //RES 4,C + begin + regC := bitRes($10, regC); + execute_cb := 8; + end; + 162: //RES 4,D + begin + setD(bitRes($10, getD)); + execute_cb := 8; + end; + 163: //RES 4,E + begin + setE(bitRes($10, getE)); + execute_cb := 8; + end; + 164: //RES 4,H + begin + setH(bitRes($10, getH)); + execute_cb := 8; + end; + 165: //RES 4,L + begin + setL(bitRes($10, getL)); + execute_cb := 8; + end; + 166: //RES 4,(HL) + begin + pokeb(regHL, bitRes($10, peekb(regHL))); + execute_cb := 15; + end; + 167: //RES 4,A + begin + regA := bitRes($10, regA); + execute_cb := 8; + end; + 168: //RES 5,B + begin + regB := bitRes($20, regB); + execute_cb := 8; + end; + 169: //RES 5,C + begin + regC := bitRes($20, regC); + execute_cb := 8; + end; + 170: //RES 5,D + begin + setD(bitRes($20, getD)); + execute_cb := 8; + end; + 171: //RES 5,E + begin + setE(bitRes($20, getE)); + execute_cb := 8; + end; + 172: //RES 5,H + begin + setH( bitRes($20, getH)); + execute_cb := 8; + end; + 173: //RES 5,L + begin + setL(bitRes($20, getL)); + execute_cb := 8; + end; + 174: //RES 5,(HL) + begin + pokeb(regHL, bitRes($20, peekb(regHL))); + execute_cb := 15; + end; + 175: //RES 5,A + begin + regA := bitRes($20, regA); + execute_cb := 8; + end; + 176: //RES 6,B + begin + regB := bitRes($40, regB); + execute_cb := 8; + end; + 177: //RES 6,C + begin + regC := bitRes($40, regC); + execute_cb := 8; + end; + 178: //RES 6,D + begin + setD(bitRes($40, getD)); + execute_cb := 8; + end; + 179: //RES 6,E + begin + setE(bitRes($40, getE)); + execute_cb := 8; + end; + 180: //RES 6,H + begin + setH(bitRes($40, getH)); + execute_cb := 8; + end; + 181: //RES 6,L + begin + setL(bitRes($40, getL)); + execute_cb := 8; + end; + 182: //RES 6,(HL) + begin + pokeb(regHL, bitRes($40, peekb(regHL))); + execute_cb := 15; + end; + 183: //RES 6,A + begin + regA := bitRes($40, regA); + execute_cb := 8; + end; + 184: //RES 7,B + begin + regB := bitRes($80, regB); + execute_cb := 8; + end; + 185: //RES 7,C + begin + regC := bitRes($80, regC); + execute_cb := 8; + end; + 186: //RES 7,D + begin + setD(bitRes($80, getD)); + execute_cb := 8; + end; + 187: //RES 7,E + begin + setE(bitRes($80, getE)); + execute_cb := 8; + end; + 188: //RES 7,H + begin + setH(bitRes($80, getH)); + execute_cb := 8; + end; + 189: //RES 7,L + begin + setL(bitRes($80, getL)); + execute_cb := 8; + end; + 190: //RES 7,(HL) + begin + pokeb(regHL, bitRes($80, peekb(regHL))); + execute_cb := 15; + end; + 191: //RES 7,A + begin + regA := bitRes($80, regA); + execute_cb := 8; + end; + 192: //SET 0,B + begin + regB := bitSet(1, regB); + execute_cb := 8; + end; + 193: //SET 0,C + begin + regC := bitSet(1, regC); + execute_cb := 8; + end; + 194: //SET 0,D + begin + setD(bitSet(1, getD)); + execute_cb := 8; + end; + 195: //SET 0,E + begin + setE(bitSet(1, getE)); + execute_cb := 8; + end; + 196: //SET 0,H + begin + setH(bitSet(1, getH)); + execute_cb := 8; + end; + 197: //SET 0,L + begin + setL(bitSet(1, getL)); + execute_cb := 8 + end; + 198: //SET 0,(HL) + begin + pokeb(regHL, bitSet(1, peekb(regHL))); + execute_cb := 15; + end; + 199: //SET 0,A + begin + regA := bitSet(1, regA); + execute_cb := 8; + end; + 200: //SET 1,B + begin + regB := bitSet(2, regB); + execute_cb := 8; + end; + 201: //SET 1,C + begin + regC := bitSet(2, regC); + execute_cb := 8; + end; + 202: //SET 1,D + begin + setD(bitSet(2, getD)); + execute_cb := 8; + end; + 203: //SET 1,E + begin + setE(bitSet(2, getE)); + execute_cb := 8; + end; + 204: //SET 1,H + begin + setH(bitSet(2, getH)); + execute_cb := 8; + end; + 205: //SET 1,L + begin + setL(bitSet(2, getL)); + execute_cb := 8; + end; + 206: //SET 1,(HL) + begin + pokeb(regHL, bitSet(2, peekb(regHL))); + execute_cb := 15; + end; + 207: //SET 1,A + begin + regA := bitSet(2, regA); + execute_cb := 8; + end; + 208: //SET 2,B + begin + regB := bitSet(4, regB); + execute_cb := 8; + end; + 209: //SET 2,C + begin + regC := bitSet(4, regC); + execute_cb := 8; + end; + 210: //SET 2,D + begin + setD(bitSet(4, getD)); + execute_cb := 8; + end; + 211: //SET 2,E + begin + setE(bitSet(4, getE)); + execute_cb := 8; + end; + 212: //SET 2,H + begin + setH(bitSet(4, getH)); + execute_cb := 8; + end; + 213: //SET 2,L + begin + setL(bitSet(4, getL)); + execute_cb := 8; + end; + 214: //SET 2,(HL) + begin + pokeb(regHL, bitSet($4, peekb(regHL))); + execute_cb := 15; + end; + 215: //SET 2,A + begin + regA := bitSet(4, regA); + execute_cb := 8; + end; + 216: //SET 3,B + begin + regB := bitSet(8, regB); + execute_cb := 8; + end; + 217: //SET 3,C + begin + regC := bitSet(8, regC); + execute_cb := 8; + end; + 218: //SET 3,D + begin + setD(bitSet(8, getD)); + execute_cb := 8; + end; + 219: //SET 3,E + begin + setE(bitSet(8, getE)); + execute_cb := 8; + end; + 220: //SET 3,H + begin + setH(bitSet(8, getH)); + execute_cb := 8; + end; + 221: //SET 3,L + begin + setL(bitSet(8, getL)); + execute_cb := 8; + end; + 222: //SET 3,(HL) + begin + pokeb(regHL, bitSet($8, peekb(regHL))); + execute_cb := 15; + end; + 223: //SET 3,A + begin + regA := bitSet(8, regA); + execute_cb := 8; + end; + 224: //SET 4,B + begin + regB := bitSet($10, regB); + execute_cb := 8; + end; + 225: //SET 4,C + begin + regC := bitSet($10, regC); + execute_cb := 8; + end; + 226: //SET 4,D + begin + setD(bitSet($10, getD)); + execute_cb := 8; + end; + 227: //SET 4,E + begin + setE(bitSet($10, getE)); + execute_cb := 8; + end; + 228: //SET 4,H + begin + setH(bitSet($10, getH)); + execute_cb := 8; + end; + 229: //SET 4,L + begin + setL(bitSet($10, getL)); + execute_cb := 8; + end; + 230: //SET 4,(HL) + begin + pokeb(regHL, bitSet($10, peekb(regHL))); + execute_cb := 15; + end; + 231: //SET 4,A + begin + regA := bitSet($10, regA); + execute_cb := 8; + end; + 232: //SET 5,B + begin + regB := bitSet($20, regB); + execute_cb := 8; + end; + 233: //SET 5,C + begin + regC := bitSet($20, regC); + execute_cb := 8; + end; + 234: //SET 5,D + begin + setD(bitSet($20, getD)); + execute_cb := 8; + end; + 235: //SET 5,E + begin + setE(bitSet($20, getE)); + execute_cb := 8; + end; + 236: //SET 5,H + begin + setH(bitSet($20, getH)); + execute_cb := 8; + end; + 237: //SET 5,L + begin + setL(bitSet($20, getL)); + execute_cb := 8; + end; + 238: //SET 5,(HL) + begin + pokeb(regHL, bitSet($20, peekb(regHL))); + execute_cb := 15; + end; + 239: //SET 5,A + begin + regA := bitSet($20, regA); + execute_cb := 8; + end; + 240: //SET 6,B + begin + regB := bitSet($40, regB); + execute_cb := 8; + end; + 241: //SET 6,C + begin + regC := bitSet($40, regC); + execute_cb := 8; + end; + 242: //SET 6,D + begin + setD(bitSet($40, getD)); + execute_cb := 8; + end; + 243: //SET 6,E + begin + setE(bitSet($40, getE)); + execute_cb := 8; + end; + 244: //SET 6,H + begin + setH(bitSet($40, getH)); + execute_cb := 8; + end; + 245: //SET 6,L + begin + setL(bitSet($40, getL)); + execute_cb := 8; + end; + 246: //SET 6,(HL) + begin + pokeb(regHL, bitSet($40, peekb(regHL))); + execute_cb := 15; + end; + 247: //SET 6,A + begin + regA := bitSet($40, regA); + execute_cb := 8; + end; + 248: //SET 7,B + begin + regB := bitSet($80, regB); + execute_cb := 8; + end; + 249: //SET 7,C + begin + regC := bitSet($80, regC); + execute_cb := 8; + end; + 250: //SET 7,D + begin + setD(bitSet($80, getD)); + execute_cb := 8; + end; + 251: //SET 7,E + begin + setE(bitSet($80, getE)); + execute_cb := 8; + end; + 252: //SET 7,H + begin + setH(bitSet($80, getH)); + execute_cb := 8; + end; + 253: //SET 7,L + begin + setL(bitSet($80, getL)); + execute_cb := 8; + end; + 254: //SET 7,(HL) + begin + pokeb(regHL, bitSet($80, peekb(regHL))); + execute_cb := 15; + end; + 255: //SET 7,A + begin + regA := bitSet($80, regA); + execute_cb := 8; + end; + Else + begin + execute_cb := 8; + Application.MessageBox( + PChar('Unknown CB instruction ' + inttostr(xxx) + ' at ' + inttostr(regPC)), + PChar(Application.Title), + MB_OK); + end; + End; +end; + +procedure exx; + var t : integer; +begin + + t := regHL; + regHL := regHL_; + regHL_ := t; + + t := regDE; + regDE := regDE_; + regDE_ := t; + + t := getBC; + setBC(regBC_); + regBC_ := t; +end; + +function id_d : integer; + var d : integer; +begin + d := nxtpcb; + If ((d And 128) = 128) Then d := -(256 - d); + id_d := (regID + d) And $FFFF; +end; + +procedure ld_a_i; +begin + fS := (intI And F_S) <> 0; + f3 := (intI And F_3) <> 0; + f5 := (intI And F_5) <> 0; + fZ := (intI = 0); + fPV := intIFF2; + fH := False; + fN := False; + regA := intI; +end; + +procedure ld_a_r; +begin + intRTemp := intRTemp And $7F; + regA := (intR And $80) Or intRTemp; + fS := (regA And F_S) <> 0; + f3 := (regA And F_3) <> 0; + f5 := (regA And F_5) <> 0; + fZ := (regA = 0); + fPV := intIFF2; + fH := False; + fN := False; +end; + +procedure neg_a; + var t : integer; +begin + t := regA; + regA := 0; + sub_a(t); +end; + +procedure rld_a; + var ans : integer; t : integer; q : integer; +begin + ans := regA; + t := peekb(regHL); + q := t; + + t := (t * 16) Or (ans And $F); + ans := (ans And $F0) Or (q shr 4); + pokeb(regHL, (t And $FF)); + + fS := (ans And F_S) <> 0; + f3 := (ans And F_3) <> 0; + f5 := (ans And F_5) <> 0; + fZ := (ans = 0); + fPV := Parity[ans]; + fH := False; + fN := False; + + regA := ans; +end; + +procedure setIDH(byteval : integer); +begin + regID := ((byteval {* 256} shl 8) And $FF00) Or (regID And $FF); // 20061220 +end; + +procedure setIDL(byteval : integer); +begin + regID := (regID And $FF00) Or (byteval And $FF); +end; + +function in_bc() : integer; + var ans : integer; +begin + ans := inb(getBC); + + fZ := (ans = 0); + fS := (ans And F_S) <> 0; + f3 := (ans And F_3) <> 0; + f5 := (ans And F_5) <> 0; + fPV := Parity[ans]; + fN := False; + fH := False; + + in_bc := ans; +end; + +function inc8(ans : integer) : integer; +begin + fPV := (ans = $7F); + fH := (((ans And $F) + 1) And F_H) <> 0; + + ans := (ans + 1) And $FF; + + fS := (ans And F_S) <> 0; + f3 := (ans And F_3) <> 0; + f5 := (ans And F_5) <> 0; + fZ := (ans = 0); + fN := False; + + inc8 := ans; +end; + +function dec8(ans : integer) : integer; +begin + fPV := (ans = $80); + fH := (((ans And $F) - 1) And F_H) <> 0; + + ans := (ans - 1) And $FF; + + fS := (ans And F_S) <> 0; + f3 := (ans And F_3) <> 0; + f5 := (ans And F_5) <> 0; + fZ := (ans = 0); + + fN := True; + + dec8 := ans; +end; + +function popw: integer; +begin + popw := peekb(regSP) Or (peekb(regSP + 1) {* 256} shl 8); // 20061220 + regSP := (regSP + 2 And $FFFF); +end; + +procedure poppc; +begin + regPC := popw; +end; + +procedure pushw(word : integer); +begin + regSP := (regSP - 2) And $FFFF; + pokew(regSP, word); +end; + +procedure pushpc; +begin + pushw(regPC); +end; + +procedure REFRESH(t : integer); +begin + intRTemp := intRTemp + t; +end; + +function qdec8(a : integer) : integer; +begin + qdec8 := (a - 1) And $FF; +end; + +function execute_ed(local_tstates : integer) : integer; + var + xxx : integer; count : integer; dest : integer; from : integer; + TempLocal_tstates : integer; c : Boolean; b : integer; +begin + + intRTemp := intRTemp + 1; + + xxx := nxtpcb; + Case xxx of + 0..63, 127..159, 164..167, 172..175, 180..183: //NOP + execute_ed := 8; + 64: //IN B,(c) + begin + regB := in_bc; + execute_ed := 12; + end; + 72: //IN C,(c) + begin + regC := in_bc(); + execute_ed := 12; + end; + 80: //IN D,(c) + begin + setD(in_bc()); + execute_ed := 12; + end; + 88: //IN E,(c) + begin + setE(in_bc()); + execute_ed := 12; + end; + 96: //IN H,(c) + begin + setH(in_bc()); + execute_ed := 12; + end; + 104: //IN L,(c) + begin + setL(in_bc()); + execute_ed := 12; + end; + 112: //IN (c) + begin + in_bc; + execute_ed := 12; + end; + 120: //IN A,(c) + begin + regA := in_bc; + execute_ed := 12; + end; + 65: //OUT (c),B + begin + outb(getBC, regB); + execute_ed := 12; + end; + 73: //OUT (c),C + begin + outb(getBC, regC); + execute_ed := 12; + end; + 81: //OUT (c),D + begin + outb(getBC, getD); + execute_ed := 12; + end; + 89: //OUT (c),E + begin + outb(getBC, getE); + execute_ed := 12; + end; + 97: //OUT (c),H + begin + outb(getBC, getH); + execute_ed := 12; + end; + 105: //OUT (c),L + begin + outb(getBC, getL); + execute_ed := 12; + end; + 113: //OUT (c),0 + begin + outb(getBC, 0); + execute_ed := 12; + end; + 121: //OUT (c),A + begin + outb(getBC, regA); + execute_ed := 12; + end; + 66: //SBC HL,BC + begin + regHL := sbc16(regHL, getBC); + execute_ed := 15; + end; + 74: //ADC HL,BC + begin + regHL := adc16(regHL, getBC); + execute_ed := 15; + end; + 82: //SBC HL,DE + begin + regHL := sbc16(regHL, regDE); + execute_ed := 15; + end; + 90: //ADC HL,DE + begin + regHL := adc16(regHL, regDE); + execute_ed := 15; + end; + 98: //SBC HL,HL + begin + regHL := sbc16(regHL, regHL); + execute_ed := 15; + end; + 106: //ADC HL,HL + begin + regHL := adc16(regHL, regHL); + execute_ed := 15; + end; + 114: //SBC HL,SP + begin + regHL := sbc16(regHL, regSP); + execute_ed := 15; + end; + 122: //ADC HL,SP + begin + regHL := adc16(regHL, regSP); + execute_ed := 15; + end; + 67: //LD (nn),BC + begin + pokew(nxtpcw, getBC); + execute_ed := 20; + end; + 75: //LD BC,(nn) + begin + setBC(peekw(nxtpcw)); + execute_ed := 20; + end; + 83: //LD (nn),DE + begin + pokew(nxtpcw, regDE); + execute_ed := 20; + end; + 91: //LD DE,(nn) + begin + regDE := peekw(nxtpcw); + execute_ed := 20; + end; + 99: //LD (nn),HL + begin + pokew(nxtpcw, regHL); + execute_ed := 20; + end; + 107: //LD HL,(nn) + begin + regHL := peekw(nxtpcw); + execute_ed := 20; + end; + 115: //LD (nn),SP + begin + pokew(nxtpcw, regSP); + execute_ed := 20; + end; + 123: //LD SP,(nn) + begin + regSP := peekw(nxtpcw); + execute_ed := 20; + end; + 68, 76, 84, 92, 100, 108, 116, 124: //NEG + begin + neg_a; + execute_ed := 8; + end; + 69, 85, 101, 117: // RETn + begin + intIFF1 := intIFF2; + poppc; + execute_ed := 14; + end; + 77, 93, 109, 125: //RETI + begin + // TOCHECK: according to the official Z80 docs, IFF2 does not get + // copied to IFF1 for RETI - but in a real Z80 it is + intIFF1 := intIFF2; + poppc; + execute_ed := 14; + end; + + 70, 78, 102, 110: //IM 0 + begin + intIM := 0; + execute_ed := 8; + end; + 86, 118: //IM 1 + begin + intIM := 1; + execute_ed := 8; + end; + 94, 126: //IM 2 + begin + intIM := 2; + execute_ed := 8; + end; + 71: //LD I,A + begin + intI := regA; + execute_ed := 9; + end; + 79: //LD R,A + begin + intR := regA; + intRTemp := intR; + execute_ed := 9; + end; + 87: //LD A,I + begin + ld_a_i; + execute_ed := 9; + end; + 95: //LD A,R + begin + ld_a_r; + execute_ed := 9; + end; + 103: //RRD + begin + rrd_a; + execute_ed := 18; + end; + 111: //RLD + begin + rld_a; + execute_ed := 18; + end; + 160: //LDI + begin + b:=peekb(regHL) + regA; + f3:=(b and F_3)<>0; + f5:=(b and $02)<>0; + pokeb(regDE, peekb(regHL)); + regDE := inc16(regDE); + regHL := inc16(regHL); + setBC(dec16(getBC)); + fPV := (getBC <> 0); + fH := False; + fN := False; + execute_ed := 16; + end; + 161: //CPI + begin + c := fC; + cp_a(peekb(regHL)); + b:=(regA-peekb(regHL)-Byte(fH)); + f3:=(b and F_3)<>0; + f5:=(b and $02)<>0; + regHL := inc16(regHL); + setBC(dec16(getBC)); + fPV := (getBC <> 0); + fC := c; + execute_ed := 16; + end; + 162: //INI + begin + pokeb(regHL, inb(getBC)); + b := qdec8(regB); + regB := b; + regHL := inc16(regHL); + fZ := (b = 0); + fN := True; + execute_ed := 16; + end; + 163: //OUTI + begin + b := qdec8(regB); + regB := b; + outb(getBC, peekb(regHL)); + regHL := inc16(regHL); + fZ := (b = 0); + fN := True; + execute_ed := 16; + end; + 168: //LDD + begin + b:=peekb(regHL) + regA; + f3:=(b and F_3)<>0; + f5:=(b and $02)<>0; + pokeb(regDE, peekb(regHL)); + regDE := dec16(regDE); + regHL := dec16(regHL); + setBC(dec16(getBC)); + fPV := (getBC <> 0); + fH := False; + fN := False; + execute_ed := 16; + end; + 169: //CPD + begin + c := fC; + cp_a(peekb(regHL)); + b:=(regA-peekb(regHL)-Byte(fH)); + f3:=(b and F_3)<>0; + f5:=(b and $02)<>0; + regHL := dec16(regHL); + setBC(dec16(getBC)); + fPV := (getBC <> 0); + fC := c; + execute_ed := 16; + end; + 170: //IND + begin + pokeb(regHL, inb(getBC)); + b := qdec8(regB); + regB := b; + regHL := dec16(regHL); + fZ := (b = 0); + fN := True; + execute_ed := 16; + end; + 171: //OUTD + begin + count := qdec8(regB); + regB := count; + outb(getBC, peekb(regHL)); + regHL := dec16(regHL); + fZ := (count = 0); + fN := True; + execute_ed := 16; + end; + 176: //LDIR (repeat until BC=0) OK + begin + b:=peekb(regHL) + regA; + f3:=(b and F_3)<>0; + f5:=(b and $02)<>0; + pokeb(regDE, peekb(regHL)); + regDE := inc16(regDE); + regHL := inc16(regHL); + setBC(dec16(getBC)); + fPV := (getBC <> 0); + fH := False; + fN := False; + TempLocal_tstates := 24; + intRTemp := intRTemp + 1; + regPC := regPC - 2; + If getBC = 0 Then + begin + regPC := regPC + 2; + TempLocal_tstates := TempLocal_tstates - 8; + End; + execute_ed := TempLocal_tstates; + end; + 177: //CPIR (repeat until BC=0) OK + begin + c := fC; + cp_a(peekb(regHL)); + b:=(regA-peekb(regHL)-Byte(fH)); + f3:=(b and F_3)<>0; + f5:=(b and $02)<>0; + regHL := inc16(regHL); + setBC(dec16(getBC)); + fPV := (getBC <> 0); + fC := c; + intRTemp := intRTemp + 1; + If fPV And (fZ = False) Then + begin + regPC := regPC - 2; + execute_ed := 24; + end + Else + execute_ed := 16; + end; + 178: //INIR (repeat until B=0) OK + begin + pokeb(regHL, inb(getBC)); + b := qdec8(regB); + regB := b; + regHL := inc16(regHL); + + fZ := True; + fN := True; + intRTemp := intRTemp + 1; + If (b <> 0) Then + begin + regPC := regPC - 2; + execute_ed := 24; + end + Else + execute_ed := 16; + end; + 179: //OTIR (repeat until B=0) OK + begin + b := qdec8(regB); + regB := b; + outb(getBC, peekb(regHL)); + regHL := inc16(regHL); + intRTemp := intRTemp + 1; + fZ := True; + fN := True; + If (b <> 0) Then + begin + regPC := regPC - 2; + execute_ed := 24; + end + Else + execute_ed := 16; + end; + 184: //LDDR (repeat until BC=0) OK + begin + b:=peekb(regHL) + regA; + f3:=(b and F_3)<>0; + f5:=(b and $02)<>0; + pokeb(regDE, peekb(regHL)); + regDE := dec16(regDE); + regHL := dec16(regHL); + setBC(dec16(getBC)); + fPV := (getBC <> 0); + fH := False; + fN := False; + TempLocal_tstates := 24; + intRTemp := intRTemp + 1; + regPC := regPC - 2; + If getBC = 0 Then + begin + regPC := regPC + 2; + TempLocal_tstates := TempLocal_tstates - 8; + End; + execute_ed := TempLocal_tstates; + end; + 185: //CPDR (repeat until BC=0) OK + begin + c := fC; + cp_a(peekb(regHL)); + + b:=(regA-peekb(regHL)-Byte(fH)); + f3:=(b and F_3)<>0; + f5:=(b and $02)<>0; + regHL := dec16(regHL); + setBC(dec16(getBC)); + fPV := (getBC <> 0); + fC := c; + intRTemp := intRTemp + 1; + If (fPV) And (fZ = False) Then + begin + regPC := regPC - 2; + execute_ed := 24; + end + Else + execute_ed := 16; + end; + 186: //INDR (repeat until B=0) OK + begin + pokeb(regHL, inb(getBC)); + b := qdec8(regB); + regB := b; + regHL := dec16(regHL); + intRTemp := intRTemp + 1; + fZ := True; + fN := True; + If (b <> 0) Then + begin + regPC := regPC - 2; + execute_ed := 24; + end + Else + execute_ed := 16; + end; + 187: //OTDR (repeat until B=0) OK + begin + b := qdec8(regB); + regB := b; + outb(getBC, peekb(regHL)); + regHL := dec16(regHL); + intRTemp := intRTemp + 1; + fZ := True; + fN := True; + If (b <> 0) Then + begin + regPC := regPC - 2; + execute_ed := 24; + end + Else + execute_ed := 16; + end; + Else + begin + Application.MessageBox(PChar('Unknown ED instruction ' + inttostr(xxx) + ' at ' + inttostr(regPC)), + PChar(Application.Title), + MB_OK); + execute_ed := 8; + end; + End; +end; + +procedure execute_id_cb(op : integer; z : integer); +begin + Case op of + 0: //RLC B + begin + op := rlc(peekb(z)); + regB := op; + pokeb(z, op); + end; + 1: //RLC C + begin + op := rlc(peekb(z)); + regC := op; + pokeb(z, op); + end; + 2: //RLC D + begin + op := rlc(peekb(z)); + setD(op); + pokeb(z, op); + end; + 3: //RLC E + begin + op := rlc(peekb(z)); + setE(op); + pokeb(z, op); + end; + 4: //RLC H + begin + op := rlc(peekb(z)); + setH(op); + pokeb(z, op); + end; + 5: //RLC L + begin + op := rlc(peekb(z)); + setL(op); + pokeb(z, op); + end; + 6: //RLC (HL) + pokeb(z, rlc(peekb(z))); + 7: //RLC A + begin + op := rlc(peekb(z)); + regA := op; + pokeb(z, op); + end; + 8: //RRC B + begin + op := rrc(peekb(z)); + regB := op; + pokeb(z, op); + end; + 9: //RRC C + begin + op := rrc(peekb(z)); + regC := op; + pokeb(z, op); + end; + 10: // RRC D + begin + op := rrc(peekb(z)); + setD(op); + pokeb(z, op); + end; + 11: //RRC E + begin + op := rrc(peekb(z)); + setE(op); + pokeb(z, op); + end; + 12: //RRC H + begin + op := rrc(peekb(z)); + setH(op); + pokeb(z, op); + end; + 13: //RRC L + begin + op := rrc(peekb(z)); + setL(op); + pokeb(z, op); + end; + 14: //RRC (HL) + pokeb(z, rrc(peekb(z))); + 15: //RRC A + begin + op := rrc(peekb(z)); + regA := op; + pokeb(z, op); + end; + 16: //RL B + begin + op := rl(peekb(z)); + regB := op; + pokeb(z, op); + end; + 17: //RL C + begin + op := rl(peekb(z)); + regC := op; + pokeb(z, op); + end; + 18: //RL D + begin + op := rl(peekb(z)); + setD(op); + pokeb(z, op); + end; + 19: //RL E + begin + op := rl(peekb(z)); + setE(op); + pokeb(z, op); + end; + 20: //RL H + begin + op := rl(peekb(z)); + setH(op); + pokeb(z, op); + end; + 21: //RL L + begin + op := rl(peekb(z)); + setL(op); + pokeb(z, op); + end; + 22: //RL (HL) + pokeb(z, rl(peekb(z))); + 23: //RL A + begin + op := rl(peekb(z)); + regA := op; + pokeb(z, op); + end; + 24: //RR B + begin + op := rr(peekb(z)); + regB := op; + pokeb(z, op); + end; + 25: //RR C + begin + op := rr(peekb(z)); + regC := op; + pokeb(z, op); + end; + 26: //RR D + begin + op := rr(peekb(z)); + setD(op); + pokeb(z, op); + end; + 27: //RR E + begin + op := rr(peekb(z)); + setE(op); + pokeb(z, op); + end; + 28: //RR H + begin + op := rr(peekb(z)); + setH(op); + pokeb(z, op); + end; + 29: //RR L + begin + op := rr(peekb(z)); + setL(op); + pokeb(z, op); + end; + 30: //RR (HL) + pokeb(z, rr(peekb(z))); + 31: //RR A + begin + op := rr(peekb(z)); + regA := op; + pokeb(z, op); + end; + 32: //SLA B + begin + op := sla(peekb(z)); + regB := op; + pokeb(z, op); + end; + 33: //SLA C + begin + op := sla(peekb(z)); + regC := op; + pokeb(z, op); + end; + 34: //SLA D + begin + op := sla(peekb(z)); + setD(op); + pokeb(z, op); + end; + 35: //SLA E + begin + op := sla(peekb(z)); + setE(op); + pokeb(z, op); + end; + 36: //SLA H + begin + op := sla(peekb(z)); + setH(op); + pokeb(z, op); + end; + 37: //SLA L + begin + op := sla(peekb(z)); + setL(op); + pokeb(z, op); + end; + 38: //SLA (HL) + pokeb(z, sla(peekb(z))); + 39: //SLA A + begin + op := sla(peekb(z)); + regA := op; + pokeb(z, op); + end; + 40: //SRA B + begin + op := sra(peekb(z)); + regB := op; + pokeb(z, op); + end; + 41: //SRA C + begin + op := sra(peekb(z)); + regC := op; + pokeb(z, op); + end; + 42: //SRA D + begin + op := sra(peekb(z)); + setD(op); + pokeb(z, op); + end; + 43: //SRA E + begin + op := sra(peekb(z)); + setE(op); + pokeb(z, op); + end; + 44: //SRA H + begin + op := sra(peekb(z)); + setH(op); + pokeb(z, op); + end; + 45: //SRA L + begin + op := sra(peekb(z)); + setL(op); + pokeb(z, op); + end; + 46: //SRA (HL) + pokeb(z, sra(peekb(z))); + 47: //SRA A + begin + op := sra(peekb(z)); + regA := op; + pokeb(z, op); + end; + 48: //SLS B + begin + op := sls(peekb(z)); + regB := op; + pokeb(z, op); + end; + 49: //SLS C + begin + op := sls(peekb(z)); + regC := op; + pokeb(z, op); + end; + 50: //SLS D + begin + op := sls(peekb(z)); + setD(op); + pokeb(z, op); + end; + 51: //SLS E + begin + op := sls(peekb(z)); + setE(op); + pokeb(z, op); + end; + 52: //SLS H + begin + op := sls(peekb(z)); + setH(op); + pokeb(z, op); + end; + 53: //SLS L + begin + op := sls(peekb(z)); + setL(op); + pokeb(z, op); + end; + 54: //SLS (HL) + pokeb(z, sls(peekb(z))); + 55: //SLS A + begin + op := sls(peekb(z)); + regA := op; + pokeb(z, op); + end; + 56: //SRL B + begin + op := srl(peekb(z)); + regB := op; + pokeb(z, op); + end; + 57: //SRL C + begin + op := srl(peekb(z)); + regC := op; + pokeb(z, op); + end; + 58: //SRL D + begin + op := srl(peekb(z)); + setD(op); + pokeb(z, op); + end; + 59: //SRL E + begin + op := srl(peekb(z)); + setE(op); + pokeb(z, op); + end; + 60: //SRL H + begin + op := srl(peekb(z)); + setH(op); + pokeb(z, op); + end; + 61: //SRL L + begin + op := srl(peekb(z)); + setL(op); + pokeb(z, op); + end; + 62: //SRL (ID) + pokeb(z, srl(peekb(z))); + 63: //SRL A + begin + op := srl(peekb(z)); + regA := op; + pokeb(z, op); + end; + 64..71: //BIT 0,B + bit_id($1, peekb(z), z); //20090118 + 72..79: //BIT 1,B + bit_id($2, peekb(z), z); //20090118 + 80..87: //BIT 2,B + bit_id($4, peekb(z), z); //20090118 + 88..95: //BIT 3,B + bit_id($8, peekb(z), z); //20090118 + 96..103: //BIT 4,B + bit_id($10, peekb(z), z); //20090118 + 104..111: //BIT 5,B + bit_id($20, peekb(z), z); //20090118 + 112..119: //BIT 6,B + bit_id($40, peekb(z), z); //20090118 + 120..127: //BIT 7,B + bit_id($80, peekb(z), z); //20090118 + 128: //RES 0,(ID+y)->B + begin + regB := bitRes(1, peekb(z)); + pokeb(z, regB); + end; + 129: //RES 0,(ID+y)->C + begin + regC := bitRes(1, peekb(z)); + pokeb(z, regC); + end; + 130: //RES 0,(ID+y)->D + begin + setD(bitRes(1, peekb(z))); + pokeb(z, getD); + end; + 131: //RES 0,(ID+y)->E + begin + setE(bitRes(1, peekb(z))); + pokeb(z, getE); + end; + 132: //RES 0,(ID+y)->H + begin + setH(bitRes(1, peekb(z))); + pokeb(z, getH); + end; + 133: //RES 0,(ID+y)->L + begin + setL(bitRes(1, peekb(z))); + pokeb(z, getL); + end; + 134: //RES 0,(HL) + pokeb(z, bitRes($1, peekb(z))); + 135: //RES 0,(ID+y)->A + begin + regA := bitRes(1, peekb(z)); + pokeb(z, regA); + end; + 136: //RES 1,(ID+y)->B + begin + regB := bitRes(2, peekb(z)); + pokeb(z, regB); + end; + 137: //RES 1,(ID+y)->C + begin + regC := bitRes(2, peekb(z)); + pokeb(z, regC); + end; + 138: //RES 1,(ID+y)->D + begin + setD(bitRes(2, peekb(z))); + pokeb(z, getD); + end; + 139: //RES 1,(ID+y)->E + begin + setE(bitRes(2, peekb(z))); + pokeb(z, getE); + end; + 140: //RES 1,(ID+y)->H + begin + setH(bitRes(2, peekb(z))); + pokeb(z, getH); + end; + 141: //RES 1,(ID+y)->L + begin + setL(bitRes(2, peekb(z))); + pokeb(z, getL); + end; + 142: //RES 1,(HL) + pokeb(z, bitRes($2, peekb(z))); + 143: //RES 1,(ID+y)->A + begin + regA := bitRes(2, peekb(z)); + pokeb(z, regA); + end; + 144: //RES 2,(ID+y)->B + begin + regB := bitRes(4, peekb(z)); + pokeb(z, regB); + end; + 145: //RES 2,(ID+y)->C + begin + regC := bitRes(4, peekb(z)); + pokeb(z, regC); + end; + 146: //RES 2,(ID+y)->D + begin + setD(bitRes(4, peekb(z))); + pokeb(z, getD); + end; + 147: //RES 2,(ID+y)->E + begin + setE(bitRes(4, peekb(z))); + pokeb(z, getE); + end; + 148: //RES 2,(ID+y)->H + begin + setH(bitRes(4, peekb(z))); + pokeb(z, getH); + end; + 149: //RES 2,(ID+y)->L + begin + setL(bitRes(4, peekb(z))); + pokeb(z, getL); + end; + 150: //RES 2,(HL) + pokeb(z, bitRes($4, peekb(z))); + 151: //RES 2,(ID+y)->A + begin + regA := bitRes(4, peekb(z)); + pokeb(z, regA); + end; + 152: //RES 3,(ID+y)->B + begin + regB := bitRes(8, peekb(z)); + pokeb(z, regB); + end; + 153: //RES 3,(ID+y)->C + begin + regC := bitRes(8, peekb(z)); + pokeb(z, regC); + end; + 154: //RES 3,(ID+y)->D + begin + setD(bitRes(8, peekb(z))); + pokeb(z, getD); + end; + 155: //RES 3,(ID+y)->E + begin + setE(bitRes(8, peekb(z))); + pokeb(z, getE); + end; + 156: //RES 3,(ID+y)->H + begin + setH(bitRes(8, peekb(z))); + pokeb(z, getH); + end; + 157: //RES 3,(ID+y)->L + begin + setL(bitRes(8, peekb(z))); + pokeb(z, getL); + end; + 158: //RES 3,(HL) + pokeb(z, bitRes($8, peekb(z))); + 159: //RES 3,(ID+y)->A + begin + regA := bitRes(8, peekb(z)); + pokeb(z, regA); + end; + 160: //RES 4,(ID+y)->B + begin + regB := bitRes($10, peekb(z)); + pokeb(z, regB); + end; + 161: //RES 4,(ID+y)->C + begin + regC := bitRes($10, peekb(z)); + pokeb(z, regC); + end; + 162: //RES 4,(ID+y)->D + begin + setD(bitRes($10, peekb(z))); + pokeb(z, getD); + end; + 163: //RES 4,(ID+y)->E + begin + setE(bitRes($10, peekb(z))); + pokeb(z, getE); + end; + 164: //RES 4,(ID+y)->H + begin + setH(bitRes($10, peekb(z))); + pokeb(z, getH); + end; + 165: //RES 4,(ID+y)->L + begin + setL(bitRes($10, peekb(z))); + pokeb(z, getL); + end; + 166: //RES 4,(HL) + pokeb(z, bitRes($10, peekb(z))); + 167: //RES 4,(ID+y)->A + begin + regA := bitRes($10, peekb(z)); + pokeb(z, regA); + end; + 168: //RES 5,(ID+y)->B + begin + regB := bitRes($20, peekb(z)); + pokeb(z, regB); + end; + 169: //RES 5,(ID+y)->C + begin + regC := bitRes($20, peekb(z)); + pokeb(z, regC); + end; + 170: //RES 5,(ID+y)->D + begin + setD(bitRes($20, peekb(z))); + pokeb(z, getD); + end; + 171: //RES 5,(ID+y)->E + begin + setE(bitRes($20, peekb(z))); + pokeb(z, getE); + end; + 172: //RES 5,(ID+y)->H + begin + setH(bitRes($20, peekb(z))); + pokeb(z, getH); + end; + 173: //RES 5,(ID+y)->L + begin + setL(bitRes($20, peekb(z))); + pokeb(z, getL); + end; + 174: //RES 5,(HL) + pokeb(z, bitRes($20, peekb(z))); + 175: //RES 5,(ID+y)->A + begin + regA := bitRes($20, peekb(z)); + pokeb(z, regA); + end; + 176: //RES 6,(ID+y)->B + begin + regB := bitRes($40, peekb(z)); + pokeb(z, regB); + end; + 177: //RES 6,(ID+y)->C + begin + regC := bitRes($40, peekb(z)); + pokeb(z, regC); + end; + 178: //RES 6,(ID+y)->D + begin + setD(bitRes($40, peekb(z))); + pokeb(z, getD); + end; + 179: //RES 6,(ID+y)->E + begin + setE(bitRes($40, peekb(z))); + pokeb(z, getE); + end; + 180: //RES 6,(ID+y)->H + begin + setH(bitRes($40, peekb(z))); + pokeb(z, getH); + end; + 181: //RES 6,(ID+y)->L + begin + setL(bitRes($40, peekb(z))); + pokeb(z, getL); + end; + 182: //RES 6,(HL) + pokeb(z, bitRes($40, peekb(z))); + 183: //RES 6,(ID+y)->A + begin + regA := bitRes($40, peekb(z)); + pokeb(z, regA); + end; + 184: //RES 6,(ID+y)->B + begin + regB := bitRes($80, peekb(z)); + pokeb(z, regB); + end; + 185: //RES 6,(ID+y)->C + begin + regC := bitRes($80, peekb(z)); + pokeb(z, regC); + end; + 186: //RES 6,(ID+y)->D + begin + setD(bitRes($80, peekb(z))); + pokeb(z, getD); + end; + 187: //RES 6,(ID+y)->E + begin + setE(bitRes($80, peekb(z))); + pokeb(z, getE); + end; + 188: //RES 6,(ID+y)->H + begin + setH(bitRes($80, peekb(z))); + pokeb(z, getH); + end; + 189: //RES 6,(ID+y)->L + begin + setL(bitRes($80, peekb(z))); + pokeb(z, getL); + end; + 190: //RES 7,(HL) + pokeb(z, bitRes($80, peekb(z))); + 191: //RES 7,(ID+y)->A + begin + regA := bitRes($80, peekb(z)); + pokeb(z, regA); + end; + 192: //SET 0,(ID+y)->B + begin + regB := bitSet(1, peekb(z)); + pokeb(z, regB); + end; + 193: //SET 0,(ID+y)->C + begin + regC := bitSet(1, peekb(z)); + pokeb(z, regC); + end; + 194: //SET 0,(ID+y)->D + begin + setD(bitSet(1, peekb(z))); + pokeb(z, getD); + end; + 195: //SET 0,(ID+y)->E + begin + setE(bitSet(1, peekb(z))); + pokeb(z, getE); + end; + 196: //SET 0,(ID+y)->H + begin + setH(bitSet(1, peekb(z))); + pokeb(z, getH); + end; + 197: //SET 0,(ID+y)->L + begin + setL(bitSet(1, peekb(z))); + pokeb(z, getL); + end; + 198: //SET 0,(HL) + pokeb(z, bitSet($1, peekb(z))); + 199: //SET 0,(ID+y)->A + begin + regA := bitSet(1, peekb(z)); + pokeb(z, regA); + end; + 200: //SET 1,(ID+y)->B + begin + regB := bitSet(2, peekb(z)); + pokeb(z, regB); + end; + 201: //SET 1,(ID+y)->C + begin + regC := bitSet(2, peekb(z)); + pokeb(z, regC); + end; + 202: //SET 1,(ID+y)->D + begin + setD(bitSet(2, peekb(z))); + pokeb(z, getD); + end; + 203: //SET 1,(ID+y)->E + begin + setE(bitSet(2, peekb(z))); + pokeb(z, getE); + end; + 204: //SET 1,(ID+y)->H + begin + setH(bitSet(2, peekb(z))); + pokeb(z, getH); + end; + 205: //SET 1,(ID+y)->L + begin + setL(bitSet(2, peekb(z))); + pokeb(z, getL); + end; + 206: //SET 1,(HL) + pokeb(z, bitSet($2, peekb(z))); + 207: //SET 1,(ID+y)->A + begin + regA := bitSet(2, peekb(z)); + pokeb(z, regA); + end; + 208: //SET 2,(ID+y)->B + begin + regB := bitSet(4, peekb(z)); + pokeb(z, regB); + end; + 209: //SET 2,(ID+y)->C + begin + regC := bitSet(4, peekb(z)); + pokeb(z, regC); + end; + 210: //SET 2,(ID+y)->D + begin + setD(bitSet(4, peekb(z))); + pokeb(z, getD); + end; + 211: //SET 2,(ID+y)->E + begin + setE(bitSet(4, peekb(z))); + pokeb(z, getE); + end; + 212: //SET 2,(ID+y)->H + begin + setH(bitSet(4, peekb(z))); + pokeb(z, getH); + end; + 213: //SET 2,(ID+y)->L + begin + setL(bitSet(4, peekb(z))); + pokeb(z, getL); + end; + 214: //SET 2,(HL) + pokeb(z, bitSet($4, peekb(z))); + 215: //SET 2,(ID+y)->A + begin + regA := bitSet(4, peekb(z)); + pokeb(z, regA); + end; + 216: //SET 3,(ID+y)->B + begin + regB := bitSet(8, peekb(z)); + pokeb(z, regB); + end; + 217: //SET 3,(ID+y)->C + begin + regC := bitSet(8, peekb(z)); + pokeb(z, regC); + end; + 218: //SET 3,(ID+y)->D + begin + setD(bitSet(8, peekb(z))); + pokeb(z, getD); + end; + 219: //SET 3,(ID+y)->E + begin + setE(bitSet(8, peekb(z))); + pokeb(z, getE); + end; + 220: //SET 3,(ID+y)->H + begin + setH(bitSet(8, peekb(z))); + pokeb(z, getH); + end; + 221: //SET 3,(ID+y)->L + begin + setL(bitSet(8, peekb(z))); + pokeb(z, getL); + end; + 222: //SET 3,(HL) + pokeb(z, bitSet($8, peekb(z))); + 223: //SET 3,(ID+y)->A + begin + regA := bitSet(8, peekb(z)); + pokeb(z, regA); + end; + 224: //SET 4,(ID+y)->B + begin + regB := bitSet($10, peekb(z)); + pokeb(z, regB); + end; + 225: //SET 4,(ID+y)->C + begin + regC := bitSet($10, peekb(z)); + pokeb(z, regC); + end; + 226: //SET 4,(ID+y)->D + begin + setD(bitSet($10, peekb(z))); + pokeb(z, getD); + end; + 227: //SET 4,(ID+y)->E + begin + setE(bitSet($10, peekb(z))); + pokeb(z, getE); + end; + 228: //SET 4,(ID+y)->H + begin + setH(bitSet($10, peekb(z))); + pokeb(z, getH); + end; + 229: //SET 4,(ID+y)->L + begin + setL(bitSet($10, peekb(z))); + pokeb(z, getL); + end; + 230: //SET 4,(HL) + pokeb(z, bitSet($10, peekb(z))); + 231: //SET 4,(ID+y)->A + begin + regA := bitSet($10, peekb(z)); + pokeb(z, regA); + end; + 232: //SET 5,(ID+y)->B + begin + regB := bitSet($20, peekb(z)); + pokeb(z, regB); + end; + 233: //SET 5,(ID+y)->C + begin + regC := bitSet($20, peekb(z)); + pokeb(z, regC); + end; + 234: //SET 5,(ID+y)->D + begin + setD(bitSet($20, peekb(z))); + pokeb(z, getD); + end; + 235: //SET 5,(ID+y)->E + begin + setE(bitSet($20, peekb(z))); + pokeb(z, getE); + end; + 236: //SET 5,(ID+y)->H + begin + setH(bitSet($20, peekb(z))); + pokeb(z, getH); + end; + 237: //SET 5,(ID+y)->L + begin + setL(bitSet($20, peekb(z))); + pokeb(z, getL); + end; + 238: //SET 5,(HL) + pokeb(z, bitSet($20, peekb(z))); + 239: //SET 5,(ID+y)->A + begin + regA := bitSet($20, peekb(z)); + pokeb(z, regA); + end; + 240: //SET 6,(ID+y)->B + begin + regB := bitSet($40, peekb(z)); + pokeb(z, regB); + end; + 241: //SET 6,(ID+y)->C + begin + regC := bitSet($40, peekb(z)); + pokeb(z, regC); + end; + 242: //SET 6,(ID+y)->D + begin + setD(bitSet($40, peekb(z))); + pokeb(z, getD); + end; + 243: //SET 6,(ID+y)->E + begin + setE(bitSet($40, peekb(z))); + pokeb(z, getE); + end; + 244: //SET 6,(ID+y)->H + begin + setH(bitSet($40, peekb(z))); + pokeb(z, getH); + end; + 245: //SET 6,(ID+y)->L + begin + setL(bitSet($40, peekb(z))); + pokeb(z, getL); + end; + 246: //SET 6,(HL) + pokeb(z, bitSet($40, peekb(z))); + 247: //SET 6,(ID+y)->A + begin + regA := bitSet($40, peekb(z)); + pokeb(z, regA); + end; + 248: //SET 7,(ID+y)->B + begin + regB := bitSet($80, peekb(z)); + pokeb(z, regB); + end; + 249: //SET 7,(ID+y)->C + begin + regC := bitSet($80, peekb(z)); + pokeb(z, regC); + end; + 250: //SET 7,(ID+y)->D + begin + setD(bitSet($80, peekb(z))); + pokeb(z, getD); + end; + 251: //SET 7,(ID+y)->E + begin + setE(bitSet($80, peekb(z))); + pokeb(z, getE); + end; + 252: //SET 7,(ID+y)->H + begin + setH(bitSet($80, peekb(z))); + pokeb(z, getH); + end; + 253: //SET 7,(ID+y)->L + begin + setL(bitSet($80, peekb(z))); + pokeb(z, getL); + end; + 254: //SET 7,(HL) + pokeb(z, bitSet($80, peekb(z))); + 255: //SET 7,A + begin + regA := bitSet($80, peekb(z)); + pokeb(z, regA); + end; + End; +end; + + +function UARTinterrupt : integer; +begin + Result:=0; + If intIFF1 = False Then + UARTinterrupt := 0 + Else begin + Case intIM of + 0, 1: + begin + pushpc; +// intIFF1 := False; + intIFF2 := False; + regPC := 56; + UARTinterrupt := 13; + end; + 2: + begin + pushpc; +// intIFF1 := False; + intIFF2 := False; + regPC := (intI {* 256} shl 8) + $FD; // Default UART IM2 vector + regPC := peekw(regPC); + UARTinterrupt := 19; + end; + else + UARTinterrupt := 0; + End; + FUART.IntCount:=FUART.IntCount-1; + end; +end; + + +function specinterrupt : integer; + var lSleep : integer; +{$IFDEF USE_SOUND} + lCounter: integer; + PDst : Pointer; + PSrc : Pointer; +{$ENDIF} +begin + Result:=0; + interruptCounter := interruptCounter + 1; + if (glTstatesPerInterrupt shr 2) + glBeeperCounter < 0 then + glBeeperVal:=128; + // If it's a maskable interrupt + If intIFF1 = False Then + specinterrupt := 0 + Else if (Z80CardMode>Z80CARD_MOSCOW) and ((MainPort[$FB] and pFB_int50_mask)=pFB_int50_on) then + begin +{ if (Z80CardMode>=Z80_ORIONPRO_v2) then // TEMPORARY !!! + if peekw($F000)<>$F2D0 then begin + CPUPaused:=true; + frmMain.CPUSuspend; + end; // TEMPORARY !!! +} Case intIM of + 0, 1: + begin + pushpc; +// intIFF1 := False; + intIFF2 := False; + regPC := 56; + specinterrupt := 13; + end; + 2: + begin + pushpc; +// intIFF1 := False; + intIFF2 := False; + if (Z80CardMode>=Z80_ORIONPRO_v2) then + regPC := (intI {* 256} shl 8) and $FF00 + else + regPC := (intI {* 256} shl 8) Or $FF; // 20061220 + regPC := peekw(regPC); + specinterrupt := 19; + end; + else + specinterrupt := 0; + End; + End; + + {$IFDEF USE_SOUND} + If SoundEnabled Then + begin + glBufNum := glBufNum + 1; + For lCounter := glWavePtr to WAV_BUFFER_SIZE do + gcWaveOut[lCounter] := gcWaveOut[glWavePtr - 1]; + + PDst := gtWavHdr[glBufNum].lpData; + pSrc := @gcWaveOut[0]; + + CopyMemory(PDst, PSrc, WAV_BUFFER_SIZE); + + waveOutWrite(glphWaveOut, + @gtWavHdr[glBufNum], sizeof(gtWavHdr[glBufNum])); + + If glBufNum = NUM_WAV_BUFFERS Then glBufNum := 0; + End; + glWavePtr := 0; + {$ENDIF} + + //Now we REALLY hog the processor + //Application.ProcessMessages; + + //Keep the emulation running at the correct speed by + // adding a delay to ensure that interrupts are + // generated at the correct frequency + lSleep := glInterruptTimer - integer(timeGetTime()) + glDelayOverage; + If lSleep < 0 Then + begin + If glDelayOverage < -40 Then + glDelayOverage := -40 + Else + glDelayOverage := lSleep; + end; + + If lSleep > 0 Then + begin + Sleep(lSleep); + glDelayOverage := glDelayOverage + (glInterruptDelay - lSleep); + If glDelayOverage > 0 Then glDelayOverage := 0; + End + else + lSleep:=0; + + // PERFORM Z80 hardware functions + + if (interruptCounter mod 50 = 0) then + begin + F146818.update_1_second; + PortF600.Flush; + glTstatesPerInterrupt := GetCPUTstates(); // CPUTstates[MIN(CPUSpeedMode, SPEED_INF)]; + if Assigned(AfterOneSecond) then + AfterOneSecond((xSleep * 100) div 1000); + xSleep:=0; + end + else + if (interruptCounter mod 20 = 0) then + begin + if Assigned(AfterHalfSecond) then + AfterHalfSecond(0); + end + else + inc(xSleep, lSleep); + + glInterruptTimer := integer(timeGetTime()) + glInterruptDelay; +end; + +function interruptTriggered(tstates : integer) : Boolean; +begin + interruptTriggered := (tstates >= 0); +end; + +procedure or_a(b : integer); +begin + regA := (regA Or b); + + fS := (regA And F_S) <> 0; + f3 := (regA And F_3) <> 0; + f5 := (regA And F_5) <> 0; + fH := False; + fPV := Parity[regA]; + fZ := (regA = 0); + fN := False; + fC := False; +end; + + +function execute_id: integer; + var xxx : integer; lTemp : integer; op : integer; +begin + + intRTemp := intRTemp + 1; + + xxx := nxtpcb; + + Case xxx of + 0..8, 10..24, 26..32, 39, 40, 47..51, 55, 56, 58..67: + begin + regPC := dec16(regPC); + intRTemp := intRTemp - 1; + execute_id := 4; + end; + 71..75, 79..83, 87..91, 95, 120..123, 127..131: + begin + regPC := dec16(regPC); + intRTemp := intRTemp - 1; + execute_id := 4; + end; + 135..139, 143..147, 151..155, 159..163, 167..171: + begin + regPC := dec16(regPC); + intRTemp := intRTemp - 1; + execute_id := 4; + end; + 175..179, 183..187, 191..202, 204..224, 226, 228: + begin + regPC := dec16(regPC); + intRTemp := intRTemp - 1; + execute_id := 4; + end; + 230..232, 234..248: + begin + regPC := dec16(regPC); + intRTemp := intRTemp - 1; + execute_id := 4; + end; + 9: //ADD ID,BC + begin + regID := add16(regID, getBC); + execute_id := 15; + end; + 25: //ADD ID,DE + begin + regID := add16(regID, regDE); + execute_id := 15; + end; + 41: //ADD ID,ID + begin + lTemp := regID; + regID := add16(lTemp, lTemp); + execute_id := 15; + end; + 57: //ADD ID,SP + begin + regID := add16(regID, regSP); + execute_id := 15; + end; + 33: //LD ID,nn + begin + regID := nxtpcw; + execute_id := 14; + end; + 34: //LD (nn),ID + begin + pokew(nxtpcw, regID); + execute_id := 20; + end; + 42: //LD ID,(nn) + begin + regID := peekw(nxtpcw); + execute_id := 20; + end; + 35: //INC ID + begin + regID := inc16(regID); + execute_id := 10; + end; + 43: //DEC ID + begin + regID := dec16(regID); + execute_id := 10; + end; + 36: //INC IDH + begin + setIDH(inc8(getIDH)); + execute_id := 9; + end; + 44: //INC IDL + begin + setIDL(inc8(getIDL)); + execute_id := 9; + end; + 52: //INC (ID+d) + begin + lTemp := id_d; + pokeb(lTemp, inc8(peekb(lTemp))); + execute_id := 23; + end; + 37: //DEC IDH + begin + setIDH(dec8(getIDH)); + execute_id := 9; + end; + 45: //DEC IDL + begin + setIDL(dec8(getIDL)); + execute_id := 9; + end; + 53: //DEC (ID+d) + begin + lTemp := id_d; + pokeb(lTemp, dec8(peekb(lTemp))); + execute_id := 23; + end; + 38: //LD IDH,n + begin + setIDH(nxtpcb); + execute_id := 11; + end; + 46: //LD IDL,n + begin + setIDL(nxtpcb); + execute_id := 11; + end; + 54: //LD (ID+d),n + begin + lTemp := id_d; + pokeb(lTemp, nxtpcb); + execute_id := 19; + end; + 68: //LD B,IDH + begin + regB := getIDH; + execute_id := 9; + end; + 69: //LD B,IDL + begin + regB := getIDL; + execute_id := 9; + end; + 70: //LD B,(ID+d) + begin + regB := peekb(id_d); + execute_id := 19; + end; + 76: //LD C,IDH + begin + regC := getIDH; + execute_id := 9; + end; + 77: //LD C,IDL + begin + regC := getIDL; + execute_id := 9; + end; + 78: //LD C,(ID+d) + begin + regC := peekb(id_d); + execute_id := 19; + end; + 84: //LD D,IDH + begin + setD(getIDH); + execute_id := 9; + end; + 85: //LD D,IDL + begin + setD(getIDL); + execute_id := 9; + end; + 86: //LD D,(ID+d) + begin + setD(peekb(id_d)); + execute_id := 19; + end; + 92: //LD E,IDH + begin + setE(getIDH); + execute_id := 9; + end; + 93: //LD E,IDL + begin + setE(getIDL); + execute_id := 9; + end; + 94: //LD E,(ID+d) + begin + setE(peekb(id_d)); + execute_id := 19; + end; + 96: //LD IDH,B + begin + setIDH(regB); + execute_id := 9; + end; + 97: //LD IDH,C + begin + setIDH(regC); + execute_id := 9; + end; + 98: //LD IDH,D + begin + setIDH(getD); + execute_id := 9; + end; + 99: //LD IDH,E + begin + setIDH(getE); + execute_id := 9; + end; + 100: //LD IDH,IDH + execute_id := 9; + 101: //LD IDH,IDL + begin + setIDH(getIDL); + execute_id := 9; + end; + 102: //LD H,(ID+d) + begin + setH(peekb(id_d)); + execute_id := 19; + end; + 103: //LD IDH,A + begin + setIDH(regA); + execute_id := 9; + end; + 104: //LD IDL,B + begin + setIDL(regB); + execute_id := 9; + end; + 105: //LD IDL,C + begin + setIDL(regC); + execute_id := 9; + end; + 106: //LD IDL,D + begin + setIDL(getD); + execute_id := 9; + end; + 107: //LD IDL,E + begin + setIDL(getE); + execute_id := 9; + end; + 108: //LD IDL,IDH + begin + setIDL(getIDH); + execute_id := 9; + end; + 109: //LD IDL,IDL + execute_id := 9; + 110: //LD L,(ID+d) + begin + setL(peekb(id_d)); + execute_id := 19; + end; + 111: //LD IDL,A + begin + setIDL(regA); + execute_id := 9; + end; + 112: //LD (ID+d),B + begin + pokeb(id_d, regB); + execute_id := 19; + end; + 113: //LD (ID+d),C + begin + pokeb(id_d, regC); + execute_id := 19; + end; + 114: //LD (ID+d),D + begin + pokeb(id_d, getD); + execute_id := 19; + end; + 115: //LD (ID+d),E + begin + pokeb(id_d, getE); + execute_id := 19; + end; + 116: //LD (ID+d),H + begin + pokeb(id_d, getH); + execute_id := 19; + end; + 117: //LD (ID+d),L + begin + pokeb(id_d, getL); + execute_id := 19; + end; + 119: //LD (ID+d),A + begin + pokeb(id_d, regA); + execute_id := 19; + end; + 124: //LD A,IDH + begin + regA := getIDH; + execute_id := 9; + end; + 125: //LD A,IDL + begin + regA := getIDL; + execute_id := 9; + end; + 126: //LD A,(ID+d) + begin + regA := peekb(id_d); + execute_id := 19; + end; + 132: //ADD A,IDH + begin + add_a(getIDH); + execute_id := 9; + end; + 133: //ADD A,IDL + begin + add_a(getIDL); + execute_id := 9; + end; + 134: //ADD A,(ID+d) + begin + add_a(peekb(id_d)); + execute_id := 19; + end; + + 140: //ADC A,IDH + begin + adc_a(getIDH); + execute_id := 9; + end; + 141: //ADC A,IDL + begin + adc_a(getIDL); + execute_id := 9; + end; + 142: //ADC A,(ID+d) + begin + adc_a(peekb(id_d)); + execute_id := 19; + end; + 148: //SUB IDH + begin + sub_a(getIDH); + execute_id := 9; + end; + 149: //SUB IDL + begin + sub_a(getIDL); + execute_id := 9; + end; + 150: //SUB (ID+d) + begin + sub_a(peekb(id_d)); + execute_id := 19; + end; + 156: //SBC A,IDH + begin + sbc_a(getIDH); + execute_id := 9; + end; + 157: //SBC A,IDL + begin + sbc_a(getIDL); + execute_id := 9; + end; + 158: //SBC A,(ID+d) + begin + sbc_a(peekb(id_d)); + execute_id := 19; + end; + 164: //AND IDH + begin + and_a(getIDH); + execute_id := 9; + end; + 165: //AND IDL + begin + and_a(getIDL); + execute_id := 9; + end; + 166: //AND (ID+d) + begin + and_a(peekb(id_d)); + execute_id := 19; + end; + 172: //XOR IDH + begin + xor_a(getIDH); + execute_id := 9; + end; + 173: //XOR IDL + begin + xor_a(getIDL); + execute_id := 9; + end; + 174: //OR (ID+d) + begin + xor_a(peekb(id_d)); + execute_id := 19; + end; + 180: //OR IDH + begin + or_a(getIDH); + execute_id := 9; + end; + 181: //OR IDL + begin + or_a(getIDL); + execute_id := 9; + end; + 182: //OR (ID+d) + begin + or_a(peekb(id_d)); + execute_id := 19; + end; + 188: //CP IDH + begin + cp_a(getIDH); + execute_id := 9; + end; + 189: //CP IDL + begin + cp_a(getIDL); + execute_id := 9; + end; + 190: //CP (ID+d) + begin + cp_a(peekb(id_d)); + execute_id := 19; + end; + 203: //prefix CB + begin + lTemp := id_d; + op := nxtpcb; + execute_id_cb(op, lTemp); + If ((op And $C0) = $40) Then execute_id := 20 Else execute_id := 23; + end; + 225: //POP ID + begin + regID := popw; + execute_id := 14; + end; + 227: //EX (SP),ID + begin + lTemp := regID; + regID := peekw(regSP); + pokew(regSP, lTemp); + execute_id := 23; + end; + 229: //PUSH ID + begin + pushw(regID); + execute_id := 15; + end; + 233: //JP ID + begin + regPC := regID; + execute_id := 8; + end; + 249: //LD SP,ID + begin + regSP := regID; + execute_id := 10; + end; + Else + begin + execute_id := 8; + Application.MessageBox( + PChar('Unknown ID instruction ' + inttostr(xxx) + ' at ' + inttostr(regPC)), + PChar(Application.Title), + MB_OK); + end; + End; +end; + +procedure execute(var local_tstates: integer); + var + bbb: byte; + intCtrTemp : integer; + d : integer; lTemp : integer; + xxx : integer; + {$IFDEF USE_SOUND} + lOldTstates : integer; + {$ENDIF} +begin + + //Execute one interrupt duration + intCtrTemp := interruptCounter; + + repeat +{$IFDEF DEBUG} + PrevLocalTstates:=local_tstates; +{$ENDIF} + If (local_tstates >= 0) Then // Trigger an interrupt + begin +{$IFDEF USE_DEBUGGING} + ReportDebug('Interrupt', 0, true); +{$ENDIF} + + local_tstates := local_tstates - glTstatesPerInterrupt; + local_tstates := local_tstates - specinterrupt(); + end; + + intRTemp := intRTemp + 1; + + {$IFDEF USE_SOUND} + lOldTstates := local_tstates; + {$ENDIF} + + if FUART.Exists and FUART.IntMode and (FUART.IntCount>0) then + begin + while FUART.IntDataReaded>FUART.IntCount do + bbb:=FUART.Port0; // 20100420 + local_tstates := local_tstates + UARTinterrupt(); + end; + + xxx := nxtpcb; + Case xxx of + 0: //NOP + local_tstates := local_tstates + 4; + 8: //EX AF,AF' + begin + ex_af_af; + local_tstates := local_tstates + 4; + end; + 16: //DJNZ dis + begin + lTemp := qdec8(regB); + + regB := lTemp; + If lTemp <> 0 Then + begin + d := nxtpcb; + If (d And 128) = 128 Then + d := -(256 - d); + + regPC := (regPC + d) And $FFFF; + local_tstates := local_tstates + 13; + end + Else + begin + regPC := inc16(regPC); + local_tstates := local_tstates + 8; + End; + end; + 24: //JR dis + begin + d := nxtpcb; + If (d And 128) = 128 Then + d := -(256 - d); + + regPC := (regPC + d) And $FFFF; + local_tstates := local_tstates + 12; + end; + 32: //JR NZ dis + begin + If fZ = False Then + begin + d := nxtpcb; + If (d And 128) = 128 Then + d := -(256 - d); + + regPC := ((regPC + d) And $FFFF); + local_tstates := local_tstates + 12; + end + Else + begin + regPC := inc16(regPC); + local_tstates := local_tstates + 7; + End; + end; + 40: //JR Z dis + begin + If fZ = True Then + begin + d := nxtpcb; + If (d And 128) = 128 Then + d := -(256 - d); + + regPC := ((regPC + d) And $FFFF); + local_tstates := local_tstates + 12; + end + Else + begin + regPC := inc16(regPC); + local_tstates := local_tstates + 7; + End; + end; + 48: //JR NC dis + begin + If fC = False Then + begin + d := nxtpcb; + If (d And 128) = 128 Then + d := -(256 - d); + + regPC := ((regPC + d) And $FFFF); + local_tstates := local_tstates + 12; + end + Else + begin + regPC := inc16(regPC); + local_tstates := local_tstates + 7; + End; + end; + 56: //JR C dis + begin + If fC = True Then + begin + d := nxtpcb; + If (d And 128) = 128 Then + d := -(256 - d); + + regPC := ((regPC + d) And $FFFF); + local_tstates := local_tstates + 12; + end + Else + begin + regPC := inc16(regPC); + local_tstates := local_tstates + 7; + End; + end; + 1: //LD BC,nn + begin + setBC(nxtpcw); + local_tstates := local_tstates + 10; + end; + 9: //ADD HL,BC + begin + regHL := add16(regHL, getBC); + local_tstates := local_tstates + 11; + end; + 17: //LD DE,nn + begin + regDE := nxtpcw; + local_tstates := local_tstates + 10; + end; + 25: //ADD HL,DE + begin + regHL := add16(regHL, regDE); + local_tstates := local_tstates + 11; + end; + 33: //LD HL,nn + begin + regHL := nxtpcw; + local_tstates := local_tstates + 10; + end; + 41: //ADD HL,HL + begin + regHL := add16(regHL, regHL); + local_tstates := local_tstates + 11; + end; + 49: //LD SP,nn + begin + regSP := nxtpcw; + local_tstates := local_tstates + 10; + end; + 57: //ADD HL,SP + begin + regHL := add16(regHL, regSP); + local_tstates := local_tstates + 11; + end; + 2: //LD (BC),A + begin + pokeb(getBC, regA); + local_tstates := local_tstates + 7; + end; + 10: //LD A,(BC) + begin + regA := peekb(getBC); + local_tstates := local_tstates + 7; + end; + 18: //LD (DE),A + begin + pokeb(regDE, regA); + local_tstates := local_tstates + 7; + end; + 26: //LD A,(DE) + begin + regA := peekb(regDE); + local_tstates := local_tstates + 7; + end; + 34: //LD (nn),HL + begin + pokew(nxtpcw, regHL); + local_tstates := local_tstates + 16; + end; + 42: //LD HL,(nn) + begin + regHL := peekw(nxtpcw); + local_tstates := local_tstates + 16; + end; + 50: //LD (nn),A + begin + pokeb(nxtpcw, regA); + local_tstates := local_tstates + 13; + end; + 58: //LD A,(nn) + begin + regA := peekb(nxtpcw); + local_tstates := local_tstates + 13; + end; + 3: //INC BC + begin + setBC(inc16(getBC)); + local_tstates := local_tstates + 6 + end; + 11: //DEC BC + begin + setBC(dec16(getBC)); + local_tstates := local_tstates + 6; + end; + 19: //INC DE + begin + regDE := inc16(regDE); + local_tstates := local_tstates + 6; + end; + 27: //DEC DE + begin + regDE := dec16(regDE); + local_tstates := local_tstates + 6; + end; + 35: //INC HL + begin + regHL := inc16(regHL); + local_tstates := local_tstates + 6; + end; + 43: //DEC HL + begin + regHL := dec16(regHL); + local_tstates := local_tstates + 6; + end; + 51: //INC SP + begin + regSP := inc16(regSP); + local_tstates := local_tstates + 6; + end; + 59: //DEC SP + begin + regSP := dec16(regSP); + local_tstates := local_tstates + 6; + end; + 4: //INC B + begin + regB := inc8(regB); + local_tstates := local_tstates + 4; + end; + 12: //INC C + begin + regC := inc8(regC); + local_tstates := local_tstates + 4; + end; + 20: //INC D + begin + setD(inc8(getD)); + local_tstates := local_tstates + 4; + end; + 28: //INC E + begin + setE(inc8(getE)); + local_tstates := local_tstates + 4; + end; + 36: //INC H + begin + setH(inc8(getH)); + local_tstates := local_tstates + 4; + end; + 44: //INC L + begin + setL(inc8(getL)); + local_tstates := local_tstates + 4; + end; + 52: //INC (HL) + begin + pokeb(regHL, inc8(peekb(regHL))); + local_tstates := local_tstates + 11; + end; + 60: //INC A + begin + regA := inc8(regA); + local_tstates := local_tstates + 4; + end; + + 5: //DEC B + begin + regB := dec8(regB); + local_tstates := local_tstates + 4; + end; + 13: //DEC C + begin + regC := dec8(regC); + local_tstates := local_tstates + 4; + end; + 21: //DEC D + begin + setD(dec8(getD)); + local_tstates := local_tstates + 4; + end; + 29: //DEC E + begin + setE(dec8(getE)); + local_tstates := local_tstates + 4; + end; + 37: //DEC H + begin + setH(dec8(getH)); + local_tstates := local_tstates + 4; + end; + 45: //DEC L + begin + setL(dec8(getL)); + local_tstates := local_tstates + 4; + end; + 53: //DEC (HL) + begin + pokeb(regHL, dec8(peekb(regHL))); + local_tstates := local_tstates + 11; + end; + 61: //DEC A + begin + regA := dec8(regA); + local_tstates := local_tstates + 4; + end; + + 6 : //D B,n + begin + regB := nxtpcb; + local_tstates := local_tstates + 7; + end; + 14: //LD C,n + begin + regC := nxtpcb; + local_tstates := local_tstates + 7; + end; + 22: //LD D,n + begin + setD(nxtpcb); + local_tstates := local_tstates + 7; + end; + 30: //LD E,n + begin + setE(nxtpcb); + local_tstates := local_tstates + 7; + end; + 38: //LD H,n + begin + setH(nxtpcb); + local_tstates := local_tstates + 7; + end; + 46: //LD L,n + begin + setL(nxtpcb); + local_tstates := local_tstates + 7; + end; + 54: //LD (HL),n + begin + pokeb(regHL, nxtpcb); + local_tstates := local_tstates + 10; + end; + 62: //LD A,n + begin + regA := nxtpcb; + local_tstates := local_tstates + 7; + end; + + 7 : //LCA + begin + rlc_a; + local_tstates := local_tstates + 4; + end; + 15: //RRCA + begin + rrc_a; + local_tstates := local_tstates + 4; + end; + 23: //RLA + begin + rl_a; + local_tstates := local_tstates + 4; + end; + 31: //RRA + begin + rr_a; + local_tstates := local_tstates + 4; + end; + 39: //DAA + begin + daa_a; + local_tstates := local_tstates + 4; + end; + 47: //CPL + begin + cpl_a; + local_tstates := local_tstates + 4; + end; + 55: //SCF + begin + scf; + local_tstates := local_tstates + 4; + end; + 63: //CCF + begin + ccf; + local_tstates := local_tstates + 4; + end; + 64: //LD B,B + local_tstates := local_tstates + 4; + 65: //LD B,C + begin + regB := regC; + local_tstates := local_tstates + 4; + end; + 66: //LD B,D + begin + regB := getD; + local_tstates := local_tstates + 4; + end; + 67: //LD B,E + begin + regB := getE; + local_tstates := local_tstates + 4; + end; + 68: //LD B,H + begin + regB := getH; + local_tstates := local_tstates + 4; + end; + 69: //LD B,L + begin + regB := getL; + local_tstates := local_tstates + 4; + end; + 70: //LD B,(HL) + begin + regB := peekb(regHL); + local_tstates := local_tstates + 7; + end; + 71: //LD B,A + begin + regB := regA; + local_tstates := local_tstates + 4; + end; + + 72: //LD C,B + begin + regC := regB; + local_tstates := local_tstates + 4; + end; + 73: //LD C,C + local_tstates := local_tstates + 4; + 74: //LD C,D + begin + regC := getD; + local_tstates := local_tstates + 4; + end; + 75: //LD C,E + begin + regC := getE; + local_tstates := local_tstates + 4; + end; + 76: //LD C,H + begin + regC := getH; + local_tstates := local_tstates + 4; + end; + 77: //LD C,L + begin + regC := getL; + local_tstates := local_tstates + 4; + end; + 78: //LD C,(HL) + begin + regC := peekb(regHL); + local_tstates := local_tstates + 7; + end; + 79: //LD C,A + begin + regC := regA; + local_tstates := local_tstates + 4; + end; + 80: //LD D,B + begin + setD(regB); + local_tstates := local_tstates + 4; + end; + 81: //LD D,C + begin + setD(regC); + local_tstates := local_tstates + 4; + end; + 82: //LD D,D + local_tstates := local_tstates + 4; + 83: //LD D,E + begin + setD(getE); + local_tstates := local_tstates + 4; + end; + 84: //LD D,H + begin + setD(getH); + local_tstates := local_tstates + 4; + end; + 85: //LD D,L + begin + setD(getL); + local_tstates := local_tstates + 4; + end; + 86: //LD D,(HL) + begin + setD(peekb(regHL)); + local_tstates := local_tstates + 7; + end; + 87: //LD D,A + begin + setD(regA); + local_tstates := local_tstates + 4; + end; + 88: //LD E,B + begin + setE(regB); + local_tstates := local_tstates + 4; + end; + 89: //LD E,C + begin + setE(regC); + local_tstates := local_tstates + 4; + end; + 90: //LD E,D + begin + setE(getD); + local_tstates := local_tstates + 4; + end; + 91: //LD E,E + local_tstates := local_tstates + 4; + 92: //LD E,H + begin + setE(getH); + local_tstates := local_tstates + 4; + end; + 93: //LD E,L + begin + setE(getL); + local_tstates := local_tstates + 4; + end; + 94: //LD E,(HL) + begin + setE(peekb(regHL)); + local_tstates := local_tstates + 7; + end; + 95: //LD E,A + begin + setE(regA); + local_tstates := local_tstates + 4; + end; + 96: //LD H,B + begin + setH(regB); + local_tstates := local_tstates + 4; + end; + 97: //LD H,C + begin + setH(regC); + local_tstates := local_tstates + 4; + end; + 98: //LD H,D + begin + setH(getD); + local_tstates := local_tstates + 4; + end; + 99: //LD H,E + begin + setH(getE); + local_tstates := local_tstates + 4; + end; + 100: //LD H,H + local_tstates := local_tstates + 4; + 101: //LD H,L + begin + setH(getL); + local_tstates := local_tstates + 4; + end; + 102: //LD H,(HL) + begin + setH(peekb(regHL)); + local_tstates := local_tstates + 7; + end; + 103: //LD H,A + begin + setH(regA); + local_tstates := local_tstates + 4; + end; + 104: //LD L,B + begin + setL(regB); + local_tstates := local_tstates + 4; + end; + 105: //LD L,C + begin + setL(regC); + local_tstates := local_tstates + 4; + end; + 106: //LD L,D + begin + setL(getD); + local_tstates := local_tstates + 4; + end; + 107: //LD L,E + begin + setL(getE); + local_tstates := local_tstates + 4; + end; + 108: //LD L,H + begin + setL(getH); + local_tstates := local_tstates + 4; + end; + 109: //LD L,L + local_tstates := local_tstates + 4; + 110: //LD L,(HL) + begin + setL(peekb(regHL)); + local_tstates := local_tstates + 7; + end; + 111: //LD L,A + begin + setL(regA); + local_tstates := local_tstates + 4; + end; + 112: //LD (HL),B + begin + pokeb(regHL, regB); + local_tstates := local_tstates + 7; + end; + 113: //LD (HL),C + begin + pokeb(regHL, regC); + local_tstates := local_tstates + 7; + end; + 114: //LD (HL),D + begin + pokeb(regHL, getD); + local_tstates := local_tstates + 7; + end; + 115: //LD (HL),E + begin + pokeb(regHL, getE); + local_tstates := local_tstates + 7; + end; + 116: //LD (HL),H + begin + pokeb(regHL, getH); + local_tstates := local_tstates + 7; + end; + 117: //LD (HL),L + begin + pokeb(regHL, getL); + local_tstates := local_tstates + 7; + end; + 118: //HALT + begin + lTemp := (((-local_tstates - 1) shr 2) + 1); + local_tstates := local_tstates + (lTemp * 4); + intRTemp := intRTemp + (lTemp - 1) + end; + 119: //LD (HL),A + begin + pokeb(regHL, regA); + local_tstates := local_tstates + 7; + end; + 120: //LD A,B + begin + regA := regB; + local_tstates := local_tstates + 4; + end; + 121: //LD A,C + begin + regA := regC; + local_tstates := local_tstates + 4; + end; + 122: //LD A,D + begin + regA := getD; + local_tstates := local_tstates + 4; + end; + 123: //LD A,E + begin + regA := getE; + local_tstates := local_tstates + 4; + end; + 124: //LD A,H + begin + regA := getH; + local_tstates := local_tstates + 4; + end; + 125: //LD A,L + begin + regA := getL; + local_tstates := local_tstates + 4; + end; + 126: //LD A,(HL) + begin + regA := peekb(regHL); + local_tstates := local_tstates + 7; + end; + 127: //LD A,A + local_tstates := local_tstates + 4; + 128: //ADD A,B + begin + add_a(regB); + local_tstates := local_tstates + 4; + end; + 129: //ADD A,C + begin + add_a(regC); + local_tstates := local_tstates + 4; + end; + 130: //ADD A,D + begin + add_a(getD); + local_tstates := local_tstates + 4; + end; + 131: //ADD A,E + begin + add_a(getE); + local_tstates := local_tstates + 4; + end; + 132: //ADD A,H + begin + add_a(getH); + local_tstates := local_tstates + 4; + end; + 133: //ADD A,L + begin + add_a(getL); + local_tstates := local_tstates + 4; + end; + 134: //ADD A,(HL) + begin + add_a(peekb(regHL)); + local_tstates := local_tstates + 7; + end; + 135: //ADD A,A + begin + add_a(regA); + local_tstates := local_tstates + 4; + end; + 136: //ADC A,B + begin + adc_a(regB); + local_tstates := local_tstates + 4; + end; + 137: //ADC A,C + begin + adc_a(regC); + local_tstates := local_tstates + 4; + end; + 138: //ADC A,D + begin + adc_a(getD); + local_tstates := local_tstates + 4; + end; + 139: //ADC A,E + begin + adc_a(getE); + local_tstates := local_tstates + 4; + end; + 140: //ADC A,H + begin + adc_a(getH); + local_tstates := local_tstates + 4; + end; + 141: //ADC A,L + begin + adc_a(getL); + local_tstates := local_tstates + 4; + end; + 142: //ADC A,(HL) + begin + adc_a(peekb(regHL)); + local_tstates := local_tstates + 7; + end; + 143: //ADC A,A + begin + adc_a(regA); + local_tstates := local_tstates + 4; + end; + 144: //SUB B + begin + sub_a(regB); + local_tstates := local_tstates + 4; + end; + 145: //SUB C + begin + sub_a(regC); + local_tstates := local_tstates + 4; + end; + 146: //SUB D + begin + sub_a(getD); + local_tstates := local_tstates + 4; + end; + 147: //SUB E + begin + sub_a(getE); + local_tstates := local_tstates + 4; + end; + 148: //SUB H + begin + sub_a(getH); + local_tstates := local_tstates + 4; + end; + 149: //SUB L + begin + sub_a(getL); + local_tstates := local_tstates + 4; + end; + 150: //SUB (HL) + begin + sub_a(peekb(regHL)); + local_tstates := local_tstates + 7; + end; + 151: //SUB A + begin + sub_a(regA); + local_tstates := local_tstates + 4; + end; + 152: //SBC A,B + begin + sbc_a(regB); + local_tstates := local_tstates + 4; + end; + 153: //SBC A,C + begin + sbc_a(regC); + local_tstates := local_tstates + 4; + end; + 154: //SBC A,D + begin + sbc_a(getD); + local_tstates := local_tstates + 4; + end; + 155: //SBC A,E + begin + sbc_a(getE); + local_tstates := local_tstates + 4; + end; + 156: //SBC A,H + begin + sbc_a(getH); + local_tstates := local_tstates + 4; + end; + 157: //SBC A,L + begin + sbc_a(getL); + local_tstates := local_tstates + 4; + end; + 158: //SBC A,(HL) + begin + sbc_a(peekb(regHL)); + local_tstates := local_tstates + 7; + end; + 159: //SBC A,A + begin + sbc_a(regA); + local_tstates := local_tstates + 4; + end; + 160: //AND B + begin + and_a(regB); + local_tstates := local_tstates + 4; + end; + 161: //AND C + begin + and_a(regC); + local_tstates := local_tstates + 4; + end; + 162: //AND D + begin + and_a(getD); + local_tstates := local_tstates + 4; + end; + 163: //AND E + begin + and_a(getE); + local_tstates := local_tstates + 4; + end; + 164: //AND H + begin + and_a(getH); + local_tstates := local_tstates + 4; + end; + 165: //AND L + begin + and_a(getL); + local_tstates := local_tstates + 4; + end; + 166: //AND (HL) + begin + and_a(peekb(regHL)); + local_tstates := local_tstates + 7; + end; + 167: //AND A + begin + and_a(regA); + local_tstates := local_tstates + 4; + end; + 168: //XOR B + begin + xor_a(regB); + local_tstates := local_tstates + 4; + end; + 169: //XOR C + begin + xor_a(regC); + local_tstates := local_tstates + 4; + end; + 170: //XOR D + begin + xor_a(getD); + local_tstates := local_tstates + 4; + end; + 171: //XOR E + begin + xor_a(getE); + local_tstates := local_tstates + 4; + end; + 172: //XOR H + begin + xor_a(getH); + local_tstates := local_tstates + 4; + end; + 173: //XOR L + begin + xor_a(getL); + local_tstates := local_tstates + 4; + end; + 174: //XOR (HL) + begin + xor_a(peekb(regHL)); + local_tstates := local_tstates + 7; + end; + 175: //XOR A + begin + regA := 0; + fS := False; + f3 := False; + f5 := False; + fH := False; + fPV := True; + fZ := True; + fN := False; + fC := False; + local_tstates := local_tstates + 4; + end; + 176: //OR B + begin + or_a(regB); + local_tstates := local_tstates + 4; + end; + 177: //OR C + begin + or_a(regC); + local_tstates := local_tstates + 4; + end; + 178: //OR D + begin + or_a(getD); + local_tstates := local_tstates + 4; + end; + 179: //OR E + begin + or_a(getE); + local_tstates := local_tstates + 4; + end; + 180: //OR H + begin + or_a(getH); + local_tstates := local_tstates + 4; + end; + 181: //OR L + begin + or_a(getL); + local_tstates := local_tstates + 4; + end; + 182: //OR (HL) + begin + or_a(peekb(regHL)); + local_tstates := local_tstates + 7; + end; + 183: //OR A + begin + or_a(regA); + local_tstates := local_tstates + 4; + end; + 184: //CP B + begin + cp_a(regB); + local_tstates := local_tstates + 4; + end; + 185: //CP C + begin + cp_a(regC); + local_tstates := local_tstates + 4; + end; + 186: //CP D + begin + cp_a(getD); + local_tstates := local_tstates + 4; + end; + 187: //CP E + begin + cp_a(getE); + local_tstates := local_tstates + 4; + end; + 188: //CP H + begin + cp_a(getH); + local_tstates := local_tstates + 4; + end; + 189: //CP L + begin + cp_a(getL); + local_tstates := local_tstates + 4; + end; + 190: //CP (HL) + begin + cp_a(peekb(regHL)); + local_tstates := local_tstates + 7; + end; + 191: //CP A + begin + cp_a(regA); + local_tstates := local_tstates + 4; + end; + 192: //RET NZ + begin + If fZ = False Then + begin + poppc; + local_tstates := local_tstates + 11; + end + Else + local_tstates := local_tstates + 5; + end; + 200: //RET Z + begin + If fZ Then + begin + poppc; + local_tstates := local_tstates + 11; + end + Else + local_tstates := local_tstates + 5; + end; + 208: //RET NC + begin + If fC = False Then + begin + poppc; + local_tstates := local_tstates + 11; + end + Else + local_tstates := local_tstates + 5; + end; + 216: //RET C + begin + If fC Then + begin + poppc; + local_tstates := local_tstates + 11; + end + Else + local_tstates := local_tstates + 5; + end; + 224: //RET PO + begin + If fPV = False Then + begin + poppc; + local_tstates := local_tstates + 11; + end + Else + local_tstates := local_tstates + 5; + end; + 232: //RET PE + begin + If fPV Then + begin + poppc; + local_tstates := local_tstates + 11; + end + Else + local_tstates := local_tstates + 5; + end; + 240: //RET P + begin + If fS = False Then + begin + poppc; + local_tstates := local_tstates + 11; + end + Else + local_tstates := local_tstates + 5; + end; + 248: //RET M + begin + If fS Then + begin + poppc; + local_tstates := local_tstates + 11; + end + Else + local_tstates := local_tstates + 5; + end; + 193: //POP BC + begin + setBC(popw); + local_tstates := local_tstates + 10; + end; + 201: //RET + begin + poppc; + local_tstates := local_tstates + 10; + end; + 209: //POP DE + begin + regDE := popw; + local_tstates := local_tstates + 10; + end; + 217: //EXX + begin + exx; + local_tstates := local_tstates + 4; + end; + 225: //POP HL + begin + regHL := popw; + local_tstates := local_tstates + 10; + end; + 233: //JP HL + begin + regPC := regHL; + local_tstates := local_tstates + 4; + end; + 241: //POP AF + begin + setAF(popw); + local_tstates := local_tstates + 10; + end; + 249: //LD SP,HL + begin + regSP := regHL; + local_tstates := local_tstates + 6; + end; + 194: //JP NZ,nn + begin + If fZ = False Then + regPC := nxtpcw + Else + regPC := regPC + 2; + + local_tstates := local_tstates + 10; + end; + 202: //JP Z,nn + begin + If fZ Then + regPC := nxtpcw + Else + regPC := regPC + 2; + + local_tstates := local_tstates + 10; + end; + 210: //JP NC,nn + begin + If fC = False Then + regPC := nxtpcw + Else + regPC := regPC + 2; + + local_tstates := local_tstates + 10; + end; + 218: //JP C,nn + begin + If fC Then + regPC := nxtpcw + Else + regPC := regPC + 2; + + local_tstates := local_tstates + 10; + end; + 226: //JP PO,nn + begin + If fPV = False Then + regPC := nxtpcw + Else + regPC := regPC + 2; + + local_tstates := local_tstates + 10; + end; + 234: //JP PE,nn + begin + If fPV Then + regPC := nxtpcw + Else + regPC := regPC + 2; + + local_tstates := local_tstates + 10; + end; + 242: //JP P,nn + begin + If fS = False Then + regPC := nxtpcw + Else + regPC := regPC + 2; + + local_tstates := local_tstates + 10; + end; + 250: //JP M,nn + begin + If fS Then + regPC := nxtpcw + Else + regPC := regPC + 2; + + local_tstates := local_tstates + 10; + end; + 195: //JP nn + begin + regPC := peekw(regPC); + local_tstates := local_tstates + 10; + end; + 203: //prefix CB + local_tstates := local_tstates + execute_cb; + 211: //OUT (n),A + begin + outb(nxtpcb, regA); + local_tstates := local_tstates + 11; + end; + 219: //IN A,(n) + begin + regA := inb((regA {* 256} shl 8) Or nxtpcb); // 20061220 + local_tstates := local_tstates + 11; + end; + 227: //EX (SP),HL + begin + lTemp := regHL; + regHL := peekw(regSP); + pokew(regSP, lTemp); + local_tstates := local_tstates + 19; + end; + 235: //EX DE,HL + begin + lTemp := regHL; + regHL := regDE; + regDE := lTemp; + local_tstates := local_tstates + 4; + end; + 243: //DI + begin + if Z80CardMode=Z80CARD_MOSCOW then SetBeeper0; + intIFF1 := False; + intIFF2 := False; + local_tstates := local_tstates + 4; + end; + 251: //EI + begin + if Z80CardMode=Z80CARD_MOSCOW then SetBeeper1; + intIFF1 := True; + intIFF2 := True; + local_tstates := local_tstates + 4; + end; + 196: //CALL NZ,nn + begin + If fZ = False Then + begin +// pushw(regPC + 2); // 20061220 +// regPC := nxtpcw; + lTemp := nxtpcw; + pushw(regPC); + regPC := lTemp; + local_tstates := local_tstates + 17; + end + Else + begin + regPC := regPC + 2; + local_tstates := local_tstates + 10; + End; + end; + 204: //CALL Z,nn + begin + If fZ Then + begin +// pushw(regPC + 2); // 20061220 +// regPC := nxtpcw; + lTemp := nxtpcw; + pushw(regPC); + regPC := lTemp; + local_tstates := local_tstates + 17; + end + Else + begin + regPC := regPC + 2; + local_tstates := local_tstates + 10; + End; + end; + 212: //CALL NC,nn + begin + If fC = False Then + begin +// pushw(regPC + 2); // 20061220 +// regPC := nxtpcw; + lTemp := nxtpcw; + pushw(regPC); + regPC := lTemp; + local_tstates := local_tstates + 17; + end + Else + begin + regPC := regPC + 2; + local_tstates := local_tstates + 10; + End; + end; + 220: //CALL C,nn + begin + If fC Then + begin +// pushw(regPC + 2); // 20061220 +// regPC := nxtpcw; + lTemp := nxtpcw; + pushw(regPC); + regPC := lTemp; + local_tstates := local_tstates + 17; + end + Else + begin + regPC := regPC + 2; + local_tstates := local_tstates + 10; + End; + end; + 228: //CALL PO,nn + begin + If fPV = False Then + begin +// pushw(regPC + 2); // 20061220 +// regPC := nxtpcw; + lTemp := nxtpcw; + pushw(regPC); + regPC := lTemp; + local_tstates := local_tstates + 17; + end + Else + begin + regPC := regPC + 2; + local_tstates := local_tstates + 10; + End + end; + 236: //CALL PE,nn + begin + If fPV Then + begin +// pushw(regPC + 2); // 20061220 +// regPC := nxtpcw; + lTemp := nxtpcw; + pushw(regPC); + regPC := lTemp; + local_tstates := local_tstates + 17; + end + Else + begin + regPC := regPC + 2; + local_tstates := local_tstates + 10; + End; + end; + 244: //CALL P,nn + begin + If fS = False Then + begin +// pushw(regPC + 2); // 20061220 +// regPC := nxtpcw; + lTemp := nxtpcw; + pushw(regPC); + regPC := lTemp; + local_tstates := local_tstates + 17; + end + Else + begin + regPC := regPC + 2; + local_tstates := local_tstates + 10; + End; + end; + 252: //CALL M,nn + begin + If fS Then + begin +// pushw(regPC + 2); // 20061220 +// regPC := nxtpcw; + lTemp := nxtpcw; + pushw(regPC); + regPC := lTemp; + local_tstates := local_tstates + 17; + end + Else + begin + regPC := regPC + 2; + local_tstates := local_tstates + 10; + End; + end; + 197: //PUSH BC + begin + pushw(getBC); + local_tstates := local_tstates + 11; + end; + 205: //CALL nn + begin +// pushw(regPC + 2); // 20061220 +// regPC := nxtpcw; + lTemp := nxtpcw; + pushw(regPC); + regPC := lTemp; + local_tstates := local_tstates + 17; + end; + 213: //PUSH DE + begin + pushw(regDE); + local_tstates := local_tstates + 11; + end; + 221: //prefix IX + begin + regID := regIX; + local_tstates := local_tstates + execute_id; + regIX := regID; + end; + 229: //PUSH HL + begin + pushw(regHL); + local_tstates := local_tstates + 11; + end; + 237: //prefix ED + local_tstates := local_tstates + execute_ed(local_tstates); + 245: //PUSH AF + begin + pushw(getAF); + local_tstates := local_tstates + 11; + end; + 253: //prefix IY + begin + regID := regIY; + local_tstates := local_tstates + execute_id; + regIY := regID; + end; + 198: //ADD A,n + begin + add_a(nxtpcb); + local_tstates := local_tstates + 7; + end; + 206: //ADC A,n + begin + adc_a(nxtpcb); + local_tstates := local_tstates + 7; + end; + 214: //SUB n + begin + sub_a(nxtpcb); + local_tstates := local_tstates + 7; + end; + 222: //SBC n + begin + sbc_a(nxtpcb); + local_tstates := local_tstates + 7; + end; + 230: //AND n + begin + and_a(nxtpcb); + local_tstates := local_tstates + 7; + end; + 238: //XOR n + begin + xor_a(nxtpcb); + local_tstates := local_tstates + 7; + end; + 246: //OR n + begin + or_a(nxtpcb); + local_tstates := local_tstates + 7; + end; + 254: //CP n + begin + cp_a(nxtpcb); + local_tstates := local_tstates + 7; + end; + 199: //RST 0 + begin + pushpc; + regPC := 0; + local_tstates := local_tstates + 11; + end; + 207: //RST 8 + begin + pushpc; + regPC := 8; + local_tstates := local_tstates + 11; + end; + 215: //RST 16 + begin + pushpc; + regPC := 16; + local_tstates := local_tstates + 11; + end; + 223: //RST 24 + begin + pushpc; + regPC := 24; + local_tstates := local_tstates + 11; + end; + 231: //RST 32 + begin + pushpc; + regPC := 32; + local_tstates := local_tstates + 11; + end; + 239: //RST 40 + begin + pushpc; + regPC := 40; + local_tstates := local_tstates + 11; + end; + 247: //RST 48 + begin + pushpc; + regPC := 48; + local_tstates := local_tstates + 11; + end; + 255: //RST 56 + begin + pushpc; + regPC := 56; + local_tstates := local_tstates + 11; + end; + Else + Application.MessageBox( + PChar('Unknown instruction ' + inttostr(xxx) + ' at ' + inttostr(regPC)), + PChar(Application.Title), + MB_OK); + End; +{$IFDEF DEBUG} + inc(TicksFromPrevSD, local_tstates-PrevLocalTstates); +{$ENDIF} + if Assigned(AfterInstruction) then + AfterInstruction(); +{$IFDEF XDEBUG} + if not tmpStart then + tmpStart:=(BreakPoint_pF9=MainPort[$F9])and(RegPC=$100); + if tmpStart and (tmpStop=$FFFF) then tmpStop:=peekw(peekw(1)+1); + if tmpStop=RegPC then tmpStart:=False; + if (BreakPoint_pF9=MainPort[$F9])and(RegPC=5) then + begin + tmpRet:=peekw(regSP); + if tmpStart then DebugInfo(#13#10'Call BDOS', 1); + end; + if (BreakPoint_pF9=MainPort[$F9])and(RegPC=tmpRet)and(tmpStart) then DebugInfo(' Ret', 0); +{$ENDIF} + if ((BreakPointPF9 or BreakPointPF9mask = MainPort[$F9] or BreakPointPF9mask) and + (BreakPointAddr or BreakPointAddrMask = RegPC or BreakPointAddrMask) and + ((not AnalyzeConditions) or (AnalyzeConditions and + ((boolean(ConditionSP[0])and(ConditionSPvalue or ConditionSPmask=regSP or ConditionSPmask)) or + (boolean(ConditionAF[0])and(ConditionAFvalue or ConditionAFmask=getAF or ConditionAFmask)) or + (boolean(ConditionBC[0])and(ConditionBCvalue or ConditionBCmask=getBC or ConditionBCmask)) or + (boolean(ConditionDE[0])and(ConditionDEvalue or ConditionDEmask=regDE or ConditionDEmask)) or + (boolean(ConditionHL[0])and(ConditionHLvalue or ConditionHLmask=regHL or ConditionHLmask)) or + (boolean(ConditionAF_[0])and(ConditionAF_value or ConditionAF_mask=regAF_ or ConditionAF_mask)) or + (boolean(ConditionBC_[0])and(ConditionBC_value or ConditionBC_mask=regBC_ or ConditionBC_mask)) or + (boolean(ConditionDE_[0])and(ConditionDE_value or ConditionDE_mask=regDE_ or ConditionDE_mask)) or + (boolean(ConditionHL_[0])and(ConditionHL_value or ConditionHL_mask=regHL_ or ConditionHL_mask)) or + (boolean(ConditionIX[0])and(ConditionIXvalue or ConditionIXmask=regIX or ConditionIXmask)) or + (boolean(ConditionIY[0])and(ConditionIYvalue or ConditionIYmask=regIY or ConditionIYmask)) or + (boolean(ConditionIR[0])and(ConditionIRvalue or ConditionIRmask=getIR or ConditionIRmask)) + ) + ) + ) + ) or + ((BreakPointRetPF9=MainPort[$F9]) and (BreakPointRetAddr=RegPC)) then + begin + if Assigned(AfterBreakPoint) then + AfterBreakPoint(); + BreakPointRetPF9:=$FF; + end; + inc(intR); + intR:=intR and $7F; +{$IFDEF USE_SOUND} + AddSoundWave(local_tstates - lOldTstates); +{$ENDIF} + until (intCtrTemp <> interruptCounter)or CpuPaused; + +end; + + + +procedure Z80Reset; +begin + regPC := 0; + regSP := 0; + regA := 0; + setF(0); + setBC(0); + regDE := 0; + regHL := 0; + + exx; + ex_af_af; + + regA := 0; + setF(0); + setBC(0); + regDE := 0; + regHL := 0; + + regIX := 0; + regIY := 0; + intR := 128; + intRTemp := 0; + + intI := 0; + intIFF1 := False; + intIFF2 := False; + intIM := 0; + + // 69888 tstates per interrupt = 3.50000 MHz + glTstatesPerInterrupt := GetCPUTstates(); // CPUTstates[CPUSpeedMode]; +{$IFDEF USE_SOUND} + glWaveAddTStates := 158; + AY8912_init(1773000, WAVE_FREQUENCY, 8); +{$ENDIF} +end; + + + +end. diff --git a/readme.md b/readme.md new file mode 100644 index 0000000..fd86470 --- /dev/null +++ b/readme.md @@ -0,0 +1,34 @@ +# OriZEmu +Это эмулятор домашнего компьютера Орион-128, описанного в журнале Радио N1 за 1990г., и модифицированного при помощи Z80 Card II (ленинградский вариант установки Z80 в Орион), а также модификации Орион-ПРО, версия 1.03, build 1.0.3.6 (15.09.2008). Программа не требует установки, работает из текущего каталога куда будет распакована, настройки хранятся в файле, одноименном исполняемому, но с расширением INI. В составе эмулятора распространяется утилита HddUtil.exe, с помощью которой под Windows NT, 2000, XP, Vista, W7 можно создать в файле посекторный образ HDD (как целиком, так и логического раздела - партиции, как всего(всей), так и N секторов). Программа работает аналогично утилите DiskUtil.exe ( DiskUtil.zip ), создающей ODI-образы дискет. В составе эмулятора распространяется плагин для TotalCommnader/DoubleCommander/FarManager для работы с образами дискет (ODI и аналогичные) и образами HDD (OHI и аналогичные). + + +Технические характеристики эмулируемого компьютера: + +процессор - Z80 2.5 МГц (режимы турбо: 3.5/5/7/10/20 MГц), режимы Z80 Орион-Сервис, Z80 Card II, Orion-PRO +память (ОЗУ) - 128..4096кб, +клавиатура - РК86, МС7007 Ленинград (совместимо с РК), МС7007 Москва(авторская), +ROM-BIOS - страндартный (128/ПРО), содержится во внешнем файле, +ROM-DISK - страндартный, содержится во внешнем файле, + расширенный режим (16 страниц по 64к, + переключаемые битами D0..D3 порта 0FEh для Ориона-128 и расширенный до 2Mб + маппер страниц порта 09h для ПЗУ ROM2 Ориона-ПРО) +КНГМД - эмуляция 1818ВГ93, 2 привода (ODI-файлы), порты F700..7003/F710..F713/F720/F714, + эмулируется режим HD (ODI-диски более 800к), +ЧАСЫ (RTC) - эмуляция 512ВИ1 на порту F760/F761 (BlackCat inc.), 50h..51h (Орион-ПРО) +муз.процессор- эмуляция AY-3-8910 на портах BFFD/FFFD, 3Eh..3Fh (Орион-ПРО) +IDE (HDD) - эмуляция контролера IDE на 580вв55 (порт F500/F600), 56h..5Fh (Орион-ПРО) +SD-card - Эмулируются 2 варианта: + = совместимо по схеме с n8vem (port F762): + http://n8vem-sbc.pbworks.com/browse/#view=ViewFolder¶m=N8VEM%20Schematics + = совместимо по схеме с MSX MMC-drive V1 (port F762, F763): + http://msx.retro8bits.com/sd-mmc-drive.html + В железе оба варианта не проверялись, только в эмуляторе! + Эмулируются только SDC карты (non-SDHC, объемом до 1Gb). +последовательный порт (RS-232) - порты F764,F765 (схема на AtTiny2313). +Ethernet - эмулируются NE2K-устройства, в железе на примере RTL8019AS +Принтер - эмуляция 2-х схем принтера CENTRONICS (порт F600) + +Минимальные требования к PC: + +Celeron 400Мгц / 64М RAM / 2M HDD free / Windows 9x, 2000, XP, Vista, W7 + + diff --git a/settswin.dfm b/settswin.dfm new file mode 100644 index 0000000..1457abf --- /dev/null +++ b/settswin.dfm @@ -0,0 +1,1110 @@ +object frmSetts: TfrmSetts + Left = 236 + Top = 127 + BorderIcons = [biSystemMenu] + BorderStyle = bsSingle + Caption = 'Settings' + ClientHeight = 364 + ClientWidth = 514 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + Position = poScreenCenter + OnActivate = FormActivate + PixelsPerInch = 96 + TextHeight = 13 + object Label28: TLabel + Left = 8 + Top = 173 + Width = 137 + Height = 13 + Caption = 'HDD Device "0" (8255 PPA)' + end + object Label29: TLabel + Left = 8 + Top = 239 + Width = 137 + Height = 13 + Caption = 'HDD Device "1" (8255 PPA)' + end + object PageControl1: TPageControl + Left = 0 + Top = 0 + Width = 514 + Height = 328 + ActivePage = tsCPU + Align = alClient + TabOrder = 0 + object tsCPU: TTabSheet + Caption = 'CPU, MEM' + object rgZ80Card: TRadioGroup + Left = 8 + Top = 75 + Width = 491 + Height = 220 + Caption = ' Platform emulation mode ' + ItemIndex = 0 + Items.Strings = ( + + 'Z80 Card Moscow (Radio 96/4) - no int50, no dispatcher, sound EI' + + '/DI' + 'Z80 Card II - minimal port 0FBh (int50 Hz)' + + 'Z80 Card II - typical port 0FBh (int50 Hz, 16k dispatcher, Ful' + + 'l RAM)' + + 'Z80 Card II - maximal port 0FBh (int50 Hz, 16k dispatcher, Full ' + + 'RAM, RAM protect)' + 'Orion-Pro - v2.9 (RAM f000..ffff at segment 3)' + 'Orion-Pro - v3.10 (RAM f000..ffff at segment 31)' + 'Orion-Pro - v3.20 (v3.10 + Z80 CardII type port 0FBh)') + TabOrder = 2 + end + object gbCPUclk: TGroupBox + Left = 8 + Top = 6 + Width = 233 + Height = 61 + Caption = ' CPU clock (MHz) ' + TabOrder = 0 + object cbCPUclk: TComboBox + Left = 12 + Top = 24 + Width = 208 + Height = 21 + Style = csDropDownList + ItemHeight = 13 + TabOrder = 0 + Items.Strings = ( + '2.5' + '3.5' + '5.0' + '7.0' + '10.0' + '20.0') + end + end + object gbRAMsz: TGroupBox + Left = 264 + Top = 6 + Width = 233 + Height = 61 + Caption = ' RAM size (kb) ' + TabOrder = 1 + object cbMEMsz: TComboBox + Left = 12 + Top = 24 + Width = 208 + Height = 21 + Style = csDropDownList + ItemHeight = 13 + TabOrder = 0 + Items.Strings = ( + '128' + '256' + '512' + '1024' + '2048' + '4096') + end + end + end + object tsKeyboard: TTabSheet + Caption = 'Keyboard' + ImageIndex = 1 + object Label1: TLabel + Left = 8 + Top = 11 + Width = 72 + Height = 13 + Caption = 'KeyPress delay' + end + object Label2: TLabel + Left = 220 + Top = 11 + Width = 91 + Height = 13 + Caption = 'Рус/Lat switch key' + end + object meKeyDelay: TMaskEdit + Left = 96 + Top = 8 + Width = 33 + Height = 21 + Hint = 'Value in range 0..99' + EditMask = '!99;1; ' + MaxLength = 2 + ParentShowHint = False + ShowHint = True + TabOrder = 0 + Text = ' ' + end + object rgKeyboardType: TRadioGroup + Left = 8 + Top = 71 + Width = 489 + Height = 96 + Caption = ' Keyboard type (depend on ROM BIOS type) ' + ItemIndex = 0 + Items.Strings = ( + 'Radio RK-86 (standard)' + 'MS7007 over RK-86 (Sp-Computer_club=Leningrad scheme)' + 'MS7007 non RK-86 (Orion-Soft=Moscow scheme)') + TabOrder = 3 + end + object cbRusLat: TComboBox + Left = 328 + Top = 8 + Width = 83 + Height = 21 + Style = csDropDownList + ItemHeight = 0 + TabOrder = 1 + end + object cbKeyExtender: TCheckBox + Left = 8 + Top = 40 + Width = 401 + Height = 17 + Caption = + 'Use key extender (extended ctrl+key combination for Pascal-alike' + + ' text editors)' + TabOrder = 2 + end + end + object tsROM: TTabSheet + Caption = 'ROM' + ImageIndex = 2 + object gbOrion128: TGroupBox + Left = 2 + Top = 6 + Width = 499 + Height = 123 + Caption = ' Orion-128' + TabOrder = 4 + object cbPFE: TCheckBox + Left = 9 + Top = 93 + Width = 481 + Height = 17 + Caption = + 'Emulate ROM-disk 64к-pages switched by 0FEh port bits D0..D3 (al' + + 'lows ROM-disk size over 64k)' + TabOrder = 0 + end + end + object edtRomBios: TEdit + Left = 149 + Top = 34 + Width = 344 + Height = 24 + TabOrder = 1 + end + object btnRomBios: TButton + Left = 11 + Top = 32 + Width = 129 + Height = 25 + Caption = 'F800 ROM-BIOS file' + TabOrder = 0 + OnClick = btnRomBiosClick + end + object btnRomDisk: TButton + Tag = 1 + Left = 11 + Top = 64 + Width = 129 + Height = 25 + Caption = '8255 ROM-disk file' + TabOrder = 2 + OnClick = btnRomBiosClick + end + object edtRomDisk: TEdit + Left = 148 + Top = 66 + Width = 344 + Height = 24 + TabOrder = 3 + end + object gbOrionPro: TGroupBox + Left = 2 + Top = 136 + Width = 499 + Height = 157 + Caption = ' Orion-Pro' + TabOrder = 9 + TabStop = True + object Label5: TLabel + Tag = 3 + Left = 38 + Top = 94 + Width = 82 + Height = 13 + Caption = 'DIP - Switches ->' + end + object Label9: TLabel + Left = 200 + Top = 110 + Width = 30 + Height = 13 + Caption = 'page2' + end + object Label10: TLabel + Left = 221 + Top = 124 + Width = 20 + Height = 13 + Caption = 'term' + end + object Label11: TLabel + Left = 239 + Top = 137 + Width = 26 + Height = 13 + Caption = 'menu' + end + object Label12: TLabel + Left = 256 + Top = 110 + Width = 32 + Height = 13 + Caption = 'romOS' + end + object Label13: TLabel + Left = 277 + Top = 124 + Width = 49 + Height = 13 + Caption = 'modePRO' + end + object Label6: TLabel + Left = 144 + Top = 109 + Width = 15 + Height = 13 + Caption = 'fdd' + end + object Label7: TLabel + Left = 165 + Top = 123 + Width = 18 + Height = 13 + Caption = 'hdd' + end + object Label8: TLabel + Left = 183 + Top = 137 + Width = 36 + Height = 13 + Caption = 'kb7007' + end + object SpeedButton1: TSpeedButton + Left = 336 + Top = 120 + Width = 23 + Height = 22 + Glyph.Data = { + 36040000424D3604000000000000360000002800000010000000100000000100 + 2000000000000004000000000000000000000000000000000000FF00FF00FF00 + FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 + FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 + FF00FF00FF00FF00FF00FF00FF00FFFFFF007F7F7F000000FF007F7F7F00FFFF + FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 + FF00FF00FF0000FFFF00FFFFFF0000FFFF000000FF000000FF000000FF0000FF + FF00FFFFFF0000FFFF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 + FF0000FFFF00FFFFFF0000FFFF00FFFFFF007F7F7F000000FF007F7F7F00FFFF + FF0000FFFF00FFFFFF0000FFFF00FF00FF00FF00FF00FF00FF00FF00FF0000FF + FF00FFFFFF0000FFFF00FFFFFF0000FFFF00FFFFFF0000FFFF00FFFFFF0000FF + FF00FFFFFF0000FFFF00FFFFFF0000FFFF00FF00FF00FF00FF00FF00FF00FFFF + FF0000FFFF00FFFFFF0000FFFF00FFFFFF0000FFFF000000FF0000FFFF00FFFF + FF0000FFFF00FFFFFF0000FFFF00FFFFFF00FF00FF00FF00FF00FFFFFF0000FF + FF00FFFFFF0000FFFF00FFFFFF0000FFFF00FFFFFF000000FF007F7F7F0000FF + FF00FFFFFF0000FFFF00FFFFFF0000FFFF00FFFFFF00FF00FF0000FFFF00FFFF + FF0000FFFF00FFFFFF0000FFFF00FFFFFF0000FFFF000000FF000000FF00FFFF + FF0000FFFF00FFFFFF0000FFFF00FFFFFF0000FFFF00FF00FF00FFFFFF0000FF + FF00FFFFFF0000FFFF00FFFFFF0000FFFF00FFFFFF0000FFFF000000FF000000 + FF00FFFFFF0000FFFF00FFFFFF0000FFFF00FFFFFF00FF00FF0000FFFF00FFFF + FF0000FFFF00FFFFFF007F7F7F007F7F7F0000FFFF00FFFFFF007F7F7F000000 + FF000000FF00FFFFFF0000FFFF00FFFFFF0000FFFF00FF00FF00FFFFFF0000FF + FF00FFFFFF0000FFFF000000FF000000FF00FFFFFF0000FFFF007F7F7F000000 + FF000000FF0000FFFF00FFFFFF0000FFFF00FFFFFF00FF00FF00FF00FF00FFFF + FF0000FFFF00FFFFFF000000FF000000FF007F7F7F00FFFFFF007F7F7F000000 + FF000000FF00FFFFFF0000FFFF00FFFFFF00FF00FF00FF00FF00FF00FF0000FF + FF00FFFFFF0000FFFF00FFFFFF000000FF000000FF000000FF000000FF000000 + FF00FFFFFF0000FFFF00FFFFFF0000FFFF00FF00FF00FF00FF00FF00FF00FF00 + FF0000FFFF00FFFFFF0000FFFF00FFFFFF000000FF000000FF000000FF00FFFF + FF0000FFFF00FFFFFF0000FFFF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 + FF00FF00FF0000FFFF00FFFFFF0000FFFF00FFFFFF0000FFFF00FFFFFF0000FF + FF00FFFFFF0000FFFF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00 + FF00FF00FF00FF00FF00FF00FF00FFFFFF0000FFFF00FFFFFF0000FFFF00FFFF + FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00} + OnClick = SpeedButton1Click + end + object cbSW0: TCheckBox + Left = 145 + Top = 92 + Width = 17 + Height = 17 + TabOrder = 0 + end + object cbSW1: TCheckBox + Left = 163 + Top = 92 + Width = 17 + Height = 17 + TabOrder = 1 + end + object cbSW2: TCheckBox + Left = 181 + Top = 92 + Width = 17 + Height = 17 + TabOrder = 2 + end + object cbSW3: TCheckBox + Left = 199 + Top = 92 + Width = 17 + Height = 17 + TabOrder = 3 + end + object cbSW4: TCheckBox + Left = 218 + Top = 92 + Width = 17 + Height = 17 + TabOrder = 4 + end + object cbSW5: TCheckBox + Left = 237 + Top = 92 + Width = 17 + Height = 17 + TabOrder = 5 + end + object cbSW6: TCheckBox + Left = 255 + Top = 92 + Width = 17 + Height = 17 + TabOrder = 6 + end + object cbSW7: TCheckBox + Left = 273 + Top = 92 + Width = 17 + Height = 17 + TabOrder = 7 + end + end + object BtnRom1BIOS: TButton + Tag = 2 + Left = 14 + Top = 162 + Width = 129 + Height = 25 + Caption = 'Rom1-BIOS file' + TabOrder = 5 + OnClick = btnRomBiosClick + end + object EdtRom1Bios: TEdit + Left = 152 + Top = 164 + Width = 342 + Height = 24 + Hint = 'Initial BIOS and base drivers' + TabOrder = 6 + end + object BtnRom2BIOS: TButton + Tag = 3 + Left = 14 + Top = 194 + Width = 129 + Height = 25 + Caption = 'Rom2-BIOS file' + TabOrder = 7 + OnClick = btnRomBiosClick + end + object EdtRom2Bios: TEdit + Left = 151 + Top = 196 + Width = 342 + Height = 24 + Hint = 'Extended BIOS and drivers, OS, user programms' + TabOrder = 8 + end + end + object tsAY8912: TTabSheet + Caption = 'Sound, RTC' + ImageIndex = 3 + object gbSound: TGroupBox + Left = 8 + Top = 8 + Width = 489 + Height = 81 + Caption = ' Sound ' + TabOrder = 3 + end + object cbSoundEnabled: TCheckBox + Left = 16 + Top = 32 + Width = 369 + Height = 17 + Hint = 'Enable all sounds' + Caption = 'Sound Enabled' + ParentShowHint = False + ShowHint = True + TabOrder = 0 + OnClick = cbSoundEnabledClick + end + object cbAYEnabled: TCheckBox + Left = 16 + Top = 56 + Width = 369 + Height = 17 + Hint = 'Enable AY-8912 sound' + Caption = 'AY-8912 Enabled' + ParentShowHint = False + ShowHint = True + TabOrder = 1 + end + object rgRTC: TRadioGroup + Left = 8 + Top = 112 + Width = 489 + Height = 129 + Caption = ' RTC ' + ItemIndex = 0 + Items.Strings = ( + 'none' + '512 VI1 / MC146818 (port F760h..F761h)' + '512 VI1 / MC146818 (port 50h..51h - Orion-Pro)' + 'DS1307 (port F402h)') + TabOrder = 2 + end + end + object TSFdd: TTabSheet + Caption = 'FDD' + ImageIndex = 4 + object Label3: TLabel + Left = 8 + Top = 12 + Width = 76 + Height = 13 + Caption = 'Recent files limit' + end + object meRecentLimit: TMaskEdit + Left = 109 + Top = 8 + Width = 33 + Height = 21 + Hint = 'Value in range 0..99' + EditMask = '!99;1; ' + MaxLength = 2 + ParentShowHint = False + ShowHint = True + TabOrder = 0 + Text = ' ' + end + object cbRestoreODI: TCheckBox + Left = 8 + Top = 56 + Width = 409 + Height = 17 + Caption = 'Restore current ODI files in virtual FD-drives at next startup' + TabOrder = 1 + end + object cbHighDensity: TCheckBox + Left = 8 + Top = 80 + Width = 401 + Height = 17 + Hint = + 'Emulate High Density floppy formats (6,7,8,9,10 1k-sectors per ' + + 'track)' + Caption = 'Emulate High Density floppy formats' + ParentShowHint = False + ShowHint = True + TabOrder = 2 + end + end + object TSIde: TTabSheet + Caption = 'IDE, SD' + ImageIndex = 6 + object IdePort: TLabel + Left = 274 + Top = 42 + Width = 40 + Height = 13 + Caption = 'IDE Port' + end + object Label14: TLabel + Left = 8 + Top = 34 + Width = 137 + Height = 13 + Caption = 'HDD Device "0" (8255 PPA)' + end + object Label15: TLabel + Left = 8 + Top = 98 + Width = 137 + Height = 13 + Caption = 'HDD Device "1" (8255 PPA)' + end + object Label16: TLabel + Left = 48 + Top = 274 + Width = 80 + Height = 13 + Caption = 'HDD Device "4"' + end + object Bevel1: TBevel + Left = 0 + Top = 236 + Width = 504 + Height = 3 + end + object lblScheme: TLabel + Left = 274 + Top = 279 + Width = 39 + Height = 13 + Caption = 'Scheme' + end + object Label30: TLabel + Left = 8 + Top = 161 + Width = 158 + Height = 13 + Caption = 'HDD Device "2" (IDE-RTC PRO)' + end + object Bevel2: TBevel + Left = 0 + Top = 121 + Width = 504 + Height = 3 + end + object Label31: TLabel + Left = 8 + Top = 211 + Width = 158 + Height = 13 + Caption = 'HDD Device "3" (IDE-RTC PRO)' + end + object BtnHDDMaster: TButton + Left = 8 + Top = 5 + Width = 153 + Height = 25 + Caption = 'IDE Master image file' + TabOrder = 0 + OnClick = BtnHDDMasterClick + end + object BtnHDDSlave: TButton + Left = 8 + Top = 69 + Width = 153 + Height = 25 + Caption = 'IDE Slave image file' + TabOrder = 3 + OnClick = BtnHDDSlaveClick + end + object EdtHDDMaster: TEdit + Left = 168 + Top = 7 + Width = 331 + Height = 21 + TabOrder = 1 + end + object EdtHDDSlave: TEdit + Left = 168 + Top = 71 + Width = 330 + Height = 21 + TabOrder = 4 + end + object cbHDDPort: TComboBox + Left = 328 + Top = 39 + Width = 171 + Height = 21 + Style = csDropDownList + ItemHeight = 13 + TabOrder = 6 + Items.Strings = ( + 'none (no IDE if selected)' + 'F500 (no RomDisk if selected)' + 'F600 (no Printer if selected)') + end + object cbMasterRO: TCheckBox + Left = 168 + Top = 32 + Width = 97 + Height = 17 + Caption = 'ReadOnly' + TabOrder = 2 + end + object cbSlaveRO: TCheckBox + Left = 168 + Top = 96 + Width = 97 + Height = 17 + Caption = 'ReadOnly' + TabOrder = 5 + end + object BtnSDCard: TButton + Left = 8 + Top = 245 + Width = 153 + Height = 26 + Caption = 'SD-card Device image file' + TabOrder = 7 + OnClick = BtnSDCardClick + end + object EdtSDcard: TEdit + Left = 167 + Top = 247 + Width = 331 + Height = 21 + TabOrder = 8 + end + object cbSDcardRO: TCheckBox + Left = 168 + Top = 274 + Width = 97 + Height = 18 + Caption = 'ReadOnly' + TabOrder = 9 + end + object cbSDscheme: TComboBox + Left = 321 + Top = 274 + Width = 177 + Height = 21 + ItemHeight = 13 + TabOrder = 10 + Items.Strings = ( + 'N8VEM Juha SD (port F762)' + 'MSX SD-MMC V1 (F762,F763)') + end + object BtnProMaster: TButton + Left = 9 + Top = 133 + Width = 153 + Height = 25 + Caption = 'IDE Master image file' + TabOrder = 11 + OnClick = BtnProMasterClick + end + object BtnProSlave: TButton + Left = 9 + Top = 182 + Width = 153 + Height = 25 + Caption = 'IDE Slave image file' + TabOrder = 12 + OnClick = BtnProSlaveClick + end + object EdtProSlave: TEdit + Left = 169 + Top = 184 + Width = 330 + Height = 21 + TabOrder = 13 + end + object EdtProMaster: TEdit + Left = 169 + Top = 135 + Width = 331 + Height = 21 + TabOrder = 14 + end + object cbProMasterRO: TCheckBox + Left = 169 + Top = 159 + Width = 97 + Height = 17 + Caption = 'ReadOnly' + TabOrder = 15 + end + object cbProSlaveRO: TCheckBox + Left = 169 + Top = 209 + Width = 97 + Height = 17 + Caption = 'ReadOnly' + TabOrder = 16 + end + end + object tsF600: TTabSheet + Caption = 'Port F600' + ImageIndex = 6 + object Label4: TLabel + Left = 8 + Top = 11 + Width = 128 + Height = 13 + Caption = 'Port F600 emulation plugin:' + end + object cbxF600plugin: TComboBox + Left = 176 + Top = 8 + Width = 321 + Height = 21 + Style = csDropDownList + ItemHeight = 0 + TabOrder = 0 + end + object btnF600pluginCfg: TButton + Left = 176 + Top = 40 + Width = 321 + Height = 25 + Caption = 'Configure selected plugin' + TabOrder = 1 + OnClick = btnF600pluginCfgClick + end + end + object tsRS232: TTabSheet + Caption = 'RS-232' + ImageIndex = 7 + object Label17: TLabel + Left = 8 + Top = 64 + Width = 51 + Height = 13 + Alignment = taRightJustify + Caption = 'Port name:' + FocusControl = PortComboBox + end + object Label18: TLabel + Left = 10 + Top = 132 + Width = 49 + Height = 13 + Alignment = taRightJustify + Caption = 'Baud rate:' + FocusControl = BaudRateComboBox + end + object Label19: TLabel + Left = 14 + Top = 160 + Width = 45 + Height = 13 + Alignment = taRightJustify + Caption = 'Data bits:' + FocusControl = DataBitsComboBox + end + object Label20: TLabel + Left = 30 + Top = 188 + Width = 29 + Height = 13 + Alignment = taRightJustify + Caption = 'Parity:' + FocusControl = ParityComboBox + end + object Label21: TLabel + Left = 15 + Top = 216 + Width = 44 + Height = 13 + Alignment = taRightJustify + Caption = 'Stop bits:' + FocusControl = StopBitsComboBox + end + object Label22: TLabel + Left = 262 + Top = 132 + Width = 71 + Height = 13 + Alignment = taRightJustify + Caption = 'Hardware flow:' + FocusControl = HwFlowComboBox + end + object Label23: TLabel + Left = 266 + Top = 160 + Width = 67 + Height = 13 + Alignment = taRightJustify + Caption = 'Software flow:' + FocusControl = SwFlowComboBox + end + object Label24: TLabel + Left = 272 + Top = 188 + Width = 61 + Height = 13 + Alignment = taRightJustify + Caption = 'DTR control:' + FocusControl = DTRControlComboBox + end + object Label25: TLabel + Left = 32 + Top = 104 + Width = 217 + Height = 13 + Caption = 'UART properties (programmed via F765 port) :' + end + object PortComboBox: TComboBox + Left = 64 + Top = 60 + Width = 114 + Height = 21 + ItemHeight = 13 + TabOrder = 1 + Items.Strings = ( + '\\.\COM1' + '\\.\COM2' + '\\.\COM3' + '\\.\COM4' + '\\.\COM5' + '\\.\COM6' + '\\.\COM7' + '\\.\COM8' + '\\.\COM9' + '\\.\COM10' + '\\.\COM11' + '\\.\COM12' + '\\.\COM13' + '\\.\COM14' + '\\.\COM15' + '\\.\COM16') + end + object BaudRateComboBox: TComboBox + Left = 64 + Top = 128 + Width = 114 + Height = 21 + Enabled = False + ItemHeight = 13 + TabOrder = 2 + Items.Strings = ( + '110' + '300' + '600' + '1200' + '2400' + '4800' + '9600' + '14400' + '19200' + '38400' + '56000' + '57600' + '115200' + '128000' + '230400' + '256000' + '460800' + '921600') + end + object DataBitsComboBox: TComboBox + Left = 64 + Top = 156 + Width = 114 + Height = 21 + Style = csDropDownList + Enabled = False + ItemHeight = 13 + TabOrder = 3 + Items.Strings = ( + '5' + '6' + '7' + '8') + end + object ParityComboBox: TComboBox + Left = 64 + Top = 184 + Width = 114 + Height = 21 + Style = csDropDownList + Enabled = False + ItemHeight = 13 + TabOrder = 4 + Items.Strings = ( + 'None' + 'Odd' + 'Even' + 'Mark' + 'Space') + end + object StopBitsComboBox: TComboBox + Left = 64 + Top = 212 + Width = 114 + Height = 21 + Style = csDropDownList + Enabled = False + ItemHeight = 13 + TabOrder = 5 + Items.Strings = ( + '1' + '1.5' + '2') + end + object HwFlowComboBox: TComboBox + Left = 338 + Top = 128 + Width = 114 + Height = 21 + Style = csDropDownList + Enabled = False + ItemHeight = 13 + TabOrder = 6 + Items.Strings = ( + 'None' + 'None but RTS on' + 'RTS/CTS') + end + object SwFlowComboBox: TComboBox + Left = 338 + Top = 156 + Width = 114 + Height = 21 + Style = csDropDownList + Enabled = False + ItemHeight = 13 + TabOrder = 7 + Items.Strings = ( + 'None' + 'XON/XOFF') + end + object DTRControlComboBox: TComboBox + Left = 338 + Top = 184 + Width = 114 + Height = 21 + Style = csDropDownList + Enabled = False + ItemHeight = 13 + TabOrder = 8 + Items.Strings = ( + 'Standard' + 'Keep off') + end + object cbUARTExists: TCheckBox + Left = 16 + Top = 16 + Width = 377 + Height = 17 + Caption = 'UART Exists (emulate RS-232 on ports F764,F765)' + TabOrder = 0 + end + end + object TabSheet1: TTabSheet + Caption = 'Ethernet' + ImageIndex = 8 + object Label26: TLabel + Left = 16 + Top = 16 + Width = 98 + Height = 16 + Caption = 'MAC address:' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -15 + Font.Name = 'MS Sans Serif' + Font.Style = [fsBold] + ParentFont = False + end + object Label27: TLabel + Left = 16 + Top = 48 + Width = 114 + Height = 16 + Caption = 'TAP connection:' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -15 + Font.Name = 'MS Sans Serif' + Font.Style = [fsBold] + ParentFont = False + end + object lblMAC: TLabel + Left = 147 + Top = 16 + Width = 5 + Height = 16 + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -15 + Font.Name = 'MS Sans Serif' + Font.Style = [fsBold] + ParentFont = False + end + object rgEthChip: TRadioGroup + Left = 13 + Top = 89 + Width = 482 + Height = 78 + Caption = ' Ethernet chip ' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -15 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ItemIndex = 0 + Items.Strings = ( + 'none' + + 'RTL8019AS (reset: 0FD->F770, registers: F770..F77F, data: F780..' + + 'F7FF)') + ParentFont = False + TabOrder = 1 + end + object cbTAPConnection: TComboBox + Left = 146 + Top = 46 + Width = 346 + Height = 24 + Hint = 'Select or type TAP connection name' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -15 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ItemHeight = 0 + ParentFont = False + ParentShowHint = False + ShowHint = True + TabOrder = 0 + end + end + end + object Panel1: TPanel + Left = 0 + Top = 328 + Width = 514 + Height = 36 + Align = alBottom + TabOrder = 1 + object BtnOk: TButton + Left = 61 + Top = 5 + Width = 97 + Height = 25 + Caption = 'OK' + Default = True + TabOrder = 0 + OnClick = BtnOkClick + end + object BtnCancel: TButton + Left = 358 + Top = 5 + Width = 93 + Height = 25 + Cancel = True + Caption = 'Cancel' + ModalResult = 2 + TabOrder = 1 + end + end +end diff --git a/settswin.pas b/settswin.pas new file mode 100644 index 0000000..fcb5ead --- /dev/null +++ b/settswin.pas @@ -0,0 +1,583 @@ +///////////////////////////////////////////////////////////////////////// +// // +// Orion/Z (Orion-128 + Z80-CARD-II) emulator, version 1.9 // +// // +// Author: Sergey A. // +// // +// Copyright (C) 2006-2016 Sergey A. // +// // +// This program is free software; you can redistribute it and/or // +// modify it in any ways. // +// This program is distributed "AS IS" 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 settswin; + +interface + + +{$I 'OrionZEm.inc'} + + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, ExtCtrls, ComCtrls, Mask, Buttons; + +type + TfrmSetts = class(TForm) + PageControl1: TPageControl; + tsCPU: TTabSheet; + tsKeyboard: TTabSheet; + Panel1: TPanel; + BtnOk: TButton; + BtnCancel: TButton; + rgZ80Card: TRadioGroup; + Label1: TLabel; + meKeyDelay: TMaskEdit; + rgKeyboardType: TRadioGroup; + tsROM: TTabSheet; + edtRomBios: TEdit; + btnRomBios: TButton; + btnRomDisk: TButton; + edtRomDisk: TEdit; + tsAY8912: TTabSheet; + cbSoundEnabled: TCheckBox; + Label2: TLabel; + cbRusLat: TComboBox; + TSFdd: TTabSheet; + Label3: TLabel; + meRecentLimit: TMaskEdit; + cbRestoreODI: TCheckBox; + cbAYEnabled: TCheckBox; + cbHighDensity: TCheckBox; + TSIde: TTabSheet; + BtnHDDMaster: TButton; + BtnHDDSlave: TButton; + EdtHDDMaster: TEdit; + EdtHDDSlave: TEdit; + IdePort: TLabel; + cbHDDPort: TComboBox; + cbMasterRO: TCheckBox; + cbSlaveRO: TCheckBox; + cbKeyExtender: TCheckBox; + tsF600: TTabSheet; + Label4: TLabel; + cbxF600plugin: TComboBox; + btnF600pluginCfg: TButton; + gbOrion128: TGroupBox; + gbOrionPro: TGroupBox; + BtnRom1BIOS: TButton; + EdtRom1Bios: TEdit; + BtnRom2BIOS: TButton; + EdtRom2Bios: TEdit; + cbSW0: TCheckBox; + cbSW1: TCheckBox; + cbSW2: TCheckBox; + cbSW3: TCheckBox; + cbSW4: TCheckBox; + cbSW5: TCheckBox; + cbSW6: TCheckBox; + cbSW7: TCheckBox; + Label5: TLabel; + Label9: TLabel; + Label10: TLabel; + Label11: TLabel; + Label12: TLabel; + Label13: TLabel; + Label6: TLabel; + Label7: TLabel; + Label8: TLabel; + SpeedButton1: TSpeedButton; + BtnSDCard: TButton; + EdtSDcard: TEdit; + cbSDcardRO: TCheckBox; + Label14: TLabel; + Label15: TLabel; + Label16: TLabel; + Bevel1: TBevel; + tsRS232: TTabSheet; + PortComboBox: TComboBox; + Label17: TLabel; + Label18: TLabel; + BaudRateComboBox: TComboBox; + Label19: TLabel; + DataBitsComboBox: TComboBox; + Label20: TLabel; + ParityComboBox: TComboBox; + Label21: TLabel; + StopBitsComboBox: TComboBox; + Label22: TLabel; + HwFlowComboBox: TComboBox; + Label23: TLabel; + SwFlowComboBox: TComboBox; + Label24: TLabel; + DTRControlComboBox: TComboBox; + cbUARTExists: TCheckBox; + Label25: TLabel; + TabSheet1: TTabSheet; + rgEthChip: TRadioGroup; + Label26: TLabel; + Label27: TLabel; + cbTAPConnection: TComboBox; + lblMAC: TLabel; + cbPFE: TCheckBox; + rgRTC: TRadioGroup; + gbSound: TGroupBox; + gbCPUclk: TGroupBox; + cbCPUclk: TComboBox; + gbRAMsz: TGroupBox; + cbMEMsz: TComboBox; + cbSDscheme: TComboBox; + lblScheme: TLabel; + Label28: TLabel; + Label29: TLabel; + Label30: TLabel; + Bevel2: TBevel; + Label31: TLabel; + BtnProMaster: TButton; + BtnProSlave: TButton; + EdtProSlave: TEdit; + EdtProMaster: TEdit; + cbProMasterRO: TCheckBox; + cbProSlaveRO: TCheckBox; + procedure FormActivate(Sender: TObject); + procedure BtnOkClick(Sender: TObject); + procedure btnRomBiosClick(Sender: TObject); + procedure cbSoundEnabledClick(Sender: TObject); + procedure BtnHDDMasterClick(Sender: TObject); + procedure BtnHDDSlaveClick(Sender: TObject); + procedure btnF600pluginCfgClick(Sender: TObject); + procedure SpeedButton1Click(Sender: TObject); + procedure BtnSDCardClick(Sender: TObject); + procedure BtnProMasterClick(Sender: TObject); + procedure BtnProSlaveClick(Sender: TObject); + private + procedure FreePluginList(PluginList: TStrings); + procedure GetPluginList(DllDir: string; PluginList: TStrings); + end; + +var + frmSetts: TfrmSetts = nil; + +implementation + +Uses modOrion, mod8255, modHDD, modSD, mod1793, modF600, mod232, CPDrv, mainwin, EthThrd, mod8019as; + +{$R *.DFM} + +procedure TfrmSetts.FormActivate(Sender: TObject); +var i, idx: integer; + st: string; +begin + OnActivate:=nil; + cbCPUclk.ItemIndex:=CPUSpeedMode; + cbMEMsz.ItemIndex:=MEMSizeMode; + rgZ80Card.ItemIndex:=Z80CardMode; + cbPFE.Checked:=PFEEnabled; + cbSoundEnabled.Checked:=SoundEnabled; + cbAYenabled.Checked:=AyEnabled; + cbAYEnabled.Enabled:=cbSoundEnabled.Checked; + rgRTC.ItemIndex:=RTCmode; + meKeyDelay.Text:=IntToStr(KeyDelay); + for i:=0 to MaxRusLat do + cbRusLat.Items.AddObject(KeyRusLatArr[i].name, pointer(KeyRusLatArr[i].code)); + cbRusLat.ItemIndex:=cbRusLat.Items.IndexOfObject(pointer(KeyRusLat)); + if cbRusLat.ItemIndex=-1 then cbRusLat.ItemIndex:=0; + edtRomBios.Text:=trim(ROMBIOSfile); + edtRomDisk.Text:=trim(ROMDISKfile); + edtRom1Bios.Text:=trim(ROM1BIOSfile); + edtRom2Bios.Text:=trim(ROM2BIOSfile); + meRecentLimit.Text:=IntToStr(FMaxRecent); + cbRestoreODI.Checked:=FRestoreODI; + cbHDDPort.ItemIndex:=HDDPort; + with IdeController do begin + EdtHDDMaster.Text:=ImageFile[HddDeviceMaster]; + EdtHDDSlave.Text:=ImageFile[HddDeviceSlave]; + cbMasterRO.Checked:=ImageRO[HddDeviceMaster]; + cbSlaveRO.Checked:=ImageRO[HddDeviceSlave]; + end; + with IdeProController do begin + EdtProMaster.Text:=ImageFile[HddDeviceMaster]; + EdtProSlave.Text:=ImageFile[HddDeviceSlave]; + cbProMasterRO.Checked:=ImageRO[HddDeviceMaster]; + cbProSlaveRO.Checked:=ImageRO[HddDeviceSlave]; + end; + with SDController do begin + EdtSDCard.Text:=ImageFile; + cbSDcardRO.Checked:=ImageRO; + SDScheme:=SDController.Scheme; + cbSDScheme.ItemIndex:=SDScheme; + end; + rgKeyboardType.ItemIndex:=KeybType and 3; + cbKeyExtender.Checked:=KeyExtender; + cbHighDensity.Checked:=FddHd; +{Port F600} + GetPluginList(ExtractFilePath(System.ParamStr(0)), cbxF600plugin.Items); + i:=0; + st:=PortF600.Plugin; + idx:=PortF600.FuncIdx; // function index + with cbxF600plugin.Items do + while (((Objects[i] as TStringList).Strings[0]<>st) or + (integer(pointer((Objects[i] as TStringList).Objects[0]))<>idx)) and + (i=Z80_ORIONPRO_v2) and (Z80CardMode=Z80_ORIONPRO_v2)) or + (cbMEMsz.ItemIndexcbMEMsz.ItemIndex then + begin + MEMSizeMode:=cbMEMsz.ItemIndex; + if not ResetFlag then begin + ii:=LongAddressParse(FrmMain.MEDumpAddr.Text, pg, adr); + FrmMain.MEDumpAddr.EditMask:=SetMemSize; + ii:=pos(':',FrmMain.MEDumpAddr.EditMask)-1; + FrmMain.MEDumpAddr.Text:=padl(IntToHex(pg, 2), ii, '0')+':'+padl(IntToHex(adr, 4), 4, '0'); + end; + end; + SDScheme:=cbSDScheme.ItemIndex; + Z80CardMode:=rgZ80Card.ItemIndex; + PFEEnabled:=cbPFE.Checked; + SoundEnabled:=cbSoundEnabled.Checked; + AyEnabled:=cbAYenabled.Checked; + RTCmode:=rgRTC.ItemIndex; + KeyDelay:=StrToIntDef(trim(meKeyDelay.Text), 0); + KeyRusLat:=integer(pointer(cbRusLat.Items.Objects[cbRusLat.ItemIndex])); + if trim(edtRomBios.Text)<>trim(ROMBIOSfile) then + begin + ROMBIOSfile:=trim(edtRomBios.Text); + frmMain.SetROMBIOS(ROMBIOSfile); + ResetFlag:=True; + end; + if trim(ROMDISKfile)<>trim(edtRomDisk.Text) then + begin + ROMDISKfile:=trim(edtRomDisk.Text); + frmMain.SetROMDisk(ROMDiskfile); + end; + if trim(edtRom1Bios.Text)<>trim(ROM1BIOSfile) then + begin + ROM1BIOSfile:=trim(edtRom1Bios.Text); + frmMain.SetROM1BIOS(ROM1BIOSfile); + ResetFlag:=True; + end; + if trim(edtRom2Bios.Text)<>trim(ROM2BIOSfile) then + begin + ROM2BIOSfile:=trim(edtRom2Bios.Text); + frmMain.SetROM2BIOS(ROM2BIOSfile); + end; + FMaxRecent:=StrToIntDef(trim(meRecentLimit.Text), 0); + FRestoreODI:=cbRestoreODI.Checked; + HDDPort:=cbHDDPort.ItemIndex; + with IdeController do begin + ImageRO[HddDeviceMaster]:=cbMasterRO.Checked; + ImageRO[HddDeviceSlave]:=cbSlaveRO.Checked; + ImageFile[HddDeviceMaster]:=EdtHDDMaster.Text; + ImageFile[HddDeviceSlave]:=EdtHDDSlave.Text; + end; + with IdeProController do begin + ImageRO[HddDeviceMaster]:=cbProMasterRO.Checked; + ImageRO[HddDeviceSlave]:=cbProSlaveRO.Checked; + ImageFile[HddDeviceMaster]:=EdtProMaster.Text; + ImageFile[HddDeviceSlave]:=EdtProSlave.Text; + end; + with SDController do begin + ImageRO:=cbSDcardRO.Checked; + ImageFile:=EdtSDcard.Text; + SDScheme:=cbSDScheme.ItemIndex; + SDController.Scheme:=SDScheme; + end; + KeybType:=rgKeyboardType.ItemIndex; + PortF400.KbdType:=TKbdType(KeybType and 3); + KeyExtender:=cbKeyExtender.Checked; + FddHd:=cbHighDensity.Checked; + with cbxF600plugin.Items.Objects[cbxF600plugin.ItemIndex] as TStringList do + begin + PortF600.Plugin:=Strings[0]; + PortF600.FuncIdx:=integer(pointer(Objects[0])); + end; + OrionPRO_DIP_SW:=255; + if cbSW0.Checked then OrionPRO_DIP_SW:=OrionPRO_DIP_SW - 1; + if cbSW1.Checked then OrionPRO_DIP_SW:=OrionPRO_DIP_SW - 2; + if cbSW2.Checked then OrionPRO_DIP_SW:=OrionPRO_DIP_SW - 4; + if cbSW3.Checked then OrionPRO_DIP_SW:=OrionPRO_DIP_SW - 8; + if cbSW4.Checked then OrionPRO_DIP_SW:=OrionPRO_DIP_SW - 16; + if cbSW5.Checked then OrionPRO_DIP_SW:=OrionPRO_DIP_SW - 32; + if cbSW6.Checked then OrionPRO_DIP_SW:=OrionPRO_DIP_SW - 64; + if cbSW7.Checked then OrionPRO_DIP_SW:=OrionPRO_DIP_SW -128; + if cbSW7.Checked<>(OrionPRO_DIP_SW and 128 = 0) then + ResetFlag:=True; + FreePluginList(cbxF600plugin.Items); +{RS232} + if (FUART.PortName <> trim(PortComboBox.Text)) or + (FUART.Exists <> cbUARTExists.Checked) then + begin + FUART.Exists:=cbUARTExists.Checked; + FUART.PortName := trim(PortComboBox.Text); + FUART.CPDrv.Connect; + end; +{Ethernet} + st:=trim(cbTAPConnection.Text); + ResetFlag:=ResetFlag or (rgEthChip.ItemIndex<>EthMode) or + ((trim(EthConnName)<>st) and (st<>'')); + ii:=cbTAPConnection.Items.IndexOf(st); + if (rgEthChip.ItemIndex>0) and (cbTAPConnection.Items.Count>0) and (ii=-1) then + raise Exception.CreateFmt('Wrong TAP connection name: `%s`', [st]); + if st<>'' then + begin + EthConnName:=st; + EthConnGUID:=GUIDList.Strings[ii]; + end; + if (rgEthChip.ItemIndex<>EthMode) then + begin + case EthMode of + 1: begin + (FNE2kDevice as T8019AS).Free; + FNE2kDevice:=nil; + end; + end; + EthMode:=rgEthChip.ItemIndex; + frmMain.InitEthernet; + end; +{} + finally + frmSetts.Cursor:=crDefault; + frmSetts.Enabled:=true; + frmSetts.Update; + ModalResult:=MrOK; + if ResetFlag then frmMain.ActResetExecute(self); + end; +end; + +procedure TfrmSetts.btnRomBiosClick(Sender: TObject); +begin + with frmMain.OpenDialog do + begin + Title:='Select binary file with F800 ROMBIOS'; + DefaultExt:='BIN'; + Filter:='Orion ROM files (*.bin;*.rom)|*.bin;*.rom|Any file (*.*)|*.*'; + FilterIndex:=1; + if Execute then + case (Sender as TButton).Tag of + 0: EdtRomBios.Text:=FileName; + 1: EdtRomDisk.Text:=FileName; + 2: EdtRom1Bios.Text:=FileName; + 3: EdtRom2Bios.Text:=FileName; + end; + end; +end; + +procedure TfrmSetts.cbSoundEnabledClick(Sender: TObject); +begin + cbAYEnabled.Enabled:=cbSoundEnabled.Checked; +end; + +procedure TfrmSetts.BtnHDDMasterClick(Sender: TObject); +begin + with frmMain.OpenDialog do + begin + Title:='Select binary file with Master HDD image'; + DefaultExt:='OHI'; + Filter:='Orion OHI files (*.ohi;*.img)|*.ohi;*.img|Any file (*.*)|*.*'; + FilterIndex:=1; + if Execute then + EdtHDDMaster.Text:=FileName; + end; +end; + +procedure TfrmSetts.BtnHDDSlaveClick(Sender: TObject); +begin + with frmMain.OpenDialog do + begin + Title:='Select binary file with Slave HDD image'; + DefaultExt:='OHI'; + Filter:='Orion OHI files (*.ohi;*.img)|*.ohi;*.img|Any file (*.*)|*.*'; + FilterIndex:=1; + if Execute then + EdtHDDSlave.Text:=FileName; + end; +end; + +procedure TfrmSetts.FreePluginList(PluginList: TStrings); +var i:integer; +begin + for i:=0 to PluginList.Count-1 do + if Assigned(PluginList.Objects[i]) then + (PluginList.Objects[i] as TStringList).Free; + PluginList.Clear; +end; + +procedure TfrmSetts.GetPluginList(DllDir: string; PluginList: TStrings); +var file_rec:TSearchRec; + dll: HMODULE; + adr: TF600Function; + PCh: pointer; + ss, st1, st2: String; + i, j: integer; +begin + DllDir:=AddSlash(trim(DllDir)); + FreePluginList(PluginList); + i:=PluginList.AddObject('', TObject(TStringList.Create)); // FunctionTitle + (PluginList.Objects[i] as TStringList).AddObject('', pointer(-1)); + if (FindFirst(DllDir+'*.DLL',$27,file_rec)=0) then + repeat + dll:=LoadLibrary(PChar(DllDir+file_rec.name)); + if dll<>0 then + begin + adr:=GetProcAddress(dll,PChar(F600FuncName)); + if Assigned(adr) then + begin + PCh:=nil; + j:=adr(0, F600Func_Enumerate, PCh); + if Assigned(PCh) and (j>0) then with PluginList do begin + ss:=StrPas(PCh); + repeat + st1:=LeftSubstr(ss); // function Title + st2:=LeftSubstr(ss); // function index + if (st1<>'') and (st2<>'') then + begin + i:=AddObject(st1, TObject(TStringList.Create)); // FunctionTitle + (Objects[i] as TStringList).AddObject(AnsiUpperCase(DllDir+file_rec.name), // PluginFile + pointer(StrToIntDef(st2, 0))); // FunctionIndex + end; + dec(j); + until (ss='') or (j=0); + end; + end; + FreeLibrary(dll); + end; + until FindNext(file_rec)<>0; + FindClose(file_rec); +end; + +procedure TfrmSetts.btnF600pluginCfgClick(Sender: TObject); +var ss: string; + ii: integer; +begin + ss:=PortF600.Plugin; + ii:=PortF600.FuncIdx; + with cbxF600plugin.Items.Objects[cbxF600plugin.ItemIndex] as TStringList do + begin + PortF600.Plugin:=Strings[0]; + PortF600.FuncIdx:=integer(pointer(Objects[0])); + end; + PortF600.ConfigurePlugin; + PortF600.Plugin:=ss; + PortF600.FuncIdx:=ii; +end; + +procedure TfrmSetts.SpeedButton1Click(Sender: TObject); +begin + Application.MessageBox('После включения компьютера (или нажатия кнопки "Сброс") режимы'#13#10+ + 'работы назначаются с учетом состояния DIP-переключателей SW1-SW8:'#13#10#13#10+ + ' 1 - Наличие дисковода:'#13#10+ + ' On - есть, Off - нет;'#13#10+ + ' 2 - Наличие жесткого диска:'#13#10+ + ' On - есть, Off - нет;'#13#10+ + ' 3 - Тип клавиатуры:'#13#10+ + ' On - MC7007 (основная клавиатура), Off - PK-86;'#13#10+ + ' 4 - Рабочая страница ОЗУ для внутренней CP/M-80 из ROM2:'#13#10+ + ' On - 2, Off - 1;'#13#10+ + ' 5 - Наличие контроллера символьного дисплея:'#13#10+ + ' On - есть, Off - нет;'#13#10+ + ' 6 - Запуск внутреннего Меню после сброса:'#13#10+ + ' On - есть, Off - нет;'#13#10+ + ' 7 - Тип загрузки операционной системы:'#13#10+ + ' On - внутренняя (ПЗУ), Off - внешняя;'#13#10+ + ' 8 - Режим работы:'#13#10+ + ' On - "Pro" (CP/M-80), Off - "Orion-128" (ORDOS)', + 'About Orion-PRO DIP-switcher', MB_OK+MB_ICONINFORMATION); +end; + +procedure TfrmSetts.BtnSDCardClick(Sender: TObject); +begin + with frmMain.OpenDialog do + begin + Title:='Select binary file with SD-card image'; + DefaultExt:='OHI'; + Filter:='Orion OHI files (*.ohi;*.img)|*.ohi;*.img|Any file (*.*)|*.*'; + FilterIndex:=1; + if Execute then + EdtSDcard.Text:=FileName; + end; +end; + +procedure TfrmSetts.BtnProMasterClick(Sender: TObject); +begin + with frmMain.OpenDialog do + begin + Title:='Select binary file with Master HDD image'; + DefaultExt:='OHI'; + Filter:='Orion OHI files (*.ohi;*.img)|*.ohi;*.img|Any file (*.*)|*.*'; + FilterIndex:=1; + if Execute then + EdtProMaster.Text:=FileName; + end; +end; + +procedure TfrmSetts.BtnProSlaveClick(Sender: TObject); +begin + with frmMain.OpenDialog do + begin + Title:='Select binary file with Slave HDD image'; + DefaultExt:='OHI'; + Filter:='Orion OHI files (*.ohi;*.img)|*.ohi;*.img|Any file (*.*)|*.*'; + FilterIndex:=1; + if Execute then + EdtProSlave.Text:=FileName; + end; +end; + +end. diff --git a/uCRC32.pas b/uCRC32.pas new file mode 100644 index 0000000..7ee9a27 --- /dev/null +++ b/uCRC32.pas @@ -0,0 +1,140 @@ +///////////////////////////////////////////////////////////////////////// +// // +// Orion/Z (Orion-128 + Z80-CARD-II) emulator, version 1.9 // +// // +// Author: Sergey A. // +// // +// Copyright (C) 2006-2016 Sergey A. // +// // +// This program is free software; you can redistribute it and/or // +// modify it in any ways. // +// This program is distributed "AS IS" 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 uCRC32; + +interface + +Uses Windows; + +function CRC32Calc(const Buf; CRC: Integer; BufSize: Integer): Integer; +function CRC32(const Buf; CRC: Integer; BufSize: Integer): Integer; + +implementation + +const +{$WARNINGS OFF} + aTableCRC32: array[0..255] of LongInt = ( + {; $} + $00000000, $77073096, $EE0E612C, $990951BA, + $076DC419, $706AF48F, $E963A535, $9E6495A3, + $0EDB8832, $79DCB8A4, $E0D5E91E, $97D2D988, + $09B64C2B, $7EB17CBD, $E7B82D07, $90BF1D91, + {; 1} + $1DB71064, $6AB020F2, $F3B97148, $84BE41DE, + $1ADAD47D, $6DDDE4EB, $F4D4B551, $83D385C7, + $136C9856, $646BA8C0, $FD62F97A, $8A65C9EC, + $14015C4F, $63066CD9, $FA0F3D63, $8D080DF5, + {; 2} + $3B6E20C8, $4C69105E, $D56041E4, $A2677172, + $3C03E4D1, $4B04D447, $D20D85FD, $A50AB56B, + $35B5A8FA, $42B2986C, $DBBBC9D6, $ACBCF940, + $32D86CE3, $45DF5C75, $DCD60DCF, $ABD13D59, + {; 3} + $26D930AC, $51DE003A, $C8D75180, $BFD06116, + $21B4F4B5, $56B3C423, $CFBA9599, $B8BDA50F, + $2802B89E, $5F058808, $C60CD9B2, $B10BE924, + $2F6F7C87, $58684C11, $C1611DAB, $B6662D3D, + {; 4} + $76DC4190, $01DB7106, $98D220BC, $EFD5102A, + $71B18589, $06B6B51F, $9FBFE4A5, $E8B8D433, + $7807C9A2, $0F00F934, $9609A88E, $E10E9818, + $7F6A0DBB, $086D3D2D, $91646C97, $E6635C01, + {; 5} + $6B6B51F4, $1C6C6162, $856530D8, $F262004E, + $6C0695ED, $1B01A57B, $8208F4C1, $F50FC457, + $65B0D9C6, $12B7E950, $8BBEB8EA, $FCB9887C, + $62DD1DDF, $15DA2D49, $8CD37CF3, $FBD44C65, + {; 6} + $4DB26158, $3AB551CE, $A3BC0074, $D4BB30E2, + $4ADFA541, $3DD895D7, $A4D1C46D, $D3D6F4FB, + $4369E96A, $346ED9FC, $AD678846, $DA60B8D0, + $44042D73, $33031DE5, $AA0A4C5F, $DD0D7CC9, + {; 7} + $5005713C, $270241AA, $BE0B1010, $C90C2086, + $5768B525, $206F85B3, $B966D409, $CE61E49F, + $5EDEF90E, $29D9C998, $B0D09822, $C7D7A8B4, + $59B33D17, $2EB40D81, $B7BD5C3B, $C0BA6CAD, + {; 8} + $EDB88320, $9ABFB3B6, $03B6E20C, $74B1D29A, + $EAD54739, $9DD277AF, $04DB2615, $73DC1683, + $E3630B12, $94643B84, $0D6D6A3E, $7A6A5AA8, + $E40ECF0B, $9309FF9D, $0A00AE27, $7D079EB1, + {; 9} + $F00F9344, $8708A3D2, $1E01F268, $6906C2FE, + $F762575D, $806567CB, $196C3671, $6E6B06E7, + $FED41B76, $89D32BE0, $10DA7A5A, $67DD4ACC, + $F9B9DF6F, $8EBEEFF9, $17B7BE43, $60B08ED5, + {; A} + $D6D6A3E8, $A1D1937E, $38D8C2C4, $4FDFF252, + $D1BB67F1, $A6BC5767, $3FB506DD, $48B2364B, + $D80D2BDA, $AF0A1B4C, $36034AF6, $41047A60, + $DF60EFC3, $A867DF55, $316E8EEF, $4669BE79, + {; B} + $CB61B38C, $BC66831A, $256FD2A0, $5268E236, + $CC0C7795, $BB0B4703, $220216B9, $5505262F, + $C5BA3BBE, $B2BD0B28, $2BB45A92, $5CB36A04, + $C2D7FFA7, $B5D0CF31, $2CD99E8B, $5BDEAE1D, + {; C} + $9B64C2B0, $EC63F226, $756AA39C, $026D930A, + $9C0906A9, $EB0E363F, $72076785, $05005713, + $95BF4A82, $E2B87A14, $7BB12BAE, $0CB61B38, + $92D28E9B, $E5D5BE0D, $7CDCEFB7, $0BDBDF21, + {; D} + $86D3D2D4, $F1D4E242, $68DDB3F8, $1FDA836E, + $81BE16CD, $F6B9265B, $6FB077E1, $18B74777, + $88085AE6, $FF0F6A70, $66063BCA, $11010B5C, + $8F659EFF, $F862AE69, $616BFFD3, $166CCF45, + {; E} + $A00AE278, $D70DD2EE, $4E048354, $3903B3C2, + $A7672661, $D06016F7, $4969474D, $3E6E77DB, + $AED16A4A, $D9D65ADC, $40DF0B66, $37D83BF0, + $A9BCAE53, $DEBB9EC5, $47B2CF7F, $30B5FFE9, + {; F} + $BDBDF21C, $CABAC28A, $53B39330, $24B4A3A6, + $BAD03605, $CDD70693, $54DE5729, $23D967BF, + $B3667A2E, $C4614AB8, $5D681B02, $2A6F2B94, + $B40BBE37, $C30C8EA1, $5A05DF1B, $2D02EF8D + ); +{$WARNINGS ON} + +function CalcCRC32(const Buf; CRC: Integer; BufSize: Integer): Integer; assembler; +asm + push esi + mov esi,Buf +@1: + movzx eax,byte ptr [esi] + inc ESI + xor al,dl + shr edx,8 + xor edx,dword ptr [atablecrc32+eax*4] + Loop @1 + mov eax,edx + pop esi +end; + +function CRC32Calc(const Buf; CRC: Integer; BufSize: Integer): Integer; +begin + Result:=CalcCRC32(Buf, CRC, BufSize); +end; + +function CRC32(const Buf; CRC: Integer; BufSize: Integer): Integer; +begin + Result:=not CalcCRC32(Buf, not CRC, BufSize); +end; + +end. diff --git a/uIniMngr.pas b/uIniMngr.pas new file mode 100644 index 0000000..513c74e --- /dev/null +++ b/uIniMngr.pas @@ -0,0 +1,968 @@ +///////////////////////////////////////////////////////////////////////// +// // +// Orion/Z (Orion-128 + Z80-CARD-II) emulator, version 1.9 // +// // +// Author: Sergey A. // +// // +// Copyright (C) 2006-2016 Sergey A. // +// // +// This program is free software; you can redistribute it and/or // +// modify it in any ways. // +// This program is distributed "AS IS" 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 uIniMngr; + +interface + +Uses Windows, SysUtils, Classes, Forms, Menus, TypInfo, IniFiles; + +const + BufSize = 32768; + stSectionRecentFiles = 'RECENT'; + +type + TIniBindType = (btInteger, btString, btBoolean, btSmallInt, btChar, btCharBuf, btDouble, btProp); + + TAsofIniFile = TIniFile; + + PString = ^String; + PInteger = ^Integer; + PBoolean = ^Boolean; + PSmallInt = ^SmallInt; + PDouble = ^Double; + + TIniBindRec = class // TObject + FBindType: TIniBindType; + FValue: pointer; // pointer to variable (or nil if FBindType=btProp) + FDefaultValue: string; // INI + FSectionName: string; // INI + FKeyName: string; // INI + FInstance: TObject; // instance of associated class (or nil if FBindType<>btProp) + FPropertyName: string; // name of associated published property + FPropInfo: PPropInfo; + FPropType: PTypeInfo; + private + function GetPropAsFloat: double; + function GetPropAsInteger: integer; + function GetPropAsString: String; + function GetVarAsFloat: double; + function GetVarAsInteger: integer; + function GetVarAsString: String; + procedure SetPropAsFloat(const Value: double); + procedure SetPropAsInteger(const Value: integer); + procedure SetPropAsString(const Value: String); + procedure SetVarAsFloat(const Value: double); + procedure SetVarAsInteger(const Value: integer); + procedure SetVarAsString(const Value: String); + function FindProperty(Instance: TObject; PropertyName:string; var PropInfo:PPropInfo):boolean; + public + constructor Create(BindType:TIniBindType; pValue: pointer; Instance: TObject; + PropertyName, SectionName, KeyName, DefaultValue:string); + property pValue:pointer read FValue; + property BindType:TIniBindType read FBindType; + property Instance:TObject read FInstance; + property PropertyName:string read FPropertyName; + property SectionName:string read FSectionName; + property KeyName:string read FKeyName; + property DefaultValue:string read FDefaultValue; + property VarAsInteger:integer read GetVarAsInteger write SetVarAsInteger; + property VarAsString:String read GetVarAsString write SetVarAsString; + property VarAsFloat:double read GetVarAsFloat write SetVarAsFloat; + property PropAsInteger:integer read GetPropAsInteger write SetPropAsInteger; + property PropAsString:String read GetPropAsString write SetPropAsString; + property PropAsFloat:double read GetPropAsFloat write SetPropAsFloat; + end; + + TIniManager = class + FIniFile: TAsofIniFile; // not creating in TIniManager - passed by external proc ! + FBindList: TList; + FRecentFilesList: TStringList; + FBuffer: array [0..BufSize] of char; + FRecentFilesMenuItem: TMenuItem; + FRecentFilesSectionName: string; + FRecentFilesDropDownMax: integer; + FRecentFilesDropDownCount: integer; + FRecentFilesItemClick: TNotifyEvent; + private + function CheckIniFile:TAsofIniFile; + procedure RecentFileItemClick(Sender:TObject); + procedure SetRecentFilesMenuItem(const Value: TMenuItem); + public + constructor Create; + destructor Destroy; override; + function GetRecentFilesSection: integer; + function WriteRecentFilesSection: boolean; + procedure GetPrivateSection(SectionName:string; SL:TStringList); + function GetPrivateString(SectionName,KeyName,DefaultValue:string):string; + function GetPrivateInt(SectionName,KeyName:string;DefaultValue:Integer):integer; + function WritePrivateString(SectionName,KeyName,Value:string):boolean; + function WritePrivateInt(SectionName,KeyName:string;Value:Integer):boolean; + function WritePrivateSection(SectionName:string; SL:TStringList):boolean; + function GetValueID(pValue: pointer): integer; + function GetPropID(Instance: TObject; PropertyName:string): integer; + procedure BindProperty(Instance: TObject; PropertyName, + SectionName, KeyName, DefaultValue:string); + procedure BindVariable(BindType: TIniBindType; pValue: pointer; + SectionName, KeyName, DefaultValue:string); + procedure LinkPropertyToVariable(Instance: TObject; PropertyName:string; pVariable: pointer); + procedure UnLinkPropertyFromVariable(pVariable: pointer); + procedure StopBindVariable(pValue: pointer); + procedure StopBindProperty(Instance: TObject; PropertyName: string); + procedure WriteValueByID(ID: integer); + procedure WritePropByID(ID: integer); + procedure GetValueByID(ID: integer); + procedure GetPropByID(ID: integer); + procedure WriteValue(pValue: pointer); + procedure WriteProp(Instance: TObject; PropertyName:string); + procedure GetValue(pValue: pointer); + procedure GetProp(Instance: TObject; PropertyName:string); + procedure LoadLinkedPropsFromIni; + procedure LoadLinkedPropsFromVar; + procedure SaveLinkedPropsToIni; + procedure SaveLinkedPropsToVar; + function IsLinkedPropsEqualToVars:boolean; + procedure WriteAllValues; + procedure GetAllValues; + procedure WriteAllProps; + procedure GetAllProps; + procedure WriteAll; + procedure GetAll; + procedure Clear; + procedure Flush; + procedure RecentFilesAdd(aCaption: String); +{} + property IniFileObj: TAsofIniFile read FIniFile write FIniFile; + property RecentFilesMenuItem: TMenuItem read FRecentFilesMenuItem write SetRecentFilesMenuItem; + property RecentFilesSectionName: string read FRecentFilesSectionName write FRecentFilesSectionName; + property RecentFilesDropDownList: TStringList read FRecentFilesList; + property RecentFilesDropDownMax: integer read FRecentFilesDropDownMax write FRecentFilesDropDownMax; +{} + property OnRecentFilesItemClick: TNotifyEvent read FRecentFilesItemClick write FRecentFilesItemClick; + end; + +implementation + +{ TIniBindRec } + +constructor TIniBindRec.Create(BindType:TIniBindType; pValue: pointer; Instance: TObject; + PropertyName, SectionName, KeyName, DefaultValue:string); +begin + inherited Create; + FBindType:=BindType; + FValue:=pValue; + FInstance:=Instance; + FPropertyName:=PropertyName; + FSectionName:=SectionName; + FKeyName:=KeyName; + FDefaultValue:=DefaultValue; +end; + +function TIniBindRec.FindProperty(Instance: TObject; PropertyName: string; + var PropInfo: PPropInfo): boolean; +var + I, Count: Integer; + PropList: PPropList; +begin + Result:=False; + Count := GetTypeData(Instance.ClassInfo)^.PropCount; + if Count > 0 then + begin + GetMem(PropList, Count * SizeOf(Pointer)); + try + GetPropInfos(Instance.ClassInfo, PropList); + I:=0; + while (I nil)and + (UpperCase(PropInfo^.Name) = UpperCase(PropertyName)); + inc(I); + end; + finally + FreeMem(PropList, Count * SizeOf(Pointer)); + end; + end; +end; + +function TIniBindRec.GetPropAsFloat: double; +var d:double; + i:integer; +begin + Result:=0.0; + if Assigned(FInstance) and (FPropertyName<>'') and + FindProperty(FInstance, FPropertyName, FPropInfo) then + begin + FPropType:=FPropInfo^.PropType^; + case FPropType^.Kind of + tkInteger, tkChar, tkEnumeration, tkSet: + Result:=GetOrdProp(FInstance, FPropInfo); + tkFloat: + Result:=GetFloatProp(FInstance, FPropInfo); + tkString, tkLString, tkWString: + begin + val(GetStrProp(FInstance, FPropInfo), d, i); + if i=0 then Result:=d; + end; + end; + end; +end; + +function TIniBindRec.GetPropAsInteger: integer; +begin + Result:=0; + if Assigned(FInstance) and (FPropertyName<>'') and + FindProperty(FInstance, FPropertyName, FPropInfo) then + begin + FPropType:=FPropInfo^.PropType^; + case FPropType^.Kind of + tkInteger, tkChar, tkEnumeration, tkSet: + Result:=GetOrdProp(FInstance, FPropInfo); + tkFloat: + Result:=Trunc(GetFloatProp(FInstance, FPropInfo)); + tkString, tkLString, tkWString: + Result:=StrToIntDef(GetStrProp(FInstance, FPropInfo), 0); + end; + end; +end; + +function TIniBindRec.GetPropAsString: String; +begin + Result:=''; + if Assigned(FInstance) and (FPropertyName<>'') and + FindProperty(FInstance, FPropertyName, FPropInfo) then + begin + FPropType:=FPropInfo^.PropType^; + case FPropType^.Kind of + tkInteger, tkChar, tkEnumeration, tkSet: + Result:=IntToStr(GetOrdProp(FInstance, FPropInfo)); + tkFloat: + Result:=FloatToStr(GetFloatProp(FInstance, FPropInfo)); + tkString, tkLString, tkWString: + Result:=GetStrProp(FInstance, FPropInfo); + end; + end; +end; + +function TIniBindRec.GetVarAsFloat: double; +var d: double; + i: integer; +begin + Result:=0.0; + if Assigned(FValue) then + case FBindType of + btInteger: Result:=PInteger(FValue)^; + btSmallInt: Result:=PSmallInt(FValue)^; + btBoolean: Result:=Integer(PBoolean(FValue)^); + btString: begin + val(PString(FValue)^, d, i); + if i=0 then Result:=d; + end; + btChar: Result:=PByte(FValue)^; + btCharBuf: begin + val(StrPas(Pchar(FValue)), d, i); + if i=0 then Result:=d; + end; + btDouble: Result:=PDouble(FValue)^; + end; +end; + +function TIniBindRec.GetVarAsInteger: integer; +begin + Result:=0; + if Assigned(FValue) then + case FBindType of + btInteger: Result:=PInteger(FValue)^; + btSmallInt: Result:=PSmallInt(FValue)^; + btBoolean: Result:=Integer(PBoolean(FValue)^); + btString: Result:=StrToIntDef(PString(FValue)^, 0); + btChar: Result:=PByte(FValue)^; + btCharBuf: Result:=StrToIntDef(StrPas(Pchar(FValue)), 0); + btDouble: Result:=Trunc(PDouble(FValue)^); + end; +end; + +function TIniBindRec.GetVarAsString: String; +begin + Result:=''; + if Assigned(FValue) then + case FBindType of + btInteger: Result:=IntToStr(PInteger(FValue)^); + btSmallInt: Result:=IntToStr(PSmallInt(FValue)^); + btBoolean: Result:=IntToStr(Integer(PBoolean(FValue)^)); + btString: Result:=PString(FValue)^; + btChar: Result:=Char(PByte(FValue)^); + btCharBuf: Result:=StrPas(Pchar(FValue)); + btDouble: Result:=FloatToStr(PDouble(FValue)^); + end; +end; + +procedure TIniBindRec.SetPropAsFloat(const Value: double); +begin + if Assigned(FInstance) and (FPropertyName<>'') and + FindProperty(FInstance, FPropertyName, FPropInfo) then + begin + FPropType:=FPropInfo^.PropType^; + case FPropType^.Kind of + tkInteger, tkChar, tkEnumeration, tkSet: + SetOrdProp(FInstance, FPropInfo, Trunc(Value)); + tkFloat: + SetFloatProp(FInstance, FPropInfo, Value); + tkString, tkLString, tkWString: + SetStrProp(FInstance, FPropInfo, FloatToStr(Value)); + end; + end; +end; + +procedure TIniBindRec.SetPropAsInteger(const Value: integer); +begin + if Assigned(FInstance) and (FPropertyName<>'') and + FindProperty(FInstance, FPropertyName, FPropInfo) then + begin + FPropType:=FPropInfo^.PropType^; + case FPropType^.Kind of + tkInteger, tkChar, tkEnumeration, tkSet: + SetOrdProp(FInstance, FPropInfo, Value); + tkFloat: + SetFloatProp(FInstance, FPropInfo, Value); + tkString, tkLString, tkWString: + SetStrProp(FInstance, FPropInfo, IntToStr(Value)); + end; + end; +end; + +procedure TIniBindRec.SetPropAsString(const Value: String); +var d: double; + i: integer; +begin + if Assigned(FInstance) and (FPropertyName<>'') and + FindProperty(FInstance, FPropertyName, FPropInfo) then + begin + FPropType:=FPropInfo^.PropType^; + case FPropType^.Kind of + tkInteger, tkChar, tkEnumeration, tkSet: + SetOrdProp(FInstance, FPropInfo, StrToIntDef(Value,0)); + tkFloat: + begin + val(Value, d, i); + if i>0 then d:=0.0; + SetFloatProp(FInstance, FPropInfo, d); + end; + tkString, tkLString, tkWString: + SetStrProp(FInstance, FPropInfo, Value); + end; + end; +end; + +procedure TIniBindRec.SetVarAsFloat(const Value: double); +begin + case FBindType of + btInteger: PInteger(FValue)^ := Trunc(Value); + btSmallInt: PSmallInt(FValue)^ := LoWord(Trunc(Value)); + btBoolean: PBoolean(FValue)^ := boolean(Trunc(Value)); + btDouble: PDouble(FValue)^ := Value; + btString: PString(FValue)^ := FloatToStr(Value); + btChar: PByte(FValue)^ := Lo(Trunc(Value)); + btCharBuf: StrPCopy(PChar(FValue), FloatToStr(Value)); + end; +end; + +procedure TIniBindRec.SetVarAsInteger(const Value: integer); +begin + case FBindType of + btInteger: PInteger(FValue)^ := Value; + btSmallInt: PSmallInt(FValue)^ := LoWord(Value); + btBoolean: PBoolean(FValue)^ := boolean(Value); + btDouble: PDouble(FValue)^ := Value; + btString: PString(FValue)^ := IntToStr(Value); + btChar: PByte(FValue)^ := Lo(Value); + btCharBuf: StrPCopy(PChar(FValue), IntToStr(Value)); + end; +end; + +procedure TIniBindRec.SetVarAsString(const Value: String); +var d: double; + i: integer; +begin + case FBindType of + btInteger: PInteger(FValue)^ := StrToIntDef(Value,0); + btSmallInt: PSmallInt(FValue)^ := LoWord(StrToIntDef(Value,0)); + btBoolean: PBoolean(FValue)^ := boolean(StrToIntDef(Value,0)); + btDouble: begin + val(Value,d,i); + if i>0 then d:=0.0; + PDouble(FValue)^ := d; + end; + btString: PString(FValue)^ := Value; + btChar: if Length(Value)>0 then PByte(FValue)^ := Byte(Value[1]); + btCharBuf: StrPCopy(Pchar(FValue), Value); + end; +end; + +{ TIniManager } + +function NonStandardGetSection(SectionName: string; + Buffer: PChar; BufferSize: integer; IniName:string): integer; +var FileSL: TStringList; + i: integer; + st: string; +begin + st:=''; + FileSL:=TStringList.Create; + FileSL.LoadFromFile(IniName); + i:=0; + while (i1) do + inc(i); + if i'')and + (trim(FileSL.Strings[i])[1]<>'[') do + begin + st:=st+FileSL.Strings[i]+#0; + inc(i); + end; + end; + if Length(st)>BufferSize-3 then st:=copy(st,1,BufferSize-3); + st:=st+#0#0; + CopyMemory(Buffer, PChar(st), Length(st)); + Result:=Length(st); + FileSL.Free; +end; + +procedure TIniManager.GetPrivateSection(SectionName: string; SL:TStringList); +const + BufSize = 16384; +var + Buffer, P: PChar; +begin + GetMem(Buffer, BufSize); + try + SL.BeginUpdate; + try + SL.Clear; + Buffer[0]:=#0; +// because inherited TIniFile.ReadSection call GetPrivateProfileString(..,nil,..) and sucks on exotic sections :) +// + NonStandardGetSection(SectionName, Buffer, BufSize, FIniFile.FileName); + P := Buffer; + while P^ <> #0 do + begin + SL.Add(P); + Inc(P, StrLen(P) + 1); + end; + finally + SL.EndUpdate; + end; + finally + FreeMem(Buffer, BufSize); + end; +end; + +procedure TIniManager.BindVariable(BindType: TIniBindType; pValue: pointer; + SectionName, KeyName, DefaultValue: string); +begin + FBindList.Add(pointer(TIniBindRec.Create(BindType, pValue, nil, '', + SectionName, KeyName, DefaultValue))); +end; + +constructor TIniManager.Create; +begin + inherited Create; + FIniFile:=nil; + RecentFilesMenuItem:=nil; + FRecentFilesItemClick:=nil; + RecentFilesSectionName:=''; + RecentFilesDropDownMax:=8; + FBindList:=TList.Create; + FRecentFilesList:=TStringList.Create; + FRecentFilesSectionName:=stSectionRecentFiles; +end; + +destructor TIniManager.Destroy; +begin + Clear; + FBindList.Free; + FRecentFilesList.Free; + inherited Destroy; +end; + +function TIniManager.GetPrivateString(SectionName,KeyName,DefaultValue:string):string; +begin + Result:=trim(CheckIniFile.ReadString(SectionName,KeyName,DefaultValue)); +end; + +function TIniManager.GetPrivateInt(SectionName,KeyName:string;DefaultValue:Integer):integer; +begin + Result:=CheckIniFile.ReadInteger(SectionName, KeyName, DefaultValue); +end; + +function TIniManager.WritePrivateString(SectionName,KeyName,Value:string):boolean; +begin + Result:=True; + CheckIniFile.WriteString(SectionName, KeyName, Value); +end; + +function TIniManager.WritePrivateInt(SectionName,KeyName:string;Value:Integer):boolean; +begin + Result:=True; + CheckIniFile.WriteInteger(SectionName, KeyName, Value); +end; + +procedure TIniManager.GetAllValues; +var i: integer; +begin + for i:=0 to FBindList.Count-1 do + begin + if Assigned(FBindList.Items[i]) then GetValueByID(i); + Application.ProcessMessages; + end; +end; + +procedure TIniManager.GetValue(pValue: pointer); +begin + GetValueByID(GetValueID(pValue)); +end; + +procedure TIniManager.WriteAllValues; +var i: integer; +begin + for i:=0 to FBindList.Count-1 do + if Assigned(FBindList.Items[i]) then WriteValueByID(i); +end; + +procedure TIniManager.WriteValue(pValue: pointer); +begin + WriteValueByID(GetValueID(pValue)); +end; + +procedure TIniManager.Clear; +var i:integer; +begin + for i:=0 to FBindList.Count-1 do + if Assigned(FBindList.Items[i]) then + TIniBindRec(FBindList.Items[i]).Free; + FBindList.Clear; +end; + +procedure TIniManager.GetValueByID(ID: integer); +begin + if (ID>=FBindList.Count)or(not Assigned(FBindList.Items[ID])) then exit; + with TIniBindRec(FBindList.Items[ID]) do + begin + case FBindType of + btInteger, btSmallInt, btBoolean: + VarAsInteger:=GetPrivateInt(FSectionName, FKeyName, StrToInt(FDefaultValue)); + btString, btChar, btCharBuf, btDouble: + VarAsString :=GetPrivateString(FSectionName, FKeyName, FDefaultValue); + end; + end; +end; + +procedure TIniManager.WriteValueByID(ID: integer); +begin + if (ID>=FBindList.Count)or(not Assigned(FBindList.Items[ID])) then exit; + with TIniBindRec(FBindList.Items[ID]) do + begin + case FBindType of + btInteger, btBoolean, btSmallInt: + WritePrivateInt(FSectionName, FKeyName, VarAsInteger); + btString, btChar, btCharBuf, btDouble: + WritePrivateString(FSectionName, FKeyName, VarAsString); + end; + end; +end; + +procedure TIniManager.StopBindVariable(pValue: pointer); +var i: integer; +begin + i:=GetValueID(pValue); + if (i=0) then + begin + if Assigned(FBindList.Items[i]) then + TIniBindRec(FBindList.Items[i]).Free; + FBindList.Delete(i); + end; +end; + +function TIniManager.GetValueID(pValue: pointer): integer; +begin + Result:=0; + while (Result=0)and(i=FBindList.Count then Result:=-1; +end; + +procedure TIniManager.WritePropByID(ID: integer); +var PropInfo: PPropInfo; + PropType: PTypeInfo; +begin + if (ID>=0) and (ID=0) and (ID'')and(aCaption[Length(aCaption)]<>'\') then + begin + NewItem := TMenuItem.Create(FRecentFilesMenuItem); + NewItem.Caption := aCaption; + NewItem.Tag := 0; + NewItem.OnClick := RecentFileItemClick; + try + FRecentFilesMenuItem.Insert(0, NewItem); + FRecentFilesList.Insert(0, aCaption); + except + NewItem.Free; + end; + i:=1; + while iFRecentFilesDropDownMax) do + begin + FRecentFilesMenuItem.Delete(FRecentFilesMenuItem.Count-1); + FRecentFilesList.Delete(FRecentFilesMenuItem.Count-1); + end; + end; +end; + +function TIniManager.GetRecentFilesSection: integer; +var NewItem: TMenuItem; + i: integer; +begin + Result:=0; + GetPrivateSection(FRecentFilesSectionName, FRecentFilesList); + for i:=FRecentFilesList.Count downto FRecentFilesDropDownMax+1 do + FRecentFilesList.Delete(i-1); + if not Assigned(FRecentFilesMenuItem) then exit; + for i:=0 to FRecentFilesList.Count-1 do + begin + NewItem := TMenuItem.Create(FRecentFilesMenuItem); + NewItem.Caption := FRecentFilesList.Strings[i]; + NewItem.Tag := i; + NewItem.OnClick := FRecentFilesItemClick; + FRecentFilesMenuItem.Add(NewItem); + end; +end; + +function TIniManager.WriteRecentFilesSection: boolean; +begin + Result:=WritePrivateSection(FRecentFilesSectionName, FRecentFilesList); +end; + +function TIniManager.WritePrivateSection(SectionName:string; + SL: TStringList): boolean; + procedure WriteSection(const Section: string; + Strings: TStrings); + const + BufSize = 16384; + var + Buffer: PChar; + i, ii: integer; + res: boolean; + begin + GetMem(Buffer, BufSize); + try + i:=0; + Buffer[0]:=#0; Buffer[1]:=#0; + WritePrivateProfileSection(PChar(Section), nil, PChar(FIniFile.FileName)); // clear in file + for ii:=0 to Strings.Count-1 do + begin + StrPCopy(@Buffer[i], Strings.Strings[ii]); + i:=i+Length(Strings.Strings[ii])+1; + end; + Buffer[i]:=#0; + res:=WritePrivateProfileSection(PChar(Section), Buffer, PChar(FIniFile.FileName)); + if not Res then raise Exception.Create('IniFile Write Error: + FIniFile.FileName'); + finally + FreeMem(Buffer, BufSize); + end; + end; +begin + Result:=True; + CheckIniFile; + WriteSection(SectionName, SL); +end; + +procedure TIniManager.RecentFileItemClick(Sender: TObject); +var i, tg: integer; +begin + If Assigned(FRecentFilesItemClick) then FRecentFilesItemClick(Sender); + if Assigned(Sender)and(Sender is TMenuItem) then + begin + tg:=(Sender as TMenuItem).Tag; + FRecentFilesList.Delete( tg ); + FRecentFilesMenuItem.Delete( tg ); + (Sender as TMenuItem).Free; + for i:=tg to FRecentFilesMenuItem.Count-1 do + FRecentFilesMenuItem.Items[i].Tag:=i; + end; +end; + +procedure TIniManager.SetRecentFilesMenuItem(const Value: TMenuItem); +begin + FRecentFilesMenuItem := Value; + if Assigned(Value) then Value.AutoHotkeys:=maManual; +end; + +function TIniManager.CheckIniFile: TAsofIniFile; +begin + Result:=nil; + if Assigned(FIniFile) then Result:=FIniFile + else raise Exception.Create('IniManager Error'#13#13'IniFileObj not assigned'); +end; + +procedure TIniManager.LinkPropertyToVariable(Instance: TObject; + PropertyName: string; pVariable: pointer); +var ID:Integer; +begin + ID:=GetValueID(pVariable); + if (ID<0) or (ID>=FBindList.Count) then ID:=GetPropID(Instance, PropertyName); + if (ID>=0) and (IDbtProp) and Assigned(FValue) and + Assigned(FInstance) and (FPropertyName<>'') then + begin + BT:=FBindType; + try + FBindType:=btProp; + GetPropByID(ID); + finally + FBindType:=BT; + end; + end; +end; + +procedure TIniManager.LoadLinkedPropsFromVar; +type TPChar = ^Char; +var ID:Integer; +begin + for ID:=0 to FBindList.Count-1 do + if Assigned(FBindList.Items[ID]) then + with TIniBindRec(FBindList.Items[ID]) do + if Assigned(FValue) and Assigned(FInstance) and (FPropertyName<>'') then + begin + case FBindType of + btInteger: PropAsInteger:=PInteger(FValue)^; + btSmallInt: PropAsInteger:=PSmallInt(FValue)^; + btBoolean: PropAsInteger:=Integer(PBoolean(FValue)^); + btString: PropAsString:=PString(FValue)^; + btChar: PropAsString:=TPChar(FValue)^; + btCharBuf: PropAsString:=StrPas(Pchar(FValue)); + btDouble: PropAsFloat:=PDouble(FValue)^; + end; + end; +end; + +procedure TIniManager.SaveLinkedPropsToIni; +var ID:Integer; + BT: TIniBindType; +begin + for ID:=0 to FBindList.Count-1 do + if Assigned(FBindList.Items[ID]) then + with TIniBindRec(FBindList.Items[ID]) do + if (FBindType<>btProp) and Assigned(FValue) and + Assigned(FInstance) and (FPropertyName<>'') then + begin + BT:=FBindType; + try + FBindType:=btProp; + WritePropByID(ID); + finally + FBindType:=BT; + end; + end; +end; + +procedure TIniManager.SaveLinkedPropsToVar; +type TPChar = ^Char; +var ID:Integer; +begin + for ID:=0 to FBindList.Count-1 do + if Assigned(FBindList.Items[ID]) then + with TIniBindRec(FBindList.Items[ID]) do + if Assigned(FValue) and Assigned(FInstance) and (FPropertyName<>'') then + begin + case FBindType of + btInteger: PInteger(FValue)^ := PropAsInteger; + btSmallInt: PSmallInt(FValue)^ := PropAsInteger; + btBoolean: PBoolean(FValue)^ := boolean(PropAsInteger); + btDouble: PDouble(FValue)^ :=PropAsFloat; + btString: PString(FValue)^ :=PropAsString; + btChar: TPChar(FValue)^ :=PropAsString[1]; + btCharBuf: StrPCopy(Pchar(FValue),PropAsString); + end; + end; +end; + +function TIniManager.IsLinkedPropsEqualToVars: boolean; +var ID:Integer; +begin + ID:=0; + Result:=True; + while (IDbtProp) and Assigned(FValue) and + Assigned(FInstance) and (FPropertyName<>'') then + Result:=VarAsString=PropAsString; + inc(ID); + end; +end; + +procedure TIniManager.UnLinkPropertyFromVariable(pVariable: pointer); +begin + +end; + +end. +