Symaptic: os/kernelhwsrv/kerneltest/e32utils/trace/btracevw.pl@260cb5ec6c19

1 #

     2 # Copyright (c) 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 the License "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 #

    17 #!/usr/bin/perl

    19 use File::Find;

    20 use File::Spec::Functions;

    23 	my $TraceFileName;

    25 	my $PrintFlagFilePos = 0;

    26 	my $PrintFlagHdrLen = 0;

    27 	my $PrintFlagHdrFlags = 0;

    28 	my $PrintFlagFormatString = 0;

    29 	my $VerboseMode = 0;

    30 	my $RawMode = 0;

    31 	my $FormatIdIsSubCategory = 0;

    32 	my $OutputSawDictionaryMode = 0;

    34 	# for the category range 0-191, the format string is indexed by the category & subcategory

    35 	%FormatTables =

    36 		(

    37 		0 => 			# ERDebugPrintf

    38 			{

    39 			0 => "ThreadId %h, %s",

    40 			},

    42 		1 => 			# ERKernPrintf

    43 			{

    44 			0 => "ThreadId %h, %s",

    45 			},

    47 		3 =>			# EThreadIdentification

    48 			{

    49 			0 => "ENanoThreadCreate, NThread %x",

    50 			1 => "ENanoThreadDestroy, NThread %x",

    51 			2 => "EThreadCreate, NThread %x, DProcess %x, name %s",

    52 			3 => "EThreadDestroy, NThread %x, DProcess %x, Id %x",

    53 			4 => "EThreadName, NThread %x, DProcess %x, name %s",

    54 			5 => "EProcessName, NThread %x, DProcess %x, name %s",

    55 			6 => "EThreadId, NThread %x, DProcess %x, Id %x",

    56 			7 => "EProcessCreate, DProcess %x",

    57 			8 => "EProcessDestroy, DProcess %x",

    58 			},

    59 		);

    61 	my @typedefs;

    62 	my @members;

    63 	my %values	= (

    64 #		UTF::KInitialClientFormat		=>	{type=>"TFormatId", size=>2, value=>512}

    65 		KMaxTUint8						=> {type=>"TUint8", size=>1, value=>255},

    66 		KMaxTUint16						=> {type=>"TUint16", size=>2, value=>65535}

    67 	);

    68 	my %macros;

    69 	my @classes;

    70 	my @enums;

    71 	my %formatStrings;		# each enum may have it's own format string

    72 	my %formatCategories;	# each enum may have it's own format category

    74 	my %filescope;

    75 	$filescope{file}=1;

    76 	undef $filescope{name};

    78 	$filescope{typedefs}=\@typedefs;

    79 	$filescope{members}=\@members;

    80 	$filescope{values}=\%values;

    81 	$filescope{macros} = \%macros;

    82 	$filescope{FormatTables} = \%FormatTables;

    84 	$filescope{classes} = \@classes;

    85 	$filescope{enums} = \@enums;

    87 	$filescope{formatStrings} =\%formatStrings;

    88 	$filescope{formatCategories} = \%formatCategories;

    92 	if (@ARGV == 0)

    93   		{

    94   		print "BTraceVw.pl \n";

    95   		print "An unsupported utility which extracts UTrace-style format-strings\n";

    96   		print "from header files & uses these to decode a BTrace output file\n";

    97   		print "Syntax : BTraceVw.pl [-v] [-r] [-sd] [-i <IncFilePath>] [<BTrace file>]\n";

    98   		print "where  : -v  = verbose mode\n";

    99   		print "       : -r  = raw output mode\n";

   100   		print "       : -sd = produce SAW trace viewer dictionary file\n";

   101   		print "       :       this file then needs to be merged into the 'com.symbian.analysis.trace.ui.prefs' file\n";

   102   		print "       :       located under the carbide workspace directory\n";

   103 		print "\n";

   105 		print "e.g. (this decodes a trace file & produces a comma-separated output file) : \n";

   106 		print "btracevw.pl -i /os/kernelhwsrv/userlibandfileserver/fileserver/inc/f32tracedef.h -i /os/kernelhwsrv/userlibandfileserver/fileserver/inc/utraceefsrv.h -i /os/kernelhwsrv/userlibandfileserver/fileserver/inc/utraceefile.h trace.utf >trace.csv\n";

   107 		print "\n";

   108 		print "e.g. (this overwrites the SAW dictioany file) : \n";

   109 		print "btracevw.pl -sd -i /os/kernelhwsrv/userlibandfileserver/fileserver/inc/f32tracedef.h -i /os/kernelhwsrv/userlibandfileserver/fileserver/inc/utraceefsrv.h -i /os/kernelhwsrv/userlibandfileserver/fileserver/inc/utraceefile.h >com.symbian.analysis.trace.ui.prefs\n";

   111 		exit;

   112 		}

   114 	while (@ARGV > 0)

   115 		{

   117 		if ($ARGV[0] eq "-i")

   118 	        {

   119 	        shift @ARGV;

   120 		    ($FilePath) = @ARGV;

   121 	        shift @ARGV;

   123 	        undef @incFiles;

   124 		    @incFiles;

   126 		    find sub { push @incFiles, $File::Find::name if m/\.h$/i;}, $FilePath ;

   127 		    foreach $incFile (@incFiles)

   128 		        {

   129 				H2Trace($incFile, \%filescope);

   130 		        }

   131 	        }

   132 		elsif ($ARGV[0] eq "-r")

   133 	        {

   134 		    $RawMode = 1;

   135    	        shift @ARGV;

   136 	        }

   137 		elsif ($ARGV[0] eq "-sd")

   138 	        {

   139 		    $OutputSawDictionaryMode = 1;

   140    	        shift @ARGV;

   141 	        }

   142 		elsif ($ARGV[0] eq "-v")

   143 	        {

   144 		    $VerboseMode = 1;

   145    	        shift @ARGV;

   146 	        }

   147 	    else

   148 	    	{

   149 			$TraceFileName = "$ARGV[0]";

   150 	        shift @ARGV;

   151 	    	}

   152         }

   154 	if ($VerboseMode)

   155 		{

   156 		dump_scope(\%filescope);

   157 		PrintFormatTables(\%FormatTables);

   158 		}

   159 	if ($OutputSawDictionaryMode)

   160 		{

   161 		OutputSawDictionary(\%FormatTables);

   162 		}

   164     if (defined ($TraceFileName))

   165         {

   166         ReadTraceFile($RawMode);

   167         }

   172 sub ReadTraceFile($)

   173     {

   174 	(my $RawMode) = @_;

   175 #	print "Trace file is $TraceFileName, RawMode $RawMode, VerboseMode $VerboseMode\n\n";

   177 	open (LOGFILE, "<$TraceFileName") or die "Can't open $TraceFileName: $!\n";

   178 	binmode (LOGFILE);

   180 	my $val = 0;

   183 	# enum TFlags from e32btrace.h

   184 	$EHeader2Present	= 1<<0;

   185 	$ETimestampPresent	= 1<<1;

   186 	$ETimestamp2Present	= 1<<2;

   187 	$EContextIdPresent	= 1<<3;

   188 	$EPcPresent			= 1<<4;

   189 	$EExtraPresent		= 1<<5;

   190 	$ERecordTruncated	= 1<<6;

   191 	$EMissingRecord		= 1<<7;

   193 	# enum TFlags2 from e32btrace.h

   194 	$EMultipartFlagMask	= 3<<0;

   195 	$ECpuIdMask			= 0xfff<<20;

   197 	# enum TMultiPart from e32btrace.h

   198 	$EMultipartFirst	= 1;

   199 	$EMultipartMiddle	= 2;

   200 	$EMultipartLast		= 3;

   202 	$EMaxBTraceDataArray = 80;

   204 	# enum TCategory from e32btrace.h

   205 	$EThreadIdentification = 3;

   207 	# enum TThreadIdentification from e32btrace.h

   208 	$EThreadCreate = 2;

   209 	$EThreadName = 4;

   210 	$EProcessName = 5;

   211 	$EThreadId = 6;

   213 	# Context Id bits from e32btrace.h

   214 	$EContextIdMask = 0x00000003;

   215 	$EContextIdThread = 0;

   216 	$EContextIdFIQ = 0x1;

   217 	$EContextIdIRQ = 0x2;

   218 	$EContextIdIDFC = 0x3;

   220 	# enum TClassificationRange from e32btraceu.h

   221 	$EAllRangeFirst = 192;

   222 	$EAllRangeLast = 222;

   224 	%TCategoryIdToString =

   225 		(

   226 		0 => "ERDebugPrintf",

   227 		1 => "EKernPrintf",

   228 		2 => "EPlatsecPrintf",

   229 		3 => "EThreadIdentification",

   230 		4 => "ECpuUsage",

   231         5 => "EKernPerfLog",

   232         6 => "EClientServer",

   233         7 => "ERequests",

   234         8 => "EChunks",

   235         9 => "ECodeSegs",

   236 		10 => "EPaging",

   237 		11 => "EThreadPriority",

   238 		12 => "EPagingMedia",

   239 		13 => "EKernelMemory",

   240 		14 => "EHeap",

   241 		15 => "EMetaTrace",

   242 		16 => "ERamAllocator",

   243 		17 => "EFastMutex",

   244 		18 => "EProfiling",

   245         19 => "EResourceManager",

   246         20 => "EResourceManagerUs",

   247 		21 => "ERawEvent ",

   248 		128 => "EPlatformSpecificFirst",

   249 		191 => "EPlatformSpecificLast",

   250 		192 => "ESymbianExtentionsFirst",

   252 		# UTrace "ALL" range

   253 		192 => "EPanic",

   254 		193 => "EError",

   255 		194 => "EWarning",

   256 		195 => "EBorder",

   257 		196 => "EState",

   258 		197 => "EInternals",

   259 		198 => "EDump",

   260 		199 => "EFlow",

   261 		200 => "ESystemCharacteristicMetrics",

   262 		201 => "EAdhoc",

   264 		253 => "ESymbianExtentionsLast",

   265 		254 => "ETest1",

   266 		255 => "ETest2",

   267 		);

   270 	%ProcessNames;

   271 	%ThreadNames;

   272 	%ThreadIds;

   275 	# print column titles

   276 	if ($PrintFlagFilePos) {printf "FilePos, ";}	# col #0

   277 	if ($PrintFlagHdrLen) {	printf "Len, ";}		# col #1

   278 	if ($PrintFlagHdrFlags) {printf "Flags, "; }	# col #2

   279 	printf "Category, ";			# col #3

   280 	printf "TimeStamp, ";			# col #4

   281 	printf "Delta, ";				# col #5

   282 	printf "context Id, ";			# col #6

   283 	printf "PC, ";					# col #7

   284 	printf "UID, ";					# col #8

   285 	if ($PrintFlagFormatString){printf "Format string, ";}	# col #9

   286 	printf "Formatted text, ";		# col #10

   287 	print "\n\n";

   290 	while (1)

   291 		{

   292 		my $pos = tell (LOGFILE);

   294 		# print file pos (col #0)

   295 		if ($PrintFlagFilePos){	printf ("0x%08X, ", $pos);}

   297 		my $category;

   298 		my $subCategory;

   299 		my $multipartFlags = 0;

   300 		my $recordData = "";

   301 		my $recordLen;

   302 		my $recordPos = 0;

   304 		$recordLen = ReadRecord(LOGFILE, \$pos, \$recordData, \$category, \$subCategory, \$multipartFlags, $RawMode);

   305 		if ($recordLen == -1)

   306 			{last;}

   309 		if (!$RawMode && ($multipartFlags == $EMultipartMiddle || $multipartFlags == $EMultipartLast))

   310 			{next;}

   312 #		print record contents

   313 #		my $buf;

   314 #					for (my $i=0; $i < $recordLen; $i+=4)

   315 #						{

   316 #		$buf.= sprintf ("%08X ", unpack("V", substr($recordData, $recordPos+$i, 4)));

   317 #						}

   318 #		printf "\n[$buf\n]";

   321 		# for UTrace "ALL" range, read UID

   322 		if ($category >= $EAllRangeFirst && $category <= $EAllRangeLast &&

   323 			(!$RawMode) && $multipartFlags != $EMultipartMiddle && $multipartFlags != $EMultipartLast)

   324 			{

   325 			$uid = unpack("V", substr($recordData, $recordPos, 4));

   326 			$recordPos+= 4;

   328 			# then read formatID

   329 			$FormatIdIsSubCategory = ($subCategory != 0) ? 1 : 0;

   330 			if ($FormatIdIsSubCategory)

   331 				{

   332 				$formatId = $subCategory

   333 				}

   334 			else

   335 				{

   336 				$formatId = unpack("V", substr($recordData, $recordPos, 4));

   337   				$recordPos+= 4;

   338 				}

   339 			}

   342 		# print UID (col #8)

   343 		printf "0x%08X, ", $uid;

   346 		my $formatTable;

   347 		my $formatString;

   348 		if ($category >= $EAllRangeFirst && $category <= $EAllRangeLast)

   349 			{

   350 			$formatString = $FormatTables{$uid}{$formatId};

   351 			}

   352 		else

   353 			{

   354 			$formatString = $FormatTables{$category}{$subCategory};

   355 			}

   358 		# Get thread names

   359 		if ($category == $EThreadIdentification)

   360 			{

   361 			if ($subCategory == $EProcessName)

   362 				{

   363 				my $process = unpack("V", substr($recordData, 4, 4));

   364 				my $processName = substr($recordData, 8, $recordLen - 8);

   365 #				printf ("\nprocess [%08X] processName [$processName]\n", $process);

   366 				$ProcessNames{$process} = $processName;

   367 				}

   368 			elsif ($subCategory == $EThreadCreate || $subCategory == $EThreadName)

   369 				{

   370 				my $thread = unpack("V", substr($recordData, 0, 4));

   371 				my $process = unpack("V", substr($recordData, 4, 4));

   372 				my $threadName = substr($recordData, 8, $recordLen - 8);

   373 #				printf ("\nprocess [%08X] thread [%08X] threadName [$threadName]\n", $process, $thread, $threadName);

   374 				$ThreadNames{$thread} = $ProcessNames{$process} . "::" . $threadName;

   375 				}

   376 			elsif ($subCategory == $EThreadId)

   377 				{

   378 				my $thread = unpack("V", substr($recordData, 0, 4));

   379 				my $process = unpack("V", substr($recordData, 4, 4));

   380 				my $threadId = unpack("V", substr($recordData, 8, 4));

   381 #				printf ("\nprocess [%08X] thread [%08X] threadId [%08X]\n", $process, $thread, $threadId);

   382 				$ThreadIds{$thread} = $threadId;

   383 				}

   384 			}

   387 		# print Format string (col #9)

   388 		if ($PrintFlagFormatString)

   389 			{

   390 			my $formatStringWithoutCommas = $formatString;

   391 			$formatStringWithoutCommas=~ s/,/ /g;

   392 			printf "%s, ", $formatStringWithoutCommas;

   393 			}

   395 		my $formattedText;

   397 		my $lenFormatString = length($formatString);

   398 		if ($lenFormatString && !$RawMode && $multipartFlags != $EMultipartMiddle && $multipartFlags != $EMultipartLast)

   399 			{

   400 			for (my $i=0; $i<$lenFormatString; $i++)

   401 				{

   402 				my $c = (substr ($formatString, $i, 1));

   403 #				printf "$c\n";

   404 				if ($c eq "%")

   405 					{

   406 					undef my $fieldLen;

   407 					$i++;

   408 	        		$c = (substr ($formatString, $i, 1));

   409 					if ($c eq "%")

   410 						{

   411 						$formattedText.= substr ($formatString, $i, 1);

   412 						next;

   413 						}

   414 					if ($c eq "*")	## take length from buffer

   415 						{

   416 						$fieldLen = unpack("V", substr($recordData, $recordPos, 4));

   417 						if ($fieldLen > $recordLen-$recordPos)

   418 							{

   419 							$formattedText.= "*** Invalid field length ***";

   420 							last;

   421 							}

   422 						$recordPos+= 4;

   423 						$i++;

   424 		        		$c = (substr ($formatString, $i, 1));

   425 						}

   426 					if (lc $c eq "x" || $c eq "h")

   427 						{

   428 						if (defined $fieldLen)

   429 							{

   430 							if (($fieldLen & 3) == 0)

   431 								{

   432 								for (my $i=0; $i< $fieldLen; $i+= 4)

   433 									{

   434 									$formattedText.= sprintf ("%08X ", unpack("V", substr($recordData, $recordPos, 4)));

   435 									$recordPos+= 4;

   436 									}

   437 								}

   438 							else

   439 								{

   440 								for (my $i=0; $i< $fieldLen; $i++)

   441 									{

   442 									$formattedText.= sprintf ("%02X ", unpack("C", substr($recordData, $recordPos, 1)));

   443 									$recordPos++;

   444 									}

   445 								}

   446 							}

   447 						else

   448 							{

   449 							$formattedText.= sprintf ("0x%08X", unpack("V", substr($recordData, $recordPos, 4)));

   450 							$recordPos+= 4;

   451 							}

   452 						$recordPos = ($recordPos + 3) & ~3;

   453 						next;

   454 						}

   455 					# display "%ld" as hex for now as don't know how to get perl to use or display a 64 decimal value

   456 					elsif (lc $c eq "l" && substr ($formatString, $i+1, 1) eq "d")

   457 						{

   458 						$i++;

   459 						my $loWord = unpack("V", substr($recordData, $recordPos, 4));

   460 						$recordPos+= 4;

   461 						my $hiWord = unpack("V", substr($recordData, $recordPos, 4));

   462 						$recordPos+= 4;

   463 						$formattedText.= sprintf ("0x%X:%08X", $hiWord, $loWord);

   464 						}

   465 					elsif (lc $c eq "l" && substr ($formatString, $i+1, 1) eq "x")

   466 						{

   467 						$i++;

   468 						my $loWord = unpack("V", substr($recordData, $recordPos, 4));

   469 						$recordPos+= 4;

   470 						my $hiWord = unpack("V", substr($recordData, $recordPos, 4));

   471 						$recordPos+= 4;

   472 						$formattedText.= sprintf ("0x%X:%08X", $hiWord, $loWord);

   473 						}

   474 					elsif (lc $c eq "d")

   475 						{

   476 						$formattedText.= sprintf ("%d", unpack("V", substr($recordData, $recordPos, 4)));

   477 						$recordPos+= 4;

   478 						$recordPos = ($recordPos + 3) & ~3;

   479 						next;

   480 						}

   481 					elsif ($c eq "s")

   482 						{

   483 						if (!defined $fieldLen)

   484 							{$fieldLen = $recordLen - $recordPos;}

   485 						$formattedText.= substr($recordData, $recordPos, $fieldLen);

   486 						$recordPos+= $fieldLen;

   487 						$recordPos = ($recordPos + 3) & ~3;

   488 						next;

   489 						}

   490 					elsif ($c eq "S")

   491 						{

   492 						if (!defined $fieldLen)

   493 							{$fieldLen = $recordLen-$recordPos;}

   494 						for (my $j=0; $j < $fieldLen; $j+=2)

   495 							{

   496 					        my $byte = unpack("c", substr ($recordData, $recordPos+$j, 1));

   497  							$formattedText.= sprintf ("%c", $byte);

   498 							}

   499 						$recordPos+= $fieldLen;

   500 						$recordPos = ($recordPos + 3) & ~3;

   501 						next;

   502 						}

   503 					elsif ($c eq "c")

   504 						{

   505 				        my $byte = unpack("c", substr ($recordData, $recordPos, 1));

   506 						$formattedText.= sprintf ("%c", $byte);

   507 						}

   508 					}

   509 				else

   510 					{

   511 					$formattedText.= $c;

   512 					}

   513 				}

   514 			}

   515 		else	# no format string : print as hex

   516 			{

   517 			for (my $i=0; $i < $recordLen; $i+=4)

   518 				{

   519 				$formattedText.= sprintf ("%08X ", unpack("V", substr($recordData, $i, 4)));

   520 				}

   521 			$recordPos+= $recordLen; $recordLen = 0;

   523 			}

   526 		# print Formatted text (col #10)

   527 		$formattedText=~ s/,/;/g;

   528 		$formattedText=~ s/\r//g;

   529 		$formattedText=~ s/\n/,/g;

   530 		printf "%s", $formattedText;

   532 		printf("\n");

   534 		if ($len < 0 || $recordLen < 0)	{die "truncated file";}

   537 		$pos+= ($len +3) & ~3;

   538 		seek (LOGFILE, $pos, SEEK_SET) or die "truncated file";

   539 		$i++;

   540 		}

   542 	close (LOGFILE);

   544 	if ($VerboseMode)

   545 		{

   546 		print "*** Processes ***\n";

   547 		for $id ( keys %ProcessNames )

   548 			{

   549 			printf ("process %08X ProcessName %s\n", $id, $ProcessNames{$id});

   550 			}

   551 		print "*** Thread ***\n";

   552 		for $id ( keys %ThreadNames )

   553 			{

   554 			printf ("thread %08X ThreadName %s::%X\n", $id, $ThreadNames{$id}, $ThreadIds{$id});

   555 			}

   556 		}

   558     }

   561 sub ReadSingleRecord

   562 	{

   563 	($fh, $data, $dataLen, $recordLen, $category, $subCategory, $multipartFlags, $extraN, $totalLen, $offset, $RawMode) = @_;

   565 	my $hdr;

   566 	my $flags;

   567 	my $header2;

   568 	my $timestamp;

   569 	my $timestamp2;

   570 	my $contextId;

   571 	my $programConter;

   573 	my $recordOffset = 0;

   575 	$timestampLast;

   576 	my $timestampDelta = 0;

   578 	my $bytesRead = read($fh, $hdr, 4);

   581 	if ($bytesRead < 4)

   582 		{return -1;}

   584 	($$recordLen,$flags,$$category,$$subCategory) = unpack("CCCC", $hdr);

   585 	$$dataLen = $$recordLen-4;

   587 	if ($flags & $EHeader2Present)

   588 		{$$multipartFlags = (ReadDword($fh) & $EMultipartFlagMask); $$dataLen-= 4}

   589 	else

   590 		{$$multipartFlags = 0;}

   591 	if ($flags & $ETimestampPresent)

   592 		{$timestamp = ReadDword($fh); $$dataLen-= 4;}

   593 	if ($flags & $ETimestamp2Present)

   594 		{$timestamp2 = ReadDword($fh); $$dataLen-= 4;}

   595 	if ($flags & $EContextIdPresent)

   596 		{$contextId = ReadDword($fh); $$dataLen-= 4;}

   597 	if ($flags & $EPcPresent)

   598 		{$programConter = ReadDword($fh); $$dataLen-= 4;}

   599 	if ($flags & $EExtraPresent)

   600 		{$$extraN = ReadDword($fh); $$dataLen-= 4;}

   601 	if ($$multipartFlags != 0)

   602 		{

   603 		$$totalLen = ReadDword($fh);  $$dataLen-= 4;

   604 		if ($$multipartFlags == $EMultipartMiddle || $$multipartFlags == $EMultipartLast)

   605 			{$$offset = ReadDword($fh);  $$totalLen-= 4; $$dataLen-= 4;}

   606 		}

   608 	$timestampDelta = $timestamp - $timestampLast;

   609 	$timestampLast = $timestamp;

   611 	read($fh, $$data, ($$dataLen + 3) & ~3);

   614 	if ($RawMode || $$multipartFlags == $EMultipartFirst || $$multipartFlags == 0)

   615 		{

   616 		# print header len (col #1)

   617 		if ($PrintFlagHdrLen){printf ("0x%02X, ", $$recordLen);}

   619 		# print header flags (col #2)

   620 		if ($PrintFlagHdrFlags)

   621 			{

   622 			printf ("%02X ", $flags);

   623 			if ($flags & $EHeader2Present) {printf "EHeader2Present ";}

   624 			if ($flags & $ETimestampPresent) {printf "ETimestampPresent ";}

   625 			if ($flags & $ETimestamp2Present) {printf "ETimestamp2Present ";}

   626 			if ($flags & $EContextIdPresent) {printf "EContextIdPresent ";}

   627 			if ($flags & $EPcPresent) {printf "EPcPresent ";}

   628 			if ($$multipartFlags != 0)

   629 				{

   630 				printf "EExtraPresent ";

   631 				if ($$multipartFlags == $EMultipartFirst) {print "EMultipartFirst ";}

   632 				elsif ($$multipartFlags == $EMultipartMiddle) {print "EMultipartMiddle ";}

   633 				elsif ($$multipartFlags == $EMultipartLast) {print "EMultipartLast ";}

   634 				printf ("ExtraN(0x%08X) ", $$extraN);

   635 				}

   636 			if ($flags & $ERecordTruncated) {printf "ERecordTruncated ";}

   637 			if ($flags & $EMissingRecord) {printf "EMissingRecord ";}

   638 			print ",";

   639 			}

   641 		# print category (col #3)

   642 		printf "(%d;%d) $categoryString  , ", $$category, $$subCategory;

   644 		# print timestamp(s) (col #4)

   645 		printf "0x";

   646 		if (defined $timestamp2) {printf "%08X : ", $timestamp2;}

   647 		printf "%08X", $timestamp;

   648 		printf ", ";;

   650 		# print timestamp delta (col #5)

   651 		printf "0x%08X, ", $timestampDelta;

   653 		# print context Id (col #6)

   654 		if (!$RawMode && defined $ThreadNames{$contextId})

   655 			{

   656 			printf ("%s::%X, ", $ThreadNames{$contextId}, $ThreadIds{$contextId});

   657 			}

   658 		else

   659 			{

   660 			if ((($contextId & $EContextIdMask) == $EContextIdThread) || $RawMode)

   661 				{printf "0x%08X, ", $contextId;}

   662 			elsif (($contextId & $EContextIdMask) == $EContextIdFIQ)

   663 				{printf "FIQ, ";}

   664 			elsif (($contextId & $EContextIdMask) == $EContextIdIRQ)

   665 				{printf "IRQ, ";}

   666 			elsif (($contextId & $EContextIdMask) == $EContextIdIDFC)

   667 				{printf "IDFC, ";}

   668 			}

   670 		# print Program Counter (col #7)

   671 		printf "0x%08X, ", $programConter;

   672 		}

   677 #########################################################

   678 #	my $hex;

   679 #	for (my $i=0; $i < $$dataLen; $i+=4)

   680 #		{

   681 #		$hex.= sprintf ("%08X ", unpack("V", substr($$data, $i, 4)));

   682 #		}

   683 #	printf "\nadding [$hex]\n";

   684 #########################################################

   685 	return $bytesRead

   686 	}

   689 sub ReadRecord

   690 	{

   691 	($fh, $recordPos, $recordData, $category, $subCategory, $multipartFlags, $RawMode) = @_;

   692 #	printf "CurrentPos %08X\n", $pos;

   696 	seek ($fh, $$recordPos, SEEK_SET) or die "truncated file";

   697 	my $recordLen;

   698 	my $extraN;

   699 	my $totalLen;

   700 	my $offset;

   701 	my $dataLen;

   702 	my $data;

   703 	my $bytesRead;

   706 	$bytesRead = ReadSingleRecord($fh,  \$data, \$dataLen, \$recordLen, \$$category, \$$subCategory, \$$multipartFlags, \$extraN, \$totalLen, \$offset, $RawMode);

   708 	if ($bytesRead == -1)	# eof ?

   709 		{return -1; }

   710 	$$recordPos+= ($recordLen +3) & ~3;

   712 	$$recordData = $data;

   713     $offset = $dataLen;

   715 	$offset-= 4;		# subtract 4 bytes for UID ?????????

   717     if ($RawMode || $$multipartFlags != $EMultipartFirst)

   718     	{return $dataLen;}

   720     $pos = $$recordPos;

   722 	while (1)

   723 		{

   725 		# find next record, i.e. look for a record which matches $extraN

   727 		seek ($fh, $pos, SEEK_SET) or die "truncated file";

   729 		my $recordLen;

   731 		my $category;

   732 		my $subCategory;

   733 		my $multipartFlags;

   734 		my $currentExtraN;

   735 		my $currentOffset;

   737 		my $totalLen;

   738 		my $currentDataLen;

   739 		my $data;

   740 		$bytesRead = ReadSingleRecord($fh, \$data, \$currentDataLen, \$recordLen, \$category, \$subCategory, \$multipartFlags, \$currentExtraN, \$totalLen, \$currentOffset, $RawMode);

   741 		if ($bytesRead == -1)	# eof ?

   742 			{return -1; }

   743 		$pos+= ($recordLen +3) & ~3;

   745 #		printf "\npos %08X, Seaching for (extra %08X, offset %08X), found (extra %08X, offset %08X)\n",

   746 #			$pos, $extraN, $offset, $currentExtraN, $currentOffset;

   748 		if ($currentExtraN == $extraN && $currentOffset == $offset)

   749 			{

   750 			$$recordData.= $data;

   751 			$offset+= $currentDataLen;

   752 			$dataLen+= $currentDataLen;

   753 			}

   755 		if ($multipartFlags == $EMultipartLast)

   756 			{last;}

   757 		}

   759 	return $dataLen;

   760 	}

   762 sub ReadDword {

   763 	(my $fh) = @_;

   764 	my $buffer;

   766 	$bytesRead = read($fh, $buffer, 4);

   767 	if ($bytesRead < 4) 	{die "truncated file";}

   769 	my $dword = unpack("V", $buffer);

   771 	return $dword

   772 	};

   774 sub ReadByte {

   775 	(my $fh) = @_;

   776 	my $buffer;

   778 	$bytesRead = read($fh, $buffer, 1);

   779 	if ($bytesRead < 1) 	{die "truncated file";}

   781 	my $byte = unpack("C", $buffer);

   783 	return $byte

   784 	};

   788 sub PrintFormatTables($)

   789 	{

   790 	my ($formatTables) = @_;

   792 	for $tableIndex ( sort keys %$formatTables )

   793 		{

   794 		printf ("SYMTraceFormatCategory %08X:\n", $tableIndex);

   795 		for $formatId (sort keys %{ $$formatTables{$tableIndex} } )

   796 			{

   797 			printf ("%08X => %s\n", $formatId, $$formatTables{$tableIndex}{$formatId});

   798 			}

   799 			print "\n";

   800 		}

   801 	}

   805 sub OutputSawDictionary($)

   806 	{

   807 	my ($formatTables) = @_;

   810 	# SAW enums

   811 	$EFieldTypeHexDump = 0;

   812 	$EFieldTypeHex = 1;

   813 	$EFieldTypeDecimal = 2;

   814 	$EFieldTypeStringToEnd = 3;

   815 	$EFieldTypeNullTerminatedString = 4;

   816 	$EFieldTypeHexDumpToEnd = 5;

   817 	$EFieldTypeUnicodeToEnd = 6;

   818 	$EFieldTypeNullTerminatedUnicode = 7;

   819 	$EFieldTypeCountedUnicode = 8;

   820 	$EFieldTypeCountedHexDump = 9;

   821 	$EFieldTypeCountedString = 10;

   823 	my $moduleIds;	# string containg all UIDs separared by semi-colons

   825 	for $tableIndex ( sort keys %$formatTables )

   826 		{

   827 		if ($tableIndex < 256)

   828 			{

   829 			next;

   830 			}

   831 		$moduleIds.= sprintf ("%08X;", $tableIndex);

   833 		printf ("MODULEID_%08X_DESC=\n", $tableIndex);

   834 		printf ("MODULEID_%08X_NAME=%08X\n", $tableIndex, $tableIndex);

   836 		my $formatIds;

   837 		$formatIds = sprintf ("MODULEID_%08X_FORMATIDS=", $tableIndex);

   839 		for $formatId  (sort keys %{ $$formatTables{$tableIndex} } )

   840 			{

   841 			$formatIds.= sprintf ("%d;", $formatId);

   842 			}

   843 		printf ("$formatIds\n");

   846 		for $formatId (sort keys %{ $$formatTables{$tableIndex} } )

   847 			{

   848 			my $fieldCount = 0;

   849 			my $formatString = $$formatTables{$tableIndex}{$formatId};

   851 #printf ("formatString = (%s)\n", $formatString);

   853 			# format name is the first format string up until the first space or '%' character or end-of line ...

   854 			$formatString=~ m/^[^%\s]*/;

   855 			my $formatName = $&;

   857 			# thow the format name away

   858 			$formatString = $';

   860 			# strip the leading space

   861 			$formatString=~ s/\s*//;

   863 			printf ("MODULEID_%08X_FORMATID_%d_NAME=%s\n", $tableIndex, $formatId, $formatName);

   864 #printf ("MODULEID_%08X_FORMATID_%d_DESC=\n", $tableIndex, $formatId);

   866 			my $lenFormatString = length($formatString);

   868 			my $formattedText;

   869 			my $fieldType = $EFieldTypeHex;

   870 			my $fieldLen = 0;

   871 			while (length($formatString))

   872 				{

   873 				my $c = (substr ($formatString, 0, 1));

   874 #print ("[$formatString][$c]\n");

   875 				$formatString=~ s/.//;	# strip the leading space

   876 				if ($c eq "%")

   877 					{

   878 #print "found %\n";

   879 					my $fieldLenSpecified = 0;

   880 	        		$c = (substr ($formatString, 0, 1));

   881 					$formatString=~ s/.//;	# discard char

   882 #print "c2=$c\n";

   883 					if ($c eq "%")

   884 						{

   885 						$formattedText.= substr ($formatString, 0, 1);

   886 						next;

   887 						}

   888 					if ($c eq "*")	## take length from buffer

   889 						{

   890 						$fieldLenSpecified = 1;

   891 		        		$c = (substr ($formatString, 0, 1));

   892 						$formatString=~ s/.//;	# discard char

   893 						}

   894 					if (lc $c eq "x" || $c eq "h")

   895 						{

   896 						## deal wilth $fieldLenSpecified

   897 						if ($fieldLenSpecified)

   898 							{

   899 							$fieldType = $EFieldTypeCountedHexDump;

   900 							$fieldLen = 0;

   901 							}

   902 						else

   903 							{

   904 							$fieldType = $EFieldTypeHex;

   905 							$fieldLen = 4;

   906 							}

   907 						}

   908 					elsif (lc $c eq "l" && substr ($formatString, 0, 1) eq "d")

   909 						{

   910 						$formatString=~ s/.//;	# discard char

   911 						$fieldType = $EFieldTypeDecimal;

   912 						$fieldLen = 8;

   913 						}

   914 					elsif (lc $c eq "l" && substr ($formatString, 0, 1) eq "x")

   915 						{

   916 						$formatString=~ s/.//;	# discard char

   917 						$fieldType = $EFieldTypeHex;

   918 						$fieldLen = 8;

   919 						}

   920 					elsif (lc $c eq "d")

   921 						{

   922 						$fieldType = $EFieldTypeDecimal;

   923 						$fieldLen = 4;

   924 						}

   925 					elsif ($c eq "s")

   926 						{

   927 						## deal wilth $fieldLenSpecified

   928 						if ($fieldLenSpecified)

   929 							{

   930 							$fieldType = $EFieldTypeCountedString;

   931 							$fieldLen = 0;

   932 							}

   933 						else

   934 							{

   935 							$fieldType = $EFieldTypeStringToEnd;

   936 							$fieldLen = 0;

   937 							}

   938 						}

   939 					elsif ($c eq "S")

   940 						{

   941 						## deal wilth $fieldLenSpecified

   942 						if ($fieldLenSpecified)

   943 							{

   944 							$fieldType = $EFieldTypeCountedUnicode;

   945 							$fieldLen = 0;

   946 							}

   947 						else

   948 							{

   949 							$fieldType = EFieldTypeUnicodeToEnd;

   950 							$fieldLen = 0;

   951 							}

   952 						}

   953 					elsif ($c eq "c")

   954 						{

   955 						$fieldType = $EFieldTypeHex;

   956 						$fieldLen = 1;

   957 						}

   958 					printf ("MODULEID_%08X_FORMATID_%d_FIELD_%d_NAME=%s\n", $tableIndex, $formatId, $fieldCount, $formattedText);

   959 					printf ("MODULEID_%08X_FORMATID_%d_FIELD_%d_TYPE=%s\n", $tableIndex, $formatId, $fieldCount, $fieldType);

   960 					if ($fieldLen > 0)

   961 						{printf ("MODULEID_%08X_FORMATID_%d_FIELD_%d_LENGTH=%s\n", $tableIndex, $formatId, $fieldCount, $fieldLen);}

   962 					$fieldCount++;

   963 					$formattedText="";

   965 					$formatString=~ s/\s//;	# strip the leading space

   966 					}

   967 				else

   968 					{

   969 #					if ($c eq ":") {$formattedText.= '\\'; }

   970 					$formattedText.= $c;

   971 					}

   972 				}

   973 			printf ("MODULEID_%08X_FORMATID_%d_FIELDS=%d\n", $tableIndex, $formatId, $fieldCount);

   975 			}

   976 		print "MODULEIDS=$moduleIds\n";

   977 		}

   978 	}

   987 sub H2Trace($$)

   988 {

   989 	%basictypes = (

   990 		TInt8		=>	1,

   991 		TUint8		=>	1,

   992 		TInt16		=>	2,

   993 		TUint16		=>	2,

   994 		TInt32		=>	4,

   995 		TUint32		=>	4,

   996 		TInt		=>	4,

   997 		TUint		=>	4,

   998 		TBool		=>	4,

   999 		TInt64		=>	8,

  1000 		TUint64		=>	8,

  1001 		TLinAddr	=>	4,

  1002 		TVersion	=>	4,

  1003 		TPde		=>	4,

  1004 		TPte		=>	4,

  1005 		TProcessPriority => 4,

  1006 		TFormatId	=>  2,

  1007 	);

  1009 	if (scalar(@_)!= 2) {

  1010 		die "perl h2trace.pl <input.h>\n";

  1011 	}

  1012 	my ($infile, $filescope) = @_;

  1014 	if ($VerboseMode)

  1015 		{print "\nOpening $infile\n";}

  1017 	open IN, $infile or die "Can't open $infile for input\n";

  1018 	my $in;

  1019 	while (<IN>) {

  1020 		$in.=$_;

  1021 	}

  1022 	close IN;

  1024 	# First remove any backslash-newline combinations

  1025 	$in =~ s/\\\n//gms;

  1027 	# Remove any character constants

  1028 	$in =~  s/\'(.?(${0})*?)\'//gms;

  1030 	# Strip comments beginning with //

  1031 	$in =~ s/\/\/(.*?)\n/\n/gms;    #//(.*?)\n

  1033 	# Strip comments (/* */) but leave doxygen comments (/** */)

  1034 	$in =~ s/\/\*[^*](.*?)\*\//\n/gms;  #/*(.*?)*/

  1037 	# Collapse whitespace into a single space or newline

  1038 	$in =~ s/\t/\ /gms;

  1039 	$in =~ s/\r/\ /gms;

  1041 	# Tokenize on non-identifier characters

  1042 	my @tokens0 = split(/(\W)/,$in);

  1043 	my @tokens;

  1044 	my $inString = 0;

  1045 	my $inComment = 0;

  1046 	my $string;

  1047 	foreach $t (@tokens0) {

  1048 		next if ($t eq "");

  1049 		next if (!$inString && ($t eq " " or $t eq ""));

  1050 		if ($inComment == 0)

  1051 			{

  1052 			if ($t eq "/")

  1053 				{$inComment = 1;}

  1054 			}

  1055 		elsif ($inComment == 1)

  1056 			{

  1057 			if ($t eq "*")

  1058 				{$inComment = 2;}

  1059 			else

  1060 				{$inComment = 0;}

  1061 			}

  1062 		elsif ($inComment == 2)

  1063 			{

  1064 			if ($t eq "*")

  1065 				{$inComment = 3;}

  1066 			}

  1067 		elsif ($inComment == 3)

  1068 			{

  1069 			if ($t eq "/")

  1070 				{

  1071 				$inComment = 0;

  1072 		        # if we were in a string, need to push previous '*'

  1073 		        if ($inString)

  1074 		          {

  1075 		          push @tokens, "*";

  1076 		          }

  1077 				$inString = 0;	# end of comment aborts a string

  1078 				$string = "";

  1079 				}

  1080 			else

  1081 				{$inComment = 2;}

  1082 			}

  1084 		if ($t eq "\"")

  1085 			{

  1086 			if (!$inString)

  1087 				{

  1088 				$inString=1;

  1089 				next;

  1090 				}

  1091 			else

  1092 				{

  1093 				$inString=0;

  1094 				$t = $string;

  1095 				$string = "";

  1096 #				if ($VerboseMode) {print "string : [$t]\n";	}

  1097 				}

  1098 			}

  1100 		if ($inString)

  1101 			{

  1102 			$string.= $t;

  1103 			next;

  1104 			}

  1105 		push @tokens, $t;

  1106 	}

  1108 	my $CurrentTraceFormatString;

  1109 	my $CurrentTraceFormatCategory;

  1110 	# format Key as specified by the @TraceFormatCategory tag is either the current category

  1111 	# or the current UID

  1112 	my $CurrentFormatTableKey;

  1115 	my $line=1;

  1116 	parse_scope($filescope, \@tokens, \$line);

  1118 	#print $in;

  1119 	#print join (" ", @tokens);

  1120 }	# end of     H2Trace

  1124 	sub parse_scope($$$) {

  1125 		my ($scope, $tokens, $line) = @_;

  1126 		my $state = 1;

  1128 		my @classes;

  1129 		my $curr_offset=0;

  1130 		my $overall_align=0;

  1131 #		print ">parse_scope $scope->{name}\n";

  1133 		while (scalar(@$tokens))

  1134 			{

  1135 			my $t = shift @$tokens;

  1136 #			printf "t: [$t] [$$line]\n";

  1137 	    	if (!defined ($t)) {

  1138 	      		printf "undefined !";

  1139 	      		next;

  1140 	      	}

  1141 			if ($state>=-1 and $t eq "\n") {

  1142 				++$$line;

  1143 				$state=1;

  1144 				next;

  1145 			} elsif ($state==-1 and $t ne "\n") {

  1146 				next;

  1147 			} elsif ($state==-2 and $t ne ';') {

  1148 				next;

  1149 			}

  1151 			if ($state>0 and $t eq '#') {

  1152 				$t = shift @$tokens;

  1153 				if ($t eq 'define') {

  1154 					my $ident = shift @$tokens;

  1155 					my $defn = shift @$tokens;

  1156 					if ($defn ne '(') {	# don't do macros with parameters

  1157 #					print "MACRO: $ident :== $defn\n";

  1158 					$macros{$ident} = $defn;

  1159 					}

  1160 				}

  1161 				$state=-1;	# skip to next line

  1162 				next;

  1163 			}

  1166 			if (parse_doxygen($scope,$tokens, $line, $t) == 1)

  1167 				{next;}

  1169 			if ($t eq "namespace" ) {

  1170 				$state=0;

  1171 				my %cl;

  1172 				$cl{specifier}=$t;

  1173 				$cl{scope}=$scope;

  1174 				$cl{values}=$scope->{values};

  1175 				$cl{members}=\$scope->{members};

  1176 				$cl{typedefs}=\$scope->{typedefs};

  1177 				$cl{FormatTables}=$scope->{FormatTables};

  1178 				$cl{formatStrings} =$scope->{formatStrings};

  1179 				$cl{formatCategories} =$scope->{formatCategories};

  1181 				my $new_namespace = \%cl;

  1182 				my $n = get_token($scope,$tokens,$line);

  1183 				if ($n !~ /\w+/) {

  1184 					warn "Unnamed $t not supported at line $$line\n";

  1185 					return;

  1186 				}

  1187 				$new_namespace->{name}=$n;

  1188 				my @class_match = grep {$_->{name} eq $n} @classes;

  1189 				my $exists = scalar(@class_match);

  1190 				my $b = get_token($scope,$tokens,$line);

  1191 				if ($b eq ':') {

  1192 					die "Inheritance not supported at line $$line\n";

  1193 				} elsif ($b eq ';') {

  1194 					# forward declaration

  1195 					push @classes, $new_namespace unless ($exists);

  1196 					next;

  1197 				} elsif ($b ne '{') {

  1198 					warn "Syntax error#1 at line $$line\n";

  1199 					return;

  1200 				}

  1201 				if ($exists) {

  1202 					$new_namespace = $class_match[0];

  1203 					if ($new_namespace->{complete}) {

  1204 						warn "Duplicate definition of $cl{specifier} $n\n";

  1205 					}

  1206 				}

  1207 				push @classes, $new_namespace unless ($exists);

  1208 				parse_scope($new_namespace, $tokens, $line);

  1209 				next;

  1210 			}

  1212 			if ($t eq "struct" or $t eq "class" or $t eq "NONSHARABLE_CLASS") {

  1213 				next if ($state==0);

  1214 				$state=0;

  1215 				my %cl;

  1216 				$cl{specifier}=$t;

  1217 				$cl{scope}=$scope;

  1218 				my @members;

  1219 				my @typedefs;

  1220 				$cl{members}=\@members;

  1221 				$cl{typedefs}=\@typedefs;

  1222 				$cl{FormatTables}=$scope->{FormatTables};

  1223 				my $new_class = \%cl;

  1224 				my $n;

  1226 				if ($t eq "NONSHARABLE_CLASS")

  1227 					{

  1228 					my $b = get_token($scope,$tokens,$line);

  1229 					if ($b !~ /\(/) {die "Syntax error at line $$line\n";}

  1230 					$n = get_token($scope,$tokens,$line);

  1231   				$b = get_token($scope,$tokens,$line);

  1232 					if ($b !~ /\)/) {die "Syntax error at line $$line\n";}

  1233 					}

  1234 				else

  1235 					{

  1236 					$n = get_token($scope,$tokens,$line);

  1237 					}

  1240 				if ($n !~ /\w+/) {

  1241 					warn "Unnamed $t not supported at line $$line\n";

  1242 					return;

  1243 				}

  1244 				$new_class->{name}=$n;

  1245 				my @class_match = grep {$_->{name} eq $n} @classes;

  1246 				my $exists = scalar(@class_match);

  1247 				my $b = get_token($scope,$tokens,$line);

  1248 				#skip inheritance etc until we get to a '{' or \ ';'

  1249 				while ($b ne '{' && $b ne ';')

  1250 					{

  1251 			        $b = get_token($scope,$tokens,$line);

  1252 			        die "Syntax error#2 at line $$line\n" if  (!defined $b);

  1253 					}

  1254 				if ($b eq ';') {

  1255 					# forward declaration

  1256 					push @classes, $new_class unless ($exists);

  1257 					next;

  1258 				}

  1259 				if ($exists) {

  1260 					$new_class = $class_match[0];

  1261 					if ($new_class->{complete}) {

  1262 						warn "Duplicate definition of $cl{specifier} $n\n";

  1263 					}

  1264 				}

  1265 				push @classes, $new_class unless ($exists);

  1266 				parse_scope($new_class, $tokens, $line);

  1267 				next;

  1268 			} elsif ($t eq "enum") {

  1269 				$state=0;

  1270 				my $n = get_token($scope,$tokens,$line);

  1271 				my $name="";

  1272 				if ($n =~ /\w+/) {

  1273 					$name = $n;

  1274 					$n = get_token($scope,$tokens,$line);

  1275 				}

  1276 				push @enums, $name;

  1277 				if ($n ne '{') {

  1278 					die "Syntax error#4 at line $$line\n";

  1279 				}

  1280 				parse_enum($scope, $tokens, $line, $name);

  1281 				next;

  1282 			} elsif ($t eq '}') {

  1283 				$state=0;

  1284 				if ($scope->{scope}) {

  1285 			        if ($scope->{specifier} eq "namespace")

  1286 			        	{

  1287 						$scope->{complete}=1;

  1288 #						print "Scope completed\n";

  1289 						last;

  1290 						}

  1291 					$t = get_token($scope,$tokens,$line);

  1292 					# skip to next ';'

  1293 					while (defined ($t) and $t ne ';')

  1294 						{$t = get_token($scope,$tokens,$line);}

  1295 					die "Syntax error#5 at line $$line\n" if ($t ne ';');

  1296 					$scope->{complete}=1;

  1297 #					print "Scope completed\n";

  1298 					last;

  1299 				}

  1300 				warn "Syntax error#5 at line $$line\n";

  1301 				return;

  1302 			}

  1303 			$state=0;

  1304 			if ($scope->{scope}) {

  1305 				if ($t eq "public" or $t eq "private" or $t eq "protected") {

  1306 					if (shift (@$tokens) eq ':') {

  1307 						next;	# ignore access specifiers

  1308 					}

  1309 				die "Syntax error#6 at line $$line\n";

  1310 				}

  1311 			}

  1312 			unshift @$tokens, $t;

  1314 			my @currdecl = parse_decl_def($scope, $tokens, $line);

  1315 #			print scalar (@currdecl), "\n";

  1316 			if ($t eq 'static') {

  1317 				next;	# skip static members

  1318 			}

  1319 			my $typedef;

  1320 			if ($t eq 'typedef') {

  1321 #			print "TYPEDEF\n";

  1322 				$typedef = 1;

  1323 				$t = shift @currdecl;

  1324 				$t = $currdecl[0];

  1325 			} else {

  1326 #			print "NOT TYPEDEF\n";

  1327 				$typedef = 0;

  1328 			}

  1329 #			print "$currdecl[0]\n";

  1330 			next if (scalar(@currdecl)==0);

  1332 			if ($t eq "const") {

  1333 				# check for constant declaration

  1334 #				print "CONST $currdecl[1] $currdecl[2] $currdecl[3]\n";

  1335 				my $ctype = lookup_type($scope, $currdecl[1]);

  1336 #				print "$ctype->{basic}    $ctype->{size}\n";

  1337 				if ($ctype->{basic} and $currdecl[2]=~/^\w+$/ and $currdecl[3] eq '=') {

  1338 					if ($typedef!=0) {

  1339 						die "Syntax error#7 at line $$line\n";

  1340 					}

  1341 					shift @currdecl;

  1342 					shift @currdecl;

  1343 					my $type = $ctype->{name};

  1344 					my $name;		#### = shift @currdecl;

  1346 					if ($scope->{name})

  1347 						{

  1348 						$name = $scope->{name} . "::" . shift @currdecl;

  1349 						}

  1350 					else

  1351 						{

  1352 						$name = shift @currdecl;

  1353 						}

  1354 #					printf "[$name,$scope->{name}]";

  1355 					my $size = $ctype->{size};

  1356 					shift @currdecl;

  1357 					my $value = get_constant_expr($scope,\@currdecl,$line);

  1358 					$values{$name} = {type=>$type, size=>$size, value=>$value};

  1359 					next;

  1360 				}

  1361 			}

  1365 		}

  1366 	}

  1368 	sub get_token($$$) {

  1369 		my ($scope,$tokenlist,$line) = @_;

  1370 		while (scalar(@$tokenlist)) {

  1371 			my $t = shift @$tokenlist;

  1372 			return $t if (!defined($t));

  1373 			if (parse_doxygen($scope,$tokenlist, $line, $t) == 1)

  1374 				{next;}

  1375 			if ($t !~ /^[\s]*$/)

  1376 				{

  1377 				if ($$tokenlist[0] eq ":" and $$tokenlist[1] eq ":")

  1378 					{

  1379 					$t.= shift @$tokenlist;

  1380 					$t.= shift @$tokenlist;

  1381 					$t.= shift @$tokenlist;

  1382 #					print "Colon-separated token";

  1383 					}

  1384 				return $t

  1385 				}

  1386 			++$$line;

  1387 		}

  1388   		return undef;

  1389 	}

  1391 	sub skip_qualifiers($) {

  1392 		my ($tokens) = @_;

  1393 		my $f=0;

  1394 		my %quals = (

  1395 			EXPORT_C => 1,

  1396 			IMPORT_C => 1,

  1397 			inline => 1,

  1398 			virtual => 0,

  1399 			const => 0,

  1400 			volatile => 0,

  1401 			static => 0,

  1402 			extern => 0,

  1403 			LOCAL_C => 0,

  1404 			LOCAL_D => 0,

  1405 			GLDEF_C => 0,

  1406 			GLREF_C => 0,

  1407 			GLDEF_D => 0,

  1408 			GLREF_D => 0

  1409 			);

  1410 		for (;;) {

  1411 			my $t = $$tokens[0];

  1412 			my $q = $quals{$t};

  1413 			last unless (defined ($q));

  1414 			$f |= $q;

  1415 			shift @$tokens;

  1416 		}

  1417 		return $f;

  1418 	}

  1420 	sub parse_indirection($) {

  1421 		my ($tokens) = @_;

  1422 		my $level = 0;

  1423 		for (;;) {

  1424 			my $t = $$tokens[0];

  1425 			if ($t eq '*') {

  1426 				++$level;

  1427 				shift @$tokens;

  1428 				next;

  1429 			}

  1430 			last if ($t ne "const" and $t ne "volatile");

  1431 			shift @$tokens;

  1432 		}

  1433 		return $level;

  1434 	}

  1436 	sub get_operand($$$) {

  1437 		my ($scope,$tokens,$line) = @_;

  1438 		my $t = get_token($scope,$tokens,$line);

  1439 		if ($t eq '-') {

  1440 			my $x = get_operand($scope,$tokens,$line);

  1441 			return -$x;

  1442 		} elsif ($t eq '+') {

  1443 			my $x = get_operand($scope,$tokens,$line);

  1444 			return $x;

  1445 		} elsif ($t eq '~') {

  1446 			my $x = get_operand($scope,$tokens,$line);

  1447 			return ~$x;

  1448 		} elsif ($t eq '!') {

  1449 			my $x = get_operand($scope,$tokens,$line);

  1450 			return $x ? 0 : 1;

  1451 		} elsif ($t eq '(') {

  1452 			my $x = get_constant_expr($scope,$tokens,$line);

  1453 			my $t = get_token($scope,$tokens,$line);

  1454 			if ($t ne ')') {

  1455 				warn "Missing ) at line $$line\n";

  1456 				return undefined;

  1457 			}

  1458 			return $x;

  1459 		} elsif ($t eq "sizeof") {

  1460 			my $ident = get_token($scope,$tokens,$line);

  1461 			if ($ident eq '(') {

  1462 				$ident = get_token($scope,$tokens,$line);

  1463 				my $cb = get_token($scope,$tokens,$line);

  1464 				if ($cb ne ')') {

  1465 					warn "Bad sizeof() syntax at line $$line\n";

  1466 					return undefined;

  1467 				}

  1468 			}

  1469 			$ident = look_through_macros($ident);

  1470 			if ($ident !~ /^\w+$/) {

  1471 				warn "Bad sizeof() syntax at line $$line\n";

  1472 				return undefined;

  1473 			}

  1474 			my $type = lookup_type($scope, $ident);

  1475 			if (!defined $type) {

  1476 				warn "Unrecognised type $ident at line $$line\n";

  1477 				return undefined;

  1478 			}

  1479 			if ($type->{basic}) {

  1480 				return $type->{size};

  1481 			} elsif ($type->{enum}) {

  1482 				return 4;

  1483 			} elsif ($type->{ptr}) {

  1484 				return 4;

  1485 			} elsif ($type->{fptr}) {

  1486 				return 4;

  1487 			}

  1488 			my $al = $type->{class}->{align};

  1489 			my $sz = $type->{class}->{size};

  1490 			return ($sz+$al-1)&~($al-1);

  1491 		}

  1492 		$t = look_through_macros($t);

  1493 		if ($t =~ /^0x/i) {

  1494 			return oct($t);

  1495 		} elsif ($t =~ /^\d/) {

  1496 			return $t;

  1497 		} elsif ($t =~ /^\w+$/) {

  1498 			my $x = lookup_value($scope,$t);

  1499 #			die "Unrecognised identifier '$t' at line $$line\n" unless defined($x);

  1500 			if (!defined($x)) {

  1501 				print "Unrecognised identifier '$t' at line $$line\n" ;

  1502 			}

  1503 			return $x;

  1504 		} elsif ($t =~ /^\w+::\w+$/) {

  1505 			my $x = lookup_value($scope,$t);

  1506 #			die "Unrecognised identifier '$t' at line $$line\n" unless defined($x);

  1507 			if (!defined($x)) {

  1508 				print "Unrecognised identifier '$t' at line $$line\n" ;

  1509 			}

  1510 			return $x;

  1511 		} else {

  1512 			warn "Syntax error#10 at line $$line\n";

  1513 			return undefined;

  1514 		}

  1515 	}

  1517 	sub look_through_macros($) {

  1518 		my ($ident) = @_;

  1519 		while ($ident and $macros{$ident}) {

  1520 			$ident = $macros{$ident};

  1521 		}

  1522 		return $ident;

  1523 	}

  1525 	sub lookup_value($$) {

  1526 		my ($scope,$ident) = @_;

  1527 		while ($scope) {

  1528 			my $vl = $scope->{values};

  1529 			if (defined($vl->{$ident})) {

  1530 				return $vl->{$ident}->{value};

  1531 			}

  1532 			$scope = $scope->{scope};

  1533 		}

  1534 		return undef();

  1535 	}

  1537 	sub lookup_type($$) {

  1538 		my ($scope,$ident) = @_;

  1539 		if ($basictypes{$ident}) {

  1540 			return {scope=>$scope, basic=>1, name=>$ident, size=>$basictypes{$ident} };

  1541 		}

  1542 		while ($scope) {

  1543 			if ($basictypes{$ident}) {

  1544 				return {scope=>$scope, basic=>1, name=>$ident, size=>$basictypes{$ident} };

  1545 			}

  1546 			my $el = $scope->{enums};

  1547 			my $cl = $scope->{classes};

  1548 			my $td = $scope->{typedefs};

  1549 			if (grep {$_ eq $ident} @$el) {

  1550 				return {scope=>$scope, enum=>1, name=>$ident, size=>4 };

  1551 			}

  1552 			my @match_class = (grep {$_->{name} eq $ident} @$cl);

  1553 			if (scalar(@match_class)) {

  1554 				return {scope=>$scope, class=>$match_class[0]};

  1555 			}

  1556 			my @match_td = (grep {$_->{name} eq $ident} @$td);

  1557 			if (scalar(@match_td)) {

  1558 				my $tdr = $match_td[0];

  1559 				my $cat = $tdr->{category};

  1560 				if ($cat eq 'basic' or $cat eq 'enum' or $cat eq 'class') {

  1561 					$ident = $tdr->{alias};

  1562 					next;

  1563 				} else {

  1564 					return { scope=>$scope, $cat=>1, $size=>$tdr->{size} };

  1565 				}

  1566 			}

  1567 			$scope = $scope->{scope};

  1568 		}

  1569 		return undef();

  1570 	}

  1572 	sub get_mult_expr($$$) {

  1573 		my ($scope,$tokens,$line) = @_;

  1574 		my $x = get_operand($scope,$tokens,$line);

  1575 		my $t;

  1576 		for (;;) {

  1577 			$t = get_token($scope,$tokens,$line);

  1578 			if ($t eq '*') {

  1579 				my $y = get_operand($scope,$tokens,$line);

  1580 				$x = $x * $y;

  1581 			} elsif ($t eq '/') {

  1582 				my $y = get_operand($scope,$tokens,$line);

  1583 				if ($y != 0)

  1584 					{$x = int($x / $y);}

  1585 			} elsif ($t eq '%') {

  1586 				my $y = get_operand($scope,$tokens,$line);

  1587 				if ($y != 0)

  1588 					{$x = int($x % $y);}

  1589 			} else {

  1590 				last;

  1591 			}

  1592 		}

  1593 		unshift @$tokens, $t;

  1594 		return $x;

  1595 	}

  1597 	sub get_add_expr($$$) {

  1598 		my ($scope,$tokens,$line) = @_;

  1599 		my $x = get_mult_expr($scope,$tokens,$line);

  1600 		my $t;

  1601 		for (;;) {

  1602 			$t = get_token($scope,$tokens,$line);

  1603 			if ($t eq '+') {

  1604 				my $y = get_mult_expr($scope,$tokens,$line);

  1605 				$x = $x + $y;

  1606 			} elsif ($t eq '-') {

  1607 				my $y = get_mult_expr($scope,$tokens,$line);

  1608 				$x = $x - $y;

  1609 			} else {

  1610 				last;

  1611 			}

  1612 		}

  1613 		unshift @$tokens, $t;

  1614 		return $x;

  1615 	}

  1617 	sub get_shift_expr($$$) {

  1618 		my ($scope,$tokens,$line) = @_;

  1619 		my $x = get_add_expr($scope,$tokens,$line);

  1620 		my $t, $t2;

  1621 		for (;;) {

  1622 			$t = get_token($scope,$tokens,$line);

  1623 			if ($t eq '<' or $t eq '>') {

  1624 				$t2 = get_token($scope,$tokens,$line);

  1625 				if ($t2 ne $t) {

  1626 					unshift @$tokens, $t2;

  1627 					last;

  1628 				}

  1629 			}

  1630 			if ($t eq '<') {

  1631 				my $y = get_add_expr($scope,$tokens,$line);

  1632 				$x = $x << $y;

  1633 			} elsif ($t eq '>') {

  1634 				my $y = get_add_expr($scope,$tokens,$line);

  1635 				$x = $x >> $y;

  1636 			} else {

  1637 				last;

  1638 			}

  1639 		}

  1640 		unshift @$tokens, $t;

  1641 		return $x;

  1642 	}

  1644 	sub get_and_expr($$$) {

  1645 		my ($scope,$tokens,$line) = @_;

  1646 		my $x = get_shift_expr($scope,$tokens,$line);

  1647 		my $t;

  1648 		for (;;) {

  1649 			$t = get_token($scope,$tokens,$line);

  1650 			if ($t eq '&') {

  1651 				my $y = get_shift_expr($scope,$tokens,$line);

  1652 				$x = $x & $y;

  1653 			} else {

  1654 				last;

  1655 			}

  1656 		}

  1657 		unshift @$tokens, $t;

  1658 		return $x;

  1659 	}

  1661 	sub get_xor_expr($$$) {

  1662 		my ($scope,$tokens,$line) = @_;

  1663 		my $x = get_and_expr($scope,$tokens,$line);

  1664 		my $t;

  1665 		for (;;) {

  1666 			$t = get_token($scope,$tokens,$line);

  1667 			if ($t eq '^') {

  1668 				my $y = get_and_expr($scope,$tokens,$line);

  1669 				$x = $x ^ $y;

  1670 			} else {

  1671 				last;

  1672 			}

  1673 		}

  1674 		unshift @$tokens, $t;

  1675 		return $x;

  1676 	}

  1678 	sub get_ior_expr($$$) {

  1679 		my ($scope,$tokens,$line) = @_;

  1680 		my $x = get_xor_expr($scope,$tokens,$line);

  1681 		my $t;

  1682 		for (;;) {

  1683 			$t = get_token($scope,$tokens,$line);

  1684 			if ($t eq '|') {

  1685 				my $y = get_xor_expr($scope,$tokens,$line);

  1686 				$x = $x | $y;

  1687 			} else {

  1688 				last;

  1689 			}

  1690 		}

  1691 		unshift @$tokens, $t;

  1692 		return $x;

  1693 	}

  1695 	sub get_constant_expr($$$) {

  1696 		my ($scope,$tokens,$line) = @_;

  1697 		my $x = get_ior_expr($scope,$tokens,$line);

  1698 		return $x;

  1699 	}

  1701 	sub parse_enum($$$$) {

  1702 		my ($scope,$tokens,$line,$enum_name) = @_;

  1703 		my $vl = $scope->{values};

  1704 		my $fstr = $scope->{formatStrings};

  1705 		my $fcat = $scope->{formatCategories};

  1706 		my $fmtTable = $scope->{FormatTables};

  1708 		my $x = 0;

  1709 		for (;;) {

  1710 			my $t = get_token($scope,$tokens,$line);

  1711 			last if ($t eq '}');

  1712 			if (!defined($t)) {

  1713 				die "Unexpected end of file #2 at line $$line\n";

  1714 			}

  1716 			if ($t eq '#') {

  1717 				next;

  1718 				}

  1720 			if ($t !~ /^\w+$/) {

  1721 				warn "Syntax error#11 at line $$line\n";

  1722 				next;

  1723 			}

  1725 			if ($scope->{name})

  1726 				{

  1727 				$t = $scope->{name} . "::" . $t;

  1728 				}

  1730 			if (defined($vl->{$t})) {

  1731 				warn "Duplicate identifier [$t] at line $$line\n";

  1732 			}

  1733 			my $t2 = get_token($scope,$tokens,$line);

  1734 			if ($t2 eq ',') {

  1735 				$vl->{$t} = {type=>$enum_name, size=>4, value=>$x, enum=>1};

  1736 				$fstr->{$t} = $CurrentTraceFormatString;

  1737 				$fcat->{$t} = $CurrentTraceFormatCategory;

  1738 				if (defined $CurrentTraceFormatCategory && defined $CurrentTraceFormatString)

  1739 					{ $fmtTable->{$CurrentTraceFormatCategory}{$x} = $CurrentTraceFormatString; }

  1740 				undef $CurrentTraceFormatString;

  1741 				++$x;

  1742 			} elsif ($t2 eq '}') {

  1743 				$vl->{$t} = {type=>$enum_name, size=>4, value=>$x, enum=>1};

  1744 				$fstr->{$t} = $CurrentTraceFormatString;

  1745 				$fcat->{$t} = $CurrentTraceFormatCategory;

  1746 				if (defined $CurrentTraceFormatCategory && defined $CurrentTraceFormatString)

  1747 					{ $fmtTable->{$CurrentTraceFormatCategory}{$x} = $CurrentTraceFormatString; }

  1748 				undef $CurrentTraceFormatString;

  1749 				++$x;

  1750 				last;

  1751 			} elsif ($t2 eq '=') {

  1752 				$x = get_constant_expr($scope, $tokens, $line);

  1753 				$vl->{$t} = {type=>$enum_name, size=>4, value=>$x, enum=>1};

  1754 				$fstr->{$t} = $CurrentTraceFormatString;

  1755 				$fcat->{$t} = $CurrentTraceFormatCategory;

  1756 				if (defined $CurrentTraceFormatCategory && defined $CurrentTraceFormatString)

  1757 					{ $fmtTable->{$CurrentTraceFormatCategory}{$x} = $CurrentTraceFormatString; }

  1758 				undef $CurrentTraceFormatString;

  1759 				++$x;

  1760 				$t2 = get_token($scope,$tokens,$line);

  1761 				last if ($t2 eq '}');

  1762 				next if ($t2 eq ',');

  1763 				warn "Syntax error#12 at line $$line\n";

  1764 			} else {

  1765 				unshift @$tokens, $t2;

  1766 			}

  1767 		}

  1768 		my $t = get_token($scope,$tokens,$line);

  1769 		if ($t ne ';') {

  1770 			warn "Missing ; at line $$line\n";

  1771 		}

  1772 	}

  1775 	sub  parse_decl_def($$$) {

  1776 		my ($scope,$tokens,$line) = @_;

  1777 		my $level=0;

  1778 		my @decl;

  1779 		while ( scalar(@$tokens) ) {

  1780 			my $t = get_token($scope,$tokens, $line);

  1781 			if ( (!defined ($t) || $t eq ';') and ($level==0)) {

  1782 				return @decl;

  1783 			}

  1785 			if ($t eq "static")

  1786 				{

  1787 				next;

  1788 				}

  1790 			push @decl, $t;

  1791 			if ($t eq '{') {

  1792 				++$level;

  1793 			}

  1794 			if ($t eq '}') {

  1795 				if ($level==0) {

  1796 					warn "Syntax error#13 at line $$line\n";

  1797 					unshift @$tokens, $t;

  1798 					return @decl;

  1800 				}

  1801 				if (--$level==0) {

  1802 					return ();	# end of function definition reached

  1803 				}

  1804 			}

  1805 		}

  1806 		die "Unexpected end of file #3 at line $$line\n";

  1807 	}

  1809 	sub dump_scope($) {

  1810 		my ($scope) = @_;

  1811 		my $el = $scope->{enums};

  1812 		my $cl = $scope->{classes};

  1813 		my $vl = $scope->{values};

  1814 		my $fstr = $scope->{formatStrings};

  1815 		my $fcat = $scope->{formatCategories};

  1816 		print "SCOPE: $scope->{name}\n";

  1817 		if (scalar(@$el)) {

  1818 			print "\tenums:\n";

  1819 			foreach (@$el) {

  1820 				print "\t\t$_\n";

  1821 			}

  1822 		}

  1823 		if (scalar(keys(%$vl))) {

  1824 			print "\tvalues:\n";

  1825 			foreach $vname (keys(%$vl)) {

  1826 				my $v = $vl->{$vname};

  1827 				my $x = $v->{value};

  1828 				my $t = $v->{type};

  1829 				my $sz = $v->{size};

  1830 				my $fstring = $fstr->{$vname};

  1831 				my $fcategory = $fcat->{$vname};

  1832 				if ($v->{enum}) {

  1833 					printf ("\t\t$vname\=$x (enum $t) size=$sz fcat=[0x%x] fstr=[%s]\n", $fcategory,$fstring);

  1834 				} else {

  1835 					printf ("\t\t$vname\=$x (type $t) size=$sz fcat=[0x%x] fstr=[%s]\n", $fcategory, $fstring);

  1836 				}

  1837 			}

  1838 		}

  1839 		if ($scope->{scope}) {

  1840 			my $members = $scope->{members};

  1841 			foreach (@$members) {

  1842 				my $n = $_->{name};

  1843 				my $sz = $_->{size};

  1844 				my $off = $_->{offset};

  1845 				my $spc = $_->{spacing};

  1846 				if (defined $spc) {

  1847 					print "\t$n\[\]\: spacing $spc size $sz offset $off\n";

  1848 				} else {

  1849 					print "\t$n\: size $sz offset $off\n";

  1850 				}

  1851 			}

  1852 			print "\tOverall size : $scope->{size}\n";

  1853 			print "\tOverall align: $scope->{align}\n";

  1854 		}

  1855 		foreach $s (@$cl) {

  1856 			dump_scope($s);

  1857 		}

  1858 	}

  1863 	sub parse_doxygen($$$$) {

  1864 		my ($scope,$tokens,$line,$t) = @_;

  1866 		if ($t ne "/")

  1867 			{

  1868 			return 0;	# not a doxygen comment

  1869 			}

  1870 		if ($t eq "/") {

  1871 			$state=0;

  1872 			my $t2 = shift @$tokens;

  1873 			my $t3 = shift @$tokens;

  1875 			if ($t2 ne "*" || $t3 ne "*")

  1876 				{

  1877 				unshift @$tokens, $t3;

  1878 				unshift @$tokens, $t2;

  1879 				return 0;	# not a doxygen comment

  1880 				}

  1881 		}

  1882 #		printf "doxygen start on line %d\n", $$line;

  1883 		for (;;) {

  1884 			my $t = shift @$tokens;

  1885 			if (!defined($t))

  1886 					{

  1887 					warn "Unexpected end of file #4 at line $$line\n";

  1888 					return

  1889 					}

  1891 			if ($t eq "\n"){++$$line };

  1893 			if ($t eq '*')

  1894 				{

  1895 				my $t2 = shift @$tokens;

  1896 				last if ($t2 eq '/');

  1897 				unshift @$tokens, $t2;

  1898 				}

  1900 			if ($t eq '@')

  1901 				{

  1902 				my $t2 = shift @$tokens;

  1903 				if ($t2 eq 'SYMTraceFormatString')

  1904 					{

  1905 					my $t3 = shift @$tokens;

  1906 #					if ($VerboseMode){print "SYMTraceFormatString = [$t3]\n";}

  1907 					$CurrentTraceFormatString = $t3;

  1908 					}

  1909 				if ($t2 eq 'SYMTraceFormatCategory')

  1910 					{

  1911 					$CurrentTraceFormatCategory = get_operand($scope,$tokens,$line);

  1912 #					if ($VerboseMode){printf ("SYMTraceFormatCategory = 0x%x\n", $CurrentTraceFormatCategory);}

  1913 					}

  1914 				else

  1915 					{

  1916 					unshift @$tokens, $t2;

  1917 					}

  1918 				}

  1920 		}

  1921 #		printf ("doxygen end  on line %d\n", $$line);

  1922 		return 1;	# is a doxygen comment

  1923 	}

author	sl
	Tue, 10 Jun 2014 14:32:02 +0200
changeset 1	260cb5ec6c19
permissions	-rw-r--r--