Newsgroup: it.comp.lang.pascal
Titolo: [LONG] Il Grande Ritorno del Razziatore

Ciao a tutti!
Per anni, visto la qualita del news server ti telecom ( 
news.tin.it
 ) ho 
usato server gratuiti prima di una universita tedesca, poi per un po' ho 
usato 
news.x-privat.org
 ma da quando è diventato a pagamento non 
scrivevo più... beh ora sono tornato alle origini ( 
news.tin.it
 )... 
magari non è il massimo ma... almeno sono tornato a scrivere.
Tremate gente, Il Razziatore è tornarato! ( E sono qui per restarci :D )
Come piccolo regalino... un piccolo scheduler scritto per un mio amico ( 
che voleva capirne il funzionamento ). Non utlizza l'interupt del 
orologgio, ma è facilmente modificabile per farlo. Spero di fare cosa 
gradita.
--------------
uses Crt, Dos, uLib;
const
	MAX_TASKS  = 3;
	STACK_SIZE = $100;
	DELAY_TIME = 300;
type
	PTaskPtr = ^TTaskPtr;
	TTaskPtr = Procedure;
	PTask		= ^TTask;
	TTask		= Record
		TaskPtr  : PTaskPtr; { Puntatore al processo }
		StackPtr : Pointer;	 { Cima dello stack del processo }
	end;
var
	TaskList	: Array[ 0..MAX_TASKS ] of PTask;
	TaskCount	: Word;
	CurentTask	: Integer;
	{ Variabili locali }
	TaskIP		: Word;    { AddTask: IP dell'inzio del task }
	OldStackPtr : Pointer; { AddTask: Vecchia coppia SS:SP }
	NewStackPtr : Pointer; { AddTask: Nuova coppia SS:SP }
procedure Scheduler_Init;
var I : Word;
begin
	WriteLn;
	Write( 'Scheduler init...' );
	TaskCount := 0;
	CurentTask := -1;
	for I := 0 to MAX_TASKS do
		TaskList[ I ] := Nil;
	WriteLn( 'done!' );
end;
function Scheduler_AddTask( TaskPtr : PTaskPtr ) : Boolean;
var result : boolean;
begin
	Write( 'Adding Task( ', IntToHex( PtrSeg( TaskPtr ) ), ':', IntToHex( 
PtrOfs( TaskPtr ) ), ' )...' );
	if ( TaskCount < MAX_TASKS) then begin
		New( TaskList[ TaskCount ] );
		GetMem( NewStackPtr, STACK_SIZE );
		TaskList[ TaskCount ]^.TaskPtr := TaskPtr;
		TaskIP := PtrOfs( TaskPtr );
		asm
			PUSH	BP
			{ Mi salvo un SS:SP dentro OldStack }
			MOV		WORD PTR [ OldStackPtr + 0 ], SP
			MOV		WORD PTR [ OldStackPtr + 2 ], SS
			{ Attivo il mio stack }
			MOV		AX, WORD PTR [ NewStackPtr + 0 ]
			MOV		BX, WORD PTR [ NewStackPtr + 2 ]
			MOV		SP, AX
			MOV		SS, BX
			ADD		SP, STACK_SIZE
			{ Preparo lo stack del Task per lo scheduler }
			PUSH	[ TaskIP ] { Fingo una chiamata al Task }
			PUSH	BP
			MOV		BP, SP
			PUSHA   { Salvo i registri }
			{ Mi salvo un SS:SP dentro NewStackPtr }
			MOV		WORD PTR [ NewStackPtr + 0 ], SP
			MOV		WORD PTR [ NewStackPtr + 2 ], SS
			{ Rimetto le cose a posto }
			MOV		SP, WORD PTR [ OldStackPtr + 0 ]
			MOV		SS, WORD PTR [ OldStackPtr + 2 ]
			POP		BP
		end;
		TaskList[ TaskCount ]^.StackPtr := NewStackPtr;
		Inc( TaskCount );
		WriteLn( 'done!' );
		Result := True;
	end else begin
		WriteLn( 'error!' );
		Result := False;
	end;
	Scheduler_AddTask := Result;
end;
procedure Scheduler_Start;
begin
	CurentTask  := 0;
	TaskIP		:= PtrOfs( TaskList[ CurentTask ]^.TaskPtr );
	NewStackPtr	:= TaskList[ CurentTask ]^.StackPtr;
	asm
		{ Attivo il mio stack }
		MOV		AX, WORD PTR [ NewStackPtr + 0 ]
		MOV		BX, WORD PTR [ NewStackPtr + 2 ]
		MOV		SP, AX
		MOV		SS, BX
		{ Eseguo il task }
		JMP		[ TaskIP ]
	end;
end;
{$S-}
procedure Scheduler_NextTask;
begin
	asm
		PUSHA
		{ Mi salvo un SS:SP dentro OldStack }
		MOV WORD PTR [ OldStackPtr + 0 ], SP
		MOV WORD PTR [ OldStackPtr + 2 ], SS
	end;
	TaskList[ CurentTask ]^.StackPtr := OldStackPtr;
	CurentTask := ( CurentTask + 1 ) MOD TaskCount;
	NewStackPtr := TaskList[ CurentTask ]^.StackPtr;
	asm
		{ Rimetto le cose a posto }
		MOV SP, WORD PTR [ NewStackPtr + 0 ]
		MOV SS, WORD PTR [ NewStackPtr + 2 ]
		POPA
	end;
end;
{$S+}
{$S-}
procedure TaskA;
var C : Byte;
begin
	Write( 'SA ' );
	C := 0;
	while True do begin
		Write( 'LA ' );
		if C > 6 then begin
			WriteLn;
			WriteLn('Scheduler shutdown...done!' );
			WriteLn;
			Write('Press ANY key to exit...'); ReadKey;
			WriteLn;
			Halt;
		end	else begin
			Delay( DELAY_TIME );
			Scheduler_NextTask; { Do il controllo a B }
			Inc( C );
		end;
	end;
end;
procedure TaskB;
begin
	Write( 'SB ' );
	while True do begin
		write( 'LB ' );
		Delay( DELAY_TIME );
		Scheduler_NextTask; { Do il controllo a C }
	end;
end;
procedure TaskC;
begin
	Write( 'SC ' );
	while True do begin
		write( 'LC ' );
		Delay( DELAY_TIME );
		Scheduler_NextTask; { Do il controllo a A }
	end;
end;
procedure TaskD;
begin
	Write( 'SD ' );
	while True do begin
		write( 'LD ' );
		Delay( DELAY_TIME );
		Scheduler_NextTask; { Do il controllo a A }
	end;
end;
{$S+}
begin
	Scheduler_Init;
	Scheduler_AddTask( @TaskA );
	Scheduler_AddTask( @TaskB );
	Scheduler_AddTask( @TaskC );
	Scheduler_AddTask( @TaskD );
	Scheduler_Start;
	ReadLn;
end.
----------------
Unit uLib;
{$S-}
interface
	function IntToHex( n : Word ) : string;
	function PtrSeg( P : Pointer ) : word;
	function PtrOfs( P : Pointer ) : word;
implementation
	function IntToHex( n : Word ) : string;
		const Alfabeto : array[0..$F] of char = (
			'0', '1', '2', '3',
			'4', '5', '6', '7',
			'8', '9', 'A', 'B',
			'C', 'D', 'E', 'F'
		);
	    var Result : string[4];
	begin
		result := '';
		result := result + alfabeto[ Hi( n ) shr  4 ];
		result := result + alfabeto[ Hi( n ) and $F ];
		result := result + alfabeto[ Lo( n ) shr  4 ];
		result := result + alfabeto[ Lo( n ) and $F ];
		intToHex := result;
	end;
	function PtrSeg( P : Pointer ) : word; assembler;
	asm
		PUSH	ES
		PUSH	DI
		LES		DI, P
		MOV		AX, ES
		POP		DI
		POP		ES
	end;
	function PtrOfs( P : Pointer ) : word; assembler;
	asm
		PUSH	ES
		LES		AX, P
		POP		ES
	end;
end.
-------------------------------
( PS: Vi piace come riotrno? :D )
-- 
Il Razziatore,
The Only Good Windows is an uninstalled Windows
-----------------------------------------------
MSN   : 
IlRazz...@netscape.net
ICQ   : 67552596
Yhaoo : Razziatore82
-----------------------------------------------
Founder of MediaPlayer Project
http://mpp.iwebland.com

 ( PS: Vi piace come riotrno? :D )
AMMAZZAAAAAAAAAA :D ciao Razzia! ;)
:"):")
-- 
______________________________
  Omega
 
http://gnammo.altervista.org
¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯

 ( PS: Vi piace come riotrno? :D )
Geniale!   Razziatore che torna dopo anni e nulla è cambiato :-)
Ancora è digi-dislessico e posta enormi blocchi di codice senza senso!
Il mio idolo, infine. Ora nulla può arrestare il grande ritorno del
Pascal, del Turbo Pascal!, a livelli mai visti prima, unico e sommo
linguaggio di programmazione universale!!
--
Dreadnaut - 
http://dreadnaut.altervista.org/
( Life would be easier if I had the source code )

 Ancora è digi-dislessico e posta enormi blocchi di codice senza senso!
"Enormi blocchi di codice senza senso!" Uhmm mi potrei anche offendere 
:( il mio scheduler non ti è piaciuto? :'(


 :( il mio scheduler non ti è piaciuto? :'(
hahaha ammetto di non averlo letto con molta attenzione. Ti rendo però 
felice avvisandoti dell'email che mi e' arrivata da x-privat: alcune 
gerarchie sono nuovamente accessibili via server gratuito! Indovina quale?
è tempo di riattivare Xnews :)
-- 
Dreadnaut - 
http://dreadnaut.altervista.org/
(Life would be easier if I had the source code)