sbsv1/abld/e32util/h2inc.pl
changeset 607 378360dbbdba
parent 606 30b30f9da0b7
equal deleted inserted replaced
591:22486c9c7b15 607:378360dbbdba
       
     1 #!/usr/bin/perl
       
     2 # Copyright (c) 2002-2009 Nokia Corporation and/or its subsidiary(-ies).
       
     3 # All rights reserved.
       
     4 # This component and the accompanying materials are made available
       
     5 # under the terms of "Eclipse Public License v1.0"
       
     6 # which accompanies this distribution, and is available
       
     7 # at the URL "http://www.eclipse.org/legal/epl-v10.html".
       
     8 #
       
     9 # Initial Contributors:
       
    10 # Nokia Corporation - initial contribution.
       
    11 #
       
    12 # Contributors:
       
    13 #
       
    14 # Description:
       
    15 # e32toolp\e32util\h2inc.pl
       
    16 # Convert structures in C++ include files to assembler format
       
    17 # Syntax:
       
    18 # perl h2inc.pl <input.h> <output.inc> <format>
       
    19 # where <format>=arm or x86
       
    20 # 
       
    21 #
       
    22 
       
    23 # Version
       
    24 my $MajorVersion = 1;
       
    25 my $MinorVersion = 1;
       
    26 my $PatchVersion = 0;
       
    27 
       
    28 %basictypes = (
       
    29 	TInt8		=>	1,
       
    30 	TUint8		=>	1,
       
    31 	TInt16		=>	2,
       
    32 	TUint16		=>	2,
       
    33 	TInt32		=>	4,
       
    34 	TUint32		=>	4,
       
    35 	TInt		=>	4,
       
    36 	TUint		=>	4,
       
    37 	TInt64		=>	8,
       
    38 	TUint64		=>	8,
       
    39 	TLinAddr	=>	4,
       
    40 	TVersion	=>	4,
       
    41 	TPde		=>	4,
       
    42 	TPte		=>	4,
       
    43 	TProcessPriority => 4
       
    44 );
       
    45 
       
    46 if (scalar(@ARGV)!=3) {
       
    47 	die "H2INC format management tools V$MajorVersion.$MinorVersion.$PatchVersion\nperl h2inc.pl <input.h> <output.inc> <format>\n";
       
    48 }
       
    49 my ($infile, $outfile, $format) = @ARGV;
       
    50 open IN, $infile or die "Can't open $infile for input\n";
       
    51 my $in;
       
    52 while (<IN>) {
       
    53 	$in.=$_;
       
    54 }
       
    55 close IN;
       
    56 $format = uc($format);
       
    57 $format_sub = undef();
       
    58 $comment_sub = undef();
       
    59 $end_sub = undef();
       
    60 if ($format eq "ARMASM") {
       
    61 	$format_sub = \&armasm_format;
       
    62 	$comment_sub = \&armasm_comment;
       
    63 	$end_sub = \&armasm_end;
       
    64 } elsif ($format eq "AS") {
       
    65 	$format_sub = \&as_format;
       
    66 	$comment_sub = \&as_comment;
       
    67 	$end_sub = \&as_end;
       
    68 } elsif ($format eq "TASM") {
       
    69 	$format_sub = \&tasm_format;
       
    70 	$comment_sub = \&tasm_comment;
       
    71 	$end_sub = \&tasm_end;
       
    72 } else {
       
    73 	die "Format $format unknown\nOnly ARMASM, AS or TASM supported\n";
       
    74 }
       
    75 
       
    76 # First remove any backslash-newline combinations
       
    77 $in =~ s/\\\n//gms;
       
    78 
       
    79 # Change escaped quotes to double quotes
       
    80 $in =~ s/\\\"/\"\"/gms;
       
    81 $in =~ s/\\\'/\'\'/gms;
       
    82 
       
    83 # Remove any character constants
       
    84 $in =~  s/\'(.?(${0})*?)\'//gms;
       
    85 
       
    86 # Remove any string literals
       
    87 $in =~ s/\"(.*?)\"//gms;
       
    88 
       
    89 # Strip comments
       
    90 $in =~ s/\/\*(.*?)\*\//\n/gms;
       
    91 $in =~ s/\/\/(.*?)\n/\n/gms;
       
    92 
       
    93 # Collapse whitespace into a single space or newline
       
    94 $in =~ s/\t/\ /gms;
       
    95 $in =~ s/\r/\ /gms;
       
    96 $in =~ s/(\ )+/\ /gms;
       
    97 $in =~ s/\n(\ )*/\n/gms;
       
    98 $in =~ s/(\ )*\n/\n/gms;
       
    99 
       
   100 # Tokenize on non-identifier characters
       
   101 my @tokens0 = split(/(\W)/,$in);
       
   102 my @tokens;
       
   103 foreach $t (@tokens0) {
       
   104 	next if ($t eq " " or $t eq "");
       
   105 	push @tokens, $t;
       
   106 }
       
   107 
       
   108 my %macros;
       
   109 my %filescope;
       
   110 $filescope{file}=1;
       
   111 $filescope{name}='*** FILE SCOPE ***';
       
   112 my @ftypedefs;
       
   113 $filescope{typedefs}=\@ftypedefs;
       
   114 my $line=1;
       
   115 parse_scope(\%filescope, \@tokens, \$line);
       
   116 
       
   117 
       
   118 my @output;
       
   119 push @output, &$comment_sub('*' x 80);
       
   120 push @output, &$comment_sub($outfile);
       
   121 push @output, &$comment_sub('*' x 80);
       
   122 push @output, &$comment_sub("GENERATED FILE - DO NOT EDIT");
       
   123 push @output, "";
       
   124 
       
   125 output_scope(\%filescope, \@output);
       
   126 
       
   127 push @output, &$end_sub();
       
   128 push @output, "";
       
   129 
       
   130 open OUT, ">$outfile" or die "Can't open $outfile for write\n";
       
   131 print OUT join("\n", @output);
       
   132 print OUT "\n\n";
       
   133 close OUT;
       
   134 
       
   135 sub get_token($$) {
       
   136 	my ($tokenlist,$line) = @_;
       
   137 	while (scalar(@$tokenlist)) {
       
   138 		my $t = shift @$tokenlist;
       
   139 		return $t if (!defined($t));
       
   140 		return $t if ($t !~ /^\s*$/);
       
   141 		++$$line;
       
   142 	}
       
   143 }
       
   144 
       
   145 sub skip_qualifiers($) {
       
   146 	my ($tokens) = @_;
       
   147 	my $f=0;
       
   148 	my %quals = (
       
   149 		EXPORT_C => 1,
       
   150 		IMPORT_C => 1,
       
   151 		inline => 1,
       
   152 		const => 0,
       
   153 		volatile => 0,
       
   154 		static => 0,
       
   155 		extern => 0,
       
   156 		LOCAL_C => 0,
       
   157 		LOCAL_D => 0,
       
   158 		GLDEF_C => 0,
       
   159 		GLREF_C => 0,
       
   160 		GLDEF_D => 0,
       
   161 		GLREF_D => 0
       
   162 		);
       
   163 	for (;;) {
       
   164 		my $t = $$tokens[0];
       
   165 		my $q = $quals{$t};
       
   166 		last unless (defined ($q));
       
   167 		$f |= $q;
       
   168 		shift @$tokens;
       
   169 	}
       
   170 	return $f;
       
   171 }
       
   172 
       
   173 sub parse_indirection($) {
       
   174 	my ($tokens) = @_;
       
   175 	my $level = 0;
       
   176 	for (;;) {
       
   177 		my $t = $$tokens[0];
       
   178 		if ($t eq '*') {
       
   179 			++$level;
       
   180 			shift @$tokens;
       
   181 			next;
       
   182 		}
       
   183 		last if ($t ne "const" and $t ne "volatile");
       
   184 		shift @$tokens;
       
   185 	}
       
   186 	return $level;
       
   187 }
       
   188 
       
   189 sub parse_scope($$$) {
       
   190 	my ($scope, $tokens, $line) = @_;
       
   191 	my $state = 0;
       
   192 	my %values;
       
   193 	my @classes;
       
   194 	my @enums;
       
   195 	my $curr_offset=0;
       
   196 	my $overall_align=0;
       
   197 	$scope->{values}=\%values;
       
   198 	$scope->{classes}=\@classes;
       
   199 	$scope->{enums}=\@enums;
       
   200 	while (scalar(@$tokens)) {
       
   201 		my $t = shift @$tokens;
       
   202 		if ($state>=-1 and $t eq "\n") {
       
   203 			++$$line;
       
   204 			$state=1;
       
   205 			next;
       
   206 		} elsif ($state==-1 and $t ne "\n") {
       
   207 			next;
       
   208 		} elsif ($state==-2 and $t ne ';') {
       
   209 			next;
       
   210 		}
       
   211 		if ($state>0 and $t eq '#') {
       
   212 			if ($scope->{scope}) {
       
   213 				warn "Preprocessor directive in class/struct at line $$line\n";
       
   214 			}
       
   215 			$t = shift @$tokens;
       
   216 			if ($t eq 'define') {
       
   217 				my $ident = shift @$tokens;
       
   218 				my $defn = shift @$tokens;
       
   219 				if ($defn ne '(') {	# don't do macros with parameters
       
   220 					$macros{$ident} = $defn;
       
   221 				}
       
   222 			}
       
   223 			$state=-1;	# skip to next line
       
   224 			next;
       
   225 		}
       
   226 		if ($t eq "struct" or $t eq "class") {
       
   227 			next if ($state==0);
       
   228 			$state=0;
       
   229 			my %cl;
       
   230 			$cl{specifier}=$t;
       
   231 			$cl{scope}=$scope;
       
   232 			my @members;
       
   233 			my @typedefs;
       
   234 			$cl{members}=\@members;
       
   235 			$cl{typedefs}=\@typedefs;
       
   236 			my $new_class = \%cl;
       
   237 			my $n = get_token($tokens,$line);
       
   238 			if ($n !~ /\w+/) {
       
   239 				die "Unnamed $t not supported at line $$line\n";
       
   240 			}
       
   241 			$new_class->{name}=$n;
       
   242 			my @class_match = grep {$_->{name} eq $n} @classes;
       
   243 			my $exists = scalar(@class_match);
       
   244 			my $b = get_token($tokens,$line);
       
   245 			if ($b eq ':') {
       
   246 				die "Inheritance not supported at line $$line\n";
       
   247 			} elsif ($b eq ';') {
       
   248 				# forward declaration
       
   249 				push @classes, $new_class unless ($exists);
       
   250 				next;
       
   251 			} elsif ($b ne '{') {
       
   252 				die "Syntax error at line $$line\n";
       
   253 			}
       
   254 			if ($exists) {
       
   255 				$new_class = $class_match[0];
       
   256 				if ($new_class->{complete}) {
       
   257 					die "Duplicate definition of $cl{specifier} $n\n";
       
   258 				}
       
   259 			}
       
   260 			push @classes, $new_class unless ($exists);
       
   261 			parse_scope($new_class, $tokens, $line);
       
   262 			next;
       
   263 		} elsif ($t eq "enum") {
       
   264 			$state=0;
       
   265 			my $n = get_token($tokens,$line);
       
   266 			my $name="";
       
   267 			if ($n =~ /\w+/) {
       
   268 				$name = $n;
       
   269 				$n = get_token($tokens,$line);
       
   270 			}
       
   271 			push @enums, $name;
       
   272 			if ($n ne '{') {
       
   273 				die "Syntax error at line $$line\n";
       
   274 			}
       
   275 			parse_enum($scope, $tokens, $line, $name);
       
   276 			next;
       
   277 		} elsif ($t eq '}') {
       
   278 			$state=0;
       
   279 			if ($scope->{scope}) {
       
   280 				$t = get_token($tokens,$line);
       
   281 				if ($t eq ';') {
       
   282 					$scope->{complete}=1;
       
   283 					last;
       
   284 				}
       
   285 			}
       
   286 			die "Syntax error at line $$line\n";
       
   287 		}
       
   288 		$state=0;
       
   289 		if ($scope->{scope}) {
       
   290 			if ($t eq "public" or $t eq "private" or $t eq "protected") {
       
   291 				if (shift (@$tokens) eq ':') {
       
   292 					next;	# ignore access specifiers
       
   293 				}
       
   294 			die "Syntax error at line $$line\n";
       
   295 			}
       
   296 		}
       
   297 		unshift @$tokens, $t;
       
   298 		my @currdecl = parse_decl_def($scope, $tokens, $line);
       
   299 		if ($t eq 'static') {
       
   300 			next;	# skip static members
       
   301 		}
       
   302 		my $typedef;
       
   303 		if ($t eq 'typedef') {
       
   304 			$typedef = 1;
       
   305 			$t = shift @currdecl;
       
   306 			$t = $currdecl[0];
       
   307 		} else {
       
   308 			$typedef = 0;
       
   309 		}
       
   310 		next if (scalar(@currdecl)==0);
       
   311 		if ($t eq "const") {
       
   312 			# check for constant declaration
       
   313 			my $ctype = lookup_type($scope, $currdecl[1]);
       
   314 			if ($ctype->{basic} and $currdecl[2]=~/^\w+$/ and $currdecl[3] eq '=') {
       
   315 				if ($typedef!=0) {
       
   316 					die "Syntax error at line $$line\n";
       
   317 				}
       
   318 				shift @currdecl;
       
   319 				shift @currdecl;
       
   320 				my $type = $ctype->{name};
       
   321 				my $name = shift @currdecl;
       
   322 				my $size = $ctype->{size};
       
   323 				shift @currdecl;
       
   324 				my $value = get_constant_expr($scope,\@currdecl,$line);
       
   325 				$values{$name} = {type=>$type, size=>$size, value=>$value};
       
   326 				next;
       
   327 			}
       
   328 		}
       
   329 		if (skip_qualifiers(\@currdecl)!=0 or ($scope->{file} and !$typedef)) {
       
   330 			next;	# function declaration or stuff at file scope
       
   331 		}
       
   332 		my $type1 = shift @currdecl;	# type, type pointed to or return type
       
   333 		if ($type1 !~ /^\w+$/) {
       
   334 			die "Syntax error at line $$line\n";
       
   335 		}
       
   336 		my $ind1 = parse_indirection(\@currdecl);
       
   337 		my $ident;	# identifier being declared
       
   338 		my $size = -1;
       
   339 		my $array = -1;
       
   340 		my $align = 0;
       
   341 		my $alias;
       
   342 		my $category;
       
   343 		if ($currdecl[0] eq '(' and $currdecl[1] eq '*' and $currdecl[2]=~/^\w+$/) {
       
   344 			# function pointer
       
   345 			$ident = $currdecl[2];
       
   346 			$size = 4;
       
   347 			$category = 'fptr';
       
   348 			shift @currdecl;
       
   349 			shift @currdecl;
       
   350 			shift @currdecl;
       
   351 		} elsif ($currdecl[0]=~/^\w+$/) {
       
   352 			$ident = shift @currdecl;
       
   353 			if ($currdecl[0] ne '(') {
       
   354 				# not function declaration
       
   355 				if ($ind1>0) {
       
   356 					# pointer
       
   357 					$category = 'ptr';
       
   358 					$size = 4;
       
   359 				} else {
       
   360 					my $type2 = lookup_type($scope, $type1);
       
   361 					if (!defined($type2)) {
       
   362 						die "Unrecognised type $type1 at line $$line\n";
       
   363 					}
       
   364 					if ($type2->{basic}) {
       
   365 						$alias = $type2->{name};
       
   366 						$size = $type2->{size};
       
   367 						$category = 'basic';
       
   368 					} elsif ($type2->{enum}) {
       
   369 						$alias = $type2->{name};
       
   370 						$category = 'enum';
       
   371 						$size = 4;
       
   372 					} elsif ($type2->{class}) {
       
   373 						$alias = $type2->{name};
       
   374 						$size = $type2->{class}->{size};
       
   375 						$category = 'class';
       
   376 						$align = $type2->{class}->{align};
       
   377 					} elsif ($type->{ptr}) {
       
   378 						$size = 4;
       
   379 						$category = 'ptr';
       
   380 						$align = 4;
       
   381 					} elsif ($type->{fptr}) {
       
   382 						$size = 4;
       
   383 						$category = 'ptr';
       
   384 						$align = 4;
       
   385 					}
       
   386 				}
       
   387 			}
       
   388 		}
       
   389 		if ($size>0) {
       
   390 			# data member declared
       
   391 			# check for array
       
   392 			if ($currdecl[0] eq '[') {
       
   393 				shift @currdecl;
       
   394 				$array = get_constant_expr($scope, \@currdecl, $line);
       
   395 				if ($array<=0) {
       
   396 					die "Bad array size at line $$line\n";
       
   397 				}
       
   398 				if ($currdecl[0] ne ']') {
       
   399 					die "Syntax error at line $$line\n";
       
   400 				}
       
   401 			}
       
   402 			my $members = $scope->{members};
       
   403 			my $typedefs = $scope->{typedefs};
       
   404 			if ($align==0) {
       
   405 				$align = $size;
       
   406 			}
       
   407 			my $am = $align-1;
       
   408 			unless ($typedef) {
       
   409 				my $al = $curr_offset & $am;
       
   410 				if ($align==8 and $al!=0) {
       
   411 					die "Bad alignment of 64-bit data $ident at line $$line\n";
       
   412 				}
       
   413 				$curr_offset += ($align-$al) if ($al!=0);
       
   414 			}
       
   415 			if ($array>0) {
       
   416 				$size = ($size + $am) &~ $am;
       
   417 				if ($typedef) {
       
   418 					push @$typedefs, {name=>$ident, category=>$category, alias=>$alias, size=>$size*$array, spacing=>$size, array=>$array};
       
   419 				} else {
       
   420 					push @$members, {name=>$ident, size=>$size*$array, offset=>$curr_offset, spacing=>$size};
       
   421 				}
       
   422 				$size *= $array;
       
   423 			} else {
       
   424 				if ($typedef) {
       
   425 					push @$typedefs, {name=>$ident, category=>$category, alias=>$alias, size=>$size};
       
   426 				} else {
       
   427 					push @$members, {name=>$ident, size=>$size, offset=>$curr_offset};
       
   428 				}
       
   429 			}
       
   430 			unless ($typedef) {
       
   431 				$curr_offset += $size;
       
   432 				if ($align > $overall_align) {
       
   433 					$overall_align = $align;
       
   434 				}
       
   435 			}
       
   436 		}
       
   437 	}
       
   438 	if ($scope->{scope}) {
       
   439 		if ($state==-2) {
       
   440 			die "Missing ; at end of file\n";
       
   441 		}
       
   442 		if (!$scope->{complete}) {
       
   443 			die "Unexpected end of file at line $$line\n";
       
   444 		}
       
   445 		my $total_size = ($curr_offset + $overall_align - 1) &~ ($overall_align - 1);
       
   446 		$scope->{size} = $total_size;
       
   447 		$scope->{align} = $overall_align;
       
   448 	}
       
   449 }
       
   450 
       
   451 sub get_operand($$$) {
       
   452 	my ($scope,$tokens,$line) = @_;
       
   453 	my $t = get_token($tokens,$line);
       
   454 	if ($t eq '-') {
       
   455 		my $x = get_operand($scope,$tokens,$line);
       
   456 		return -$x;
       
   457 	} elsif ($t eq '+') {
       
   458 		my $x = get_operand($scope,$tokens,$line);
       
   459 		return $x;
       
   460 	} elsif ($t eq '~') {
       
   461 		my $x = get_operand($scope,$tokens,$line);
       
   462 		return ~$x;
       
   463 	} elsif ($t eq '!') {
       
   464 		my $x = get_operand($scope,$tokens,$line);
       
   465 		return $x ? 0 : 1;
       
   466 	} elsif ($t eq '(') {
       
   467 		my $x = get_constant_expr($scope,$tokens,$line);
       
   468 		my $t = get_token($tokens,$line);
       
   469 		if ($t ne ')') {
       
   470 			die "Missing ) at line $$line\n";
       
   471 		}
       
   472 		return $x;
       
   473 	} elsif ($t eq "sizeof") {
       
   474 		my $ident = get_token($tokens,$line);
       
   475 		if ($ident eq '(') {
       
   476 			$ident = get_token($tokens,$line);
       
   477 			my $cb = get_token($tokens,$line);
       
   478 			if ($cb ne ')') {
       
   479 				die "Bad sizeof() syntax at line $$line\n";
       
   480 			}
       
   481 		}
       
   482 		$ident = look_through_macros($ident);
       
   483 		if ($ident !~ /^\w+$/) {
       
   484 			die "Bad sizeof() syntax at line $$line\n";
       
   485 		}
       
   486 		my $type = lookup_type($scope, $ident);
       
   487 		if (!defined $type) {
       
   488 			die "Unrecognised type $ident at line $$line\n";
       
   489 		}
       
   490 		if ($type->{basic}) {
       
   491 			return $type->{size};
       
   492 		} elsif ($type->{enum}) {
       
   493 			return 4;
       
   494 		} elsif ($type->{ptr}) {
       
   495 			return 4;
       
   496 		} elsif ($type->{fptr}) {
       
   497 			return 4;
       
   498 		}
       
   499 		my $al = $type->{class}->{align};
       
   500 		my $sz = $type->{class}->{size};
       
   501 		return ($sz+$al-1)&~($al-1);
       
   502 	}
       
   503 	$t = look_through_macros($t);
       
   504 	if ($t =~ /^0x[0-9a-f]+/i) {
       
   505 		return oct($t);
       
   506 	} elsif ($t =~ /^\d/) {
       
   507 		return $t;
       
   508 	} elsif ($t =~ /^\w+$/) {
       
   509 		my $x = lookup_value($scope,$t);
       
   510 		die "Unrecognised identifier '$t' at line $$line\n" unless defined($x);
       
   511 		return $x;
       
   512 	} else {
       
   513 		die "Syntax error at line $$line\n";
       
   514 	}
       
   515 }
       
   516 
       
   517 sub look_through_macros($) {
       
   518 	my ($ident) = @_;
       
   519 	while ($ident and $macros{$ident}) {
       
   520 		$ident = $macros{$ident};
       
   521 	}
       
   522 	return $ident;
       
   523 }
       
   524 
       
   525 sub lookup_value($$) {
       
   526 	my ($scope,$ident) = @_;
       
   527 	while ($scope) {
       
   528 		my $vl = $scope->{values};
       
   529 		if (defined($vl->{$ident})) {
       
   530 			return $vl->{$ident}->{value};
       
   531 		}
       
   532 		$scope = $scope->{scope};
       
   533 	}
       
   534 	return undef();
       
   535 }
       
   536 
       
   537 sub lookup_type($$) {
       
   538 	my ($scope,$ident) = @_;
       
   539 	if ($basictypes{$ident}) {
       
   540 		return {scope=>$scope, basic=>1, name=>$ident, size=>$basictypes{$ident} };
       
   541 	}
       
   542 	while ($scope) {
       
   543 		if ($basictypes{$ident}) {
       
   544 			return {scope=>$scope, basic=>1, name=>$ident, size=>$basictypes{$ident} };
       
   545 		}
       
   546 		my $el = $scope->{enums};
       
   547 		my $cl = $scope->{classes};
       
   548 		my $td = $scope->{typedefs};
       
   549 		if (grep {$_ eq $ident} @$el) {
       
   550 			return {scope=>$scope, enum=>1, name=>$ident, size=>4 };
       
   551 		}
       
   552 		my @match_class = (grep {$_->{name} eq $ident} @$cl);
       
   553 		if (scalar(@match_class)) {
       
   554 			return {scope=>$scope, class=>$match_class[0]};
       
   555 		}
       
   556 		my @match_td = (grep {$_->{name} eq $ident} @$td);
       
   557 		if (scalar(@match_td)) {
       
   558 			my $tdr = $match_td[0];
       
   559 			my $cat = $tdr->{category};
       
   560 			if ($cat eq 'basic' or $cat eq 'enum' or $cat eq 'class') {
       
   561 				$ident = $tdr->{alias};
       
   562 				next;
       
   563 			} else {
       
   564 				return { scope=>$scope, $cat=>1, $size=>$tdr->{size} };
       
   565 			}
       
   566 		}
       
   567 		$scope = $scope->{scope};
       
   568 	}
       
   569 	return undef();
       
   570 }
       
   571 
       
   572 sub get_mult_expr($$$) {
       
   573 	my ($scope,$tokens,$line) = @_;
       
   574 	my $x = get_operand($scope,$tokens,$line);
       
   575 	my $t;
       
   576 	for (;;) {
       
   577 		$t = get_token($tokens,$line);
       
   578 		if ($t eq '*') {
       
   579 			my $y = get_operand($scope,$tokens,$line);
       
   580 			$x = $x * $y;
       
   581 		} elsif ($t eq '/') {
       
   582 			my $y = get_operand($scope,$tokens,$line);
       
   583 			$x = int($x / $y);
       
   584 		} elsif ($t eq '%') {
       
   585 			my $y = get_operand($scope,$tokens,$line);
       
   586 			$x = int($x % $y);
       
   587 		} else {
       
   588 			last;
       
   589 		}
       
   590 	}
       
   591 	unshift @$tokens, $t;
       
   592 	return $x;
       
   593 }
       
   594 
       
   595 sub get_add_expr($$$) {
       
   596 	my ($scope,$tokens,$line) = @_;
       
   597 	my $x = get_mult_expr($scope,$tokens,$line);
       
   598 	my $t;
       
   599 	for (;;) {
       
   600 		$t = get_token($tokens,$line);
       
   601 		if ($t eq '+') {
       
   602 			my $y = get_mult_expr($scope,$tokens,$line);
       
   603 			$x = $x + $y;
       
   604 		} elsif ($t eq '-') {
       
   605 			my $y = get_mult_expr($scope,$tokens,$line);
       
   606 			$x = $x - $y;
       
   607 		} else {
       
   608 			last;
       
   609 		}
       
   610 	}
       
   611 	unshift @$tokens, $t;
       
   612 	return $x;
       
   613 }
       
   614 
       
   615 sub get_shift_expr($$$) {
       
   616 	my ($scope,$tokens,$line) = @_;
       
   617 	my $x = get_add_expr($scope,$tokens,$line);
       
   618 	my $t, $t2;
       
   619 	for (;;) {
       
   620 		$t = get_token($tokens,$line);
       
   621 		if ($t eq '<' or $t eq '>') {
       
   622 			$t2 = get_token($tokens,$line);
       
   623 			if ($t2 ne $t) {
       
   624 				unshift @$tokens, $t2;
       
   625 				last;
       
   626 			}
       
   627 		}
       
   628 		if ($t eq '<') {
       
   629 			my $y = get_add_expr($scope,$tokens,$line);
       
   630 			$x = $x << $y;
       
   631 		} elsif ($t eq '>') {
       
   632 			my $y = get_add_expr($scope,$tokens,$line);
       
   633 			$x = $x >> $y;
       
   634 		} else {
       
   635 			last;
       
   636 		}
       
   637 	}
       
   638 	unshift @$tokens, $t;
       
   639 	return $x;
       
   640 }
       
   641 
       
   642 sub get_and_expr($$$) {
       
   643 	my ($scope,$tokens,$line) = @_;
       
   644 	my $x = get_shift_expr($scope,$tokens,$line);
       
   645 	my $t;
       
   646 	for (;;) {
       
   647 		$t = get_token($tokens,$line);
       
   648 		if ($t eq '&') {
       
   649 			my $y = get_shift_expr($scope,$tokens,$line);
       
   650 			$x = $x & $y;
       
   651 		} else {
       
   652 			last;
       
   653 		}
       
   654 	}
       
   655 	unshift @$tokens, $t;
       
   656 	return $x;
       
   657 }
       
   658 
       
   659 sub get_xor_expr($$$) {
       
   660 	my ($scope,$tokens,$line) = @_;
       
   661 	my $x = get_and_expr($scope,$tokens,$line);
       
   662 	my $t;
       
   663 	for (;;) {
       
   664 		$t = get_token($tokens,$line);
       
   665 		if ($t eq '^') {
       
   666 			my $y = get_and_expr($scope,$tokens,$line);
       
   667 			$x = $x ^ $y;
       
   668 		} else {
       
   669 			last;
       
   670 		}
       
   671 	}
       
   672 	unshift @$tokens, $t;
       
   673 	return $x;
       
   674 }
       
   675 
       
   676 sub get_ior_expr($$$) {
       
   677 	my ($scope,$tokens,$line) = @_;
       
   678 	my $x = get_xor_expr($scope,$tokens,$line);
       
   679 	my $t;
       
   680 	for (;;) {
       
   681 		$t = get_token($tokens,$line);
       
   682 		if ($t eq '|') {
       
   683 			my $y = get_xor_expr($scope,$tokens,$line);
       
   684 			$x = $x | $y;
       
   685 		} else {
       
   686 			last;
       
   687 		}
       
   688 	}
       
   689 	unshift @$tokens, $t;
       
   690 	return $x;
       
   691 }
       
   692 
       
   693 sub get_constant_expr($$$) {
       
   694 	my ($scope,$tokens,$line) = @_;
       
   695 	my $x = get_ior_expr($scope,$tokens,$line);
       
   696 	return $x;
       
   697 }
       
   698 
       
   699 sub parse_enum($$$$) {
       
   700 	my ($scope,$tokens,$line,$enum_name) = @_;
       
   701 	my $vl = $scope->{values};
       
   702 	my $x = 0;
       
   703 	for (;;) {
       
   704 		my $t = get_token($tokens,$line);
       
   705 		last if ($t eq '}');
       
   706 		if (!defined($t)) {
       
   707 			die "Unexpected end of file at line $$line\n";
       
   708 		}
       
   709 		if ($t !~ /^\w+$/) {
       
   710 			die "Syntax error at line $$line\n";
       
   711 		}
       
   712 		if (defined($vl->{$t})) {
       
   713 			die "Duplicate identifier at line $$line\n";
       
   714 		}
       
   715 		my $t2 = get_token($tokens,$line);
       
   716 		if ($t2 eq ',') {
       
   717 			$vl->{$t} = {type=>$enum_name, size=>4, value=>$x, enum=>1};
       
   718 			++$x;
       
   719 		} elsif ($t2 eq '}') {
       
   720 			$vl->{$t} = {type=>$enum_name, size=>4, value=>$x, enum=>1};
       
   721 			++$x;
       
   722 			last;
       
   723 		} elsif ($t2 eq '=') {
       
   724 			$x = get_constant_expr($scope, $tokens, $line);
       
   725 			$vl->{$t} = {type=>$enum_name, size=>4, value=>$x, enum=>1};
       
   726 			++$x;
       
   727 			$t2 = get_token($tokens,$line);
       
   728 			last if ($t2 eq '}');
       
   729 			next if ($t2 eq ',');
       
   730 			die "Syntax error at line $$line\n";
       
   731 		} else {
       
   732 			unshift @$tokens, $t2;
       
   733 		}
       
   734 	}
       
   735 	my $t = get_token($tokens,$line);
       
   736 	if ($t ne ';') {
       
   737 		die "Missing ; at line $$line\n";
       
   738 	}
       
   739 }
       
   740 
       
   741 sub parse_decl_def($$$) {
       
   742 	my ($scope,$tokens,$line) = @_;
       
   743 	my $level=0;
       
   744 	my @decl;
       
   745 	while ( scalar(@$tokens) ) {
       
   746 		my $t = get_token($tokens, $line);
       
   747 		if ($t eq ';' and $level==0) {
       
   748 			return @decl;
       
   749 		}
       
   750 		push @decl, $t;
       
   751 		if ($t eq '{') {
       
   752 			++$level;
       
   753 		}
       
   754 		if ($t eq '}') {
       
   755 			if ($level==0) {
       
   756 				die "Syntax error at line $$line\n";
       
   757 			}
       
   758 			if (--$level==0) {
       
   759 				return ();	# end of function definition reached
       
   760 			}
       
   761 		}
       
   762 	}
       
   763 	die "Unexpected end of file at line $$line\n";
       
   764 }
       
   765 
       
   766 sub dump_scope($) {
       
   767 	my ($scope) = @_;
       
   768 	my $el = $scope->{enums};
       
   769 	my $cl = $scope->{classes};
       
   770 	my $vl = $scope->{values};
       
   771 	print "SCOPE: $scope->{name}\n";
       
   772 	if (scalar(@$el)) {
       
   773 		print "\tenums:\n";
       
   774 		foreach (@$el) {
       
   775 			print "\t\t$_\n";
       
   776 		}
       
   777 	}
       
   778 	if (scalar(keys(%$vl))) {
       
   779 		print "\tvalues:\n";
       
   780 		foreach $vname (keys(%$vl)) {
       
   781 			my $v = $vl->{$vname};
       
   782 			my $x = $v->{value};
       
   783 			my $t = $v->{type};
       
   784 			my $sz = $v->{size};
       
   785 			if ($v->{enum}) {
       
   786 				print "\t\t$vname\=$x (enum $t) size=$sz\n";
       
   787 			} else {
       
   788 				print "\t\t$vname\=$x (type $t) size=$sz\n";
       
   789 			}
       
   790 		}
       
   791 	}
       
   792 	if ($scope->{scope}) {
       
   793 		my $members = $scope->{members};
       
   794 		foreach (@$members) {
       
   795 			my $n = $_->{name};
       
   796 			my $sz = $_->{size};
       
   797 			my $off = $_->{offset};
       
   798 			my $spc = $_->{spacing};
       
   799 			if (defined $spc) {
       
   800 				print "\t$n\[\]\: spacing $spc size $sz offset $off\n";
       
   801 			} else {
       
   802 				print "\t$n\: size $sz offset $off\n";
       
   803 			}
       
   804 		}
       
   805 		print "\tOverall size : $scope->{size}\n";
       
   806 		print "\tOverall align: $scope->{align}\n";
       
   807 	}
       
   808 	foreach $s (@$cl) {
       
   809 		dump_scope($s);
       
   810 	}
       
   811 }
       
   812 
       
   813 sub output_scope($$) {
       
   814 	my ($scope, $out) = @_;
       
   815 	my $el = $scope->{enums};
       
   816 	my $cl = $scope->{classes};
       
   817 	my $vl = $scope->{values};
       
   818 	my $sn = scope_full_name($scope);
       
   819 	my $sp = ($scope->{file}) ? "" : $sn."_";
       
   820 	if ($scope->{file}) {
       
   821 		push @$out, "";
       
   822 		push @$out, &$comment_sub("FILE SCOPE");
       
   823 		push @$out, "";
       
   824 	} else {
       
   825 		push @$out, "";
       
   826 		push @$out, &$comment_sub($scope->{specifier}." ".$scope->{name});
       
   827 		push @$out, "";
       
   828 	}
       
   829 	if (scalar(keys(%$vl))) {
       
   830 		foreach $vname (keys(%$vl)) {
       
   831 			my $v = $vl->{$vname};
       
   832 			my $x = $v->{value};
       
   833 			my $t = $v->{type};
       
   834 			my $sz = $v->{size};
       
   835 			push @$out, &$format_sub($sp.$vname, $x);
       
   836 		}
       
   837 	}
       
   838 	if ($scope->{scope}) {
       
   839 		my $members = $scope->{members};
       
   840 		foreach (@$members) {
       
   841 			my $n = $_->{name};
       
   842 			my $sz = $_->{size};
       
   843 			my $off = $_->{offset};
       
   844 			my $spc = $_->{spacing};
       
   845 			push @$out, &$format_sub($sp.$n, $off);
       
   846 			if (defined $spc) {
       
   847 				push @$out, &$format_sub($sp.$n."_spc", $spc);
       
   848 			}
       
   849 		}
       
   850 		push @$out, &$format_sub($sp."sz", $scope->{size});
       
   851 	}
       
   852 	foreach $s (@$cl) {
       
   853 		if ($s->{complete})	{
       
   854 			output_scope($s, $out);
       
   855 		}
       
   856 	}
       
   857 }
       
   858 
       
   859 sub scope_full_name($) {
       
   860 	my ($scope) = @_;
       
   861 	if ($scope->{file}) {
       
   862 		return "";
       
   863 	}
       
   864 	my $parent = $scope->{scope};
       
   865 	if ($parent->{file}) {
       
   866 		return $scope->{name};
       
   867 	}
       
   868 	return scope_full_name($parent)."_".$scope->{name};
       
   869 }
       
   870 
       
   871 sub pad($$) {
       
   872 	my ($lineref, $n) = @_;
       
   873 	my $l = length ($$lineref);
       
   874 	if ($l < $n) {
       
   875 		$$lineref .= ' 'x($n-$l);
       
   876 	}
       
   877 }
       
   878 
       
   879 #
       
   880 # Subroutines for ARMASM compatible output
       
   881 #
       
   882 sub armasm_format($$;$) {
       
   883 	my ($name, $value, $comment) = @_;
       
   884 	my $r = "$name ";
       
   885 	pad(\$r, 40);
       
   886 	$r .= sprintf("EQU 0x%08x", $value & 0xFFFFFFFF);
       
   887 	if ($comment and $comment!~/^\s*$/) {
       
   888 		$r .= " ";
       
   889 		pad(\$r, 60);
       
   890 		$r .= "; $comment";
       
   891 	}
       
   892 	return $r;
       
   893 }
       
   894 
       
   895 sub armasm_comment($) {
       
   896 	my ($comment) = @_;
       
   897 	return "; $comment";
       
   898 }
       
   899 
       
   900 sub armasm_end() {
       
   901 	return "\n\tEND\n";
       
   902 }
       
   903 
       
   904 #
       
   905 # Subroutines for GNU AS compatible output
       
   906 #
       
   907 sub as_format($$;$) {
       
   908 	my ($name, $value, $comment) = @_;
       
   909 	my $r = "    .equ $name, ";
       
   910 	pad(\$r, 50);
       
   911 	$r .= sprintf("0x%08x", $value & 0xFFFFFFFF);
       
   912 	if ($comment and $comment!~/^\s*$/) {
       
   913 		$r .= " ";
       
   914 		pad(\$r, 65);
       
   915 		$r .= "/* $comment */";
       
   916 	}
       
   917 	return $r;
       
   918 }
       
   919 
       
   920 sub as_comment($) {
       
   921 	my ($comment) = @_;
       
   922 	if (length ($comment) > 0) {
       
   923 		return "/* $comment */";
       
   924 	} else {
       
   925 		return "";
       
   926 	}
       
   927 }
       
   928 
       
   929 sub as_end() {
       
   930 	return "";
       
   931 }
       
   932 
       
   933 #
       
   934 # Subroutines for Turbo Assembler compatible output
       
   935 #
       
   936 sub tasm_format($$;$) {
       
   937 	my ($name, $value, $comment) = @_;
       
   938 	my $r = "$name ";
       
   939 	pad(\$r, 40);
       
   940 	$r .= sprintf("EQU 0%08xh", $value & 0xFFFFFFFF);
       
   941 	if ($comment and $comment!~/^\s*$/) {
       
   942 		$r .= " ";
       
   943 		pad(\$r, 60);
       
   944 		$r .= "; $comment";
       
   945 	}
       
   946 	return $r;
       
   947 }
       
   948 
       
   949 sub tasm_comment($) {
       
   950 	my ($comment) = @_;
       
   951 	return "; $comment";
       
   952 }
       
   953 
       
   954 sub tasm_end() {
       
   955 	return "";
       
   956 }