procedure Sound(Freq : Word);

var B : Byte;

begin

if Freq > 18 then

begin

Freq := Word(1193181 div LongInt(Freq));

B := Byte(GetPort($61));

if (B and 3) = 0 then

begin

SetPort($61, Word(B or 3));

SetPort($43, $B6);

end;

SetPort($42, Freq);

SetPort($42, Freq shr 8);

end;

end;



procedure NoSound;

var Value: Word;

begin

Value := GetPort($61) and $FC;

SetPort($61, Value);

end;



procedure SetPort(address, Value:Word);

var bValue: byte;

begin

bValue := trunc(Value and 255);

asm

mov dx, address

mov al, bValue

out dx, al

end;

end;



function GetPort(address:word):word;

var bValue: byte;

begin

asm

mov dx, address

in al, dx

mov bValue, al

end;

GetPort := bValue;

end;

procedure SwapVars1(var u, v; Size: Integer);

var

x: Pointer;

begin

GetMem(x, Size);

try

System.move(u, x^, Size);

System.move(v, u, Size);

System.move(x^, v, Size);

finally

FreeMem(x);

end;

end;


procedure SwapVars2(var Source, Dest; Size: Integer);

begin

asm

push edi

push esi

mov esi,Source

mov edi,Dest

mov ecx,Size

cld

@1:

mov al,[edi]

xchg [esi],al

inc si

stosb

loop @1

pop esi

pop edi

end;

end;



procedure TForm1.Button2Click(Sender: TObject);

begin

SwapVars1(X1, X2, SizeOf(Integer));

end;

unit MsFormR;



interface



uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls, ExtCtrls;



type

TForm1 = class(TForm)

OpenDialog1: TOpenDialog;

SaveDialog1: TSaveDialog;

Memo1: TMemo;

ListBox1: TListBox;

Panel1: TPanel;

Button1: TButton;

Button2: TButton;

Splitter1: TSplitter;

procedure FormCreate(Sender: TObject);

procedure Button1Click(Sender: TObject);

procedure Button2Click(Sender: TObject);

private

MemStr1: TMemoryStream;

public

procedure ShowMemStr;

end;



var

Form1: TForm1;



implementation



{$R *.DFM}



procedure TForm1.FormCreate(Sender: TObject);

begin

MemStr1 := TMemoryStream.Create;

end;



procedure TForm1.Button1Click(Sender: TObject);

var

Str1: TFileStream;

begin

OpenDialog1.Filter :=

'Any file (*.*)|*.*';

OpenDialog1.DefaultExt := '*';

if OpenDialog1.Execute then

begin

Str1 := TFileStream.Create (

OpenDialog1.Filename, fmOpenRead);

try

MemStr1.LoadFromStream (Str1);

ShowMemStr;

Button2.Enabled := true;

finally

Str1.Free;

end;

end;

end;



procedure TForm1.ShowMemStr;

begin

Memo1.Lines.LoadFromStream (MemStr1);

end;



procedure TForm1.Button2Click(Sender: TObject);

const

ndx: LongInt = 1;

var

pch: PChar;

tmpC: Char;

begin

pch := MemStr1.Memory;

tmpC := pch[ndx];

pch[ndx] := #0;

ListBox1.Items.SetText(MemStr1.Memory);

pch[ndx] := tmpC;



if ndx < MemStr1.Size then

Inc(ndx)

else

Button2.Enabled := False;

end;



end.

function TestFunc1(d: Double): Integer;

begin

....

end;



function TestFunc2(d: Double): Integer;

begin

....

end;



exports

TestFunc1,

TestFunc2;



procedure TForm1.Button1Click(Sender: TObject);

var

Func: function (d: Double): Integer;

begin

@Func := GetProcAddress(hInstance, PChar(Edit1.Text));

if @Func = nil then

raise Exception.CreateFmt('Функция с именем "%s" не существует', [Edit1.Text]);

ShowMessage(IntToStr(Func(10.63)));

end;

Function Pos(Substr: String; S: String): Integer;

Function PosEx(Const SubStr, S: String; Offset: Cardinal = 1): Integer;

Function PosEx(Const SubStr, S: String; Offset: Cardinal = 1): Integer;

var

I,X: Integer;

Len, LenSubStr: Integer;

begin

If Offset = 1 Then

Result := Pos(SubStr, S)

Else

begin

I := Offset;

LenSubStr := Length(SubStr);

Len := Length(S) - LenSubStr + 1;

While I <= Len Do

begin

If S[I] = SubStr[1] Then

begin

X := 1;

While (X < LenSubStr) And (S[I + X] = SubStr[X + 1]) Do

Inc(X);

If (X = LenSubStr) Then

begin

Result := I;

Exit;

End;

End;

Inc(I);

End;

Result := 0;

End;

End;

if paramstr(1) = '/v' then

showmessage('Parameter "/v" was found!');

if paramstr(1) = '/c' then

color := clBlue;

if paramstr(1) = '/f' then

caption := 'Parameter "/f" was found';

type

TMacroProc = procedure(param: Integer);

//массив, сопоставляющий имена процедур их адресам во время выполнения приложения:

TMacroName = string[32];

TMacroLink = record

name: TMacroName;

proc: TMacroProc;

end;

TMacroList = array [1..MaxMacroIndex] of TMacroLink;



const

Macros: TMacroList = (

(name: 'Proc1'; proc: Proc1),

(name: 'Proc2'; proc: Proc2),

...

); //интерпретатор функций, типа:



procedure CallMacro(name: String; param: Integer);

var

i: Integer;

begin

for i := 1 to MaxMacroIndex do

if CompareText(name, Macros[i].name) = 0 then

begin

Macros[i].proc(param);

break;

end;

end;



{Макропроцедуры необходимо объявить в секции Interface модуля или с ключевым словом Far, например: }

procedure Proc1(n: Integer); far;

begin

...

end;



procedure Proc2(n: Integer); far;

begin

...

end;

{ .... }



type

VA_FN = function(const par1, par2{, ...}: Pointer): Boolean;

cdecl varargs;



{ .... }



//

// varargs without "external" keyword

//

function fn(const par1, par2{, ...}: Pointer): Boolean; cdecl;

var

last_arg: Pointer absolute par2;

ptr_args: array[0..MAXLONG shr 2] of Pointer absolute last_arg;

dw_args: array[0..MAXLONG shr 2] of Cardinal absolute last_arg;

s_args: array[0..MAXLONG shr 2] of PChar absolute last_arg;

w_args: array[0..MAXLONG shr 2] of WideString absolute last_arg;

begin

// ptr_args[1] is first optional argument

Result := (ptr_args[1] {par3} = Pointer(1)) and

(dw_args[2] {par4} = 2) and

(string(ptr_args[3]) = 'CHAR') and

(w_args[4] = 'WCHAR');

end;



procedure test_fn;

begin

// VA_FN typecast

VA_FN(@fn)({par1}nil, {par2}nil, {par3}Pointer(1), {par4}2, {par5}'CHAR',

{par6}WideString('WCHAR'));

end;

For i:=0 to Maximum do if i mod step = 0 then

begin

end;