Re: Ein bisschen Assembler

Halllo Andreas,

Dein Programmcode lädt also dynamisch eine DLL.
richtig!

Er implementiert eine Routine save_variable die etwas mit
den Integer-Variablen new_ bzw. saved_eax, _ebx und _ecx
anfängt.
Ja, Zwischenspeicherung.
EAX für FloatToDecimal -> Digits
EBX für den Fließomma-Anteil -> Exponent
ECX habe ich für reversed Anteil gespeichert

movl $3, %eax
movl %eax, -4(%ebp) -> lokale Variabel,

mov [ebp-4], eax ...
so wie es ein echter Compiler machen würde.
BTW: Parameter einer Funktion werden so
geschrieben:
mov [ebp+4], eax -> siehe "subl $16, %esp"
(stack pointer)

Was ist PRG.EXE, und wie wurde der Assembler-Code produziert?
im Prinzip ganz einfach:

--schnipp
%{
// ----------------------------------------------------------------------------
// Yacc pcode.y
// (c) 2003 by Jens Kallup
//
// Parser Definitionen für den mBASE Interpreter ...
// ----------------------------------------------------------------------------
unit pcode;

interface
uses
YaccLib, YaccBase, YaccMsgs, WinCrt,
Windows,Dialogs,SysUtils, Classes, Forms, mBASEexception, Variablen,
StrUtils, Math,Contnrs, KlassenElemente, HilfsFunktionen,
Functions, Graphics;

var
exit_popl : Boolean = false;
expr_token : String;

fltodec: TFloatRec;

current_variable: String;
yystage : Word = 1;
yytoken : String;
yyfilename: String;
yyvalue: Extended;

last_op : String;

num_str, ident_str: String;

tmp_int: Integer = 1;
yyin_procedure : Integer;
tmpstr: string;
val_count : Integer = 0;
data_counter: Integer = 0;
label_count : Integer = 0;
call_proc : String;
mov_label : Integer = 4;

if_counter: Integer;
withsymbolstr: String;

ident_str_counter: Integer = 0;
has_emit : Boolean = true;
end_command : Boolean = false;
local_vars : Integer = 0;
inproc: Boolean = false;
t: Integer;
s: String;

fgc,bgc: TColor;
tColorArray : Array[0..15] of TColor;

const TLOCAL = 1;
TPARAM1 = 2; TPARAM2 = 4;
TPROC = 3;

const SVT_ADD = 1;

type
lbl = record
value: Extended;
ip_expr: String;
yytoken: String;
else_label, end_label: Integer;

expr_lab: Integer;
expr_tok: String;
last_op:char;

saved_expr: Byte;

tmp_int: Integer;
tmp_bool: Boolean;
end;


procedure parse_code(fn: String; mode: Boolean);
procedure FreeParserMemory;

procedure set_farbe(x,y,col,fg,bg: Integer); forward;
procedure con_writeln(S: String); forward;

procedure check_debug;

function skip_white_space: Char; forward;
function scan_num: Integer; forward;

var
new_label: Integer;

function handle_color(val: Word): Word;


var
debug_modus: Boolean = true;

found: Boolean;
c: Char;
tmp_token,s1,s2: String;
i,i2,pa_id: Integer;

fg_color: Integer;
bg_color: Integer;

function reverse_forward(s: String): String;

%}

%type <lbl>

%token ID
%token NUMBER TOK_IPEXPR
%token TOK_IF TOK_ELSE TOK_ENDIF TOK_TESTCALL TOK_LOCAL
%token TOK_SET TOK_ON TOK_OFF TOK_GET TOK_SELECT TOK_USE TOK_EXCLUSIVE
%token TOK_CONSOLE TOK_CLS TOK_SAY TOK_COLOR TOK_DISPLAY
%token TOK_MONO TOK_MONO43 TOK_EGA25 TOK_EGA43 TOK_VGA43 TOK_VGA50 TOK_VGA25
%token TOK_PROCEDURE TOK_RETURN TOK_BREAK
%token TOK_DOS TOK_WINDOWS TOK_CODEPAGE
%token TOK_DO TOK_WHILE TOK_ENDDO TOK_FOR TOK_TO TOK_NEXT TOK_STEP TOK_EXIT
%token TOK_SPACE TOK_WITH TOK_ENDWITH
%token TOK_CLASS TOK_OF TOK_ENDCLASS TOK_NEW
%token EXPR_SIN EXPR_COS
%token TOKEN TOK_FALSE TOK_TRUE

%token LITERAL LITID
%token ILLEGAL

%left '*' '/'
%left '+' '-'

%start lines

%%

lines
: /* empty */
| lines line
;

line
:
| TOK_PROCEDURE ident_str {
code_segment := code_segment + #9 + '.text' + CR;
code_segment := code_segment + '.globl _' + $<lbl>2.yytoken + CR + '_' +
$<lbl>2.yytoken + ':' + CR;
code_segment := code_segment + #9 + 'pushl' + #9 +'%ebp' + CR + #9 +
'movl' + #9+ '%esp, %ebp' + CR;

procedure_name[ploc] := $<lbl>2.yytoken;
ploc := ploc+1;
} procedure_parameter local_stmt {

code_segment := code_segment + #9 + 'subl'+#9+ '$' + inttostr(
4+(4*local_vars))
+', %esp' +CR;

mov_label := 4+(4*local_vars);

} standard_commands TOK_RETURN ident_procedure_str {

code_segment := code_segment +
#9 + 'popl' + #9 + '%ebp' + CR +
#9 + 'leave' + CR +
#9 + 'ret' + CR + CR;

pcount := 1;
local_vars := 0
}
;

ident_procedure_str
:
| NUMBER {
$<lbl>$.value := $<lbl>1.value;
}
| ident_str {
$<lbl>$.yytoken := $<lbl>1.yytoken;
$<lbl>$.value := 1;
}
;

procedure_parameter
:
| '(' procedure_parameter_id ')' {
}
;

procedure_parameter_id
: ident_str {
pcount := pcount + 1;
klassen_element.parse($<lbl>1.yytoken+'.'+procedure_name[ploc-1]+'.in').pv_count
:= pcount;
klassen_element.parse($<lbl>1.yytoken+'.'+procedure_name[ploc-1]+'.in').ttype
:= TPARAM1;
}
| procedure_parameter_id ',' procedure_parameter_id { }
;

true_or_false
: TOK_TRUE { code_segment := code_segment + #9 + 'spush ".t."' + CR; }
| TOK_FALSE { code_segment := code_segment + #9 + 'spush ".f."' + CR; }
;

local_stmt
:
| TOK_LOCAL locals
;

locals
: ident_str {
klassen_element.parse($<lbl>1.yytoken+'.'+procedure_name[ploc-1]+'.in').lv_count
:= local_vars;
local_vars := local_vars + 1;

klassen_element.parse($<lbl>1.yytoken + '.' + procedure_name[ploc-1] +
'.in').TTYPE := TPARAM2;
klassen_element.parse($<lbl>1.yytoken + '.' + procedure_name[ploc-1] +
'.in').lv_count := local_vars;
}
| locals ',' locals
;

standard_commands
:
| standard_commands std_command
;

ident_stmt
: ident_str '=' {
variable_name := $<lbl>1.yytoken;
} expr_stmt {
klassen_element.parse($<lbl>1.yytoken + '.' +
procedure_name[ploc-1]+'.in').value := $<lbl>3.value;
}
;

std_command
:
| ident_stmt
| for_stat
| if_stat
| set_stmt
| TOK_CLS {
code_segment := code_segment + #9 + 'call @cls' + CR;
}
| '@' expr_stmt ',' expr_stmt TOK_SAY ident_str color_token {
set_farbe(
round($<lbl>2.value),
round($<lbl>4.value),
round($<lbl>7.value), round(fg_color),round(bg_color));
con_writeln($<lbl>6.yytoken);
}
| '@' expr_stmt ',' expr_stmt TOK_SAY string_token color_token {
set_farbe(
round($<lbl>2.value),
round($<lbl>4.value),
round($<lbl>7.value), round(fg_color),round(bg_color));
con_writeln($<lbl>6.yytoken);
}
| do_stmt
;

ident_liste
:
| ident_str {
klassen_element.parse($<lbl>1.yytoken + '.' + procedure_name[ploc-1] +
'.in').para := true;

if inproc = true then
begin
klassen_element.parse($<lbl>1.yytoken+'.'+procedure_name[ploc-1] +
'.in').para := true;
end;
}
| ident_liste ',' ident_liste
;

do_stmt
:
| TOK_DO ident_str {

}
| TOK_DO ident_str '(' expr_stmt ')' {
call_proc := $<lbl>2.yytoken;

for i := 0 to
klassen_element.parse(procedure_name[ploc-1]+'.in').GetSubElementCount-1 do
begin
showmessage(klassen_element.parse(procedure_name[ploc-1]+'.in').GetSubElement(i).Fname);
end;

// klassen_element.parse('para'+inttostr(1)+'.'+$<lbl>2.yytoken +
'.in').value :=
//
klassen_element.parse('para'+inttostr(1)+'.'+$<lbl>2.yytoken+'.in').value;

showmessage('X: '+klassen_element.parse($<lbl>2.yytoken + '.in').fname);
showmessage('Z: '+#10+klassen_element.getasstring);

inproc := false;
}
;

set_stmt
: TOK_SET set_types
;

set_types
: codepage_set
| console_set
| display_set
| exclusive_set
;

codepage_set
: TOK_CODEPAGE TOK_TO windows_dos_codepage {
code_segment := code_segment + #9 + 'npush ';

if $<lbl>3.value = 0 then
code_segment := code_segment + '0' + CR else
code_segment := code_segment + '1' + CR;

code_segment := code_segment + 'call @set_codepage' + CR;
}
;

windows_dos_codepage
: TOK_DOS { $<lbl>$.value := 0; }
| TOK_WINDOWS { $<lbl>$.value := 1; }
;

exclusive_set
: TOK_EXCLUSIVE TOK_ON { }
| TOK_EXCLUSIVE TOK_OFF { }
;

console_set
: TOK_CONSOLE on_off_stmt {
(*
if $<lbl>2.value = 0 then
begin
ConsoleWindow.Free;
code_segment := code_segment + #9 + 'pushl' + #9 + '$0';
end else
begin
code_segment := code_segment + 'pushl' + #9 + '$1';

if not Assigned(ConsoleWindow) then
ConsoleWindow := TConsoleWindow.Create(Application);
SetForegroundWindow(ConsoleWindow.Handle);
end;
code_segment := code_segment + #9 + 'call' + #9 + '@set_tconole' + CR;
*)
}
;

on_off_stmt
: TOK_ON { $<lbl>$.value := 1; }
| TOK_OFF { $<lbl>$.value := 0; }
;

display_set
: TOK_DISPLAY TOK_TO display_set_mode {
code_segment := code_segment + #9 + 'npush ' + FloatToStr($<lbl>3.value)
+ CR +
'call @set_display' + CR;
}
;

display_set_mode
: TOK_MONO { $<lbl>$.value := 0; }
| TOK_COLOR { $<lbl>$.value := 1; }
| TOK_EGA25 { $<lbl>$.value := 2; }
| TOK_EGA43 { $<lbl>$.value := 3; }
| TOK_MONO43 { $<lbl>$.value := 4; }
| TOK_VGA25 { $<lbl>$.value := 5; }
| TOK_VGA43 { $<lbl>$.value := 6; }
| TOK_VGA50 { $<lbl>$.value := 7; }
;

color_token
: { $<lbl>$.value := 7; }
| TOK_COLOR str_color { $<lbl>$.value := $<lbl>2.value; }
;

str_color
: ident_str '/' ident_str {
s := LowerCase($<lbl>1.yytoken);

if s = 'n' then fg_color := 0 else
if s = 'b' then fg_color := 1 else
if s = 'g' then fg_color := 2 else
if s = 'gb' then fg_color := 3 else
if s = 'r' then fg_color := 4 else
if s = 'rb' then fg_color := 5 else
if s = 'rg' then fg_color := 6 else
if s = 'w' then fg_color := 7 else
if s = 'y' then fg_color := 14;

s := LowerCase($<lbl>3.yytoken);

if s = 'n' then bg_color := 0 else
if s = 'b' then bg_color := 1 else
if s = 'g' then bg_color := 2 else
if s = 'gb' then bg_color := 3 else
if s = 'r' then bg_color := 4 else
if s = 'rb' then bg_color := 5 else
if s = 'rg' then bg_color := 6 else
if s = 'w' then bg_color := 7 else
if s = 'y' then bg_color := 14;

$<lbl>$.value := (16*bg_color) + fg_color;
}
| ident_str '+' '/' ident_str '+' {
s := LowerCase($<lbl>1.yytoken);

if s = 'n' then fg_color := 8 else
if s = 'b' then fg_color := 9 else
if s = 'g' then fg_color := 10 else
if s = 'gb' then fg_color := 11 else
if s = 'r' then fg_color := 12 else
if s = 'rb' then fg_color := 13 else
if s = 'y' then fg_color := 14 else
if s = 'w' then fg_color := 15;

s := LowerCase($<lbl>4.yytoken);

if s = 'n' then bg_color := 8 else
if s = 'b' then bg_color := 9 else
if s = 'g' then bg_color := 10 else
if s = 'gb' then bg_color := 11 else
if s = 'r' then bg_color := 12 else
if s = 'rb' then bg_color := 13 else
if s = 'y' then bg_color := 14 else
if s = 'w' then bg_color := 15;

$<lbl>$.value := (16*bg_color) + fg_color;
}
| ident_str '+' '/' ident_str {
s := LowerCase($<lbl>1.yytoken);

if s = 'n' then fg_color := 8 else
if s = 'b' then fg_color := 9 else
if s = 'g' then fg_color := 10 else
if s = 'gb' then fg_color := 11 else
if s = 'r' then fg_color := 12 else
if s = 'rb' then fg_color := 13 else
if s = 'y' then fg_color := 14 else
if s = 'w' then fg_color := 15;

s := LowerCase($<lbl>4.yytoken);

if s = 'n' then bg_color := 0 else
if s = 'b' then bg_color := 1 else
if s = 'g' then bg_color := 2 else
if s = 'gb' then bg_color := 3 else
if s = 'r' then bg_color := 4 else
if s = 'rb' then bg_color := 5 else
if s = 'rg' then bg_color := 6 else
if s = 'w' then bg_color := 7 else
if s = 'y' then bg_color := 14;

$<lbl>$.value := (16*bg_color) + fg_color;
}
| ident_str '/' ident_str '+' {
s := LowerCase($<lbl>1.yytoken);

if s = 'n' then fg_color := 0 else
if s = 'b' then fg_color := 1 else
if s = 'g' then fg_color := 2 else
if s = 'gb' then fg_color := 3 else
if s = 'r' then fg_color := 4 else
if s = 'rb' then fg_color := 5 else
if s = 'rg' then fg_color := 6 else
if s = 'w' then fg_color := 7 else
if s = 'y' then fg_color := 14;

s := LowerCase($<lbl>3.yytoken);

if s = 'n' then bg_color := 8 else
if s = 'b' then bg_color := 9 else
if s = 'g' then bg_color := 10 else
if s = 'gb' then bg_color := 11 else
if s = 'r' then bg_color := 12 else
if s = 'rb' then bg_color := 13 else
if s = 'y' then bg_color := 14 else
if s = 'w' then bg_color := 15;

$<lbl>$.value := (16*bg_color) + fg_color;
}
| ident_str '+' {
s := LowerCase($<lbl>1.yytoken);

if s = 'n' then bg_color := 8 else
if s = 'b' then fg_color := 9 else
if s = 'g' then fg_color := 10 else
if s = 'gb' then fg_color := 11 else
if s = 'r' then fg_color := 12 else
if s = 'rb' then fg_color := 13 else
if s = 'y' then fg_color := 14 else
if s = 'w' then fg_color := 15;

$<lbl>$.value := fg_color;
}
| ident_str {
s := LowerCase($<lbl>1.yytoken);

if s = 'n' then fg_color := 0 else
if s = 'b' then fg_color := 1 else
if s = 'g' then fg_color := 2 else
if s = 'gb' then fg_color := 3 else
if s = 'r' then fg_color := 4 else
if s = 'rb' then fg_color := 5 else
if s = 'rg' then fg_color := 6 else
if s = 'w' then fg_color := 7 else
if s = 'y' then fg_color := 14;

$<lbl>$.value := fg_color;
}
;

ident_str
: ID { $<lbl>$.yytoken := yytoken; }
;

string_token
: string_line {
$<lbl>$.yytoken := $<lbl>1.yytoken;
}
| TOK_SPACE '(' expr_stmt ')' {
code_segment := code_segment + #9 + 'call @space' + CR;

//$<lbl>$.yytoken := 'space ( @ev ' + floattostr($<lbl>3.expr_lab) + ' )
';
}
| string_token '+' string_token {
code_segment := code_segment + #9 + 'strsub' + CR;

//$<lbl>$.yytoken := $<lbl>1.yytoken + ' + ' + $<lbl>3.yytoken;
}
;

string_line
: '"' {
tmp_token := '';
repeat
code_stream[file_no].Read(c,1);
case c of
#10,#13:
begin
yyerror('Zeichenkette nicht korrekt abgeschlossen.');
exit;
end;

'"':
begin
$<lbl>$.yytoken := tmp_token;
break;
end

else begin
tmp_token := tmp_token + c;
end;
end;
until c = '"';
yytoken := tmp_token;
}
;

expr_stmt
: expr {
$<lbl>$.value := $<lbl>1.value;

//showmessage(procedure_name[ploc-1]+#10+
//variable_name + '.' + procedure_name[ploc-1]+'.in'+#10+'-->'+#10 +
klassen_element.getasstring);
}
;

expr
: NUMBER {
$<lbl>$.value := $<lbl>1.value;
klassen_element.parse(variable_name + '.' +
procedure_name[ploc-1]+'.in').value := $<lbl>1.value;

v1 := $<lbl>1.value;
FloatToDecimal(fltodec,v1,fvextended,10,10);

code_segment := code_segment + #9 + 'movl' + #9 + '$' + fltodec.digits
+', %eax' + CR;
code_segment := code_segment + #9 + 'movl' + #9 + '%eax, ' +
inttostr(0-klassen_element.parse(variable_name + '.' +
procedure_name[ploc-1]+'.in').lv_count * 4) + '(%ebp)' + CR;
code_segment := code_segment + #9 + 'movl' + #9+ '$' +
inttostr(fltodec.exponent) +', %ebx'+CR;
code_segment := code_segment + #9 + 'movl' + #9 + '%ebx, ' +
inttostr(0-klassen_element.parse(variable_name + '.' +
procedure_name[ploc-1]+'.in').lv_count * 4) + '(%ebp)' + CR;

code_segment := code_segment + #9 + 'movl' + #9 + '$' +
inttostr(klassen_element.parse(variable_name +
'.' + procedure_name[ploc-1]+'.in').lv_count * 4)+', %ecx' + CR ;
code_segment := code_segment + #9 + 'call' + #9 + '_save_variable' +
CR+CR;
}
| ident_str {
data_segment := data_segment + '.globl _' + $<lbl>1.yytoken + CR + '_' +
$<lbl>1.yytoken + ':' + CR + '.long 0'+CR;
code_segment := code_segment + #9 + 'movl'+#9 + '_' + $<lbl>1.yytoken +
', %eax' + CR;

v1 := klassen_element.parse(variable_name + '.' +
procedure_name[ploc-1]+'.in').value;
FloatToDecimal(fltodec,v1,fvextended,10,10);

if fltodec.exponent = 0 then v1 := 1 else
FloatToDecimal(fltodec,v1,fvextended,10,10);

code_segment := code_segment + #9 + 'movl' + #9 + '%eax, ' +
inttostr(0-klassen_element.parse(variable_name + '.' +
procedure_name[ploc-1]+'.in').lv_count * 4) + '(%ebp)' + CR;

code_segment := code_segment + #9 + 'movl' + #9 + '$' + floattostr(v1) +
', %ebx' + CR;
code_segment := code_segment + #9 + 'movl' + #9 + '%ebx, ' +
inttostr(0-klassen_element.parse(variable_name + '.' +
procedure_name[ploc-1]+'.in').lv_count * 4) + '(%ebp)' + CR;
code_segment := code_segment + #9 + 'movl' + #9 + '$' +
inttostr(klassen_element.parse(variable_name +
'.' + procedure_name[ploc-1]+'.in').lv_count * 4)+', %ecx' + CR ;

code_segment := code_segment + #9 + 'call' + #9 + '_save_variable' +
CR+CR;
}
| expr '+' expr {
$<lbl>$.value := $<lbl>1.value + $<lbl>3.value;

klassen_element.parse(variable_name + '.' +
procedure_name[ploc-1]+'.in').value :=
$<lbl>1.value + $<lbl>3.value;

//code_segment := code_segment + 'add' + CR;
}
| expr '-' expr {
$<lbl>$.value := $<lbl>1.value - $<lbl>3.value;

klassen_element.parse(variable_name + '.' +
procedure_name[ploc-1]+'.in').value :=
$<lbl>1.value - $<lbl>3.value;

code_segment := code_segment + 'sub' + CR;
}
| expr '/' expr {
$<lbl>$.value := $<lbl>1.value / $<lbl>3.value;

klassen_element.parse(variable_name + '.' +
procedure_name[ploc-1]+'.in').value :=
$<lbl>1.value / $<lbl>3.value;

code_segment := code_segment + #9 + 'div' + CR;
}
| expr '*' expr {
$<lbl>$.value := $<lbl>1.value * $<lbl>3.value;
klassen_element.parse(variable_name + '.' +
procedure_name[ploc-1]+'.in').value :=
$<lbl>1.value * $<lbl>3.value;

code_segment := code_segment + 'mul' + floattostr($<lbl>1.value) +
floattostr($<lbl>3.value) + CR;
}
;

%%

function skip_white_space: char;
label agge, skip_start;
var
in_comment: Integer;
pos: Integer;
begin
in_comment := 0;
pos := 1;
repeat
skip_start:
code_stream[file_no].Read(c,1);
case c of
#32,
#9: begin inc(pos); end;

'/': begin
code_stream[file_no].Read(c,1);
inc(pos);
case c of
'/': begin
// ShowMessage('C++ comment in line:' + IntToStr(line_no));
repeat
code_stream[file_no].Read(c,1);
if c = #0 then skip_white_space := #0;
until c = #13;

{IFDEF MSWINDOWS}
code_stream[file_no].Read(c,1);
{ENDIF}
inc(line_no);
end;

'*': begin
// ShowMessage('C comment in line: ' + IntToStr(line_no));
inc(in_comment);
agge:
repeat
code_stream[file_no].Read(c,1);
if code_stream[file_no].Position = code_stream[file_no].Size
then
begin
yyerror('EOF erreicht, Kommentarzeile nicht
abgeschlossen.');
skip_white_space := #0;
exit;
end;

if c = '/' then
begin
code_stream[file_no].Read(c,1);
if c = '*' then
begin
inc(in_comment);
goto agge;
end;
end;

if c = #13 then
begin
inc(line_no);
code_stream[file_no].Read(c,1);
end;
until c = '*';
code_stream[file_no].Read(c,1);
if c <> '/' then
begin
code_stream[file_no].Seek(code_stream[file_no].Position-1,soFromBeginning);
goto agge;
end;

dec(in_comment);
if in_comment > 0 then goto agge;

// ShowMessage('comment end');
end;

#32,#9,#13:
begin
pos := 1;
if c = #13 then
begin
pos := 2;
//inc(line_no);
code_stream[file_no].Read(c,1);
end;
code_stream[file_no].Seek(code_stream[file_no].Position-pos,soFromBeginning);
skip_white_space := '/';
exit;
end;

else begin
code_stream[file_no].Seek(code_stream[file_no].Position-2,soFromBeginning);
code_stream[file_no].Read(c,1);
skip_white_space := c;
exit;
end;
end;
end;

'*':
begin
code_stream[file_no].Read(c,1);
if c = '*' then
begin
repeat
code_stream[file_no].Read(c,1);
until (c = #10);
line_no := line_no + 1;
end else
begin
code_stream[file_no].Seek(-1,soFromCurrent);
skip_white_space := '*';
Exit;
end;
end;

#13: begin
inc(line_no);
code_stream[file_no].Read(c,1);
end;
else begin
skip_white_space := c;
exit;
end;
end;
until code_stream[file_no].Position = code_stream[file_no].Size;
skip_white_space := #0;
end;



function scan_num: Integer;
label end_func, hex_ende, hex_start, hex_1, hex_2, agge;
var
has_semi: Boolean;
pos, in_comment: Integer;
begin
in_comment := 0;
has_semi := false;
repeat
code_stream[file_no].Read(c,1);

case c of
'0'..'9': begin num_str := num_str + c; end;

'X','x':
begin
if has_semi = true then
begin
yyerror('parse error: (Punkt hier nicht erwartet.');
scan_num := ILLEGAL;
exit;
end;

if (num_str[1] <> '0') or (Length(num_str) > 1) then
begin
yyerror('keine Hexadezimale Schreibform eingehalten.');
scan_num := ILLEGAL;
exit;
end;

code_stream[file_no].Read(c,1);
if code_stream[file_no].Size > code_stream[file_no].Position then
begin
case c of
'0'..'9', 'a','b','c','d','e','f', 'A','B','C','D','E','F':
begin
num_str := '';
num_str := num_str + c;
//showmessage('HEX: ' + num_Str);

repeat
code_stream[file_no].Read(c,1);
case c of
#32,#13,#9:
begin
if c = #13 then
begin
code_stream[file_no].Read(c,1);
end;
goto hex_ende;
end;

'0'..'9','a','b','c','d','e','f','A','B','C','D','E','F':
begin
num_str := num_str + c;
repeat
code_stream[file_no].Read(c,1);
case c of
#32,#13,#9:
begin
if c = #13 then
begin
code_stream[file_no].Read(c,1);
end;
goto hex_ende;
end;

'0'..'9','a','b','c','d','e','f','A','B','C','D','E','F':
begin
num_str := num_str + c;
end;
else begin
code_stream[file_no].Seek(code_stream[file_no].Position-1,soFromBeginning);
goto hex_ende;
end;
end;
until code_stream[file_no].Position =
code_stream[file_no].Size;
end;
else begin
code_stream[file_no].Seek(code_stream[file_no].Position-1,soFromBeginning);
goto hex_ende;
end;
end;
until code_stream[file_no].Position =
code_stream[file_no].Size;

hex_ende:
if Length(num_str) > 8 then
begin
yyerror('Hexwert überschreitet Grenzwert');
scan_num := ILLEGAL;
exit;
end;

num_str := IntToStr(StrToInt('$' + num_str));
scan_num := NUMBER;
exit;
end;
else begin
yyerror('kein gültiger Hexwert');
scan_num := ILLEGAL;
exit;
end;
end;
end else
begin
yyerror('hexwert nicht korrekt angegeben.');
scan_num := ILLEGAL;
exit;
end;
end;

'.':
begin
if has_semi = true then
begin
yyerror('parse error (punkt hier nicht erwartet.');
scan_num := ILLEGAL;
exit;
end else
has_semi := true;
num_str := num_str + ',';
end;

(*
'.':
begin

end;

'=':
begin
yyerror('Achtung: Kein Leerzeichen in Anweisung in Zeile: ' +
InttoStr(line_no));
exit;
end;
*)
else begin
code_stream[file_no].Seek(-1,soFromCurrent);
scan_num := NUMBER;
exit;
end;
end;
until code_stream[file_no].Position = code_stream[file_no].Size;
end_func:
end;

function yylex: integer;
var
c: char;
tok, r: Integer;

function scan_ident: Integer;
begin
repeat
code_stream[file_no].Read(c,1);
case c of
'A'..'Z','a'..'z','_','0'..'9':
begin
ident_str := ident_str + c;
end;

'(',')','+','-','*','/',':',',','.','=':
begin
code_stream[file_no].Seek(code_stream[file_no].Position-1,soFromBeginning);
scan_ident := ID;
exit;
end;

#13:
begin
code_stream[file_no].Read(c,1);
inc(line_no);
scan_ident := ID;
exit;
end;

#32,#9:
begin
scan_ident := ID;
exit;
end;
else begin
scan_ident := ILLEGAL;
exit;
end;
end;
until code_stream[file_no].Position = code_stream[file_no].Size;
scan_ident := ID;
end;

var
i, nump: Integer;
tc: Char;
found: Integer;
label
ende_lab;
begin
begin
c := skip_white_space;
case c of
#0:
begin
//ShowMessage('--->>> ende parsing');

yyclearin;
yyabort;

Result := yychar;
exit;
end;

'.':
begin
code_stream[file_no].Read(c,1);

if (c = 't') or (c = 'f') then
begin
tc := c;
code_stream[file_no].Read(c,1);

if (c = '.') then
begin
yytoken := '.' + tc + '.';
found := 2;
goto ende_lab;
end else
begin
code_stream[file_no].Seek(-2,soFromCurrent);
Result := Word('.');
exit;
end;

found := 1;
end;

code_stream[file_no].Seek(-1,soFromCurrent);
Result := Word('.');
exit;

ende_lab:
Result := ID;
exit;
end;

'0'..'9':
begin
num_str := c;
tok := scan_num;

yyvalue := StrToFloat(num_str);

nump := 0;
for i := 0 to Length(num_str) do
begin
if num_str[i] = ',' then nump := nump + 1;
end;

if (nump = 0) or (nump = 1) then
begin
//ShowMessage('---> ' + num_str);
yylval.yylbl.value := StrToFloat(num_str)
end else
if nump = 3 then
begin
for i := 0 to Length(num_str) do
begin
if num_str[i] = ',' then num_str[i] := '.';
end;

tok := TOK_IPEXPR;
yylval.yylbl.ip_expr := num_str;
end else
yyerror('NUMBER PARSE ERROR');

// ShowMessage('parsed number: ' + FloatToStr(StrToFloat(num_str) +
0.01));

Result := tok;
exit; end;

'A'..'Z','a'..'z','_':
begin
ident_str := c;
tok := scan_ident;
//ShowMessage('parsed ident: "' + ident_str + '"');
ident_str := LowerCase(ident_str);

if ident_str = 'class' then r := TOK_CLASS else
if ident_str = 'endclass' then r := TOK_ENDCLASS else
if ident_str = 'new' then r := TOK_NEW else
if ident_str = 'with' then r := TOK_WITH else
if ident_str = 'endwith' then r := TOK_ENDWITH else
if ident_str = 'cls' then r := TOK_CLS else
if ident_str = 'of' then r := TOK_OF else
if ident_str = 'set' then r := TOK_SET else
if ident_str = 'off' then r := TOK_OFF else
if ident_str = 'on' then r := TOK_ON else
if ident_str = 'console' then r := TOK_CONSOLE else
if ident_str = 'color' then r := TOK_COLOR else
if ident_str = 'say' then r := TOK_SAY else
if ident_str = 'procedure' then r := TOK_PROCEDURE else
if ident_str = 'return' then r := TOK_RETURN else
if ident_str = 'select' then r := TOK_SELECT else
if ident_str = 'exclusive' then r := TOK_EXCLUSIVE else
if ident_str = 'use' then r := TOK_USE else
if ident_str = 'get' then r := TOK_GET else
if ident_str = 'if' then r := TOK_IF else
if ident_str = 'else' then r := TOK_ELSE else
if ident_str = 'endif' then r := TOK_ENDIF else
if ident_str = 'local' then r := TOK_LOCAL else
if ident_str = 'do' then r := TOK_DO else
if ident_str = 'while' then r := TOK_WHILE else
if ident_str = 'enddo' then r := TOK_ENDDO else
if ident_str = 'for' then r := TOK_FOR else
if ident_str = 'next' then r := TOK_NEXT else
if ident_str = 'step' then r := TOK_STEP else
if ident_str = 'exit' then r := TOK_EXIT else
if ident_str = 'to' then r := TOK_TO else
if ident_str = 'codepage' then r := TOK_CODEPAGE else
if ident_str = 'dos' then r := TOK_DOS else
if ident_str = 'windows' then r := TOK_WINDOWS else
if ident_str = 'space' then r := TOK_SPACE else
if ident_str = 'break' then r := TOK_BREAK else
if ident_str = 'display' then r := TOK_DISPLAY else
if ident_str = 'mono' then r := TOK_MONO else
if ident_str = 'mono43' then r := TOK_MONO43 else
if ident_str = 'ega43' then r := TOK_EGA43 else
if ident_str = 'ega25' then r := TOK_EGA25 else
if ident_str = 'vga25' then r := TOK_VGA25 else
if ident_str = 'vga43' then r := TOK_VGA43 else
if ident_str = 'vga50' then r := TOK_VGA50 else

if ident_str = 'sin' then r := EXPR_SIN else
if ident_str = 'cos' then r := EXPR_COS else

r := ID;
yytoken := ident_str;
yylex := r;
exit;
end;

else begin yylex := Word(c); exit; end;
end;
end;

yyclearin;
yyabort;

Result := yychar;
end;

procedure parse_code(fn: String; mode: Boolean);
var
i: Integer;
f: Boolean;
Begin
tColorArray[0 ] := clBlack;
tColorArray[1 ] := RGB(0,0,128);
tColorArray[2 ] := RGB(0,128,0);
tColorArray[3 ] := RGB(0,128,128);
tColorArray[4 ] := RGB(128,0,0);
tColorArray[5 ] := RGB(128,0,128);
tColorArray[6 ] := RGB(128,128,0);
tColorArray[7 ] := RGB(192,192,192);
tColorArray[8 ] := RGB(128,128,128);
tColorArray[9 ] := RGB(0,0,255);
tColorArray[10] := RGB(0,255,0);
tColorArray[11] := RGB(0,255,255);
tColorArray[12] := RGB(255,0,0);
tColorArray[13] := RGB(255,0,255);
tColorArray[14] := RGB(255,255,0);
tColorArray[15] := clWhite;

klassen_element := TKlassenElement.Create('in');
para__stk := Tstack.Create;

yyclearin;

line_no := 1;
file_no := 1;
pcount := 0;

if_counter := 1;

active_procedure := 'main';

FreeAndNil(ConsoleWindow);

tmp_var := TVarListRecord.Create;
temp_classnames := TObjectList.Create;

assignFile(yyin, fn);
Reset(yyin); if ioresult<>0 then
ShowMessage(cannot_open_file+ParamStr(1));
CloseFile(yyin);

if not Assigned(var_classes) then var_classes := TObjectList.Create;
if not Assigned(proc_offset) then proc_offset := TObjectList.Create;

call_proc := '';

code_segment := '';

new_label := 1;

yyfilename := fn;

code_stream[file_no] := TMemoryStream.Create;

try
try
// -----------------------------------------
// Lese zuerst die Datei in den Speicher ...
// -----------------------------------------
code_stream[file_no].Clear;
code_stream[file_no].LoadFromFile(fn);
code_stream[file_no].Seek(0,soFromBeginning);

// ------------------------------------
// erster Durchlauf, initialization ...
// ------------------------------------
yystage := 1;
line_no := 1;

app_variablen := TObjectList.Create;
yyparse;

Form1.Memo1.Lines.Clear;
Form1.Memo1.Lines.Text := code_segment;

except
on E:EmBASEyyerror do
begin
Form1.Show;

ShowMessage(IntToStr(E.line_no) + ': ' + E.Message);
yyclearin;
yystage := 1;
line_no := 1;

Exit;
end;
on E:EyyEndOfFile do
begin
end
else begin
ShowMessage('Fehler aufgetreten.');
Form1.Show;
raise;
end;
end;

finally
yylval.yylbl.value := 0.0;
yylval.yylbl.else_label := 0;
yylval.yylbl. end_label := 0;

FreeParserMemory;

end;
end;

procedure FreeParserMemory;
begin
{
try
para__stk.Free;
para__stk := nil;


code_stream[file_no].Free;
code_stream[file_no] := nil;

app_variablen.Free;


FreeAndNil(var_classes);
FreeAndNil(proc_offset);

FreeAndNil(parameter_container);
FreeAndNil(parameter_stack);

temp_classnames.Clear;
temp_classnames.Free;
temp_classnames := nil;
except
Showmessage('Speicherfreigabefehler');
end;
}
end;

// -------------------------------------------------------
// Function handles the foreground / background colors ...
// -------------------------------------------------------
function handle_color(val: Word): Word;
var v: Byte;
begin
case fg_color of
0: begin v := (16*val) or 8; end;
1: begin v := (16*val) or 1; end;
2: begin v := (16*val) or 2; end;
8: begin v := (16*val) or 8; end;
9: begin v := (16*val) or 9; end;
14: begin v := (16*val) or fg_color; end;
end;
Result := v;
end;


function reverse_forward(S: String): String;
begin
Result := reversestring(s);
end;

procedure con_writeln(S: String);
begin
ConsoleWindow.ColorConsole1.WriteString(s);
end;

procedure set_farbe(x,y,col,fg,bg: Integer);
begin
if Assigned(ConsoleWindow) then
begin
ConsoleWindow.ColorConsole1.Show;
ConsoleWindow.ColorConsole1.CursorTo(x,y);

fgc := tColorArray[StrToInt('$'+IntToHex(col,2)) mod 16];

if (StrToInt('$'+IntToHex(col,2)) div 16) > 16 then
bgc := tColorArray[(StrToInt('$'+IntToHex(col,2)) div 16)-16] else
bgc := tColorArray[(StrToInt('$'+IntToHex(col,2)) div 16)];

ConsoleWindow.ColorConsole1.Font.Color := fgc;
ConsoleWindow.ColorConsole1.Font.BkColor := bgc;
end;
end;

procedure check_debug;
begin
code_segment := code_segment + 'line ' + inttostr(line_no) + CR;
end;

end.
--schnapp

IMHO keinen Sinn, da baut der Compiler Schrott.
Das glaube ich nicht so recht:
Auf jede Variabel-Zuweisung kommt dan ein gespeicherter StackWert
-4(%ebp) für lokale Variablen, wenn der Code so ausschaut:

procedure main(p1,p2)
local b1, b2
b1 := 3
b2 := b1 ..
.....
Ok du erzeugst dir ein Stack-Objekt und speicherst das
übergebene eax und ebx drin.
Ähm jor

Also bitte bei jedem neu angefangenen Thread genau beschreiben:
-Was willst du erreichen
-Was hast du gemacht
-Wo ist das Problem

Ok, ich werds einen gelben Zettel an die Matschscheibe kleben

...
Grüß
Jens


.

Relevant Pages

  • Re: Excel ActiveX TextBox Question
    ... You can use the Exit event to test whether the user should be allowed ... Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) ... Then test the state of the SHIFT key: ... process the full string after the user hits "Enter". ...
    (microsoft.public.excel.misc)
  • RE: System.Diagnostics.Process() hangs
    ... you redirected output & input, then did a wait for task exit. ... exit until it writes its output, which you won't read until it exits. ... public string CreateTSUser ... SecureString securePass = new SecureString; ...
    (microsoft.public.dotnet.framework.aspnet)
  • Re: echo client/server give problems if array sizes are different
    ... memset(arrc, '\0', strlen(arrc)); ... not contain a C-style string yet. ... exit(EXIT_FAILURE); ...
    (comp.unix.programmer)
  • Re: Parse String
    ... it picking up substrings beginning with 'f' followed by hyphens, ... Function gnaf(s As String) As Variant ... Exit Do 'inner Do ... Loop ...
    (microsoft.public.excel.programming)
  • diff. between exit 0 and 1
    ... Can someone explains me whats the difference between exit 1 and exit 0 ... manpage says " The only universally recognized values for EXPR are "0" ...
    (perl.beginners)