--- a/kerneltest/e32utils/trace/btracevw.pl Wed May 12 10:34:10 2010 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,1952 +0,0 @@
-#
-# Copyright (c) 2009 Nokia Corporation and/or its subsidiary(-ies).
-# All rights reserved.
-# This component and the accompanying materials are made available
-# under the terms of the License "Eclipse Public License v1.0"
-# which accompanies this distribution, and is available
-# at the URL "http://www.eclipse.org/legal/epl-v10.html".
-#
-# Initial Contributors:
-# Nokia Corporation - initial contribution.
-#
-# Contributors:
-#
-# Description:
-#
-
-#!/usr/bin/perl
-
-use File::Find;
-use File::Spec::Functions;
-
-
- my $TraceFileName;
-
- my $PrintFlagFilePos = 0;
- my $PrintFlagHdrLen = 0;
- my $PrintFlagHdrFlags = 0;
- my $PrintFlagFormatString = 0;
- my $VerboseMode = 0;
- my $RawMode = 0;
- my $FormatIdIsSubCategory = 0;
- my $OutputSawDictionaryMode = 0;
-
- # for the category range 0-191, the format string is indexed by the category & subcategory
- %FormatTables =
- (
- 0 => # ERDebugPrintf
- {
- 0 => "ThreadId %h, %s",
- },
-
- 1 => # ERKernPrintf
- {
- 0 => "ThreadId %h, %s",
- },
-
- 3 => # EThreadIdentification
- {
- 0 => "ENanoThreadCreate, NThread %x",
- 1 => "ENanoThreadDestroy, NThread %x",
- 2 => "EThreadCreate, NThread %x, DProcess %x, name %s",
- 3 => "EThreadDestroy, NThread %x, DProcess %x, Id %x",
- 4 => "EThreadName, NThread %x, DProcess %x, name %s",
- 5 => "EProcessName, NThread %x, DProcess %x, name %s",
- 6 => "EThreadId, NThread %x, DProcess %x, Id %x",
- 7 => "EProcessCreate, DProcess %x",
- 8 => "EProcessDestroy, DProcess %x",
- },
- );
-
- my @typedefs;
- my @members;
- my %values = (
-# UTF::KInitialClientFormat => {type=>"TFormatId", size=>2, value=>512}
- KMaxTUint8 => {type=>"TUint8", size=>1, value=>255},
- KMaxTUint16 => {type=>"TUint16", size=>2, value=>65535}
- );
- my %macros;
- my @classes;
- my @enums;
- my %formatStrings; # each enum may have it's own format string
- my %formatCategories; # each enum may have it's own format category
-
- my %filescope;
- $filescope{file}=1;
- undef $filescope{name};
-
- $filescope{typedefs}=\@typedefs;
- $filescope{members}=\@members;
- $filescope{values}=\%values;
- $filescope{macros} = \%macros;
- $filescope{FormatTables} = \%FormatTables;
-
- $filescope{classes} = \@classes;
- $filescope{enums} = \@enums;
-
- $filescope{formatStrings} =\%formatStrings;
- $filescope{formatCategories} = \%formatCategories;
-
-
-
- if (@ARGV == 0)
- {
- print "BTraceVw.pl \n";
- print "An unsupported utility which extracts UTrace-style format-strings\n";
- print "from header files & uses these to decode a BTrace output file\n";
- print "Syntax : BTraceVw.pl [-v] [-r] [-sd] [-i <IncFilePath>] [<BTrace file>]\n";
- print "where : -v = verbose mode\n";
- print " : -r = raw output mode\n";
- print " : -sd = produce SAW trace viewer dictionary file\n";
- print " : this file then needs to be merged into the 'com.symbian.analysis.trace.ui.prefs' file\n";
- print " : located under the carbide workspace directory\n";
- print "\n";
-
- print "e.g. (this decodes a trace file & produces a comma-separated output file) : \n";
- 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";
- print "\n";
- print "e.g. (this overwrites the SAW dictioany file) : \n";
- 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";
-
- exit;
- }
-
- while (@ARGV > 0)
- {
-
- if ($ARGV[0] eq "-i")
- {
- shift @ARGV;
- ($FilePath) = @ARGV;
- shift @ARGV;
-
- undef @incFiles;
- @incFiles;
-
- find sub { push @incFiles, $File::Find::name if m/\.h$/i;}, $FilePath ;
- foreach $incFile (@incFiles)
- {
- H2Trace($incFile, \%filescope);
- }
- }
- elsif ($ARGV[0] eq "-r")
- {
- $RawMode = 1;
- shift @ARGV;
- }
- elsif ($ARGV[0] eq "-sd")
- {
- $OutputSawDictionaryMode = 1;
- shift @ARGV;
- }
- elsif ($ARGV[0] eq "-v")
- {
- $VerboseMode = 1;
- shift @ARGV;
- }
- else
- {
- $TraceFileName = "$ARGV[0]";
- shift @ARGV;
- }
- }
-
- if ($VerboseMode)
- {
- dump_scope(\%filescope);
- PrintFormatTables(\%FormatTables);
- }
- if ($OutputSawDictionaryMode)
- {
- OutputSawDictionary(\%FormatTables);
- }
-
- if (defined ($TraceFileName))
- {
- ReadTraceFile($RawMode);
- }
-
-
-
-
-sub ReadTraceFile($)
- {
- (my $RawMode) = @_;
-# print "Trace file is $TraceFileName, RawMode $RawMode, VerboseMode $VerboseMode\n\n";
-
- open (LOGFILE, "<$TraceFileName") or die "Can't open $TraceFileName: $!\n";
- binmode (LOGFILE);
-
- my $val = 0;
-
-
- # enum TFlags from e32btrace.h
- $EHeader2Present = 1<<0;
- $ETimestampPresent = 1<<1;
- $ETimestamp2Present = 1<<2;
- $EContextIdPresent = 1<<3;
- $EPcPresent = 1<<4;
- $EExtraPresent = 1<<5;
- $ERecordTruncated = 1<<6;
- $EMissingRecord = 1<<7;
-
- # enum TFlags2 from e32btrace.h
- $EMultipartFlagMask = 3<<0;
- $ECpuIdMask = 0xfff<<20;
-
- # enum TMultiPart from e32btrace.h
- $EMultipartFirst = 1;
- $EMultipartMiddle = 2;
- $EMultipartLast = 3;
-
- $EMaxBTraceDataArray = 80;
-
- # enum TCategory from e32btrace.h
- $EThreadIdentification = 3;
-
- # enum TThreadIdentification from e32btrace.h
- $EThreadCreate = 2;
- $EThreadName = 4;
- $EProcessName = 5;
- $EThreadId = 6;
-
- # Context Id bits from e32btrace.h
- $EContextIdMask = 0x00000003;
- $EContextIdThread = 0;
- $EContextIdFIQ = 0x1;
- $EContextIdIRQ = 0x2;
- $EContextIdIDFC = 0x3;
-
- # enum TClassificationRange from e32btraceu.h
- $EAllRangeFirst = 192;
- $EAllRangeLast = 222;
-
- %TCategoryIdToString =
- (
- 0 => "ERDebugPrintf",
- 1 => "EKernPrintf",
- 2 => "EPlatsecPrintf",
- 3 => "EThreadIdentification",
- 4 => "ECpuUsage",
- 5 => "EKernPerfLog",
- 6 => "EClientServer",
- 7 => "ERequests",
- 8 => "EChunks",
- 9 => "ECodeSegs",
- 10 => "EPaging",
- 11 => "EThreadPriority",
- 12 => "EPagingMedia",
- 13 => "EKernelMemory",
- 14 => "EHeap",
- 15 => "EMetaTrace",
- 16 => "ERamAllocator",
- 17 => "EFastMutex",
- 18 => "EProfiling",
- 19 => "EResourceManager",
- 20 => "EResourceManagerUs",
- 21 => "ERawEvent ",
- 128 => "EPlatformSpecificFirst",
- 191 => "EPlatformSpecificLast",
- 192 => "ESymbianExtentionsFirst",
-
- # UTrace "ALL" range
- 192 => "EPanic",
- 193 => "EError",
- 194 => "EWarning",
- 195 => "EBorder",
- 196 => "EState",
- 197 => "EInternals",
- 198 => "EDump",
- 199 => "EFlow",
- 200 => "ESystemCharacteristicMetrics",
- 201 => "EAdhoc",
-
- 253 => "ESymbianExtentionsLast",
- 254 => "ETest1",
- 255 => "ETest2",
- );
-
-
- %ProcessNames;
- %ThreadNames;
- %ThreadIds;
-
-
- # print column titles
- if ($PrintFlagFilePos) {printf "FilePos, ";} # col #0
- if ($PrintFlagHdrLen) { printf "Len, ";} # col #1
- if ($PrintFlagHdrFlags) {printf "Flags, "; } # col #2
- printf "Category, "; # col #3
- printf "TimeStamp, "; # col #4
- printf "Delta, "; # col #5
- printf "context Id, "; # col #6
- printf "PC, "; # col #7
- printf "UID, "; # col #8
- if ($PrintFlagFormatString){printf "Format string, ";} # col #9
- printf "Formatted text, "; # col #10
- print "\n\n";
-
-
- while (1)
- {
- my $pos = tell (LOGFILE);
-
- # print file pos (col #0)
- if ($PrintFlagFilePos){ printf ("0x%08X, ", $pos);}
-
- my $category;
- my $subCategory;
- my $multipartFlags = 0;
- my $recordData = "";
- my $recordLen;
- my $recordPos = 0;
-
- $recordLen = ReadRecord(LOGFILE, \$pos, \$recordData, \$category, \$subCategory, \$multipartFlags, $RawMode);
- if ($recordLen == -1)
- {last;}
-
-
- if (!$RawMode && ($multipartFlags == $EMultipartMiddle || $multipartFlags == $EMultipartLast))
- {next;}
-
-# print record contents
-# my $buf;
-# for (my $i=0; $i < $recordLen; $i+=4)
-# {
-# $buf.= sprintf ("%08X ", unpack("V", substr($recordData, $recordPos+$i, 4)));
-# }
-# printf "\n[$buf\n]";
-
-
- # for UTrace "ALL" range, read UID
- if ($category >= $EAllRangeFirst && $category <= $EAllRangeLast &&
- (!$RawMode) && $multipartFlags != $EMultipartMiddle && $multipartFlags != $EMultipartLast)
- {
- $uid = unpack("V", substr($recordData, $recordPos, 4));
- $recordPos+= 4;
-
- # then read formatID
- $FormatIdIsSubCategory = ($subCategory != 0) ? 1 : 0;
- if ($FormatIdIsSubCategory)
- {
- $formatId = $subCategory
- }
- else
- {
- $formatId = unpack("V", substr($recordData, $recordPos, 4));
- $recordPos+= 4;
- }
- }
-
-
- # print UID (col #8)
- printf "0x%08X, ", $uid;
-
-
- my $formatTable;
- my $formatString;
- if ($category >= $EAllRangeFirst && $category <= $EAllRangeLast)
- {
- $formatString = $FormatTables{$uid}{$formatId};
- }
- else
- {
- $formatString = $FormatTables{$category}{$subCategory};
- }
-
-
- # Get thread names
- if ($category == $EThreadIdentification)
- {
- if ($subCategory == $EProcessName)
- {
- my $process = unpack("V", substr($recordData, 4, 4));
- my $processName = substr($recordData, 8, $recordLen - 8);
-# printf ("\nprocess [%08X] processName [$processName]\n", $process);
- $ProcessNames{$process} = $processName;
- }
- elsif ($subCategory == $EThreadCreate || $subCategory == $EThreadName)
- {
- my $thread = unpack("V", substr($recordData, 0, 4));
- my $process = unpack("V", substr($recordData, 4, 4));
- my $threadName = substr($recordData, 8, $recordLen - 8);
-# printf ("\nprocess [%08X] thread [%08X] threadName [$threadName]\n", $process, $thread, $threadName);
- $ThreadNames{$thread} = $ProcessNames{$process} . "::" . $threadName;
- }
- elsif ($subCategory == $EThreadId)
- {
- my $thread = unpack("V", substr($recordData, 0, 4));
- my $process = unpack("V", substr($recordData, 4, 4));
- my $threadId = unpack("V", substr($recordData, 8, 4));
-# printf ("\nprocess [%08X] thread [%08X] threadId [%08X]\n", $process, $thread, $threadId);
- $ThreadIds{$thread} = $threadId;
- }
- }
-
-
- # print Format string (col #9)
- if ($PrintFlagFormatString)
- {
- my $formatStringWithoutCommas = $formatString;
- $formatStringWithoutCommas=~ s/,/ /g;
- printf "%s, ", $formatStringWithoutCommas;
- }
-
- my $formattedText;
-
- my $lenFormatString = length($formatString);
- if ($lenFormatString && !$RawMode && $multipartFlags != $EMultipartMiddle && $multipartFlags != $EMultipartLast)
- {
- for (my $i=0; $i<$lenFormatString; $i++)
- {
- my $c = (substr ($formatString, $i, 1));
-# printf "$c\n";
- if ($c eq "%")
- {
- undef my $fieldLen;
- $i++;
- $c = (substr ($formatString, $i, 1));
- if ($c eq "%")
- {
- $formattedText.= substr ($formatString, $i, 1);
- next;
- }
- if ($c eq "*") ## take length from buffer
- {
- $fieldLen = unpack("V", substr($recordData, $recordPos, 4));
- if ($fieldLen > $recordLen-$recordPos)
- {
- $formattedText.= "*** Invalid field length ***";
- last;
- }
- $recordPos+= 4;
- $i++;
- $c = (substr ($formatString, $i, 1));
- }
- if (lc $c eq "x" || $c eq "h")
- {
- if (defined $fieldLen)
- {
- if (($fieldLen & 3) == 0)
- {
- for (my $i=0; $i< $fieldLen; $i+= 4)
- {
- $formattedText.= sprintf ("%08X ", unpack("V", substr($recordData, $recordPos, 4)));
- $recordPos+= 4;
- }
- }
- else
- {
- for (my $i=0; $i< $fieldLen; $i++)
- {
- $formattedText.= sprintf ("%02X ", unpack("C", substr($recordData, $recordPos, 1)));
- $recordPos++;
- }
- }
- }
- else
- {
- $formattedText.= sprintf ("0x%08X", unpack("V", substr($recordData, $recordPos, 4)));
- $recordPos+= 4;
- }
- $recordPos = ($recordPos + 3) & ~3;
- next;
- }
- # display "%ld" as hex for now as don't know how to get perl to use or display a 64 decimal value
- elsif (lc $c eq "l" && substr ($formatString, $i+1, 1) eq "d")
- {
- $i++;
- my $loWord = unpack("V", substr($recordData, $recordPos, 4));
- $recordPos+= 4;
- my $hiWord = unpack("V", substr($recordData, $recordPos, 4));
- $recordPos+= 4;
- $formattedText.= sprintf ("0x%X:%08X", $hiWord, $loWord);
- }
- elsif (lc $c eq "l" && substr ($formatString, $i+1, 1) eq "x")
- {
- $i++;
- my $loWord = unpack("V", substr($recordData, $recordPos, 4));
- $recordPos+= 4;
- my $hiWord = unpack("V", substr($recordData, $recordPos, 4));
- $recordPos+= 4;
- $formattedText.= sprintf ("0x%X:%08X", $hiWord, $loWord);
- }
- elsif (lc $c eq "d")
- {
- $formattedText.= sprintf ("%d", unpack("V", substr($recordData, $recordPos, 4)));
- $recordPos+= 4;
- $recordPos = ($recordPos + 3) & ~3;
- next;
- }
- elsif ($c eq "s")
- {
- if (!defined $fieldLen)
- {$fieldLen = $recordLen - $recordPos;}
- $formattedText.= substr($recordData, $recordPos, $fieldLen);
- $recordPos+= $fieldLen;
- $recordPos = ($recordPos + 3) & ~3;
- next;
- }
- elsif ($c eq "S")
- {
- if (!defined $fieldLen)
- {$fieldLen = $recordLen-$recordPos;}
- for (my $j=0; $j < $fieldLen; $j+=2)
- {
- my $byte = unpack("c", substr ($recordData, $recordPos+$j, 1));
- $formattedText.= sprintf ("%c", $byte);
- }
- $recordPos+= $fieldLen;
- $recordPos = ($recordPos + 3) & ~3;
- next;
- }
- elsif ($c eq "c")
- {
- my $byte = unpack("c", substr ($recordData, $recordPos, 1));
- $formattedText.= sprintf ("%c", $byte);
- }
- }
- else
- {
- $formattedText.= $c;
- }
- }
- }
- else # no format string : print as hex
- {
- for (my $i=0; $i < $recordLen; $i+=4)
- {
- $formattedText.= sprintf ("%08X ", unpack("V", substr($recordData, $i, 4)));
- }
- $recordPos+= $recordLen; $recordLen = 0;
-
- }
-
-
- # print Formatted text (col #10)
- $formattedText=~ s/,/;/g;
- $formattedText=~ s/\r//g;
- $formattedText=~ s/\n/,/g;
- printf "%s", $formattedText;
-
- printf("\n");
-
- if ($len < 0 || $recordLen < 0) {die "truncated file";}
-
-
- $pos+= ($len +3) & ~3;
- seek (LOGFILE, $pos, SEEK_SET) or die "truncated file";
- $i++;
- }
-
- close (LOGFILE);
-
- if ($VerboseMode)
- {
- print "*** Processes ***\n";
- for $id ( keys %ProcessNames )
- {
- printf ("process %08X ProcessName %s\n", $id, $ProcessNames{$id});
- }
- print "*** Thread ***\n";
- for $id ( keys %ThreadNames )
- {
- printf ("thread %08X ThreadName %s::%X\n", $id, $ThreadNames{$id}, $ThreadIds{$id});
- }
- }
-
- }
-
-
-sub ReadSingleRecord
- {
- ($fh, $data, $dataLen, $recordLen, $category, $subCategory, $multipartFlags, $extraN, $totalLen, $offset, $RawMode) = @_;
-
- my $hdr;
- my $flags;
- my $header2;
- my $timestamp;
- my $timestamp2;
- my $contextId;
- my $programConter;
-
- my $recordOffset = 0;
-
- $timestampLast;
- my $timestampDelta = 0;
-
- my $bytesRead = read($fh, $hdr, 4);
-
-
- if ($bytesRead < 4)
- {return -1;}
-
- ($$recordLen,$flags,$$category,$$subCategory) = unpack("CCCC", $hdr);
- $$dataLen = $$recordLen-4;
-
- if ($flags & $EHeader2Present)
- {$$multipartFlags = (ReadDword($fh) & $EMultipartFlagMask); $$dataLen-= 4}
- else
- {$$multipartFlags = 0;}
- if ($flags & $ETimestampPresent)
- {$timestamp = ReadDword($fh); $$dataLen-= 4;}
- if ($flags & $ETimestamp2Present)
- {$timestamp2 = ReadDword($fh); $$dataLen-= 4;}
- if ($flags & $EContextIdPresent)
- {$contextId = ReadDword($fh); $$dataLen-= 4;}
- if ($flags & $EPcPresent)
- {$programConter = ReadDword($fh); $$dataLen-= 4;}
- if ($flags & $EExtraPresent)
- {$$extraN = ReadDword($fh); $$dataLen-= 4;}
- if ($$multipartFlags != 0)
- {
- $$totalLen = ReadDword($fh); $$dataLen-= 4;
- if ($$multipartFlags == $EMultipartMiddle || $$multipartFlags == $EMultipartLast)
- {$$offset = ReadDword($fh); $$totalLen-= 4; $$dataLen-= 4;}
- }
-
- $timestampDelta = $timestamp - $timestampLast;
- $timestampLast = $timestamp;
-
- read($fh, $$data, ($$dataLen + 3) & ~3);
-
-
- if ($RawMode || $$multipartFlags == $EMultipartFirst || $$multipartFlags == 0)
- {
- # print header len (col #1)
- if ($PrintFlagHdrLen){printf ("0x%02X, ", $$recordLen);}
-
- # print header flags (col #2)
- if ($PrintFlagHdrFlags)
- {
- printf ("%02X ", $flags);
- if ($flags & $EHeader2Present) {printf "EHeader2Present ";}
- if ($flags & $ETimestampPresent) {printf "ETimestampPresent ";}
- if ($flags & $ETimestamp2Present) {printf "ETimestamp2Present ";}
- if ($flags & $EContextIdPresent) {printf "EContextIdPresent ";}
- if ($flags & $EPcPresent) {printf "EPcPresent ";}
- if ($$multipartFlags != 0)
- {
- printf "EExtraPresent ";
- if ($$multipartFlags == $EMultipartFirst) {print "EMultipartFirst ";}
- elsif ($$multipartFlags == $EMultipartMiddle) {print "EMultipartMiddle ";}
- elsif ($$multipartFlags == $EMultipartLast) {print "EMultipartLast ";}
- printf ("ExtraN(0x%08X) ", $$extraN);
- }
- if ($flags & $ERecordTruncated) {printf "ERecordTruncated ";}
- if ($flags & $EMissingRecord) {printf "EMissingRecord ";}
- print ",";
- }
-
- # print category (col #3)
- printf "(%d;%d) $categoryString , ", $$category, $$subCategory;
-
- # print timestamp(s) (col #4)
- printf "0x";
- if (defined $timestamp2) {printf "%08X : ", $timestamp2;}
- printf "%08X", $timestamp;
- printf ", ";;
-
- # print timestamp delta (col #5)
- printf "0x%08X, ", $timestampDelta;
-
- # print context Id (col #6)
- if (!$RawMode && defined $ThreadNames{$contextId})
- {
- printf ("%s::%X, ", $ThreadNames{$contextId}, $ThreadIds{$contextId});
- }
- else
- {
- if ((($contextId & $EContextIdMask) == $EContextIdThread) || $RawMode)
- {printf "0x%08X, ", $contextId;}
- elsif (($contextId & $EContextIdMask) == $EContextIdFIQ)
- {printf "FIQ, ";}
- elsif (($contextId & $EContextIdMask) == $EContextIdIRQ)
- {printf "IRQ, ";}
- elsif (($contextId & $EContextIdMask) == $EContextIdIDFC)
- {printf "IDFC, ";}
- }
-
- # print Program Counter (col #7)
- printf "0x%08X, ", $programConter;
- }
-
-
-
-
-#########################################################
-# my $hex;
-# for (my $i=0; $i < $$dataLen; $i+=4)
-# {
-# $hex.= sprintf ("%08X ", unpack("V", substr($$data, $i, 4)));
-# }
-# printf "\nadding [$hex]\n";
-#########################################################
- return $bytesRead
- }
-
-
-sub ReadRecord
- {
- ($fh, $recordPos, $recordData, $category, $subCategory, $multipartFlags, $RawMode) = @_;
-# printf "CurrentPos %08X\n", $pos;
-
-
-
- seek ($fh, $$recordPos, SEEK_SET) or die "truncated file";
- my $recordLen;
- my $extraN;
- my $totalLen;
- my $offset;
- my $dataLen;
- my $data;
- my $bytesRead;
-
-
- $bytesRead = ReadSingleRecord($fh, \$data, \$dataLen, \$recordLen, \$$category, \$$subCategory, \$$multipartFlags, \$extraN, \$totalLen, \$offset, $RawMode);
-
- if ($bytesRead == -1) # eof ?
- {return -1; }
- $$recordPos+= ($recordLen +3) & ~3;
-
- $$recordData = $data;
- $offset = $dataLen;
-
- $offset-= 4; # subtract 4 bytes for UID ?????????
-
- if ($RawMode || $$multipartFlags != $EMultipartFirst)
- {return $dataLen;}
-
- $pos = $$recordPos;
-
- while (1)
- {
-
- # find next record, i.e. look for a record which matches $extraN
-
- seek ($fh, $pos, SEEK_SET) or die "truncated file";
-
- my $recordLen;
-
- my $category;
- my $subCategory;
- my $multipartFlags;
- my $currentExtraN;
- my $currentOffset;
-
- my $totalLen;
- my $currentDataLen;
- my $data;
- $bytesRead = ReadSingleRecord($fh, \$data, \$currentDataLen, \$recordLen, \$category, \$subCategory, \$multipartFlags, \$currentExtraN, \$totalLen, \$currentOffset, $RawMode);
- if ($bytesRead == -1) # eof ?
- {return -1; }
- $pos+= ($recordLen +3) & ~3;
-
-# printf "\npos %08X, Seaching for (extra %08X, offset %08X), found (extra %08X, offset %08X)\n",
-# $pos, $extraN, $offset, $currentExtraN, $currentOffset;
-
- if ($currentExtraN == $extraN && $currentOffset == $offset)
- {
- $$recordData.= $data;
- $offset+= $currentDataLen;
- $dataLen+= $currentDataLen;
- }
-
- if ($multipartFlags == $EMultipartLast)
- {last;}
- }
-
- return $dataLen;
- }
-
-sub ReadDword {
- (my $fh) = @_;
- my $buffer;
-
- $bytesRead = read($fh, $buffer, 4);
- if ($bytesRead < 4) {die "truncated file";}
-
- my $dword = unpack("V", $buffer);
-
- return $dword
- };
-
-sub ReadByte {
- (my $fh) = @_;
- my $buffer;
-
- $bytesRead = read($fh, $buffer, 1);
- if ($bytesRead < 1) {die "truncated file";}
-
- my $byte = unpack("C", $buffer);
-
- return $byte
- };
-
-
-
-sub PrintFormatTables($)
- {
- my ($formatTables) = @_;
-
- for $tableIndex ( sort keys %$formatTables )
- {
- printf ("SYMTraceFormatCategory %08X:\n", $tableIndex);
- for $formatId (sort keys %{ $$formatTables{$tableIndex} } )
- {
- printf ("%08X => %s\n", $formatId, $$formatTables{$tableIndex}{$formatId});
- }
- print "\n";
- }
- }
-
-
-
-sub OutputSawDictionary($)
- {
- my ($formatTables) = @_;
-
-
- # SAW enums
- $EFieldTypeHexDump = 0;
- $EFieldTypeHex = 1;
- $EFieldTypeDecimal = 2;
- $EFieldTypeStringToEnd = 3;
- $EFieldTypeNullTerminatedString = 4;
- $EFieldTypeHexDumpToEnd = 5;
- $EFieldTypeUnicodeToEnd = 6;
- $EFieldTypeNullTerminatedUnicode = 7;
- $EFieldTypeCountedUnicode = 8;
- $EFieldTypeCountedHexDump = 9;
- $EFieldTypeCountedString = 10;
-
- my $moduleIds; # string containg all UIDs separared by semi-colons
-
- for $tableIndex ( sort keys %$formatTables )
- {
- if ($tableIndex < 256)
- {
- next;
- }
- $moduleIds.= sprintf ("%08X;", $tableIndex);
-
- printf ("MODULEID_%08X_DESC=\n", $tableIndex);
- printf ("MODULEID_%08X_NAME=%08X\n", $tableIndex, $tableIndex);
-
- my $formatIds;
- $formatIds = sprintf ("MODULEID_%08X_FORMATIDS=", $tableIndex);
-
- for $formatId (sort keys %{ $$formatTables{$tableIndex} } )
- {
- $formatIds.= sprintf ("%d;", $formatId);
- }
- printf ("$formatIds\n");
-
-
- for $formatId (sort keys %{ $$formatTables{$tableIndex} } )
- {
- my $fieldCount = 0;
- my $formatString = $$formatTables{$tableIndex}{$formatId};
-
-#printf ("formatString = (%s)\n", $formatString);
-
- # format name is the first format string up until the first space or '%' character or end-of line ...
- $formatString=~ m/^[^%\s]*/;
- my $formatName = $&;
-
- # thow the format name away
- $formatString = $';
-
- # strip the leading space
- $formatString=~ s/\s*//;
-
- printf ("MODULEID_%08X_FORMATID_%d_NAME=%s\n", $tableIndex, $formatId, $formatName);
-#printf ("MODULEID_%08X_FORMATID_%d_DESC=\n", $tableIndex, $formatId);
-
- my $lenFormatString = length($formatString);
-
- my $formattedText;
- my $fieldType = $EFieldTypeHex;
- my $fieldLen = 0;
- while (length($formatString))
- {
- my $c = (substr ($formatString, 0, 1));
-#print ("[$formatString][$c]\n");
- $formatString=~ s/.//; # strip the leading space
- if ($c eq "%")
- {
-#print "found %\n";
- my $fieldLenSpecified = 0;
- $c = (substr ($formatString, 0, 1));
- $formatString=~ s/.//; # discard char
-#print "c2=$c\n";
- if ($c eq "%")
- {
- $formattedText.= substr ($formatString, 0, 1);
- next;
- }
- if ($c eq "*") ## take length from buffer
- {
- $fieldLenSpecified = 1;
- $c = (substr ($formatString, 0, 1));
- $formatString=~ s/.//; # discard char
- }
- if (lc $c eq "x" || $c eq "h")
- {
- ## deal wilth $fieldLenSpecified
- if ($fieldLenSpecified)
- {
- $fieldType = $EFieldTypeCountedHexDump;
- $fieldLen = 0;
- }
- else
- {
- $fieldType = $EFieldTypeHex;
- $fieldLen = 4;
- }
- }
- elsif (lc $c eq "l" && substr ($formatString, 0, 1) eq "d")
- {
- $formatString=~ s/.//; # discard char
- $fieldType = $EFieldTypeDecimal;
- $fieldLen = 8;
- }
- elsif (lc $c eq "l" && substr ($formatString, 0, 1) eq "x")
- {
- $formatString=~ s/.//; # discard char
- $fieldType = $EFieldTypeHex;
- $fieldLen = 8;
- }
- elsif (lc $c eq "d")
- {
- $fieldType = $EFieldTypeDecimal;
- $fieldLen = 4;
- }
- elsif ($c eq "s")
- {
- ## deal wilth $fieldLenSpecified
- if ($fieldLenSpecified)
- {
- $fieldType = $EFieldTypeCountedString;
- $fieldLen = 0;
- }
- else
- {
- $fieldType = $EFieldTypeStringToEnd;
- $fieldLen = 0;
- }
- }
- elsif ($c eq "S")
- {
- ## deal wilth $fieldLenSpecified
- if ($fieldLenSpecified)
- {
- $fieldType = $EFieldTypeCountedUnicode;
- $fieldLen = 0;
- }
- else
- {
- $fieldType = EFieldTypeUnicodeToEnd;
- $fieldLen = 0;
- }
- }
- elsif ($c eq "c")
- {
- $fieldType = $EFieldTypeHex;
- $fieldLen = 1;
- }
- printf ("MODULEID_%08X_FORMATID_%d_FIELD_%d_NAME=%s\n", $tableIndex, $formatId, $fieldCount, $formattedText);
- printf ("MODULEID_%08X_FORMATID_%d_FIELD_%d_TYPE=%s\n", $tableIndex, $formatId, $fieldCount, $fieldType);
- if ($fieldLen > 0)
- {printf ("MODULEID_%08X_FORMATID_%d_FIELD_%d_LENGTH=%s\n", $tableIndex, $formatId, $fieldCount, $fieldLen);}
- $fieldCount++;
- $formattedText="";
-
- $formatString=~ s/\s//; # strip the leading space
- }
- else
- {
-# if ($c eq ":") {$formattedText.= '\\'; }
- $formattedText.= $c;
- }
- }
- printf ("MODULEID_%08X_FORMATID_%d_FIELDS=%d\n", $tableIndex, $formatId, $fieldCount);
-
- }
- print "MODULEIDS=$moduleIds\n";
- }
- }
-
-
-
-
-
-
-
-
-sub H2Trace($$)
-{
- %basictypes = (
- TInt8 => 1,
- TUint8 => 1,
- TInt16 => 2,
- TUint16 => 2,
- TInt32 => 4,
- TUint32 => 4,
- TInt => 4,
- TUint => 4,
- TBool => 4,
- TInt64 => 8,
- TUint64 => 8,
- TLinAddr => 4,
- TVersion => 4,
- TPde => 4,
- TPte => 4,
- TProcessPriority => 4,
- TFormatId => 2,
- );
-
- if (scalar(@_)!= 2) {
- die "perl h2trace.pl <input.h>\n";
- }
- my ($infile, $filescope) = @_;
-
- if ($VerboseMode)
- {print "\nOpening $infile\n";}
-
- open IN, $infile or die "Can't open $infile for input\n";
- my $in;
- while (<IN>) {
- $in.=$_;
- }
- close IN;
-
- # First remove any backslash-newline combinations
- $in =~ s/\\\n//gms;
-
- # Remove any character constants
- $in =~ s/\'(.?(${0})*?)\'//gms;
-
- # Strip comments beginning with //
- $in =~ s/\/\/(.*?)\n/\n/gms; #//(.*?)\n
-
- # Strip comments (/* */) but leave doxygen comments (/** */)
- $in =~ s/\/\*[^*](.*?)\*\//\n/gms; #/*(.*?)*/
-
-
- # Collapse whitespace into a single space or newline
- $in =~ s/\t/\ /gms;
- $in =~ s/\r/\ /gms;
-
- # Tokenize on non-identifier characters
- my @tokens0 = split(/(\W)/,$in);
- my @tokens;
- my $inString = 0;
- my $inComment = 0;
- my $string;
- foreach $t (@tokens0) {
- next if ($t eq "");
- next if (!$inString && ($t eq " " or $t eq ""));
- if ($inComment == 0)
- {
- if ($t eq "/")
- {$inComment = 1;}
- }
- elsif ($inComment == 1)
- {
- if ($t eq "*")
- {$inComment = 2;}
- else
- {$inComment = 0;}
- }
- elsif ($inComment == 2)
- {
- if ($t eq "*")
- {$inComment = 3;}
- }
- elsif ($inComment == 3)
- {
- if ($t eq "/")
- {
- $inComment = 0;
- # if we were in a string, need to push previous '*'
- if ($inString)
- {
- push @tokens, "*";
- }
- $inString = 0; # end of comment aborts a string
- $string = "";
- }
- else
- {$inComment = 2;}
- }
-
- if ($t eq "\"")
- {
- if (!$inString)
- {
- $inString=1;
- next;
- }
- else
- {
- $inString=0;
- $t = $string;
- $string = "";
-# if ($VerboseMode) {print "string : [$t]\n"; }
- }
- }
-
- if ($inString)
- {
- $string.= $t;
- next;
- }
- push @tokens, $t;
- }
-
- my $CurrentTraceFormatString;
- my $CurrentTraceFormatCategory;
- # format Key as specified by the @TraceFormatCategory tag is either the current category
- # or the current UID
- my $CurrentFormatTableKey;
-
-
- my $line=1;
- parse_scope($filescope, \@tokens, \$line);
-
- #print $in;
- #print join (" ", @tokens);
-} # end of H2Trace
-
-
-
- sub parse_scope($$$) {
- my ($scope, $tokens, $line) = @_;
- my $state = 1;
-
- my @classes;
- my $curr_offset=0;
- my $overall_align=0;
-# print ">parse_scope $scope->{name}\n";
-
- while (scalar(@$tokens))
- {
- my $t = shift @$tokens;
-# printf "t: [$t] [$$line]\n";
- if (!defined ($t)) {
- printf "undefined !";
- next;
- }
- if ($state>=-1 and $t eq "\n") {
- ++$$line;
- $state=1;
- next;
- } elsif ($state==-1 and $t ne "\n") {
- next;
- } elsif ($state==-2 and $t ne ';') {
- next;
- }
-
- if ($state>0 and $t eq '#') {
- $t = shift @$tokens;
- if ($t eq 'define') {
- my $ident = shift @$tokens;
- my $defn = shift @$tokens;
- if ($defn ne '(') { # don't do macros with parameters
-# print "MACRO: $ident :== $defn\n";
- $macros{$ident} = $defn;
- }
- }
- $state=-1; # skip to next line
- next;
- }
-
-
- if (parse_doxygen($scope,$tokens, $line, $t) == 1)
- {next;}
-
- if ($t eq "namespace" ) {
- $state=0;
- my %cl;
- $cl{specifier}=$t;
- $cl{scope}=$scope;
- $cl{values}=$scope->{values};
- $cl{members}=\$scope->{members};
- $cl{typedefs}=\$scope->{typedefs};
- $cl{FormatTables}=$scope->{FormatTables};
- $cl{formatStrings} =$scope->{formatStrings};
- $cl{formatCategories} =$scope->{formatCategories};
-
- my $new_namespace = \%cl;
- my $n = get_token($scope,$tokens,$line);
- if ($n !~ /\w+/) {
- warn "Unnamed $t not supported at line $$line\n";
- return;
- }
- $new_namespace->{name}=$n;
- my @class_match = grep {$_->{name} eq $n} @classes;
- my $exists = scalar(@class_match);
- my $b = get_token($scope,$tokens,$line);
- if ($b eq ':') {
- die "Inheritance not supported at line $$line\n";
- } elsif ($b eq ';') {
- # forward declaration
- push @classes, $new_namespace unless ($exists);
- next;
- } elsif ($b ne '{') {
- warn "Syntax error#1 at line $$line\n";
- return;
- }
- if ($exists) {
- $new_namespace = $class_match[0];
- if ($new_namespace->{complete}) {
- warn "Duplicate definition of $cl{specifier} $n\n";
- }
- }
- push @classes, $new_namespace unless ($exists);
- parse_scope($new_namespace, $tokens, $line);
- next;
- }
-
- if ($t eq "struct" or $t eq "class" or $t eq "NONSHARABLE_CLASS") {
- next if ($state==0);
- $state=0;
- my %cl;
- $cl{specifier}=$t;
- $cl{scope}=$scope;
- my @members;
- my @typedefs;
- $cl{members}=\@members;
- $cl{typedefs}=\@typedefs;
- $cl{FormatTables}=$scope->{FormatTables};
- my $new_class = \%cl;
- my $n;
-
- if ($t eq "NONSHARABLE_CLASS")
- {
- my $b = get_token($scope,$tokens,$line);
- if ($b !~ /\(/) {die "Syntax error at line $$line\n";}
- $n = get_token($scope,$tokens,$line);
- $b = get_token($scope,$tokens,$line);
- if ($b !~ /\)/) {die "Syntax error at line $$line\n";}
- }
- else
- {
- $n = get_token($scope,$tokens,$line);
- }
-
-
- if ($n !~ /\w+/) {
- warn "Unnamed $t not supported at line $$line\n";
- return;
- }
- $new_class->{name}=$n;
- my @class_match = grep {$_->{name} eq $n} @classes;
- my $exists = scalar(@class_match);
- my $b = get_token($scope,$tokens,$line);
- #skip inheritance etc until we get to a '{' or \ ';'
- while ($b ne '{' && $b ne ';')
- {
- $b = get_token($scope,$tokens,$line);
- die "Syntax error#2 at line $$line\n" if (!defined $b);
- }
- if ($b eq ';') {
- # forward declaration
- push @classes, $new_class unless ($exists);
- next;
- }
- if ($exists) {
- $new_class = $class_match[0];
- if ($new_class->{complete}) {
- warn "Duplicate definition of $cl{specifier} $n\n";
- }
- }
- push @classes, $new_class unless ($exists);
- parse_scope($new_class, $tokens, $line);
- next;
- } elsif ($t eq "enum") {
- $state=0;
- my $n = get_token($scope,$tokens,$line);
- my $name="";
- if ($n =~ /\w+/) {
- $name = $n;
- $n = get_token($scope,$tokens,$line);
- }
- push @enums, $name;
- if ($n ne '{') {
- die "Syntax error#4 at line $$line\n";
- }
- parse_enum($scope, $tokens, $line, $name);
- next;
- } elsif ($t eq '}') {
- $state=0;
- if ($scope->{scope}) {
- if ($scope->{specifier} eq "namespace")
- {
- $scope->{complete}=1;
-# print "Scope completed\n";
- last;
- }
- $t = get_token($scope,$tokens,$line);
- # skip to next ';'
- while (defined ($t) and $t ne ';')
- {$t = get_token($scope,$tokens,$line);}
- die "Syntax error#5 at line $$line\n" if ($t ne ';');
- $scope->{complete}=1;
-# print "Scope completed\n";
- last;
- }
- warn "Syntax error#5 at line $$line\n";
- return;
- }
- $state=0;
- if ($scope->{scope}) {
- if ($t eq "public" or $t eq "private" or $t eq "protected") {
- if (shift (@$tokens) eq ':') {
- next; # ignore access specifiers
- }
- die "Syntax error#6 at line $$line\n";
- }
- }
- unshift @$tokens, $t;
-
- my @currdecl = parse_decl_def($scope, $tokens, $line);
-# print scalar (@currdecl), "\n";
- if ($t eq 'static') {
- next; # skip static members
- }
- my $typedef;
- if ($t eq 'typedef') {
-# print "TYPEDEF\n";
- $typedef = 1;
- $t = shift @currdecl;
- $t = $currdecl[0];
- } else {
-# print "NOT TYPEDEF\n";
- $typedef = 0;
- }
-# print "$currdecl[0]\n";
- next if (scalar(@currdecl)==0);
-
- if ($t eq "const") {
- # check for constant declaration
-# print "CONST $currdecl[1] $currdecl[2] $currdecl[3]\n";
- my $ctype = lookup_type($scope, $currdecl[1]);
-# print "$ctype->{basic} $ctype->{size}\n";
- if ($ctype->{basic} and $currdecl[2]=~/^\w+$/ and $currdecl[3] eq '=') {
- if ($typedef!=0) {
- die "Syntax error#7 at line $$line\n";
- }
- shift @currdecl;
- shift @currdecl;
- my $type = $ctype->{name};
- my $name; #### = shift @currdecl;
-
- if ($scope->{name})
- {
- $name = $scope->{name} . "::" . shift @currdecl;
- }
- else
- {
- $name = shift @currdecl;
- }
-# printf "[$name,$scope->{name}]";
- my $size = $ctype->{size};
- shift @currdecl;
- my $value = get_constant_expr($scope,\@currdecl,$line);
- $values{$name} = {type=>$type, size=>$size, value=>$value};
- next;
- }
- }
-
-
-
- }
- }
-
- sub get_token($$$) {
- my ($scope,$tokenlist,$line) = @_;
- while (scalar(@$tokenlist)) {
- my $t = shift @$tokenlist;
- return $t if (!defined($t));
- if (parse_doxygen($scope,$tokenlist, $line, $t) == 1)
- {next;}
- if ($t !~ /^[\s]*$/)
- {
- if ($$tokenlist[0] eq ":" and $$tokenlist[1] eq ":")
- {
- $t.= shift @$tokenlist;
- $t.= shift @$tokenlist;
- $t.= shift @$tokenlist;
-# print "Colon-separated token";
- }
- return $t
- }
- ++$$line;
- }
- return undef;
- }
-
- sub skip_qualifiers($) {
- my ($tokens) = @_;
- my $f=0;
- my %quals = (
- EXPORT_C => 1,
- IMPORT_C => 1,
- inline => 1,
- virtual => 0,
- const => 0,
- volatile => 0,
- static => 0,
- extern => 0,
- LOCAL_C => 0,
- LOCAL_D => 0,
- GLDEF_C => 0,
- GLREF_C => 0,
- GLDEF_D => 0,
- GLREF_D => 0
- );
- for (;;) {
- my $t = $$tokens[0];
- my $q = $quals{$t};
- last unless (defined ($q));
- $f |= $q;
- shift @$tokens;
- }
- return $f;
- }
-
- sub parse_indirection($) {
- my ($tokens) = @_;
- my $level = 0;
- for (;;) {
- my $t = $$tokens[0];
- if ($t eq '*') {
- ++$level;
- shift @$tokens;
- next;
- }
- last if ($t ne "const" and $t ne "volatile");
- shift @$tokens;
- }
- return $level;
- }
-
- sub get_operand($$$) {
- my ($scope,$tokens,$line) = @_;
- my $t = get_token($scope,$tokens,$line);
- if ($t eq '-') {
- my $x = get_operand($scope,$tokens,$line);
- return -$x;
- } elsif ($t eq '+') {
- my $x = get_operand($scope,$tokens,$line);
- return $x;
- } elsif ($t eq '~') {
- my $x = get_operand($scope,$tokens,$line);
- return ~$x;
- } elsif ($t eq '!') {
- my $x = get_operand($scope,$tokens,$line);
- return $x ? 0 : 1;
- } elsif ($t eq '(') {
- my $x = get_constant_expr($scope,$tokens,$line);
- my $t = get_token($scope,$tokens,$line);
- if ($t ne ')') {
- warn "Missing ) at line $$line\n";
- return undefined;
- }
- return $x;
- } elsif ($t eq "sizeof") {
- my $ident = get_token($scope,$tokens,$line);
- if ($ident eq '(') {
- $ident = get_token($scope,$tokens,$line);
- my $cb = get_token($scope,$tokens,$line);
- if ($cb ne ')') {
- warn "Bad sizeof() syntax at line $$line\n";
- return undefined;
- }
- }
- $ident = look_through_macros($ident);
- if ($ident !~ /^\w+$/) {
- warn "Bad sizeof() syntax at line $$line\n";
- return undefined;
- }
- my $type = lookup_type($scope, $ident);
- if (!defined $type) {
- warn "Unrecognised type $ident at line $$line\n";
- return undefined;
- }
- if ($type->{basic}) {
- return $type->{size};
- } elsif ($type->{enum}) {
- return 4;
- } elsif ($type->{ptr}) {
- return 4;
- } elsif ($type->{fptr}) {
- return 4;
- }
- my $al = $type->{class}->{align};
- my $sz = $type->{class}->{size};
- return ($sz+$al-1)&~($al-1);
- }
- $t = look_through_macros($t);
- if ($t =~ /^0x/i) {
- return oct($t);
- } elsif ($t =~ /^\d/) {
- return $t;
- } elsif ($t =~ /^\w+$/) {
- my $x = lookup_value($scope,$t);
-# die "Unrecognised identifier '$t' at line $$line\n" unless defined($x);
- if (!defined($x)) {
- print "Unrecognised identifier '$t' at line $$line\n" ;
- }
- return $x;
- } elsif ($t =~ /^\w+::\w+$/) {
- my $x = lookup_value($scope,$t);
-# die "Unrecognised identifier '$t' at line $$line\n" unless defined($x);
- if (!defined($x)) {
- print "Unrecognised identifier '$t' at line $$line\n" ;
- }
- return $x;
- } else {
- warn "Syntax error#10 at line $$line\n";
- return undefined;
- }
- }
-
- sub look_through_macros($) {
- my ($ident) = @_;
- while ($ident and $macros{$ident}) {
- $ident = $macros{$ident};
- }
- return $ident;
- }
-
- sub lookup_value($$) {
- my ($scope,$ident) = @_;
- while ($scope) {
- my $vl = $scope->{values};
- if (defined($vl->{$ident})) {
- return $vl->{$ident}->{value};
- }
- $scope = $scope->{scope};
- }
- return undef();
- }
-
- sub lookup_type($$) {
- my ($scope,$ident) = @_;
- if ($basictypes{$ident}) {
- return {scope=>$scope, basic=>1, name=>$ident, size=>$basictypes{$ident} };
- }
- while ($scope) {
- if ($basictypes{$ident}) {
- return {scope=>$scope, basic=>1, name=>$ident, size=>$basictypes{$ident} };
- }
- my $el = $scope->{enums};
- my $cl = $scope->{classes};
- my $td = $scope->{typedefs};
- if (grep {$_ eq $ident} @$el) {
- return {scope=>$scope, enum=>1, name=>$ident, size=>4 };
- }
- my @match_class = (grep {$_->{name} eq $ident} @$cl);
- if (scalar(@match_class)) {
- return {scope=>$scope, class=>$match_class[0]};
- }
- my @match_td = (grep {$_->{name} eq $ident} @$td);
- if (scalar(@match_td)) {
- my $tdr = $match_td[0];
- my $cat = $tdr->{category};
- if ($cat eq 'basic' or $cat eq 'enum' or $cat eq 'class') {
- $ident = $tdr->{alias};
- next;
- } else {
- return { scope=>$scope, $cat=>1, $size=>$tdr->{size} };
- }
- }
- $scope = $scope->{scope};
- }
- return undef();
- }
-
- sub get_mult_expr($$$) {
- my ($scope,$tokens,$line) = @_;
- my $x = get_operand($scope,$tokens,$line);
- my $t;
- for (;;) {
- $t = get_token($scope,$tokens,$line);
- if ($t eq '*') {
- my $y = get_operand($scope,$tokens,$line);
- $x = $x * $y;
- } elsif ($t eq '/') {
- my $y = get_operand($scope,$tokens,$line);
- if ($y != 0)
- {$x = int($x / $y);}
- } elsif ($t eq '%') {
- my $y = get_operand($scope,$tokens,$line);
- if ($y != 0)
- {$x = int($x % $y);}
- } else {
- last;
- }
- }
- unshift @$tokens, $t;
- return $x;
- }
-
- sub get_add_expr($$$) {
- my ($scope,$tokens,$line) = @_;
- my $x = get_mult_expr($scope,$tokens,$line);
- my $t;
- for (;;) {
- $t = get_token($scope,$tokens,$line);
- if ($t eq '+') {
- my $y = get_mult_expr($scope,$tokens,$line);
- $x = $x + $y;
- } elsif ($t eq '-') {
- my $y = get_mult_expr($scope,$tokens,$line);
- $x = $x - $y;
- } else {
- last;
- }
- }
- unshift @$tokens, $t;
- return $x;
- }
-
- sub get_shift_expr($$$) {
- my ($scope,$tokens,$line) = @_;
- my $x = get_add_expr($scope,$tokens,$line);
- my $t, $t2;
- for (;;) {
- $t = get_token($scope,$tokens,$line);
- if ($t eq '<' or $t eq '>') {
- $t2 = get_token($scope,$tokens,$line);
- if ($t2 ne $t) {
- unshift @$tokens, $t2;
- last;
- }
- }
- if ($t eq '<') {
- my $y = get_add_expr($scope,$tokens,$line);
- $x = $x << $y;
- } elsif ($t eq '>') {
- my $y = get_add_expr($scope,$tokens,$line);
- $x = $x >> $y;
- } else {
- last;
- }
- }
- unshift @$tokens, $t;
- return $x;
- }
-
- sub get_and_expr($$$) {
- my ($scope,$tokens,$line) = @_;
- my $x = get_shift_expr($scope,$tokens,$line);
- my $t;
- for (;;) {
- $t = get_token($scope,$tokens,$line);
- if ($t eq '&') {
- my $y = get_shift_expr($scope,$tokens,$line);
- $x = $x & $y;
- } else {
- last;
- }
- }
- unshift @$tokens, $t;
- return $x;
- }
-
- sub get_xor_expr($$$) {
- my ($scope,$tokens,$line) = @_;
- my $x = get_and_expr($scope,$tokens,$line);
- my $t;
- for (;;) {
- $t = get_token($scope,$tokens,$line);
- if ($t eq '^') {
- my $y = get_and_expr($scope,$tokens,$line);
- $x = $x ^ $y;
- } else {
- last;
- }
- }
- unshift @$tokens, $t;
- return $x;
- }
-
- sub get_ior_expr($$$) {
- my ($scope,$tokens,$line) = @_;
- my $x = get_xor_expr($scope,$tokens,$line);
- my $t;
- for (;;) {
- $t = get_token($scope,$tokens,$line);
- if ($t eq '|') {
- my $y = get_xor_expr($scope,$tokens,$line);
- $x = $x | $y;
- } else {
- last;
- }
- }
- unshift @$tokens, $t;
- return $x;
- }
-
- sub get_constant_expr($$$) {
- my ($scope,$tokens,$line) = @_;
- my $x = get_ior_expr($scope,$tokens,$line);
- return $x;
- }
-
- sub parse_enum($$$$) {
- my ($scope,$tokens,$line,$enum_name) = @_;
- my $vl = $scope->{values};
- my $fstr = $scope->{formatStrings};
- my $fcat = $scope->{formatCategories};
- my $fmtTable = $scope->{FormatTables};
-
- my $x = 0;
- for (;;) {
- my $t = get_token($scope,$tokens,$line);
- last if ($t eq '}');
- if (!defined($t)) {
- die "Unexpected end of file #2 at line $$line\n";
- }
-
- if ($t eq '#') {
- next;
- }
-
- if ($t !~ /^\w+$/) {
- warn "Syntax error#11 at line $$line\n";
- next;
- }
-
- if ($scope->{name})
- {
- $t = $scope->{name} . "::" . $t;
- }
-
- if (defined($vl->{$t})) {
- warn "Duplicate identifier [$t] at line $$line\n";
- }
- my $t2 = get_token($scope,$tokens,$line);
- if ($t2 eq ',') {
- $vl->{$t} = {type=>$enum_name, size=>4, value=>$x, enum=>1};
- $fstr->{$t} = $CurrentTraceFormatString;
- $fcat->{$t} = $CurrentTraceFormatCategory;
- if (defined $CurrentTraceFormatCategory && defined $CurrentTraceFormatString)
- { $fmtTable->{$CurrentTraceFormatCategory}{$x} = $CurrentTraceFormatString; }
- undef $CurrentTraceFormatString;
- ++$x;
- } elsif ($t2 eq '}') {
- $vl->{$t} = {type=>$enum_name, size=>4, value=>$x, enum=>1};
- $fstr->{$t} = $CurrentTraceFormatString;
- $fcat->{$t} = $CurrentTraceFormatCategory;
- if (defined $CurrentTraceFormatCategory && defined $CurrentTraceFormatString)
- { $fmtTable->{$CurrentTraceFormatCategory}{$x} = $CurrentTraceFormatString; }
- undef $CurrentTraceFormatString;
- ++$x;
- last;
- } elsif ($t2 eq '=') {
- $x = get_constant_expr($scope, $tokens, $line);
- $vl->{$t} = {type=>$enum_name, size=>4, value=>$x, enum=>1};
- $fstr->{$t} = $CurrentTraceFormatString;
- $fcat->{$t} = $CurrentTraceFormatCategory;
- if (defined $CurrentTraceFormatCategory && defined $CurrentTraceFormatString)
- { $fmtTable->{$CurrentTraceFormatCategory}{$x} = $CurrentTraceFormatString; }
- undef $CurrentTraceFormatString;
- ++$x;
- $t2 = get_token($scope,$tokens,$line);
- last if ($t2 eq '}');
- next if ($t2 eq ',');
- warn "Syntax error#12 at line $$line\n";
- } else {
- unshift @$tokens, $t2;
- }
- }
- my $t = get_token($scope,$tokens,$line);
- if ($t ne ';') {
- warn "Missing ; at line $$line\n";
- }
- }
-
-
- sub parse_decl_def($$$) {
- my ($scope,$tokens,$line) = @_;
- my $level=0;
- my @decl;
- while ( scalar(@$tokens) ) {
- my $t = get_token($scope,$tokens, $line);
- if ( (!defined ($t) || $t eq ';') and ($level==0)) {
- return @decl;
- }
-
- if ($t eq "static")
- {
- next;
- }
-
- push @decl, $t;
- if ($t eq '{') {
- ++$level;
- }
- if ($t eq '}') {
- if ($level==0) {
- warn "Syntax error#13 at line $$line\n";
- unshift @$tokens, $t;
- return @decl;
-
- }
- if (--$level==0) {
- return (); # end of function definition reached
- }
- }
- }
- die "Unexpected end of file #3 at line $$line\n";
- }
-
- sub dump_scope($) {
- my ($scope) = @_;
- my $el = $scope->{enums};
- my $cl = $scope->{classes};
- my $vl = $scope->{values};
- my $fstr = $scope->{formatStrings};
- my $fcat = $scope->{formatCategories};
- print "SCOPE: $scope->{name}\n";
- if (scalar(@$el)) {
- print "\tenums:\n";
- foreach (@$el) {
- print "\t\t$_\n";
- }
- }
- if (scalar(keys(%$vl))) {
- print "\tvalues:\n";
- foreach $vname (keys(%$vl)) {
- my $v = $vl->{$vname};
- my $x = $v->{value};
- my $t = $v->{type};
- my $sz = $v->{size};
- my $fstring = $fstr->{$vname};
- my $fcategory = $fcat->{$vname};
- if ($v->{enum}) {
- printf ("\t\t$vname\=$x (enum $t) size=$sz fcat=[0x%x] fstr=[%s]\n", $fcategory,$fstring);
- } else {
- printf ("\t\t$vname\=$x (type $t) size=$sz fcat=[0x%x] fstr=[%s]\n", $fcategory, $fstring);
- }
- }
- }
- if ($scope->{scope}) {
- my $members = $scope->{members};
- foreach (@$members) {
- my $n = $_->{name};
- my $sz = $_->{size};
- my $off = $_->{offset};
- my $spc = $_->{spacing};
- if (defined $spc) {
- print "\t$n\[\]\: spacing $spc size $sz offset $off\n";
- } else {
- print "\t$n\: size $sz offset $off\n";
- }
- }
- print "\tOverall size : $scope->{size}\n";
- print "\tOverall align: $scope->{align}\n";
- }
- foreach $s (@$cl) {
- dump_scope($s);
- }
- }
-
-
-
-
- sub parse_doxygen($$$$) {
- my ($scope,$tokens,$line,$t) = @_;
-
- if ($t ne "/")
- {
- return 0; # not a doxygen comment
- }
- if ($t eq "/") {
- $state=0;
- my $t2 = shift @$tokens;
- my $t3 = shift @$tokens;
-
- if ($t2 ne "*" || $t3 ne "*")
- {
- unshift @$tokens, $t3;
- unshift @$tokens, $t2;
- return 0; # not a doxygen comment
- }
- }
-# printf "doxygen start on line %d\n", $$line;
- for (;;) {
- my $t = shift @$tokens;
- if (!defined($t))
- {
- warn "Unexpected end of file #4 at line $$line\n";
- return
- }
-
- if ($t eq "\n"){++$$line };
-
- if ($t eq '*')
- {
- my $t2 = shift @$tokens;
- last if ($t2 eq '/');
- unshift @$tokens, $t2;
- }
-
- if ($t eq '@')
- {
- my $t2 = shift @$tokens;
- if ($t2 eq 'SYMTraceFormatString')
- {
- my $t3 = shift @$tokens;
-# if ($VerboseMode){print "SYMTraceFormatString = [$t3]\n";}
- $CurrentTraceFormatString = $t3;
- }
- if ($t2 eq 'SYMTraceFormatCategory')
- {
- $CurrentTraceFormatCategory = get_operand($scope,$tokens,$line);
-# if ($VerboseMode){printf ("SYMTraceFormatCategory = 0x%x\n", $CurrentTraceFormatCategory);}
- }
- else
- {
- unshift @$tokens, $t2;
- }
- }
-
- }
-# printf ("doxygen end on line %d\n", $$line);
- return 1; # is a doxygen comment
- }
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-