#!/usr/bin/perl -w # (c) 2001, Dave Jones. (the file handling bit) # (c) 2005, Joel Schopp (the ugly bit) # (c) 2007,2008, Andy Whitcroft (new conditions, test suite) # (c) 2008-2010 Andy Whitcroft # (c) 2013 Vasilis Tsiligiannis (adapt for OpenWrt tree) # Licensed under the terms of the GNU GPL License version 2 use strict; my $P = $0; $P =~ s@.*/@@g; my $V = '0.32-openwrt'; use Getopt::Long qw(:config no_auto_abbrev); my $quiet = 0; my $tree = 1; my $chk_signoff = 1; my $chk_patch = 1; my $tst_only; my $emacs = 0; my $terse = 0; my $file = 0; my $check = 0; my $summary = 1; my $mailback = 0; my $summary_file = 0; my $show_types = 0; my $root; my %debug; my %ignore_type = (); my @ignore = (); my $help = 0; my $configuration_file = ".checkpatch.conf"; sub help { my ($exitcode) = @_; print << "EOM"; Usage: $P [OPTION]... [FILE]... Version: $V Options: -q, --quiet quiet --no-tree run without a kernel tree --no-signoff do not check for 'Signed-off-by' line --patch treat FILE as patchfile (default) --emacs emacs compile window format --terse one line per report -f, --file treat FILE as regular source file --subjective, --strict enable more subjective tests --ignore TYPE(,TYPE2...) ignore various comma separated message types --show-types show the message "types" in the output --root=PATH PATH to the kernel tree root --no-summary suppress the per-file summary --mailback only produce a report in case of warnings/errors --summary-file include the filename in summary --debug KEY=[0|1] turn on/off debugging of KEY, where KEY is one of 'values', 'possible', 'type', and 'attr' (default is all off) --test-only=WORD report only warnings/errors containing WORD literally -h, --help, --version display this help and exit When FILE is - read standard input. EOM exit($exitcode); } my $conf = which_conf($configuration_file); if (-f $conf) { my @conf_args; open(my $conffile, '<', "$conf") or warn "$P: Can't find a readable $configuration_file file $!\n"; while (<$conffile>) { my $line = $_; $line =~ s/\s*\n?$//g; $line =~ s/^\s*//g; $line =~ s/\s+/ /g; next if ($line =~ m/^\s*#/); next if ($line =~ m/^\s*$/); my @words = split(" ", $line); foreach my $word (@words) { last if ($word =~ m/^#/); push (@conf_args, $word); } } close($conffile); unshift(@ARGV, @conf_args) if @conf_args; } GetOptions( 'q|quiet+' => \$quiet, 'tree!' => \$tree, 'signoff!' => \$chk_signoff, 'patch!' => \$chk_patch, 'emacs!' => \$emacs, 'terse!' => \$terse, 'f|file!' => \$file, 'subjective!' => \$check, 'strict!' => \$check, 'ignore=s' => \@ignore, 'show-types!' => \$show_types, 'root=s' => \$root, 'summary!' => \$summary, 'mailback!' => \$mailback, 'summary-file!' => \$summary_file, 'debug=s' => \%debug, 'test-only=s' => \$tst_only, 'h|help' => \$help, 'version' => \$help ) or help(1); help(0) if ($help); my $exit = 0; if ($#ARGV < 0) { print "$P: no input files\n"; exit(1); } @ignore = split(/,/, join(',',@ignore)); foreach my $word (@ignore) { $word =~ s/\s*\n?$//g; $word =~ s/^\s*//g; $word =~ s/\s+/ /g; $word =~ tr/[a-z]/[A-Z]/; next if ($word =~ m/^\s*#/); next if ($word =~ m/^\s*$/); $ignore_type{$word}++; } my $dbg_values = 0; my $dbg_possible = 0; my $dbg_type = 0; my $dbg_attr = 0; for my $key (keys %debug) { ## no critic eval "\${dbg_$key} = '$debug{$key}';"; die "$@" if ($@); } my $rpt_cleaners = 0; if ($terse) { $emacs = 1; $quiet++; } if ($tree) { if (defined $root) { if (!top_of_openwrt_tree($root)) { die "$P: $root: --root does not point at a valid tree\n"; } } else { if (top_of_openwrt_tree('.')) { $root = '.'; } elsif ($0 =~ m@(.*)/scripts/[^/]*$@ && top_of_openwrt_tree($1)) { $root = $1; } } if (!defined $root) { print "Must be run from the top-level dir. of a OpenWrt tree\n"; exit(2); } } my $emitted_corrupt = 0; our $Ident = qr{ [A-Za-z_][A-Za-z\d_]* (?:\s*\#\#\s*[A-Za-z_][A-Za-z\d_]*)* }x; our $Storage = qr{extern|static|asmlinkage}; our $Sparse = qr{ __user| __kernel| __force| __iomem| __must_check| __init_refok| __kprobes| __ref| __rcu }x; # Notes to $Attribute: # We need \b after 'init' otherwise 'initconst' will cause a false positive in a check our $Attribute = qr{ const| __percpu| __nocast| __safe| __bitwise__| __packed__| __packed2__| __naked| __maybe_unused| __always_unused| __noreturn| __used| __cold| __noclone| __deprecated| __read_mostly| __kprobes| __(?:mem|cpu|dev|)(?:initdata|initconst|init\b)| ____cacheline_aligned| ____cacheline_aligned_in_smp| ____cacheline_internodealigned_in_smp| __weak }x; our $Modifier; our $Inline = qr{inline|__always_inline|noinline}; our $Member = qr{->$Ident|\.$Ident|\[[^]]*\]}; our $Lval = qr{$Ident(?:$Member)*}; our $Constant = qr{(?i:(?:[0-9]+|0x[0-9a-f]+)[ul]*)}; our $Assignment = qr{(?:\*\=|/=|%=|\+=|-=|<<=|>>=|&=|\^=|\|=|=)}; our $Compare = qr{<=|>=|==|!=|<|>}; our $Operators = qr{ <=|>=|==|!=| =>|->|<<|>>|<|>|!|~| &&|\|\||,|\^|\+\+|--|&|\||\+|-|\*|\/|% }x; our $NonptrType; our $Type; our $Declare; our $NON_ASCII_UTF8 = qr{ [\xC2-\xDF][\x80-\xBF] # non-overlong 2-byte | \xE0[\xA0-\xBF][\x80-\xBF] # excluding overlongs | [\xE1-\xEC\xEE\xEF][\x80-\xBF]{2} # straight 3-byte | \xED[\x80-\x9F][\x80-\xBF] # excluding surrogates | \xF0[\x90-\xBF][\x80-\xBF]{2} # planes 1-3 | [\xF1-\xF3][\x80-\xBF]{3} # planes 4-15 | \xF4[\x80-\x8F][\x80-\xBF]{2} # plane 16 }x; our $UTF8 = qr{ [\x09\x0A\x0D\x20-\x7E] # ASCII | $NON_ASCII_UTF8 }x; our $typeTypedefs = qr{(?x: (?:__)?(?:u|s|be|le)(?:8|16|32|64)| atomic_t )}; our $logFunctions = qr{(?x: printk(?:_ratelimited|_once|)| [a-z0-9]+_(?:printk|emerg|alert|crit|err|warning|warn|notice|info|debug|dbg|vdbg|devel|cont|WARN)(?:_ratelimited|_once|)| WARN(?:_RATELIMIT|_ONCE|)| panic| MODULE_[A-Z_]+ )}; our $signature_tags = qr{(?xi: Signed-off-by:| Acked-by:| Tested-by:| Reviewed-by:| Reported-by:| To:| Cc: )}; our @typeList = ( qr{void}, qr{(?:unsigned\s+)?char}, qr{(?:unsigned\s+)?short}, qr{(?:unsigned\s+)?int}, qr{(?:unsigned\s+)?long}, qr{(?:unsigned\s+)?long\s+int}, qr{(?:unsigned\s+)?long\s+long}, qr{(?:unsigned\s+)?long\s+long\s+int}, qr{unsigned}, qr{float}, qr{double}, qr{bool}, qr{struct\s+$Ident}, qr{union\s+$Ident}, qr{enum\s+$Ident}, qr{${Ident}_t}, qr{${Ident}_handler}, qr{${Ident}_handler_fn}, ); our @modifierList = ( qr{fastcall}, ); our $allowed_asm_includes = qr{(?x: irq| memory )}; # memory.h: ARM has a custom one sub build_types { my $mods = "(?x: \n" . join("|\n ", @modifierList) . "\n)"; my $all = "(?x: \n" . join("|\n ", @typeList) . "\n)"; $Modifier = qr{(?:$Attribute|$Sparse|$mods)}; $NonptrType = qr{ (?:$Modifier\s+|const\s+)* (?: (?:typeof|__typeof__)\s*\([^\)]*\)| (?:$typeTypedefs\b)| (?:${all}\b) ) (?:\s+$Modifier|\s+const)* }x; $Type = qr{ $NonptrType (?:(?:\s|\*|\[\])+\s*const|(?:\s|\*|\[\])+|(?:\s*\[\s*\])+)? (?:\s+$Inline|\s+$Modifier)* }x; $Declare = qr{(?:$Storage\s+)?$Type}; } build_types(); our $Typecast = qr{\s*(\(\s*$NonptrType\s*\)){0,1}\s*}; # Using $balanced_parens, $LvalOrFunc, or $FuncArg # requires at least perl version v5.10.0 # Any use must be runtime checked with $^V our $balanced_parens = qr/(\((?:[^\(\)]++|(?-1))*\))/; our $LvalOrFunc = qr{($Lval)\s*($balanced_parens{0,1})\s*}; our $FuncArg = qr{$Typecast{0,1}($LvalOrFunc|$Constant)}; sub deparenthesize { my ($string) = @_; return "" if (!defined($string)); $string =~ s@^\s*\(\s*@@g; $string =~ s@\s*\)\s*$@@g; $string =~ s@\s+@ @g; return $string; } $chk_signoff = 0 if ($file); my @rawlines = (); my @lines = (); my $vname; for my $filename (@ARGV) { my $FILE; if ($file) { open($FILE, '-|', "diff -u /dev/null $filename") || die "$P: $filename: diff failed - $!\n"; } elsif ($filename eq '-') { open($FILE, '<&STDIN'); } else { open($FILE, '<', "$filename") || die "$P: $filename: open failed - $!\n"; } if ($filename eq '-') { $vname = 'Your patch'; } else { $vname = $filename; } while (<$FILE>) { chomp; push(@rawlines, $_); } close($FILE); if (!process($filename)) { $exit = 1; } @rawlines = (); @lines = (); } exit($exit); sub top_of_openwrt_tree { my ($root) = @_; my @tree_check = ( "BSDmakefile", "Config.in", "LICENSE", "Makefile", "README", "docs", "feeds.conf.default", "include", "package", "rules.mk", "scripts", "target", "toolchain", "tools" ); foreach my $check (@tree_check) { if (! -e $root . '/' . $check) { return 0; } } return 1; } sub parse_email { my ($formatted_email) = @_; my $name = ""; my $address = ""; my $comment = ""; if ($formatted_email =~ /^(.*)<(\S+\@\S+)>(.*)$/) { $name = $1; $address = $2; $comment = $3 if defined $3; } elsif ($formatted_email =~ /^\s*<(\S+\@\S+)>(.*)$/) { $address = $1; $comment = $2 if defined $2; } elsif ($formatted_email =~ /(\S+\@\S+)(.*)$/) { $address = $1; $comment = $2 if defined $2; $formatted_email =~ s/$address.*$//; $name = $formatted_email; $name =~ s/^\s+|\s+$//g; $name =~ s/^\"|\"$//g; # If there's a name left after stripping spaces and # leading quotes, and the address doesn't have both # leading and trailing angle brackets, the address # is invalid. ie: # "joe smith joe@smith.com" bad # "joe smith ]+>$/) { $name = ""; $address = ""; $comment = ""; } } $name =~ s/^\s+|\s+$//g; $name =~ s/^\"|\"$//g; $address =~ s/^\s+|\s+$//g; $address =~ s/^\<|\>$//g; if ($name =~ /[^\w \-]/i) { ##has "must quote" chars $name =~ s/(?"; } return $formatted_email; } sub which_conf { my ($conf) = @_; foreach my $path (split(/:/, ".:$ENV{HOME}:.scripts")) { if (-e "$path/$conf") { return "$path/$conf"; } } return ""; } sub expand_tabs { my ($str) = @_; my $res = ''; my $n = 0; for my $c (split(//, $str)) { if ($c eq "\t") { $res .= ' '; $n++; for (; ($n % 8) != 0; $n++) { $res .= ' '; } next; } $res .= $c; $n++; } return $res; } sub copy_spacing { (my $res = shift) =~ tr/\t/ /c; return $res; } sub line_stats { my ($line) = @_; # Drop the diff line leader and expand tabs $line =~ s/^.//; $line = expand_tabs($line); # Pick the indent from the front of the line. my ($white) = ($line =~ /^(\s*)/); return (length($line), length($white)); } my $sanitise_quote = ''; sub sanitise_line_reset { my ($in_comment) = @_; if ($in_comment) { $sanitise_quote = '*/'; } else { $sanitise_quote = ''; } } sub sanitise_line { my ($line) = @_; my $res = ''; my $l = ''; my $qlen = 0; my $off = 0; my $c; # Always copy over the diff marker. $res = substr($line, 0, 1); for ($off = 1; $off < length($line); $off++) { $c = substr($line, $off, 1); # Comments we are wacking completly including the begin # and end, all to $;. if ($sanitise_quote eq '' && substr($line, $off, 2) eq '/*') { $sanitise_quote = '*/'; substr($res, $off, 2, "$;$;"); $off++; next; } if ($sanitise_quote eq '*/' && substr($line, $off, 2) eq '*/') { $sanitise_quote = ''; substr($res, $off, 2, "$;$;"); $off++; next; } if ($sanitise_quote eq '' && substr($line, $off, 2) eq '//') { $sanitise_quote = '//'; substr($res, $off, 2, $sanitise_quote); $off++; next; } # A \ in a string means ignore the next character. if (($sanitise_quote eq "'" || $sanitise_quote eq '"') && $c eq "\\") { substr($res, $off, 2, 'XX'); $off++; next; } # Regular quotes. if ($c eq "'" || $c eq '"') { if ($sanitise_quote eq '') { $sanitise_quote = $c; substr($res, $off, 1, $c); next; } elsif ($sanitise_quote eq $c) { $sanitise_quote = ''; } } #print "c<$c> SQ<$sanitise_quote>\n"; if ($off != 0 && $sanitise_quote eq '*/' && $c ne "\t") { substr($res, $off, 1, $;); } elsif ($off != 0 && $sanitise_quote eq '//' && $c ne "\t") { substr($res, $off, 1, $;); } elsif ($off != 0 && $sanitise_quote && $c ne "\t") { substr($res, $off, 1, 'X'); } else { substr($res, $off, 1, $c); } } if ($sanitise_quote eq '//') { $sanitise_quote = ''; } # The pathname on a #include may be surrounded by '<' and '>'. if ($res =~ /^.\s*\#\s*include\s+\<(.*)\>/) { my $clean = 'X' x length($1); $res =~ s@\<.*\>@<$clean>@; # The whole of a #error is a string. } elsif ($res =~ /^.\s*\#\s*(?:error|warning)\s+(.*)\b/) { my $clean = 'X' x length($1); $res =~ s@(\#\s*(?:error|warning)\s+).*@$1$clean@; } return $res; } sub ctx_statement_block { my ($linenr, $remain, $off) = @_; my $line = $linenr - 1; my $blk = ''; my $soff = $off; my $coff = $off - 1; my $coff_set = 0; my $loff = 0; my $type = ''; my $level = 0; my @stack = (); my $p; my $c; my $len = 0; my $remainder; while (1) { @stack = (['', 0]) if ($#stack == -1); #warn "CSB: blk<$blk> remain<$remain>\n"; # If we are about to drop off the end, pull in more # context. if ($off >= $len) { for (; $remain > 0; $line++) { last if (!defined $lines[$line]); next if ($lines[$line] =~ /^-/); $remain--; $loff = $len; $blk .= $lines[$line] . "\n"; $len = length($blk); $line++; last; } # Bail if there is no further context. #warn "CSB: blk<$blk> off<$off> len<$len>\n"; if ($off >= $len) { last; } if ($level == 0 && substr($blk, $off) =~ /^.\s*#\s*define/) { $level++; $type = '#'; } } $p = $c; $c = substr($blk, $off, 1); $remainder = substr($blk, $off); #warn "CSB: c<$c> type<$type> level<$level> remainder<$remainder> coff_set<$coff_set>\n"; # Handle nested #if/#else. if ($remainder =~ /^#\s*(?:ifndef|ifdef|if)\s/) { push(@stack, [ $type, $level ]); } elsif ($remainder =~ /^#\s*(?:else|elif)\b/) { ($type, $level) = @{$stack[$#stack - 1]}; } elsif ($remainder =~ /^#\s*endif\b/) { ($type, $level) = @{pop(@stack)}; } # Statement ends at the ';' or a close '}' at the # outermost level. if ($level == 0 && $c eq ';') { last; } # An else is really a conditional as long as its not else if if ($level == 0 && $coff_set == 0 && (!defined($p) || $p =~ /(?:\s|\}|\+)/) && $remainder =~ /^(else)(?:\s|{)/ && $remainder !~ /^else\s+if\b/) { $coff = $off + length($1) - 1; $coff_set = 1; #warn "CSB: mark coff<$coff> soff<$soff> 1<$1>\n"; #warn "[" . substr($blk, $soff, $coff - $soff + 1) . "]\n"; } if (($type eq '' || $type eq '(') && $c eq '(') { $level++; $type = '('; } if ($type eq '(' && $c eq ')') { $level--; $type = ($level != 0)? '(' : ''; if ($level == 0 && $coff < $soff) { $coff = $off; $coff_set = 1; #warn "CSB: mark coff<$coff>\n"; } } if (($type eq '' || $type eq '{') && $c eq '{') { $level++; $type = '{'; } if ($type eq '{' && $c eq '}') { $level--; $type = ($level != 0)? '{' : ''; if ($level == 0) { if (substr($blk, $off + 1, 1) eq ';') { $off++; } last; } } # Preprocessor commands end at the newline unless escaped. if ($type eq '#' && $c eq "\n" && $p ne "\\") { $level--; $type = ''; $off++; last; } $off++; } # We are truly at the end, so shuffle to the next line. if ($off == $len) { $loff = $len + 1; $line++; $remain--; } my $statement = substr($blk, $soff, $off - $soff + 1); my $condition = substr($blk, $soff, $coff - $soff + 1); #warn "STATEMENT<$statement>\n"; #warn "CONDITION<$condition>\n"; #print "coff<$coff> soff<$off> loff<$loff>\n"; return ($statement, $condition, $line, $remain + 1, $off - $loff + 1, $level); } sub statement_lines { my ($stmt) = @_; # Strip the diff line prefixes and rip blank lines at start and end. $stmt =~ s/(^|\n)./$1/g; $stmt =~ s/^\s*//; $stmt =~ s/\s*$//; my @stmt_lines = ($stmt =~ /\n/g); return $#stmt_lines + 2; } sub statement_rawlines { my ($stmt) = @_; my @stmt_lines = ($stmt =~ /\n/g); return $#stmt_lines + 2; } sub statement_block_size { my ($stmt) = @_; $stmt =~ s/(^|\n)./$1/g; $stmt =~ s/^\s*{//; $stmt =~ s/}\s*$//; $stmt =~ s/^\s*//; $stmt =~ s/\s*$//; my @stmt_lines = ($stmt =~ /\n/g); my @stmt_statements = ($stmt =~ /;/g); my $stmt_lines = $#stmt_lines + 2; my $stmt_statements = $#stmt_statements + 1; if ($stmt_lines > $stmt_statements) { return $stmt_lines; } else { return $stmt_statements; } } sub ctx_statement_full { my ($linenr, $remain, $off) = @_; my ($statement, $condition, $level); my (@chunks); # Grab the first conditional/block pair. ($statement, $condition, $linenr, $remain, $off, $level) = ctx_statement_block($linenr, $remain, $off); #print "F: c<$condition> s<$statement> remain<$remain>\n"; push(@chunks, [ $condition, $statement ]); if (!($remain > 0 && $condition =~ /^\s*(?:\n[+-])?\s*(?:if|else|do)\b/s)) { return ($level, $linenr, @chunks); } # Pull in the following conditional/block pairs and see if they # could continue the statement. for (;;) { ($statement, $condition, $linenr, $remain, $off, $level) = ctx_statement_block($linenr, $remain, $off); #print "C: c<$condition> s<$statement> remain<$remain>\n"; last if (!($remain > 0 && $condition =~ /^(?:\s*\n[+-])*\s*(?:else|do)\b/s)); #print "C: push\n"; push(@chunks, [ $condition, $statement ]); } return ($level, $linenr, @chunks); } sub ctx_block_get { my ($linenr, $remain, $outer, $open, $close, $off) = @_; my $line; my $start = $linenr - 1; my $blk = ''; my @o; my @c; my @res = (); my $level = 0; my @stack = ($level); for ($line = $start; $remain > 0; $line++) { next if ($rawlines[$line] =~ /^-/); $remain--; $blk .= $rawlines[$line]; # Handle nested #if/#else. if ($lines[$line] =~ /^.\s*#\s*(?:ifndef|ifdef|if)\s/) { push(@stack, $level); } elsif ($lines[$line] =~ /^.\s*#\s*(?:else|elif)\b/) { $level = $stack[$#stack - 1]; } elsif ($lines[$line] =~ /^.\s*#\s*endif\b/) { $level = pop(@stack); } foreach my $c (split(//, $lines[$line])) { ##print "C<$c>L<$level><$open$close>O<$off>\n"; if ($off > 0) { $off--; next; } if ($c eq $close && $level > 0) { $level--; last if ($level == 0); } elsif ($c eq $open) { $level++; } } if (!$outer || $level <= 1) { push(@res, $rawlines[$line]); } last if ($level == 0); } return ($level, @res); } sub ctx_block_outer { my ($linenr, $remain) = @_; my ($level, @r) = ctx_block_get($linenr, $remain, 1, '{', '}', 0); return @r; } sub ctx_block { my ($linenr, $remain) = @_; my ($level, @r) = ctx_block_get($linenr, $remain, 0, '{', '}', 0); return @r; } sub ctx_statement { my ($linenr, $remain, $off) = @_; my ($level, @r) = ctx_block_get($linenr, $remain, 0, '(', ')', $off); return @r; } sub ctx_block_level { my ($linenr, $remain) = @_; return ctx_block_get($linenr, $remain, 0, '{', '}', 0); } sub ctx_statement_level { my ($linenr, $remain, $off) = @_; return ctx_block_get($linenr, $remain, 0, '(', ')', $off); } sub ctx_locate_comment { my ($first_line, $end_line) = @_; # Catch a comment on the end of the line itself. my ($current_comment) = ($rawlines[$end_line - 1] =~ m@.*(/\*.*\*/)\s*(?:\\\s*)?$@); return $current_comment if (defined $current_comment); # Look through the context and try and figure out if there is a # comment. my $in_comment = 0; $current_comment = ''; for (my $linenr = $first_line; $linenr < $end_line; $linenr++) { my $line = $rawlines[$linenr - 1]; #warn " $line\n"; if ($linenr == $first_line and $line =~ m@^.\s*\*@) { $in_comment = 1; } if ($line =~ m@/\*@) { $in_comment = 1; } if (!$in_comment && $current_comment ne '') { $current_comment = ''; } $current_comment .= $line . "\n" if ($in_comment); if ($line =~ m@\*/@) { $in_comment = 0; } } chomp($current_comment); return($current_comment); } sub ctx_has_comment { my ($first_line, $end_line) = @_; my $cmt = ctx_locate_comment($first_line, $end_line); ##print "LINE: $rawlines[$end_line - 1 ]\n"; ##print "CMMT: $cmt\n"; return ($cmt ne ''); } sub raw_line { my ($linenr, $cnt) = @_; my $offset = $linenr - 1; $cnt++; my $line; while ($cnt) { $line = $rawlines[$offset++]; next if (defined($line) && $line =~ /^-/); $cnt--; } return $line; } sub cat_vet { my ($vet) = @_; my ($res, $coded); $res = ''; while ($vet =~ /([^[:cntrl:]]*)([[:cntrl:]]|$)/g) { $res .= $1; if ($2 ne '') { $coded = sprintf("^%c", unpack('C', $2) + 64); $res .= $coded; } } $res =~ s/$/\$/; return $res; } my $av_preprocessor = 0; my $av_pending; my @av_paren_type; my $av_pend_colon; sub annotate_reset { $av_preprocessor = 0; $av_pending = '_'; @av_paren_type = ('E'); $av_pend_colon = 'O'; } sub annotate_values { my ($stream, $type) = @_; my $res; my $var = '_' x length($stream); my $cur = $stream; print "$stream\n" if ($dbg_values > 1); while (length($cur)) { @av_paren_type = ('E') if ($#av_paren_type < 0); print " <" . join('', @av_paren_type) . "> <$type> <$av_pending>" if ($dbg_values > 1); if ($cur =~ /^(\s+)/o) { print "WS($1)\n" if ($dbg_values > 1); if ($1 =~ /\n/ && $av_preprocessor) { $type = pop(@av_paren_type); $av_preprocessor = 0; } } elsif ($cur =~ /^(\(\s*$Type\s*)\)/ && $av_pending eq '_') { print "CAST($1)\n" if ($dbg_values > 1); push(@av_paren_type, $type); $type = 'c'; } elsif ($cur =~ /^($Type)\s*(?:$Ident|,|\)|\(|\s*$)/) { print "DECLARE($1)\n" if ($dbg_values > 1); $type = 'T'; } elsif ($cur =~ /^($Modifier)\s*/) { print "MODIFIER($1)\n" if ($dbg_values > 1); $type = 'T'; } elsif ($cur =~ /^(\#\s*define\s*$Ident)(\(?)/o) { print "DEFINE($1,$2)\n" if ($dbg_values > 1); $av_preprocessor = 1; push(@av_paren_type, $type); if ($2 ne '') { $av_pending = 'N'; } $type = 'E'; } elsif ($cur =~ /^(\#\s*(?:undef\s*$Ident|include\b))/o) { print "UNDEF($1)\n" if ($dbg_values > 1); $av_preprocessor = 1; push(@av_paren_type, $type); } elsif ($cur =~ /^(\#\s*(?:ifdef|ifndef|if))/o) { print "PRE_START($1)\n" if ($dbg_values > 1); $av_preprocessor = 1; push(@av_paren_type, $type); push(@av_paren_type, $type); $type = 'E'; } elsif ($cur =~ /^(\#\s*(?:else|elif))/o) { print "PRE_RESTART($1)\n" if ($dbg_values > 1); $av_preprocessor = 1; push(@av_paren_type, $av_paren_type[$#av_paren_type]); $type = 'E'; } elsif ($cur =~ /^(\#\s*(?:endif))/o) { print "PRE_END($1)\n" if ($dbg_values > 1); $av_preprocessor = 1; # Assume all arms of the conditional end as this # one does, and continue as if the #endif was not here. pop(@av_paren_type); push(@av_paren_type, $type); $type = 'E'; } elsif ($cur =~ /^(\\\n)/o) { print "PRECONT($1)\n" if ($dbg_values > 1); } elsif ($cur =~ /^(__attribute__)\s*\(?/o) { print "ATTR($1)\n" if ($dbg_values > 1); $av_pending = $type; $type = 'N'; } elsif ($cur =~ /^(sizeof)\s*(\()?/o) { print "SIZEOF($1)\n" if ($dbg_values > 1); if (defined $2) { $av_pending = 'V'; } $type = 'N'; } elsif ($cur =~ /^(if|while|for)\b/o) { print "COND($1)\n" if ($dbg_values > 1); $av_pending = 'E'; $type = 'N'; } elsif ($cur =~/^(case)/o) { print "CASE($1)\n" if ($dbg_values > 1); $av_pend_colon = 'C'; $type = 'N'; } elsif ($cur =~/^(return|else|goto|typeof|__typeof__)\b/o) { print "KEYWORD($1)\n" if ($dbg_values > 1); $type = 'N'; } elsif ($cur =~ /^(\()/o) { print "PAREN('$1')\n" if ($dbg_values > 1); push(@av_paren_type, $av_pending); $av_pending = '_'; $type = 'N'; } elsif ($cur =~ /^(\))/o) { my $new_type = pop(@av_paren_type); if ($new_type ne '_') { $type = $new_type; print "PAREN('$1') -> $type\n" if ($dbg_values > 1); } else { print "PAREN('$1')\n" if ($dbg_values > 1); } } elsif ($cur =~ /^($Ident)\s*\(/o) { print "FUNC($1)\n" if ($dbg_values > 1); $type = 'V'; $av_pending = 'V'; } elsif ($cur =~ /^($Ident\s*):(?:\s*\d+\s*(,|=|;))?/) { if (defined $2 && $type eq 'C' || $type eq 'T') { $av_pend_colon = 'B'; } elsif ($type eq 'E') { $av_pend_colon = 'L'; } print "IDENT_COLON($1,$type>$av_pend_colon)\n" if ($dbg_values > 1); $type = 'V'; } elsif ($cur =~ /^($Ident|$Constant)/o) { print "IDENT($1)\n" if ($dbg_values > 1); $type = 'V'; } elsif ($cur =~ /^($Assignment)/o) { print "ASSIGN($1)\n" if ($dbg_values > 1); $type = 'N'; } elsif ($cur =~/^(;|{|})/) { print "END($1)\n" if ($dbg_values > 1); $type = 'E'; $av_pend_colon = 'O'; } elsif ($cur =~/^(,)/) { print "COMMA($1)\n" if ($dbg_values > 1); $type = 'C'; } elsif ($cur =~ /^(\?)/o) { print "QUESTION($1)\n" if ($dbg_values > 1); $type = 'N'; } elsif ($cur =~ /^(:)/o) { print "COLON($1,$av_pend_colon)\n" if ($dbg_values > 1); substr($var, length($res), 1, $av_pend_colon); if ($av_pend_colon eq 'C' || $av_pend_colon eq 'L') { $type = 'E'; } else { $type = 'N'; } $av_pend_colon = 'O'; } elsif ($cur =~ /^(\[)/o) { print "CLOSE($1)\n" if ($dbg_values > 1); $type = 'N'; } elsif ($cur =~ /^(-(?![->])|\+(?!\+)|\*|\&\&|\&)/o) { my $variant; print "OPV($1)\n" if ($dbg_values > 1); if ($type eq 'V') { $variant = 'B'; } else { $variant = 'U'; } substr($var, length($res), 1, $variant); $type = 'N'; } elsif ($cur =~ /^($Operators)/o) { print "OP($1)\n" if ($dbg_values > 1); if ($1 ne '++' && $1 ne '--') { $type = 'N'; } } elsif ($cur =~ /(^.)/o) { print "C($1)\n" if ($dbg_values > 1); } if (defined $1) { $cur = substr($cur, length($1)); $res .= $type x length($1); } } return ($res, $var); } sub possible { my ($possible, $line) = @_; my $notPermitted = qr{(?: ^(?: $Modifier| $Storage| $Type| DEFINE_\S+ )$| ^(?: goto| return| case| else| asm|__asm__| do| \#| \#\#| )(?:\s|$)| ^(?:typedef|struct|enum)\b )}x; warn "CHECK<$possible> ($line)\n" if ($dbg_possible > 2); if ($possible !~ $notPermitted) { # Check for modifiers. $possible =~ s/\s*$Storage\s*//g; $possible =~ s/\s*$Sparse\s*//g; if ($possible =~ /^\s*$/) { } elsif ($possible =~ /\s/) { $possible =~ s/\s*$Type\s*//g; for my $modifier (split(' ', $possible)) { if ($modifier !~ $notPermitted) { warn "MODIFIER: $modifier ($possible) ($line)\n" if ($dbg_possible); push(@modifierList, $modifier); } } } else { warn "POSSIBLE: $possible ($line)\n" if ($dbg_possible); push(@typeList, $possible); } build_types(); } else { warn "NOTPOSS: $possible ($line)\n" if ($dbg_possible > 1); } } my $prefix = ''; sub show_type { return !defined $ignore_type{$_[0]}; } sub report { if (!show_type($_[1]) || (defined $tst_only && $_[2] !~ /\Q$tst_only\E/)) { return 0; } my $line; if ($show_types) { $line = "$prefix$_[0]:$_[1]: $_[2]\n"; } else { $line = "$prefix$_[0]: $_[2]\n"; } $line = (split('\n', $line))[0] . "\n" if ($terse); push(our @report, $line); return 1; } sub report_dump { our @report; } sub ERROR { if (report("ERROR", $_[0], $_[1])) { our $clean = 0; our $cnt_error++; } } sub WARN { if (report("WARNING", $_[0], $_[1])) { our $clean = 0; our $cnt_warn++; } } sub CHK { if ($check && report("CHECK", $_[0], $_[1])) { our $clean = 0; our $cnt_chk++; } } sub check_absolute_file { my ($absolute, $herecurr) = @_; my $file = $absolute; ##print "absolute<$absolute>\n"; # See if any suffix of this path is a path within the tree. while ($file =~ s@^[^/]*/@@) { if (-f "$root/$file") { ##print "file<$file>\n"; last; } } if (! -f _) { return 0; } # It is, so see if the prefix is acceptable. my $prefix = $absolute; substr($prefix, -length($file)) = ''; ##print "prefix<$prefix>\n"; if ($prefix ne ".../") { WARN("USE_RELATIVE_PATH", "use relative pathname instead of absolute in changelog text\n" . $herecurr); } } sub pos_last_openparen { my ($line) = @_; my $pos = 0; my $opens = $line =~ tr/\(/\(/; my $closes = $line =~ tr/\)/\)/; my $last_openparen = 0; if (($opens == 0) || ($closes >= $opens)) { return -1; } my $len = length($line); for ($pos = 0; $pos < $len; $pos++) { my $string = substr($line, $pos); if ($string =~ /^($FuncArg|$balanced_parens)/) { $pos += length($1) - 1; } elsif (substr($line, $pos, 1) eq '(') { $last_openparen = $pos; } elsif (index($string, '(') == -1) { last; } } return $last_openparen + 1; } sub process { my $filename = shift; my $linenr=0; my $prevline=""; my $prevrawline=""; my $stashline=""; my $stashrawline=""; my $length; my $indent; my $previndent=0; my $stashindent=0; our $clean = 1; my $signoff = 0; my $is_patch = 0; my $in_header_lines = 1; my $in_commit_log = 0; #Scanning lines before patch our @report = (); our $cnt_lines = 0; our $cnt_error = 0; our $cnt_warn = 0; our $cnt_chk = 0; # Trace the real file/line as we go. my $realfile = ''; my $realline = 0; my $realcnt = 0; my $here = ''; my $in_comment = 0; my $comment_edge = 0; my $first_line = 0; my $p1_prefix = ''; my $prev_values = 'E'; # suppression flags my %suppress_ifbraces; my %suppress_whiletrailers; my %suppress_export; my $suppress_statement = 0; # Pre-scan the patch sanitizing the lines. sanitise_line_reset(); my $line; foreach my $rawline (@rawlines) { $linenr++; $line = $rawline; if ($rawline=~/^\@\@ -\d+(?:,\d+)? \+(\d+)(,(\d+))? \@\@/) { $realline=$1-1; if (defined $2) { $realcnt=$3+1; } else { $realcnt=1+1; } $in_comment = 0; # Guestimate if this is a continuing comment. Run # the context looking for a comment "edge". If this # edge is a close comment then we must be in a comment # at context start. my $edge; my $cnt = $realcnt; for (my $ln = $linenr + 1; $cnt > 0; $ln++) { next if (defined $rawlines[$ln - 1] && $rawlines[$ln - 1] =~ /^-/); $cnt--; #print "RAW<$rawlines[$ln - 1]>\n"; last if (!defined $rawlines[$ln - 1]); if ($rawlines[$ln - 1] =~ m@(/\*|\*/)@ && $rawlines[$ln - 1] !~ m@"[^"]*(?:/\*|\*/)[^"]*"@) { ($edge) = $1; last; } } if (defined $edge && $edge eq '*/') { $in_comment = 1; } # Guestimate if this is a continuing comment. If this # is the start of a diff block and this line starts # ' *' then it is very likely a comment. if (!defined $edge && $rawlines[$linenr] =~ m@^.\s*(?:\*\*+| \*)(?:\s|$)@) { $in_comment = 1; } ##print "COMMENT:$in_comment edge<$edge> $rawline\n"; sanitise_line_reset($in_comment); } elsif ($realcnt && $rawline =~ /^(?:\+| |$)/) { # Standardise the strings and chars within the input to # simplify matching -- only bother with positive lines. $line = sanitise_line($rawline); } push(@lines, $line); if ($realcnt > 1) { $realcnt-- if ($line =~ /^(?:\+| |$)/); } else { $realcnt = 0; } #print "==>$rawline\n"; #print "-->$line\n"; } $prefix = ''; $realcnt = 0; $linenr = 0; foreach my $line (@lines) { $linenr++; my $rawline = $rawlines[$linenr - 1]; #extract the line range in the file after the patch is applied if ($line=~/^\@\@ -\d+(?:,\d+)? \+(\d+)(,(\d+))? \@\@/) { $is_patch = 1; $first_line = $linenr + 1; $realline=$1-1; if (defined $2) { $realcnt=$3+1; } else { $realcnt=1+1; } annotate_reset(); $prev_values = 'E'; %suppress_ifbraces = (); %suppress_whiletrailers = (); %suppress_export = (); $suppress_statement = 0; next; # track the line number as we move through the hunk, note that # new versions of GNU diff omit the leading space on completely # blank context lines so we need to count that too. } elsif ($line =~ /^( |\+|$)/) { $realline++; $realcnt-- if ($realcnt != 0); # Measure the line length and indent. ($length, $indent) = line_stats($rawline); # Track the previous line. ($prevline, $stashline) = ($stashline, $line); ($previndent, $stashindent) = ($stashindent, $indent); ($prevrawline, $stashrawline) = ($stashrawline, $rawline); #warn "line<$line>\n"; } elsif ($realcnt == 1) { $realcnt--; } my $hunk_line = ($realcnt != 0); #make up the handle for any error we report on this line $prefix = "$filename:$realline: " if ($emacs && $file); $prefix = "$filename:$linenr: " if ($emacs && !$file); $here = "#$linenr: " if (!$file); $here = "#$realline: " if ($file); # extract the filename as it passes if ($line =~ /^diff --git.*?(\S+)$/) { $realfile = $1; $realfile =~ s@^([^/]*)/@@; $in_commit_log = 0; } elsif ($line =~ /^\+\+\+\s+(\S+)/) { $realfile = $1; $realfile =~ s@^([^/]*)/@@; $in_commit_log = 0; $p1_prefix = $1; if (!$file && $tree && $p1_prefix ne '' && -e "$root/$p1_prefix") { WARN("PATCH_PREFIX", "patch prefix '$p1_prefix' exists, appears to be a -p0 patch\n"); } if ($realfile =~ m@^include/asm/@) { ERROR("MODIFIED_INCLUDE_ASM", "do not modify files in include/asm, change architecture specific files in include/asm-\n" . "$here$rawline\n"); } next; } $here .= "FILE: $realfile:$realline:" if ($realcnt != 0); my $hereline = "$here\n$rawline\n"; my $herecurr = "$here\n$rawline\n"; my $hereprev = "$here\n$prevrawline\n$rawline\n"; $cnt_lines++ if ($realcnt != 0); # Check for incorrect file permissions if ($line =~ /^new (file )?mode.*[7531]\d{0,2}$/) { my $permhere = $here . "FILE: $realfile\n"; if ($realfile =~ /(Makefile|Kconfig|\.c|\.h|\.S|\.tmpl)$/) { ERROR("EXECUTE_PERMISSIONS", "do not set execute permissions for source files\n" . $permhere); } } # Check the patch for a signoff: if ($line =~ /^\s*signed-off-by:/i) { $signoff++; $in_commit_log = 0; } # Check signature styles if (!$in_header_lines && $line =~ /^(\s*)($signature_tags)(\s*)(.*)/) { my $space_before = $1; my $sign_off = $2; my $space_after = $3; my $email = $4; my $ucfirst_sign_off = ucfirst(lc($sign_off)); if (defined $space_before && $space_before ne "") { WARN("BAD_SIGN_OFF", "Do not use whitespace before $ucfirst_sign_off\n" . $herecurr); } if ($sign_off =~ /-by:$/i && $sign_off ne $ucfirst_sign_off) { WARN("BAD_SIGN_OFF", "'$ucfirst_sign_off' is the preferred signature form\n" . $herecurr); } if (!defined $space_after || $space_after ne " ") { WARN("BAD_SIGN_OFF", "Use a single space after $ucfirst_sign_off\n" . $herecurr); } my ($email_name, $email_address, $comment) = parse_email($email); my $suggested_email = format_email(($email_name, $email_address)); if ($suggested_email eq "") { ERROR("BAD_SIGN_OFF", "Unrecognized email address: '$email'\n" . $herecurr); } else { my $dequoted = $suggested_email; $dequoted =~ s/^"//; $dequoted =~ s/" $comment" ne $email && "$suggested_email$comment" ne $email) { WARN("BAD_SIGN_OFF", "email address '$email' might be better as '$suggested_email$comment'\n" . $herecurr); } } } # Check for wrappage within a valid hunk of the file if ($realcnt != 0 && $line !~ m{^(?:\+|-| |\\ No newline|$)}) { ERROR("CORRUPTED_PATCH", "patch seems to be corrupt (line wrapped?)\n" . $herecurr) if (!$emitted_corrupt++); } # Check for absolute kernel paths. if ($tree) { while ($line =~ m{(?:^|\s)(/\S*)}g) { my $file = $1; if ($file =~ m{^(.*?)(?::\d+)+:?$} && check_absolute_file($1, $herecurr)) { # } else { check_absolute_file($file, $herecurr); } } } # UTF-8 regex found at http://www.w3.org/International/questions/qa-forms-utf-8.en.php if (($realfile =~ /^$/ || $line =~ /^\+/) && $rawline !~ m/^$UTF8*$/) { my ($utf8_prefix) = ($rawline =~ /^($UTF8*)/); my $blank = copy_spacing($rawline); my $ptr = substr($blank, 0, length($utf8_prefix)) . "^"; my $hereptr = "$hereline$ptr\n"; CHK("INVALID_UTF8", "Invalid UTF-8, patch and commit message should be encoded in UTF-8\n" . $hereptr); } # Check if it's the start of a commit log # (not a header line and we haven't seen the patch filename) if ($in_header_lines && $realfile =~ /^$/ && $rawline !~ /^(commit\b|from\b|[\w-]+:).+$/i) { $in_header_lines = 0; $in_commit_log = 1; } # Still not yet in a patch, check for any UTF-8 if ($in_commit_log && $realfile =~ /^$/ && $rawline =~ /$NON_ASCII_UTF8/) { CHK("UTF8_BEFORE_PATCH", "8-bit UTF-8 used in possible commit log\n" . $herecurr); } # ignore non-hunk lines and lines being removed next if (!$hunk_line || $line =~ /^-/); #trailing whitespace if ($line =~ /^\+.*\015/) { my $herevet = "$here\n" . cat_vet($rawline) . "\n"; ERROR("DOS_LINE_ENDINGS", "DOS line endings\n" . $herevet); } elsif ($rawline =~ /^\+.*\S\s+$/ || $rawline =~ /^\+\s+$/) { my $herevet = "$here\n" . cat_vet($rawline) . "\n"; ERROR("TRAILING_WHITESPACE", "trailing whitespace\n" . $herevet); $rpt_cleaners = 1; } # check for Kconfig help text having a real description # Only applies when adding the entry originally, after that we do not have # sufficient context to determine whether it is indeed long enough. if ($realfile =~ /Kconfig/ && $line =~ /.\s*config\s+/) { my $length = 0; my $cnt = $realcnt; my $ln = $linenr + 1; my $f; my $is_start = 0; my $is_end = 0; for (; $cnt > 0 && defined $lines[$ln - 1]; $ln++) { $f = $lines[$ln - 1]; $cnt-- if ($lines[$ln - 1] !~ /^-/); $is_end = $lines[$ln - 1] =~ /^\+/; next if ($f =~ /^-/); if ($lines[$ln - 1] =~ /.\s*(?:bool|tristate)\s*\"/) { $is_start = 1; } elsif ($lines[$ln - 1] =~ /.\s*(?:---)?help(?:---)?$/) { $length = -1; } $f =~ s/^.//; $f =~ s/#.*//; $f =~ s/^\s+//; next if ($f =~ /^$/); if ($f =~ /^\s*config\s/) { $is_end = 1; last; } $length++; } WARN("CONFIG_DESCRIPTION", "please write a paragraph that describes the config symbol fully\n" . $herecurr) if ($is_start && $is_end && $length < 4); #print "is_start<$is_start> is_end<$is_end> length<$length>\n"; } if (($realfile =~ /Makefile.*/ || $realfile =~ /Kbuild.*/) && ($line =~ /\+(EXTRA_[A-Z]+FLAGS).*/)) { my $flag = $1; my $replacement = { 'EXTRA_AFLAGS' => 'asflags-y', 'EXTRA_CFLAGS' => 'ccflags-y', 'EXTRA_CPPFLAGS' => 'cppflags-y', 'EXTRA_LDFLAGS' => 'ldflags-y', }; WARN("DEPRECATED_VARIABLE", "Use of $flag is deprecated, please use \`$replacement->{$flag} instead.\n" . $herecurr) if ($replacement->{$flag}); } # check we are in a valid source file if not then ignore this hunk next if ($realfile !~ /\.(h|c|s|S|pl|sh)$/); #80 column limit if ($line =~ /^\+/ && $prevrawline !~ /\/\*\*/ && $rawline !~ /^.\s*\*\s*\@$Ident\s/ && !($line =~ /^\+\s*$logFunctions\s*\(\s*(?:(KERN_\S+\s*|[^"]*))?"[X\t]*"\s*(?:|,|\)\s*;)\s*$/ || $line =~ /^\+\s*"[^"]*"\s*(?:\s*|,|\)\s*;)\s*$/) && $length > 80) { WARN("LONG_LINE", "line over 80 characters\n" . $herecurr); } # Check for user-visible strings broken across lines, which breaks the ability # to grep for the string. Limited to strings used as parameters (those # following an open parenthesis), which almost completely eliminates false # positives, as well as warning only once per parameter rather than once per # line of the string. Make an exception when the previous string ends in a # newline (multiple lines in one string constant) or \n\t (common in inline # assembly to indent the instruction on the following line). if ($line =~ /^\+\s*"/ && $prevline =~ /"\s*$/ && $prevline =~ /\(/ && $prevrawline !~ /\\n(?:\\t)*"\s*$/) { WARN("SPLIT_STRING", "quoted string split across lines\n" . $hereprev); } # check for spaces before a quoted newline if ($rawline =~ /^.*\".*\s\\n/) { WARN("QUOTED_WHITESPACE_BEFORE_NEWLINE", "unnecessary whitespace before a quoted newline\n" . $herecurr); } # check for adding lines without a newline. if ($line =~ /^\+/ && defined $lines[$linenr] && $lines[$linenr] =~ /^\\ No newline at end of file/) { WARN("MISSING_EOF_NEWLINE", "adding a line without newline at end of file\n" . $herecurr); } # Blackfin: use hi/lo macros if ($realfile =~ m@arch/blackfin/.*\.S$@) { if ($line =~ /\.[lL][[:space:]]*=.*&[[:space:]]*0x[fF][fF][fF][fF]/) { my $herevet = "$here\n" . cat_vet($line) . "\n"; ERROR("LO_MACRO", "use the LO() macro, not (... & 0xFFFF)\n" . $herevet); } if ($line =~ /\.[hH][[:space:]]*=.*>>[[:space:]]*16/) { my $herevet = "$here\n" . cat_vet($line) . "\n"; ERROR("HI_MACRO", "use the HI() macro, not (... >> 16)\n" . $herevet); } } # check we are in a valid source file C or perl if not then ignore this hunk next if ($realfile !~ /\.(h|c|pl)$/); # at the beginning of a line any tabs must come first and anything # more than 8 must use tabs. if ($rawline =~ /^\+\s* \t\s*\S/ || $rawline =~ /^\+\s* \s*/) { my $herevet = "$here\n" . cat_vet($rawline) . "\n"; ERROR("CODE_INDENT", "code indent should use tabs where possible\n" . $herevet); $rpt_cleaners = 1; } # check for space before tabs. if ($rawline =~ /^\+/ && $rawline =~ / \t/) { my $herevet = "$here\n" . cat_vet($rawline) . "\n"; WARN("SPACE_BEFORE_TAB", "please, no space before tabs\n" . $herevet); } # check for && or || at the start of a line if ($rawline =~ /^\+\s*(&&|\|\|)/) { CHK("LOGICAL_CONTINUATIONS", "Logical continuations should be on the previous line\n" . $hereprev); } # check multi-line statement indentation matches previous line if ($^V && $^V ge 5.10.0 && $prevline =~ /^\+(\t*)(if \(|$Ident\().*(\&\&|\|\||,)\s*$/) { $prevline =~ /^\+(\t*)(.*)$/; my $oldindent = $1; my $rest = $2; my $pos = pos_last_openparen($rest); if ($pos >= 0) { $line =~ /^\+([ \t]*)/; my $newindent = $1; my $goodtabindent = $oldindent . "\t" x ($pos / 8) . " " x ($pos % 8); my $goodspaceindent = $oldindent . " " x $pos; if ($newindent ne $goodtabindent && $newindent ne $goodspaceindent) { CHK("PARENTHESIS_ALIGNMENT", "Alignment should match open parenthesis\n" . $hereprev); } } } if ($line =~ /^\+.*\*[ \t]*\)[ \t]+/) { CHK("SPACING", "No space is necessary after a cast\n" . $hereprev); } if ($rawline =~ /^\+[ \t]*\/\*[ \t]*$/ && $prevrawline =~ /^\+[ \t]*$/) { CHK("BLOCK_COMMENT_STYLE", "Don't begin block comments with only a /* line, use /* comment...\n" . $hereprev); } # check for spaces at the beginning of a line. # Exceptions: # 1) within comments # 2) indented preprocessor commands # 3) hanging labels if ($rawline =~ /^\+ / && $line !~ /\+ *(?:$;|#|$Ident:)/) { my $herevet = "$here\n" . cat_vet($rawline) . "\n"; WARN("LEADING_SPACE", "please, no spaces at the start of a line\n" . $herevet); } # check we are in a valid C source file if not then ignore this hunk next if ($realfile !~ /\.(h|c)$/); # check for RCS/CVS revision markers if ($rawline =~ /^\+.*\$(Revision|Log|Id)(?:\$|)/) { WARN("CVS_KEYWORD", "CVS style keyword markers, these will _not_ be updated\n". $herecurr); } # Blackfin: don't use __builtin_bfin_[cs]sync if ($line =~ /__builtin_bfin_csync/) { my $herevet = "$here\n" . cat_vet($line) . "\n"; ERROR("CSYNC", "use the CSYNC() macro in asm/blackfin.h\n" . $herevet); } if ($line =~ /__builtin_bfin_ssync/) { my $herevet = "$here\n" . cat_vet($line) . "\n"; ERROR("SSYNC", "use the SSYNC() macro in asm/blackfin.h\n" . $herevet); } # Check for potential 'bare' types my ($stat, $cond, $line_nr_next, $remain_next, $off_next, $realline_next); #print "LINE<$line>\n"; if ($linenr >= $suppress_statement && $realcnt && $line =~ /.\s*\S/) { ($stat, $cond, $line_nr_next, $remain_next, $off_next) = ctx_statement_block($linenr, $realcnt, 0); $stat =~ s/\n./\n /g; $cond =~ s/\n./\n /g; #print "linenr<$linenr> <$stat>\n"; # If this statement has no statement boundaries within # it there is no point in retrying a statement scan # until we hit end of it. my $frag = $stat; $frag =~ s/;+\s*$//; if ($frag !~ /(?:{|;)/) { #print "skip<$line_nr_next>\n"; $suppress_statement = $line_nr_next; } # Find the real next line. $realline_next = $line_nr_next; if (defined $realline_next && (!defined $lines[$realline_next - 1] || substr($lines[$realline_next - 1], $off_next) =~ /^\s*$/)) { $realline_next++; } my $s = $stat; $s =~ s/{.*$//s; # Ignore goto labels. if ($s =~ /$Ident:\*$/s) { # Ignore functions being called } elsif ($s =~ /^.\s*$Ident\s*\(/s) { } elsif ($s =~ /^.\s*else\b/s) { # declarations always start with types } elsif ($prev_values eq 'E' && $s =~ /^.\s*(?:$Storage\s+)?(?:$Inline\s+)?(?:const\s+)?((?:\s*$Ident)+?)\b(?:\s+$Sparse)?\s*\**\s*(?:$Ident|\(\*[^\)]*\))(?:\s*$Modifier)?\s*(?:;|=|,|\()/s) { my $type = $1; $type =~ s/\s+/ /g; possible($type, "A:" . $s); # definitions in global scope can only start with types } elsif ($s =~ /^.(?:$Storage\s+)?(?:$Inline\s+)?(?:const\s+)?($Ident)\b\s*(?!:)/s) { possible($1, "B:" . $s); } # any (foo ... *) is a pointer cast, and foo is a type while ($s =~ /\(($Ident)(?:\s+$Sparse)*[\s\*]+\s*\)/sg) { possible($1, "C:" . $s); } # Check for any sort of function declaration. # int foo(something bar, other baz); # void (*store_gdt)(x86_descr_ptr *); if ($prev_values eq 'E' && $s =~ /^(.(?:typedef\s*)?(?:(?:$Storage|$Inline)\s*)*\s*$Type\s*(?:\b$Ident|\(\*\s*$Ident\))\s*)\(/s) { my ($name_len) = length($1); my $ctx = $s; substr($ctx, 0, $name_len + 1, ''); $ctx =~ s/\)[^\)]*$//; for my $arg (split(/\s*,\s*/, $ctx)) { if ($arg =~ /^(?:const\s+)?($Ident)(?:\s+$Sparse)*\s*\**\s*(:?\b$Ident)?$/s || $arg =~ /^($Ident)$/s) { possible($1, "D:" . $s); } } } } # # Checks which may be anchored in the context. # # Check for switch () and associated case and default # statements should be at the same indent. if ($line=~/\bswitch\s*\(.*\)/) { my $err = ''; my $sep = ''; my @ctx = ctx_block_outer($linenr, $realcnt); shift(@ctx); for my $ctx (@ctx) { my ($clen, $cindent) = line_stats($ctx); if ($ctx =~ /^\+\s*(case\s+|default:)/ && $indent != $cindent) { $err .= "$sep$ctx\n"; $sep = ''; } else { $sep = "[...]\n"; } } if ($err ne '') { ERROR("SWITCH_CASE_INDENT_LEVEL", "switch and case should be at the same indent\n$hereline$err"); } } # if/while/etc brace do not go on next line, unless defining a do while loop, # or if that brace on the next line is for something else if ($line =~ /(.*)\b((?:if|while|for|switch)\s*\(|do\b|else\b)/ && $line !~ /^.\s*\#/) { my $pre_ctx = "$1$2"; my ($level, @ctx) = ctx_statement_level($linenr, $realcnt, 0); if ($line =~ /^\+\t{6,}/) { WARN("DEEP_INDENTATION", "Too many leading tabs - consider code refactoring\n" . $herecurr); } my $ctx_cnt = $realcnt - $#ctx - 1; my $ctx = join("\n", @ctx); my $ctx_ln = $linenr; my $ctx_skip = $realcnt; while ($ctx_skip > $ctx_cnt || ($ctx_skip == $ctx_cnt && defined $lines[$ctx_ln - 1] && $lines[$ctx_ln - 1] =~ /^-/)) { ##print "SKIP<$ctx_skip> CNT<$ctx_cnt>\n"; $ctx_skip-- if (!defined $lines[$ctx_ln - 1] || $lines[$ctx_ln - 1] !~ /^-/); $ctx_ln++; } #print "realcnt<$realcnt> ctx_cnt<$ctx_cnt>\n"; #print "pre<$pre_ctx>\nline<$line>\nctx<$ctx>\nnext<$lines[$ctx_ln - 1]>\n"; if ($ctx !~ /{\s*/ && defined($lines[$ctx_ln -1]) && $lines[$ctx_ln - 1] =~ /^\+\s*{/) { ERROR("OPEN_BRACE", "that open brace { should be on the previous line\n" . "$here\n$ctx\n$rawlines[$ctx_ln - 1]\n"); } if ($level == 0 && $pre_ctx !~ /}\s*while\s*\($/ && $ctx =~ /\)\s*\;\s*$/ && defined $lines[$ctx_ln - 1]) { my ($nlength, $nindent) = line_stats($lines[$ctx_ln - 1]); if ($nindent > $indent) { WARN("TRAILING_SEMICOLON", "trailing semicolon indicates no statements, indent implies otherwise\n" . "$here\n$ctx\n$rawlines[$ctx_ln - 1]\n"); } } } # Check relative indent for conditionals and blocks. if ($line =~ /\b(?:(?:if|while|for)\s*\(|do\b)/ && $line !~ /^.\s*#/ && $line !~ /\}\s*while\s*/) { ($stat, $cond, $line_nr_next, $remain_next, $off_next) = ctx_statement_block($linenr, $realcnt, 0) if (!defined $stat); my ($s, $c) = ($stat, $cond); substr($s, 0, length($c), ''); # Make sure we remove the line prefixes as we have # none on the first line, and are going to readd them # where necessary. $s =~ s/\n./\n/gs; # Find out how long the conditional actually is. my @newlines = ($c =~ /\n/gs); my $cond_lines = 1 + $#newlines; # We want to check the first line inside the block # starting at the end of the conditional, so remove: # 1) any blank line termination # 2) any opening brace { on end of the line # 3) any do (...) { my $continuation = 0; my $check = 0; $s =~ s/^.*\bdo\b//; $s =~ s/^\s*{//; if ($s =~ s/^\s*\\//) { $continuation = 1; } if ($s =~ s/^\s*?\n//) { $check = 1; $cond_lines++; } # Also ignore a loop construct at the end of a # preprocessor statement. if (($prevline =~ /^.\s*#\s*define\s/ || $prevline =~ /\\\s*$/) && $continuation == 0) { $check = 0; } my $cond_ptr = -1; $continuation = 0; while ($cond_ptr != $cond_lines) { $cond_ptr = $cond_lines; # If we see an #else/#elif then the code # is not linear. if ($s =~ /^\s*\#\s*(?:else|elif)/) { $check = 0; } # Ignore: # 1) blank lines, they should be at 0, # 2) preprocessor lines, and # 3) labels. if ($continuation || $s =~ /^\s*?\n/ || $s =~ /^\s*#\s*?/ || $s =~ /^\s*$Ident\s*:/) { $continuation = ($s =~ /^.*?\\\n/) ? 1 : 0; if ($s =~ s/^.*?\n//) { $cond_lines++; } } } my (undef, $sindent) = line_stats("+" . $s); my $stat_real = raw_line($linenr, $cond_lines); # Check if either of these lines are modified, else # this is not this patch's fault. if (!defined($stat_real) || $stat !~ /^\+/ && $stat_real !~ /^\+/) { $check = 0; } if (defined($stat_real) && $cond_lines > 1) { $stat_real = "[...]\n$stat_real"; } #print "line<$line> prevline<$prevline> indent<$indent> sindent<$sindent> check<$check> continuation<$continuation> s<$s> cond_lines<$cond_lines> stat_real<$stat_real> stat<$stat>\n"; if ($check && (($sindent % 8) != 0 || ($sindent <= $indent && $s ne ''))) { WARN("SUSPECT_CODE_INDENT", "suspect code indent for conditional statements ($indent, $sindent)\n" . $herecurr . "$stat_real\n"); } } # Track the 'values' across context and added lines. my $opline = $line; $opline =~ s/^./ /; my ($curr_values, $curr_vars) = annotate_values($opline . "\n", $prev_values); $curr_values = $prev_values . $curr_values; if ($dbg_values) { my $outline = $opline; $outline =~ s/\t/ /g; print "$linenr > .$outline\n"; print "$linenr > $curr_values\n"; print "$linenr > $curr_vars\n"; } $prev_values = substr($curr_values, -1); #ignore lines not being added if ($line=~/^[^\+]/) {next;} # TEST: allow direct testing of the type matcher. if ($dbg_type) { if ($line =~ /^.\s*$Declare\s*$/) { ERROR("TEST_TYPE", "TEST: is type\n" . $herecurr); } elsif ($dbg_type > 1 && $line =~ /^.+($Declare)/) { ERROR("TEST_NOT_TYPE", "TEST: is not type ($1 is)\n". $herecurr); } next; } # TEST: allow direct testing of the attribute matcher. if ($dbg_attr) { if ($line =~ /^.\s*$Modifier\s*$/) { ERROR("TEST_ATTR", "TEST: is attr\n" . $herecurr); } elsif ($dbg_attr > 1 && $line =~ /^.+($Modifier)/) { ERROR("TEST_NOT_ATTR", "TEST: is not attr ($1 is)\n". $herecurr); } next; } # check for initialisation to aggregates open brace on the next line if ($line =~ /^.\s*{/ && $prevline =~ /(?:^|[^=])=\s*$/) { ERROR("OPEN_BRACE", "that open brace { should be on the previous line\n" . $hereprev); } # # Checks which are anchored on the added line. # # check for malformed paths in #include statements (uses RAW line) if ($rawline =~ m{^.\s*\#\s*include\s+[<"](.*)[">]}) { my $path = $1; if ($path =~ m{//}) { ERROR("MALFORMED_INCLUDE", "malformed #include filename\n" . $herecurr); } } # no C99 // comments if ($line =~ m{//}) { ERROR("C99_COMMENTS", "do not use C99 // comments\n" . $herecurr); } # Remove C99 comments. $line =~ s@//.*@@; $opline =~ s@//.*@@; # EXPORT_SYMBOL should immediately follow the thing it is exporting, consider # the whole statement. #print "APW <$lines[$realline_next - 1]>\n"; if (defined $realline_next && exists $lines[$realline_next - 1] && !defined $suppress_export{$realline_next} && ($lines[$realline_next - 1] =~ /EXPORT_SYMBOL.*\((.*)\)/ || $lines[$realline_next - 1] =~ /EXPORT_UNUSED_SYMBOL.*\((.*)\)/)) { # Handle definitions which produce identifiers with # a prefix: # XXX(foo); # EXPORT_SYMBOL(something_foo); my $name = $1; if ($stat =~ /^(?:.\s*}\s*\n)?.([A-Z_]+)\s*\(\s*($Ident)/ && $name =~ /^${Ident}_$2/) { #print "FOO C name<$name>\n"; $suppress_export{$realline_next} = 1; } elsif ($stat !~ /(?: \n.}\s*$| ^.DEFINE_$Ident\(\Q$name\E\)| ^.DECLARE_$Ident\(\Q$name\E\)| ^.LIST_HEAD\(\Q$name\E\)| ^.(?:$Storage\s+)?$Type\s*\(\s*\*\s*\Q$name\E\s*\)\s*\(| \b\Q$name\E(?:\s+$Attribute)*\s*(?:;|=|\[|\() )/x) { #print "FOO A<$lines[$realline_next - 1]> stat<$stat> name<$name>\n"; $suppress_export{$realline_next} = 2; } else { $suppress_export{$realline_next} = 1; } } if (!defined $suppress_export{$linenr} && $prevline =~ /^.\s*$/ && ($line =~ /EXPORT_SYMBOL.*\((.*)\)/ || $line =~ /EXPORT_UNUSED_SYMBOL.*\((.*)\)/)) { #print "FOO B <$lines[$linenr - 1]>\n"; $suppress_export{$linenr} = 2; } if (defined $suppress_export{$linenr} && $suppress_export{$linenr} == 2) { WARN("EXPORT_SYMBOL", "EXPORT_SYMBOL(foo); should immediately follow its function/variable\n" . $herecurr); } # check for global initialisers. if ($line =~ /^.$Type\s*$Ident\s*(?:\s+$Modifier)*\s*=\s*(0|NULL|false)\s*;/) { ERROR("GLOBAL_INITIALISERS", "do not initialise globals to 0 or NULL\n" . $herecurr); } # check for static initialisers. if ($line =~ /\bstatic\s.*=\s*(0|NULL|false)\s*;/) { ERROR("INITIALISED_STATIC", "do not initialise statics to 0 or NULL\n" . $herecurr); } # check for static const char * arrays. if ($line =~ /\bstatic\s+const\s+char\s*\*\s*(\w+)\s*\[\s*\]\s*=\s*/) { WARN("STATIC_CONST_CHAR_ARRAY", "static const char * array should probably be static const char * const\n" . $herecurr); } # check for static char foo[] = "bar" declarations. if ($line =~ /\bstatic\s+char\s+(\w+)\s*\[\s*\]\s*=\s*"/) { WARN("STATIC_CONST_CHAR_ARRAY", "static char array declaration should probably be static const char\n" . $herecurr); } # check for declarations of struct pci_device_id if ($line =~ /\bstruct\s+pci_device_id\s+\w+\s*\[\s*\]\s*\=\s*\{/) { WARN("DEFINE_PCI_DEVICE_TABLE", "Use DEFINE_PCI_DEVICE_TABLE for struct pci_device_id\n" . $herecurr); } # check for new typedefs, only function parameters and sparse annotations # make sense. if ($line =~ /\btypedef\s/ && $line !~ /\btypedef\s+$Type\s*\(\s*\*?$Ident\s*\)\s*\(/ && $line !~ /\btypedef\s+$Type\s+$Ident\s*\(/ && $line !~ /\b$typeTypedefs\b/ && $line !~ /\b__bitwise(?:__|)\b/) { WARN("NEW_TYPEDEFS", "do not add new typedefs\n" . $herecurr); } # * goes on variable not on type # (char*[ const]) while ($line =~ m{(\($NonptrType(\s*(?:$Modifier\b\s*|\*\s*)+)\))}g) { #print "AA<$1>\n"; my ($from, $to) = ($2, $2); # Should start with a space. $to =~ s/^(\S)/ $1/; # Should not end with a space. $to =~ s/\s+$//; # '*'s should not have spaces between. while ($to =~ s/\*\s+\*/\*\*/) { } #print "from<$from> to<$to>\n"; if ($from ne $to) { ERROR("POINTER_LOCATION", "\"(foo$from)\" should be \"(foo$to)\"\n" . $herecurr); } } while ($line =~ m{(\b$NonptrType(\s*(?:$Modifier\b\s*|\*\s*)+)($Ident))}g) { #print "BB<$1>\n"; my ($from, $to, $ident) = ($2, $2, $3); # Should start with a space. $to =~ s/^(\S)/ $1/; # Should not end with a space. $to =~ s/\s+$//; # '*'s should not have spaces between. while ($to =~ s/\*\s+\*/\*\*/) { } # Modifiers should have spaces. $to =~ s/(\b$Modifier$)/$1 /; #print "from<$from> to<$to> ident<$ident>\n"; if ($from ne $to && $ident !~ /^$Modifier$/) { ERROR("POINTER_LOCATION", "\"foo${from}bar\" should be \"foo${to}bar\"\n" . $herecurr); } } # # no BUG() or BUG_ON() # if ($line =~ /\b(BUG|BUG_ON)\b/) { # print "Try to use WARN_ON & Recovery code rather than BUG() or BUG_ON()\n"; # print "$herecurr"; # $clean = 0; # } if ($line =~ /\bLINUX_VERSION_CODE\b/) { WARN("LINUX_VERSION_CODE", "LINUX_VERSION_CODE should be avoided, code should be for the version to which it is merged\n" . $herecurr); } # check for uses of printk_ratelimit if ($line =~ /\bprintk_ratelimit\s*\(/) { WARN("PRINTK_RATELIMITED", "Prefer printk_ratelimited or pr__ratelimited to printk_ratelimit\n" . $herecurr); } # printk should use KERN_* levels. Note that follow on printk's on the # same line do not need a level, so we use the current block context # to try and find and validate the current printk. In summary the current # printk includes all preceding printk's which have no newline on the end. # we assume the first bad printk is the one to report. if ($line =~ /\bprintk\((?!KERN_)\s*"/) { my $ok = 0; for (my $ln = $linenr - 1; $ln >= $first_line; $ln--) { #print "CHECK<$lines[$ln - 1]\n"; # we have a preceding printk if it ends # with "\n" ignore it, else it is to blame if ($lines[$ln - 1] =~ m{\bprintk\(}) { if ($rawlines[$ln - 1] !~ m{\\n"}) { $ok = 1; } last; } } if ($ok == 0) { WARN("PRINTK_WITHOUT_KERN_LEVEL", "printk() should include KERN_ facility level\n" . $herecurr); } } # function brace can't be on same line, except for #defines of do while, # or if closed on same line if (($line=~/$Type\s*$Ident\(.*\).*\s{/) and !($line=~/\#\s*define.*do\s{/) and !($line=~/}/)) { ERROR("OPEN_BRACE", "open brace '{' following function declarations go on the next line\n" . $herecurr); } # open braces for enum, union and struct go on the same line. if ($line =~ /^.\s*{/ && $prevline =~ /^.\s*(?:typedef\s+)?(enum|union|struct)(?:\s+$Ident)?\s*$/) { ERROR("OPEN_BRACE", "open brace '{' following $1 go on the same line\n" . $hereprev); } # missing space after union, struct or enum definition if ($line =~ /^.\s*(?:typedef\s+)?(enum|union|struct)(?:\s+$Ident)?(?:\s+$Ident)?[=\{]/) { WARN("SPACING", "missing space after $1 definition\n" . $herecurr); } # check for spacing round square brackets; allowed: # 1. with a type on the left -- int [] a; # 2. at the beginning of a line for slice initialisers -- [0...10] = 5, # 3. inside a curly brace -- = { [0...10] = 5 } while ($line =~ /(.*?\s)\[/g) { my ($where, $prefix) = ($-[1], $1); if ($prefix !~ /$Type\s+$/ && ($where != 0 || $prefix !~ /^.\s+$/) && $prefix !~ /[{,]\s+$/) { ERROR("BRACKET_SPACE", "space prohibited before open square bracket '['\n" . $herecurr); } } # check for spaces between functions and their parentheses. while ($line =~ /($Ident)\s+\(/g) { my $name = $1; my $ctx_before = substr($line, 0, $-[1]); my $ctx = "$ctx_before$name"; # Ignore those directives where spaces _are_ permitted. if ($name =~ /^(?: if|for|while|switch|return|case| volatile|__volatile__| __attribute__|format|__extension__| asm|__asm__)$/x) { # cpp #define statements have non-optional spaces, ie # if there is a space between the name and the open # parenthesis it is simply not a parameter group. } elsif ($ctx_before =~ /^.\s*\#\s*define\s*$/) { # cpp #elif statement condition may start with a ( } elsif ($ctx =~ /^.\s*\#\s*elif\s*$/) { # If this whole things ends with a type its most # likely a typedef for a function. } elsif ($ctx =~ /$Type$/) { } else { WARN("SPACING", "space prohibited between function name and open parenthesis '('\n" . $herecurr); } } # Check operator spacing. if (!($line=~/\#\s*include/)) { my $ops = qr{ <<=|>>=|<=|>=|==|!=| \+=|-=|\*=|\/=|%=|\^=|\|=|&=| =>|->|<<|>>|<|>|=|!|~| &&|\|\||,|\^|\+\+|--|&|\||\+|-|\*|\/|%| \?|: }x; my @elements = split(/($ops|;)/, $opline); my $off = 0; my $blank = copy_spacing($opline); for (my $n = 0; $n < $#elements; $n += 2) { $off += length($elements[$n]); # Pick up the preceding and succeeding characters. my $ca = substr($opline, 0, $off); my $cc = ''; if (length($opline) >= ($off + length($elements[$n + 1]))) { $cc = substr($opline, $off + length($elements[$n + 1])); } my $cb = "$ca$;$cc"; my $a = ''; $a = 'V' if ($elements[$n] ne ''); $a = 'W' if ($elements[$n] =~ /\s$/); $a = 'C' if ($elements[$n] =~ /$;$/); $a = 'B' if ($elements[$n] =~ /(\[|\()$/); $a = 'O' if ($elements[$n] eq ''); $a = 'E' if ($ca =~ /^\s*$/); my $op = $elements[$n + 1]; my $c = ''; if (defined $elements[$n + 2]) { $c = 'V' if ($elements[$n + 2] ne ''); $c = 'W' if ($elements[$n + 2] =~ /^\s/); $c = 'C' if ($elements[$n + 2] =~ /^$;/); $c = 'B' if ($elements[$n + 2] =~ /^(\)|\]|;)/); $c = 'O' if ($elements[$n + 2] eq ''); $c = 'E' if ($elements[$n + 2] =~ /^\s*\\$/); } else { $c = 'E'; } my $ctx = "${a}x${c}"; my $at = "(ctx:$ctx)"; my $ptr = substr($blank, 0, $off) . "^"; my $hereptr = "$hereline$ptr\n"; # Pull out the value of this operator. my $op_type = substr($curr_values, $off + 1, 1); # Get the full operator variant. my $opv = $op . substr($curr_vars, $off, 1); # Ignore operators passed as parameters. if ($op_type ne 'V' && $ca =~ /\s$/ && $cc =~ /^\s*,/) { # # Ignore comments # } elsif ($op =~ /^$;+$/) { # ; should have either the end of line or a space or \ after it } elsif ($op eq ';') { if ($ctx !~ /.x[WEBC]/ && $cc !~ /^\\/ && $cc !~ /^;/) { ERROR("SPACING", "space required after that '$op' $at\n" . $hereptr); } # // is a comment } elsif ($op eq '//') { # No spaces for: # -> # : when part of a bitfield } elsif ($op eq '->' || $opv eq ':B') { if ($ctx =~ /Wx.|.xW/) { ERROR("SPACING", "spaces prohibited around that '$op' $at\n" . $hereptr); } # , must have a space on the right. } elsif ($op eq ',') { if ($ctx !~ /.x[WEC]/ && $cc !~ /^}/) { ERROR("SPACING", "space required after that '$op' $at\n" . $hereptr); } # '*' as part of a type definition -- reported already. } elsif ($opv eq '*_') { #warn "'*' is part of type\n"; # unary operators should have a space before and # none after. May be left adjacent to another # unary operator, or a cast } elsif ($op eq '!' || $op eq '~' || $opv eq '*U' || $opv eq '-U' || $opv eq '&U' || $opv eq '&&U') { if ($ctx !~ /[WEBC]x./ && $ca !~ /(?:\)|!|~|\*|-|\&|\||\+\+|\-\-|\{)$/) { ERROR("SPACING", "space required before that '$op' $at\n" . $hereptr); } if ($op eq '*' && $cc =~/\s*$Modifier\b/) { # A unary '*' may be const } elsif ($ctx =~ /.xW/) { ERROR("SPACING", "space prohibited after that '$op' $at\n" . $hereptr); } # unary ++ and unary -- are allowed no space on one side. } elsif ($op eq '++' or $op eq '--') { if ($ctx !~ /[WEOBC]x[^W]/ && $ctx !~ /[^W]x[WOBEC]/) { ERROR("SPACING", "space required one side of that '$op' $at\n" . $hereptr); } if ($ctx =~ /Wx[BE]/ || ($ctx =~ /Wx./ && $cc =~ /^;/)) { ERROR("SPACING", "space prohibited before that '$op' $at\n" . $hereptr); } if ($ctx =~ /ExW/) { ERROR("SPACING", "space prohibited after that '$op' $at\n" . $hereptr); } # << and >> may either have or not have spaces both sides } elsif ($op eq '<<' or $op eq '>>' or $op eq '&' or $op eq '^' or $op eq '|' or $op eq '+' or $op eq '-' or $op eq '*' or $op eq '/' or $op eq '%') { if ($ctx =~ /Wx[^WCE]|[^WCE]xW/) { ERROR("SPACING", "need consistent spacing around '$op' $at\n" . $hereptr); } # A colon needs no spaces before when it is # terminating a case value or a label. } elsif ($opv eq ':C' || $opv eq ':L') { if ($ctx =~ /Wx./) { ERROR("SPACING", "space prohibited before that '$op' $at\n" . $hereptr); } # All the others need spaces both sides. } elsif ($ctx !~ /[EWC]x[CWE]/) { my $ok = 0; # Ignore email addresses if (($op eq '<' && $cc =~ /^\S+\@\S+>/) || ($op eq '>' && $ca =~ /<\S+\@\S+$/)) { $ok = 1; } # Ignore ?: if (($opv eq ':O' && $ca =~ /\?$/) || ($op eq '?' && $cc =~ /^:/)) { $ok = 1; } if ($ok == 0) { ERROR("SPACING", "spaces required around that '$op' $at\n" . $hereptr); } } $off += length($elements[$n + 1]); } } # check for multiple assignments if ($line =~ /^.\s*$Lval\s*=\s*$Lval\s*=(?!=)/) { CHK("MULTIPLE_ASSIGNMENTS", "multiple assignments should be avoided\n" . $herecurr); } ## # check for multiple declarations, allowing for a function declaration ## # continuation. ## if ($line =~ /^.\s*$Type\s+$Ident(?:\s*=[^,{]*)?\s*,\s*$Ident.*/ && ## $line !~ /^.\s*$Type\s+$Ident(?:\s*=[^,{]*)?\s*,\s*$Type\s*$Ident.*/) { ## ## # Remove any bracketed sections to ensure we do not ## # falsly report the parameters of functions. ## my $ln = $line; ## while ($ln =~ s/\([^\(\)]*\)//g) { ## } ## if ($ln =~ /,/) { ## WARN("MULTIPLE_DECLARATION", ## "declaring multiple variables together should be avoided\n" . $herecurr); ## } ## } #need space before brace following if, while, etc if (($line =~ /\(.*\){/ && $line !~ /\($Type\){/) || $line =~ /do{/) { ERROR("SPACING", "space required before the open brace '{'\n" . $herecurr); } # closing brace should have a space following it when it has anything # on the line if ($line =~ /}(?!(?:,|;|\)))\S/) { ERROR("SPACING", "space required after that close brace '}'\n" . $herecurr); } # check spacing on square brackets if ($line =~ /\[\s/ && $line !~ /\[\s*$/) { ERROR("SPACING", "space prohibited after that open square bracket '['\n" . $herecurr); } if ($line =~ /\s\]/) { ERROR("SPACING", "space prohibited before that close square bracket ']'\n" . $herecurr); } # check spacing on parentheses if ($line =~ /\(\s/ && $line !~ /\(\s*(?:\\)?$/ && $line !~ /for\s*\(\s+;/) { ERROR("SPACING", "space prohibited after that open parenthesis '('\n" . $herecurr); } if ($line =~ /(\s+)\)/ && $line !~ /^.\s*\)/ && $line !~ /for\s*\(.*;\s+\)/ && $line !~ /:\s+\)/) { ERROR("SPACING", "space prohibited before that close parenthesis ')'\n" . $herecurr); } #goto labels aren't indented, allow a single space however if ($line=~/^.\s+[A-Za-z\d_]+:(?![0-9]+)/ and !($line=~/^. [A-Za-z\d_]+:/) and !($line=~/^.\s+default:/)) { WARN("INDENTED_LABEL", "labels should not be indented\n" . $herecurr); } # Return is not a function. if (defined($stat) && $stat =~ /^.\s*return(\s*)(\(.*);/s) { my $spacing = $1; my $value = $2; # Flatten any parentheses $value =~ s/\(/ \(/g; $value =~ s/\)/\) /g; while ($value =~ s/\[[^\[\]]*\]/1/ || $value !~ /(?:$Ident|-?$Constant)\s* $Compare\s* (?:$Ident|-?$Constant)/x && $value =~ s/\([^\(\)]*\)/1/) { } #print "value<$value>\n"; if ($value =~ /^\s*(?:$Ident|-?$Constant)\s*$/) { ERROR("RETURN_PARENTHESES", "return is not a function, parentheses are not required\n" . $herecurr); } elsif ($spacing !~ /\s+/) { ERROR("SPACING", "space required before the open parenthesis '('\n" . $herecurr); } } # Return of what appears to be an errno should normally be -'ve if ($line =~ /^.\s*return\s*(E[A-Z]*)\s*;/) { my $name = $1; if ($name ne 'EOF' && $name ne 'ERROR') { WARN("USE_NEGATIVE_ERRNO", "return of an errno should typically be -ve (return -$1)\n" . $herecurr); } } # Need a space before open parenthesis after if, while etc if ($line=~/\b(if|while|for|switch)\(/) { ERROR("SPACING", "space required before the open parenthesis '('\n" . $herecurr); } # Check for illegal assignment in if conditional -- and check for trailing # statements after the conditional. if ($line =~ /do\s*(?!{)/) { ($stat, $cond, $line_nr_next, $remain_next, $off_next) = ctx_statement_block($linenr, $realcnt, 0) if (!defined $stat); my ($stat_next) = ctx_statement_block($line_nr_next, $remain_next, $off_next); $stat_next =~ s/\n./\n /g; ##print "stat<$stat> stat_next<$stat_next>\n"; if ($stat_next =~ /^\s*while\b/) { # If the statement carries leading newlines, # then count those as offsets. my ($whitespace) = ($stat_next =~ /^((?:\s*\n[+-])*\s*)/s); my $offset = statement_rawlines($whitespace) - 1; $suppress_whiletrailers{$line_nr_next + $offset} = 1; } } if (!defined $suppress_whiletrailers{$linenr} && $line =~ /\b(?:if|while|for)\s*\(/ && $line !~ /^.\s*#/) { my ($s, $c) = ($stat, $cond); if ($c =~ /\bif\s*\(.*[^<>!=]=[^=].*/s) { ERROR("ASSIGN_IN_IF", "do not use assignment in if condition\n" . $herecurr); } # Find out what is on the end of the line after the # conditional. substr($s, 0, length($c), ''); $s =~ s/\n.*//g; $s =~ s/$;//g; # Remove any comments if (length($c) && $s !~ /^\s*{?\s*\\*\s*$/ && $c !~ /}\s*while\s*/) { # Find out how long the conditional actually is. my @newlines = ($c =~ /\n/gs); my $cond_lines = 1 + $#newlines; my $stat_real = ''; $stat_real = raw_line($linenr, $cond_lines) . "\n" if ($cond_lines); if (defined($stat_real) && $cond_lines > 1) { $stat_real = "[...]\n$stat_real"; } ERROR("TRAILING_STATEMENTS", "trailing statements should be on next line\n" . $herecurr . $stat_real); } } # Check for bitwise tests written as boolean if ($line =~ / (?: (?:\[|\(|\&\&|\|\|) \s*0[xX][0-9]+\s* (?:\&\&|\|\|) | (?:\&\&|\|\|) \s*0[xX][0-9]+\s* (?:\&\&|\|\||\)|\]) )/x) { WARN("HEXADECIMAL_BOOLEAN_TEST", "boolean test with hexadecimal, perhaps just 1 \& or \|?\n" . $herecurr); } # if and else should not have general statements after it if ($line =~ /^.\s*(?:}\s*)?else\b(.*)/) { my $s = $1; $s =~ s/$;//g; # Remove any comments if ($s !~ /^\s*(?:\sif|(?:{|)\s*\\?\s*$)/) { ERROR("TRAILING_STATEMENTS", "trailing statements should be on next line\n" . $herecurr); } } # if should not continue a brace if ($line =~ /}\s*if\b/) { ERROR("TRAILING_STATEMENTS", "trailing statements should be on next line\n" . $herecurr); } # case and default should not have general statements after them if ($line =~ /^.\s*(?:case\s*.*|default\s*):/g && $line !~ /\G(?: (?:\s*$;*)(?:\s*{)?(?:\s*$;*)(?:\s*\\)?\s*$| \s*return\s+ )/xg) { ERROR("TRAILING_STATEMENTS", "trailing statements should be on next line\n" . $herecurr); } # Check for }else {, these must be at the same # indent level to be relevant to each other. if ($prevline=~/}\s*$/ and $line=~/^.\s*else\s*/ and $previndent == $indent) { ERROR("ELSE_AFTER_BRACE", "else should follow close brace '}'\n" . $hereprev); } if ($prevline=~/}\s*$/ and $line=~/^.\s*while\s*/ and $previndent == $indent) { my ($s, $c) = ctx_statement_block($linenr, $realcnt, 0); # Find out what is on the end of the line after the # conditional. substr($s, 0, length($c), ''); $s =~ s/\n.*//g; if ($s =~ /^\s*;/) { ERROR("WHILE_AFTER_BRACE", "while should follow close brace '}'\n" . $hereprev); } } #studly caps, commented out until figure out how to distinguish between use of existing and adding new # if (($line=~/[\w_][a-z\d]+[A-Z]/) and !($line=~/print/)) { # print "No studly caps, use _\n"; # print "$herecurr"; # $clean = 0; # } #no spaces allowed after \ in define if ($line=~/\#\s*define.*\\\s$/) { WARN("WHITESPACE_AFTER_LINE_CONTINUATION", "Whitepspace after \\ makes next lines useless\n" . $herecurr); } #warn if is #included and is available (uses RAW line) if ($tree && $rawline =~ m{^.\s*\#\s*include\s*\}) { my $file = "$1.h"; my $checkfile = "include/linux/$file"; if (-f "$root/$checkfile" && $realfile ne $checkfile && $1 !~ /$allowed_asm_includes/) { if ($realfile =~ m{^arch/}) { CHK("ARCH_INCLUDE_LINUX", "Consider using #include instead of \n" . $herecurr); } else { WARN("INCLUDE_LINUX", "Use #include instead of \n" . $herecurr); } } } # multi-statement macros should be enclosed in a do while loop, grab the # first statement and ensure its the whole macro if its not enclosed # in a known good container if ($realfile !~ m@/vmlinux.lds.h$@ && $line =~ /^.\s*\#\s*define\s*$Ident(\()?/) { my $ln = $linenr; my $cnt = $realcnt; my ($off, $dstat, $dcond, $rest); my $ctx = ''; ($dstat, $dcond, $ln, $cnt, $off) = ctx_statement_block($linenr, $realcnt, 0); $ctx = $dstat; #print "dstat<$dstat> dcond<$dcond> cnt<$cnt> off<$off>\n"; #print "LINE<$lines[$ln-1]> len<" . length($lines[$ln-1]) . "\n"; $dstat =~ s/^.\s*\#\s*define\s+$Ident(?:\([^\)]*\))?\s*//; $dstat =~ s/$;//g; $dstat =~ s/\\\n.//g; $dstat =~ s/^\s*//s; $dstat =~ s/\s*$//s; # Flatten any parentheses and braces while ($dstat =~ s/\([^\(\)]*\)/1/ || $dstat =~ s/\{[^\{\}]*\}/1/ || $dstat =~ s/\[[^\[\]]*\]/1/) { } # Flatten any obvious string concatentation. while ($dstat =~ s/("X*")\s*$Ident/$1/ || $dstat =~ s/$Ident\s*("X*")/$1/) { } my $exceptions = qr{ $Declare| module_param_named| MODULE_PARAM_DESC| DECLARE_PER_CPU| DEFINE_PER_CPU| __typeof__\(| union| struct| \.$Ident\s*=\s*| ^\"|\"$ }x; #print "REST<$rest> dstat<$dstat> ctx<$ctx>\n"; if ($dstat ne '' && $dstat !~ /^(?:$Ident|-?$Constant),$/ && # 10, // foo(), $dstat !~ /^(?:$Ident|-?$Constant);$/ && # foo(); $dstat !~ /^[!~-]?(?:$Ident|$Constant)$/ && # 10 // foo() // !foo // ~foo // -foo $dstat !~ /^'X'$/ && # character constants $dstat !~ /$exceptions/ && $dstat !~ /^\.$Ident\s*=/ && # .foo = $dstat !~ /^do\s*$Constant\s*while\s*$Constant;?$/ && # do {...} while (...); // do {...} while (...) $dstat !~ /^for\s*$Constant$/ && # for (...) $dstat !~ /^for\s*$Constant\s+(?:$Ident|-?$Constant)$/ && # for (...) bar() $dstat !~ /^do\s*{/ && # do {... $dstat !~ /^\({/) # ({... { $ctx =~ s/\n*$//; my $herectx = $here . "\n"; my $cnt = statement_rawlines($ctx); for (my $n = 0; $n < $cnt; $n++) { $herectx .= raw_line($linenr, $n) . "\n"; } if ($dstat =~ /;/) { ERROR("MULTISTATEMENT_MACRO_USE_DO_WHILE", "Macros with multiple statements should be enclosed in a do - while loop\n" . "$herectx"); } else { ERROR("COMPLEX_MACRO", "Macros with complex values should be enclosed in parenthesis\n" . "$herectx"); } } } # make sure symbols are always wrapped with VMLINUX_SYMBOL() ... # all assignments may have only one of the following with an assignment: # . # ALIGN(...) # VMLINUX_SYMBOL(...) if ($realfile eq 'vmlinux.lds.h' && $line =~ /(?:(?:^|\s)$Ident\s*=|=\s*$Ident(?:\s|$))/) { WARN("MISSING_VMLINUX_SYMBOL", "vmlinux.lds.h needs VMLINUX_SYMBOL() around C-visible symbols\n" . $herecurr); } # check for redundant bracing round if etc if ($line =~ /(^.*)\bif\b/ && $1 !~ /else\s*$/) { my ($level, $endln, @chunks) = ctx_statement_full($linenr, $realcnt, 1); #print "chunks<$#chunks> linenr<$linenr> endln<$endln> level<$level>\n"; #print "APW: <<$chunks[1][0]>><<$chunks[1][1]>>\n"; if ($#chunks > 0 && $level == 0) { my @allowed = (); my $allow = 0; my $seen = 0; my $herectx = $here . "\n"; my $ln = $linenr - 1; for my $chunk (@chunks) { my ($cond, $block) = @{$chunk}; # If the condition carries leading newlines, then count those as offsets. my ($whitespace) = ($cond =~ /^((?:\s*\n[+-])*\s*)/s); my $offset = statement_rawlines($whitespace) - 1; $allowed[$allow] = 0; #print "COND<$cond> whitespace<$whitespace> offset<$offset>\n"; # We have looked at and allowed this specific line. $suppress_ifbraces{$ln + $offset} = 1; $herectx .= "$rawlines[$ln + $offset]\n[...]\n"; $ln += statement_rawlines($block) - 1; substr($block, 0, length($cond), ''); $seen++ if ($block =~ /^\s*{/); #print "cond<$cond> block<$block> allowed<$allowed[$allow]>\n"; if (statement_lines($cond) > 1) { #print "APW: ALLOWED: cond<$cond>\n"; $allowed[$allow] = 1; } if ($block =~/\b(?:if|for|while)\b/) { #print "APW: ALLOWED: block<$block>\n"; $allowed[$allow] = 1; } if (statement_block_size($block) > 1) { #print "APW: ALLOWED: lines block<$block>\n"; $allowed[$allow] = 1; } $allow++; } if ($seen) { my $sum_allowed = 0; foreach (@allowed) { $sum_allowed += $_; } if ($sum_allowed == 0) { WARN("BRACES", "braces {} are not necessary for any arm of this statement\n" . $herectx); } elsif ($sum_allowed != $allow && $seen != $allow) { CHK("BRACES", "braces {} should be used on all arms of this statement\n" . $herectx); } } } } if (!defined $suppress_ifbraces{$linenr - 1} && $line =~ /\b(if|while|for|else)\b/) { my $allowed = 0; # Check the pre-context. if (substr($line, 0, $-[0]) =~ /(\}\s*)$/) { #print "APW: ALLOWED: pre<$1>\n"; $allowed = 1; } my ($level, $endln, @chunks) = ctx_statement_full($linenr, $realcnt, $-[0]); # Check the condition. my ($cond, $block) = @{$chunks[0]}; #print "CHECKING<$linenr> cond<$cond> block<$block>\n"; if (defined $cond) { substr($block, 0, length($cond), ''); } if (statement_lines($cond) > 1) { #print "APW: ALLOWED: cond<$cond>\n"; $allowed = 1; } if ($block =~/\b(?:if|for|while)\b/) { #print "APW: ALLOWED: block<$block>\n"; $allowed = 1; } if (statement_block_size($block) > 1) { #print "APW: ALLOWED: lines block<$block>\n"; $allowed = 1; } # Check the post-context. if (defined $chunks[1]) { my ($cond, $block) = @{$chunks[1]}; if (defined $cond) { substr($block, 0, length($cond), ''); } if ($block =~ /^\s*\{/) { #print "APW: ALLOWED: chunk-1 block<$block>\n"; $allowed = 1; } } if ($level == 0 && $block =~ /^\s*\{/ && !$allowed) { my $herectx = $here . "\n"; my $cnt = statement_rawlines($block); for (my $n = 0; $n < $cnt; $n++) { $herectx .= raw_line($linenr, $n) . "\n"; } WARN("BRACES", "braces {} are not necessary for single statement blocks\n" . $herectx); } } # no volatiles please my $asm_volatile = qr{\b(__asm__|asm)\s+(__volatile__|volatile)\b}; if ($line =~ /\bvolatile\b/ && $line !~ /$asm_volatile/) { WARN("VOLATILE", "Use of volatile is usually wrong: see Documentation/volatile-considered-harmful.txt\n" . $herecurr); } # warn about #if 0 if ($line =~ /^.\s*\#\s*if\s+0\b/) { CHK("REDUNDANT_CODE", "if this code is redundant consider removing it\n" . $herecurr); } # check for needless kfree() checks if ($prevline =~ /\bif\s*\(([^\)]*)\)/) { my $expr = $1; if ($line =~ /\bkfree\(\Q$expr\E\);/) { WARN("NEEDLESS_KFREE", "kfree(NULL) is safe this check is probably not required\n" . $hereprev); } } # check for needless usb_free_urb() checks if ($prevline =~ /\bif\s*\(([^\)]*)\)/) { my $expr = $1; if ($line =~ /\busb_free_urb\(\Q$expr\E\);/) { WARN("NEEDLESS_USB_FREE_URB", "usb_free_urb(NULL) is safe this check is probably not required\n" . $hereprev); } } # prefer usleep_range over udelay if ($line =~ /\budelay\s*\(\s*(\w+)\s*\)/) { # ignore udelay's < 10, however if (! (($1 =~ /(\d+)/) && ($1 < 10)) ) { CHK("USLEEP_RANGE", "usleep_range is preferred over udelay; see Documentation/timers/timers-howto.txt\n" . $line); } } # warn about unexpectedly long msleep's if ($line =~ /\bmsleep\s*\((\d+)\);/) { if ($1 < 20) { WARN("MSLEEP", "msleep < 20ms can sleep for up to 20ms; see Documentation/timers/timers-howto.txt\n" . $line); } } # warn about #ifdefs in C files # if ($line =~ /^.\s*\#\s*if(|n)def/ && ($realfile =~ /\.c$/)) { # print "#ifdef in C files should be avoided\n"; # print "$herecurr"; # $clean = 0; # } # warn about spacing in #ifdefs if ($line =~ /^.\s*\#\s*(ifdef|ifndef|elif)\s\s+/) { ERROR("SPACING", "exactly one space required after that #$1\n" . $herecurr); } # check for spinlock_t definitions without a comment. if ($line =~ /^.\s*(struct\s+mutex|spinlock_t)\s+\S+;/ || $line =~ /^.\s*(DEFINE_MUTEX)\s*\(/) { my $which = $1; if (!ctx_has_comment($first_line, $linenr)) { CHK("UNCOMMENTED_DEFINITION", "$1 definition without comment\n" . $herecurr); } } # check for memory barriers without a comment. if ($line =~ /\b(mb|rmb|wmb|read_barrier_depends|smp_mb|smp_rmb|smp_wmb|smp_read_barrier_depends)\(/) { if (!ctx_has_comment($first_line, $linenr)) { CHK("MEMORY_BARRIER", "memory barrier without comment\n" . $herecurr); } } # check of hardware specific defines if ($line =~ m@^.\s*\#\s*if.*\b(__i386__|__powerpc64__|__sun__|__s390x__)\b@ && $realfile !~ m@include/asm-@) { CHK("ARCH_DEFINES", "architecture specific defines should be avoided\n" . $herecurr); } # Check that the storage class is at the beginning of a declaration if ($line =~ /\b$Storage\b/ && $line !~ /^.\s*$Storage\b/) { WARN("STORAGE_CLASS", "storage class should be at the beginning of the declaration\n" . $herecurr) } # check the location of the inline attribute, that it is between # storage class and type. if ($line =~ /\b$Type\s+$Inline\b/ || $line =~ /\b$Inline\s+$Storage\b/) { ERROR("INLINE_LOCATION", "inline keyword should sit between storage class and type\n" . $herecurr); } # Check for __inline__ and __inline, prefer inline if ($line =~ /\b(__inline__|__inline)\b/) { WARN("INLINE", "plain inline is preferred over $1\n" . $herecurr); } # Check for __attribute__ packed, prefer __packed if ($line =~ /\b__attribute__\s*\(\s*\(.*\bpacked\b/) { WARN("PREFER_PACKED", "__packed is preferred over __attribute__((packed))\n" . $herecurr); } # Check for __attribute__ aligned, prefer __aligned if ($line =~ /\b__attribute__\s*\(\s*\(.*aligned/) { WARN("PREFER_ALIGNED", "__aligned(size) is preferred over __attribute__((aligned(size)))\n" . $herecurr); } # Check for __attribute__ format(printf, prefer __printf if ($line =~ /\b__attribute__\s*\(\s*\(\s*format\s*\(\s*printf/) { WARN("PREFER_PRINTF", "__printf(string-index, first-to-check) is preferred over __attribute__((format(printf, string-index, first-to-check)))\n" . $herecurr); } # Check for __attribute__ format(scanf, prefer __scanf if ($line =~ /\b__attribute__\s*\(\s*\(\s*format\s*\(\s*scanf\b/) { WARN("PREFER_SCANF", "__scanf(string-index, first-to-check) is preferred over __attribute__((format(scanf, string-index, first-to-check)))\n" . $herecurr); } # check for sizeof(&) if ($line =~ /\bsizeof\s*\(\s*\&/) { WARN("SIZEOF_ADDRESS", "sizeof(& should be avoided\n" . $herecurr); } # check for line continuations in quoted strings with odd counts of " if ($rawline =~ /\\$/ && $rawline =~ tr/"/"/ % 2) { WARN("LINE_CONTINUATIONS", "Avoid line continuations in quoted strings\n" . $herecurr); } # Check for misused memsets if ($^V && $^V ge 5.10.0 && defined $stat && $stat =~ /^\+(?:.*?)\bmemset\s*\(\s*$FuncArg\s*,\s*$FuncArg\s*\,\s*$FuncArg\s*\)/s) { my $ms_addr = $2; my $ms_val = $7; my $ms_size = $12; if ($ms_size =~ /^(0x|)0$/i) { ERROR("MEMSET", "memset to 0's uses 0 as the 2nd argument, not the 3rd\n" . "$here\n$stat\n"); } elsif ($ms_size =~ /^(0x|)1$/i) { WARN("MEMSET", "single byte memset is suspicious. Swapped 2nd/3rd argument?\n" . "$here\n$stat\n"); } } # typecasts on min/max could be min_t/max_t if ($^V && $^V ge 5.10.0 && defined $stat && $stat =~ /^\+(?:.*?)\b(min|max)\s*\(\s*$FuncArg\s*,\s*$FuncArg\s*\)/) { if (defined $2 || defined $7) { my $call = $1; my $cast1 = deparenthesize($2); my $arg1 = $3; my $cast2 = deparenthesize($7); my $arg2 = $8; my $cast; if ($cast1 ne "" && $cast2 ne "" && $cast1 ne $cast2) { $cast = "$cast1 or $cast2"; } elsif ($cast1 ne "") { $cast = $cast1; } else { $cast = $cast2; } WARN("MINMAX", "$call() should probably be ${call}_t($cast, $arg1, $arg2)\n" . "$here\n$stat\n"); } } # check for new externs in .c files. if ($realfile =~ /\.c$/ && defined $stat && $stat =~ /^.\s*(?:extern\s+)?$Type\s+($Ident)(\s*)\(/s) { my $function_name = $1; my $paren_space = $2; my $s = $stat; if (defined $cond) { substr($s, 0, length($cond), ''); } if ($s =~ /^\s*;/ && $function_name ne 'uninitialized_var') { WARN("AVOID_EXTERNS", "externs should be avoided in .c files\n" . $herecurr); } if ($paren_space =~ /\n/) { WARN("FUNCTION_ARGUMENTS", "arguments for function declarations should follow identifier\n" . $herecurr); } } elsif ($realfile =~ /\.c$/ && defined $stat && $stat =~ /^.\s*extern\s+/) { WARN("AVOID_EXTERNS", "externs should be avoided in .c files\n" . $herecurr); } # check for pointless casting of kmalloc return if ($line =~ /\*\s*\)\s*[kv][czm]alloc(_node){0,1}\b/) { WARN("UNNECESSARY_CASTS", "unnecessary cast may hide bugs, see http://c-faq.com/malloc/mallocnocast.html\n" . $herecurr); } # check for multiple semicolons if ($line =~ /;\s*;\s*$/) { WARN("ONE_SEMICOLON", "Statements terminations use 1 semicolon\n" . $herecurr); } # check for gcc specific __FUNCTION__ if ($line =~ /__FUNCTION__/) { WARN("USE_FUNC", "__func__ should be used instead of gcc specific __FUNCTION__\n" . $herecurr); } # check for use of yield() if ($line =~ /\byield\s*\(\s*\)/) { WARN("YIELD", "Using yield() is generally wrong. See yield() kernel-doc (sched/core.c)\n" . $herecurr); } # check for semaphores initialized locked if ($line =~ /^.\s*sema_init.+,\W?0\W?\)/) { WARN("CONSIDER_COMPLETION", "consider using a completion\n" . $herecurr); } # recommend kstrto* over simple_strto* and strict_strto* if ($line =~ /\b((simple|strict)_(strto(l|ll|ul|ull)))\s*\(/) { WARN("CONSIDER_KSTRTO", "$1 is obsolete, use k$3 instead\n" . $herecurr); } # check for __initcall(), use device_initcall() explicitly please if ($line =~ /^.\s*__initcall\s*\(/) { WARN("USE_DEVICE_INITCALL", "please use device_initcall() instead of __initcall()\n" . $herecurr); } # check for various ops structs, ensure they are const. my $struct_ops = qr{acpi_dock_ops| address_space_operations| backlight_ops| block_device_operations| dentry_operations| dev_pm_ops| dma_map_ops| extent_io_ops| file_lock_operations| file_operations| hv_ops| ide_dma_ops| intel_dvo_dev_ops| item_operations| iwl_ops| kgdb_arch| kgdb_io| kset_uevent_ops| lock_manager_operations| microcode_ops| mtrr_ops| neigh_ops| nlmsvc_binding| pci_raw_ops| pipe_buf_operations| platform_hibernation_ops| platform_suspend_ops| proto_ops| rpc_pipe_ops| seq_operations| snd_ac97_build_ops| soc_pcmcia_socket_ops| stacktrace_ops| sysfs_ops| tty_operations| usb_mon_operations| wd_ops}x; if ($line !~ /\bconst\b/ && $line =~ /\bstruct\s+($struct_ops)\b/) { WARN("CONST_STRUCT", "struct $1 should normally be const\n" . $herecurr); } # use of NR_CPUS is usually wrong # ignore definitions of NR_CPUS and usage to define arrays as likely right if ($line =~ /\bNR_CPUS\b/ && $line !~ /^.\s*\s*#\s*if\b.*\bNR_CPUS\b/ && $line !~ /^.\s*\s*#\s*define\b.*\bNR_CPUS\b/ && $line !~ /^.\s*$Declare\s.*\[[^\]]*NR_CPUS[^\]]*\]/ && $line !~ /\[[^\]]*\.\.\.[^\]]*NR_CPUS[^\]]*\]/ && $line !~ /\[[^\]]*NR_CPUS[^\]]*\.\.\.[^\]]*\]/) { WARN("NR_CPUS", "usage of NR_CPUS is often wrong - consider using cpu_possible(), num_possible_cpus(), for_each_possible_cpu(), etc\n" . $herecurr); } # check for %L{u,d,i} in strings my $string; while ($line =~ /(?:^|")([X\t]*)(?:"|$)/g) { $string = substr($rawline, $-[1], $+[1] - $-[1]); $string =~ s/%%/__/g; if ($string =~ /(?mutex.\n" . $herecurr); } } if ($line =~ /debugfs_create_file.*S_IWUGO/ || $line =~ /DEVICE_ATTR.*S_IWUGO/ ) { WARN("EXPORTED_WORLD_WRITABLE", "Exporting world writable files is usually an error. Consider more restrictive permissions.\n" . $herecurr); } } # If we have no input at all, then there is nothing to report on # so just keep quiet. if ($#rawlines == -1) { exit(0); } # In mailback mode only produce a report in the negative, for # things that appear to be patches. if ($mailback && ($clean == 1 || !$is_patch)) { exit(0); } # This is not a patch, and we are are in 'no-patch' mode so # just keep quiet. if (!$chk_patch && !$is_patch) { exit(0); } if (!$is_patch) { ERROR("NOT_UNIFIED_DIFF", "Does not appear to be a unified-diff format patch\n"); } if ($is_patch && $chk_signoff && $signoff == 0) { ERROR("MISSING_SIGN_OFF", "Missing Signed-off-by: line(s)\n"); } print report_dump(); if ($summary && !($clean == 1 && $quiet == 1)) { print "$filename " if ($summary_file); print "total: $cnt_error errors, $cnt_warn warnings, " . (($check)? "$cnt_chk checks, " : "") . "$cnt_lines lines checked\n"; print "\n" if ($quiet == 0); } if ($quiet == 0) { if ($^V lt 5.10.0) { print("NOTE: perl $^V is not modern enough to detect all possible issues.\n"); print("An upgrade to at least perl v5.10.0 is suggested.\n\n"); } # If there were whitespace errors which cleanpatch can fix # then suggest that. if ($rpt_cleaners) { print "NOTE: whitespace errors detected, you may wish to use scripts/cleanpatch or\n"; print " scripts/cleanfile\n\n"; $rpt_cleaners = 0; } } if ($quiet == 0 && keys %ignore_type) { print "NOTE: Ignored message types:"; foreach my $ignore (sort keys %ignore_type) { print " $ignore"; } print "\n\n"; } if ($clean == 1 && $quiet == 0) { print "$vname has no obvious style problems and is ready for submission.\n" } if ($clean == 0 && $quiet == 0) { print << "EOM"; $vname has style problems, please review. If any of these errors are false positives, please report them to the maintainer, see CHECKPATCH in MAINTAINERS. EOM } return $clean; } umber.Bin */ .highlight .mf { color: #0000DD; font-weight: bold } /* Literal.Number.Float */ .highlight .mh { color: #0000DD; font-weight: bold } /* Literal.Number.Hex */ .highlight .mi { color: #0000DD; font-weight: bold } /* Literal.Number.Integer */ .highlight .mo { color: #0000DD; font-weight: bold } /* Literal.Number.Oct */ .highlight .sa { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Affix */ .highlight .sb { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Backtick */ .highlight .sc { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Char */ .highlight .dl { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Delimiter */ .highlight .sd { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Doc */ .highlight .s2 { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Double */ .highlight .se { color: #0044dd; background-color: #fff0f0 } /* Literal.String.Escape */ .highlight .sh { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Heredoc */ .highlight .si { color: #3333bb; background-color: #fff0f0 } /* Literal.String.Interpol */ .highlight .sx { color: #22bb22; background-color: #f0fff0 } /* Literal.String.Other */ .highlight .sr { color: #008800; background-color: #fff0ff } /* Literal.String.Regex */ .highlight .s1 { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Single */ .highlight .ss { color: #aa6600; background-color: #fff0f0 } /* Literal.String.Symbol */ .highlight .bp { color: #003388 } /* Name.Builtin.Pseudo */ .highlight .fm { color: #0066bb; font-weight: bold } /* Name.Function.Magic */ .highlight .vc { color: #336699 } /* Name.Variable.Class */ .highlight .vg { color: #dd7700 } /* Name.Variable.Global */ .highlight .vi { color: #3333bb } /* Name.Variable.Instance */ .highlight .vm { color: #336699 } /* Name.Variable.Magic */ .highlight .il { color: #0000DD; font-weight: bold } /* Literal.Number.Integer.Long */
--  Semantic analysis.
--  Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
--
--  GHDL is free software; you can redistribute it and/or modify it under
--  the terms of the GNU General Public License as published by the Free
--  Software Foundation; either version 2, or (at your option) any later
--  version.
--
--  GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
--  WARRANTY; without even the implied warranty of MERCHANTABILITY or
--  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
--  for more details.
--
--  You should have received a copy of the GNU General Public License
--  along with GHDL; see the file COPYING.  If not, write to the Free
--  Software Foundation, 59 Temple Place - Suite 330, Boston, MA
--  02111-1307, USA.
with Errorout; use Errorout;
with Types; use Types;
with Flags; use Flags;
with Vhdl.Errors; use Vhdl.Errors;
with Vhdl.Sem_Specs; use Vhdl.Sem_Specs;
with Vhdl.Std_Package; use Vhdl.Std_Package;
with Vhdl.Sem; use Vhdl.Sem;
with Vhdl.Sem_Decls; use Vhdl.Sem_Decls;
with Vhdl.Sem_Expr; use Vhdl.Sem_Expr;
with Vhdl.Sem_Names; use Vhdl.Sem_Names;
with Vhdl.Sem_Scopes; use Vhdl.Sem_Scopes;
with Vhdl.Sem_Types;
with Vhdl.Sem_Psl;
with Std_Names;
with Vhdl.Evaluation; use Vhdl.Evaluation;
with Vhdl.Utils; use Vhdl.Utils;
with Vhdl.Xrefs; use Vhdl.Xrefs;

package body Vhdl.Sem_Stmts is
   -- Process is the scope, this is also the process for which drivers can
   -- be created.
   -- Note: FIRST_STMT is the first statement, which can be get by:
   --  get_sequential_statement_chain (usual)
   --  get_associated_chain (for case statement).
   procedure Sem_Sequential_Statements_Internal (First_Stmt : Iir);

   procedure Sem_Simultaneous_Statements (First : Iir);

   -- Access to the current subprogram or process.
   Current_Subprogram: Iir := Null_Iir;

   function Get_Current_Subprogram return Iir is
   begin
      return Current_Subprogram;
   end Get_Current_Subprogram;

   -- Access to the current concurrent statement.
   -- Null_iir if no one.
   Current_Concurrent_Statement : Iir := Null_Iir;

   function Get_Current_Concurrent_Statement return Iir is
   begin
      return Current_Concurrent_Statement;
   end Get_Current_Concurrent_Statement;

   --  LRM 8 Sequential statements.
   --  All statements may be labeled.
   --  Such labels are implicitly declared at the beginning of the declarative
   --  part of the innermost enclosing process statement of subprogram body.
   procedure Sem_Sequential_Labels (First_Stmt : Iir)
   is
      Stmt: Iir;
      Label: Name_Id;
   begin
      Stmt := First_Stmt;
      while Stmt /= Null_Iir loop
         Label := Get_Label (Stmt);
         if Label /= Null_Identifier then
            Sem_Scopes.Add_Name (Stmt);
            Name_Visible (Stmt);
            Xref_Decl (Stmt);
         end if;

         --  Some statements have sub-lists of statements.
         case Get_Kind (Stmt) is
            when Iir_Kind_For_Loop_Statement
              | Iir_Kind_While_Loop_Statement =>
               Sem_Sequential_Labels (Get_Sequential_Statement_Chain (Stmt));
            when Iir_Kind_If_Statement =>
               declare
                  Clause : Iir;
               begin
                  Clause := Stmt;
                  while Clause /= Null_Iir loop
                     Sem_Sequential_Labels
                       (Get_Sequential_Statement_Chain (Clause));
                     Clause := Get_Else_Clause (Clause);
                  end loop;
               end;
            when Iir_Kind_Case_Statement =>
               declare
                  El : Iir;
               begin
                  El := Get_Case_Statement_Alternative_Chain (Stmt);
                  while El /= Null_Iir loop
                     Sem_Sequential_Labels (Get_Associated_Chain (El));
                     El := Get_Chain (El);
                  end loop;
               end;
            when others =>
               null;
         end case;
         Stmt := Get_Chain (Stmt);
      end loop;
   end Sem_Sequential_Labels;

   procedure Fill_Array_From_Aggregate_Associated
     (Chain : Iir; Nbr : in out Natural; Arr : in out Iir_Array)
   is
      El : Iir;
      Ass : Iir;
   begin
      El := Chain;
      while El /= Null_Iir loop
         Ass := Get_Associated_Expr (El);
         if Get_Kind (Ass) = Iir_Kind_Aggregate then
            Fill_Array_From_Aggregate_Associated
              (Get_Association_Choices_Chain (Ass), Nbr, Arr);
         else
            Arr (Nbr) := Ass;
            Nbr := Nbr + 1;
         end if;
         El := Get_Chain (El);
      end loop;
   end Fill_Array_From_Aggregate_Associated;

   --  Return TRUE iff there is no common elements designed by N1 and N2.
   --  N1 and N2 are static names.
   --  FIXME:  The current implementation is completly wrong; should check from
   --   prefix to suffix.
   function Is_Disjoint (N1, N2: Iir) return Boolean
   is
      List1, List2 : Iir_Flist;
      El1, El2 : Iir;
   begin
      if N1 = N2 then
         return False;
      end if;
      if Get_Kind (N1) = Iir_Kind_Indexed_Name
        and then Get_Kind (N2) = Iir_Kind_Indexed_Name
      then
         if Is_Disjoint (Get_Prefix (N1), Get_Prefix (N2)) then
            return True;
         end if;
         --  Check indexes.
         List1 := Get_Index_List (N1);
         List2 := Get_Index_List (N2);
         for I in Flist_First .. Flist_Last (List1) loop
            El1 := Get_Nth_Element (List1, I);
            El2 := Get_Nth_Element (List2, I);
            El1 := Eval_Expr (El1);
            Set_Nth_Element (List1, I, El1);
            El2 := Eval_Expr (El2);
            Set_Nth_Element (List2, I, El2);
            --  EL are of discrete type.
            if Get_Value (El1) /= Get_Value (El2) then
               return True;
            end if;
         end loop;
         return False;
      elsif Get_Kind (N1) in Iir_Kinds_Denoting_Name
        and then Get_Kind (N2) in Iir_Kinds_Denoting_Name
      then
         return Get_Named_Entity (N1) /= Get_Named_Entity (N2);
      else
         return True;
      end if;
   end Is_Disjoint;

   procedure Check_Uniq_Aggregate_Associated
     (Aggr : Iir_Aggregate; Nbr : Natural)
   is
      Chain : constant Iir := Get_Association_Choices_Chain (Aggr);
      subtype El_Array_Type is Iir_Array (0 .. Nbr - 1);
      Name_Arr, Obj_Arr : El_Array_Type;
      Index : Natural;
      El : Iir;
   begin
      --  Fill the array.
      Index := 0;
      Fill_Array_From_Aggregate_Associated (Chain, Index, Name_Arr);
      --  Should be the same.
      pragma Assert (Index = Nbr);

      --  Replace name with object.  Return now in case of error (not an
      --  object or not a static name).
      for I in Name_Arr'Range loop
         El := Name_To_Object (Name_Arr (I));
         if El = Null_Iir
           or else Get_Name_Staticness (El) /= Locally
         then
            --  Error...
            return;
         end if;
         Obj_Arr (I) := El;
      end loop;

      --  Check each element is uniq.
      for I in Name_Arr'Range loop
         for J in 0 .. I - 1 loop
            if not Is_Disjoint (Obj_Arr (I), Obj_Arr (J)) then
               Report_Start_Group;
               Error_Msg_Sem
                 (+Name_Arr (I), "target is assigned more than once");
               Error_Msg_Sem
                 (+Name_Arr (J), " (previous assignment is here)");
               Report_End_Group;
               return;
            end if;
         end loop;
      end loop;
   end Check_Uniq_Aggregate_Associated;

   --  Do checks for the target of an assignment.
   procedure Check_Simple_Signal_Target
     (Stmt : Iir; Target : Iir; Staticness : Iir_Staticness);
   --  STMT is used to localize the error (if any).
   procedure Check_Simple_Variable_Target
     (Stmt : Iir; Target : Iir; Staticness : Iir_Staticness);

   -- Semantic associed with signal mode.
   -- See LRM93 4.3.3 (or LRM08 6.5.2)
   type Boolean_Array_Of_Iir_Mode is array (Iir_Mode) of Boolean;
   Iir_Mode_Readable : constant Boolean_Array_Of_Iir_Mode :=
     (Iir_Unknown_Mode => False,
      Iir_In_Mode => True,
      Iir_Out_Mode => False,
      Iir_Inout_Mode => True,
      Iir_Buffer_Mode => True,
      Iir_Linkage_Mode => False);
   Iir_Mode_Writable : constant Boolean_Array_Of_Iir_Mode :=
     (Iir_Unknown_Mode => False,
      Iir_In_Mode => False,
      Iir_Out_Mode => True,
      Iir_Inout_Mode => True,
      Iir_Buffer_Mode => True,
      Iir_Linkage_Mode => False);

   --  Return True iff signal interface INTER is readable.
   function Is_Interface_Signal_Readable (Inter : Iir) return Boolean
   is
      pragma Assert (Get_Kind (Inter) = Iir_Kind_Interface_Signal_Declaration);
      Mode : constant Iir_Mode := Get_Mode (Inter);
   begin
      if Mode = Iir_Out_Mode and then Flags.Vhdl_Std >= Vhdl_08 then
         --  LRM08 6.5.2 Interface object declarations
         --  OUT.  The value of the inerface object is allowed [...] and
         --  provided it is not a signal parameter, read.
         return not Is_Parameter (Inter);
      else
         return Iir_Mode_Readable (Mode);
      end if;
   end Is_Interface_Signal_Readable;

   procedure Check_Aggregate_Target
     (Stmt : Iir; Target : Iir; Nbr : in out Natural)
   is
      Choice : Iir;
      Ass : Iir;
   begin
      Choice := Get_Association_Choices_Chain (Target);
      while Choice /= Null_Iir loop
         case Get_Kind (Choice) is
            when Iir_Kind_Choice_By_Range =>
               --  LRM93 8.4
               --  It is an error if an element association in such an
               --  aggregate contains an OTHERS choice or a choice that is
               --  a discrete range.
               Error_Msg_Sem
                 (+Choice, "discrete range choice not allowed for target");
            when Iir_Kind_Choice_By_Others =>
               --  LRM93 8.4
               --  It is an error if an element association in such an
               --  aggregate contains an OTHERS choice or a choice that is
               --  a discrete range.
               Error_Msg_Sem
                 (+Choice, "others choice not allowed for target");
            when Iir_Kind_Choice_By_Expression
              | Iir_Kind_Choice_By_Name
              | Iir_Kind_Choice_By_None =>
               --  LRM93 9.4
               --  Such a target may not only contain locally static signal
               --  names [...]
               Ass := Get_Associated_Expr (Choice);
               if Get_Kind (Ass) = Iir_Kind_Aggregate then
                  Check_Aggregate_Target (Stmt, Ass, Nbr);
               else
                  if Get_Kind (Stmt) in
                    Iir_Kinds_Variable_Assignment_Statement
                  then
                     Check_Simple_Variable_Target (Stmt, Ass, Locally);
                  else
                     Check_Simple_Signal_Target (Stmt, Ass, Locally);
                  end if;
                  Nbr := Nbr + 1;
               end if;
            when others =>
               Error_Kind ("check_aggregate_target", Choice);
         end case;
         Choice := Get_Chain (Choice);
      end loop;
   end Check_Aggregate_Target;

   procedure Check_Simple_Signal_Target
     (Stmt : Iir; Target : Iir; Staticness : Iir_Staticness)
   is
      Target_Object : Iir;
      Target_Prefix : Iir;
      Guarded_Target : Tri_State_Type;
      Targ_Obj_Kind : Iir_Kind;
   begin
      Target_Object := Name_To_Object (Target);
      if Target_Object = Null_Iir then
         if Get_Kind (Target) = Iir_Kind_Simple_Name
           and then Is_Error (Get_Named_Entity (Target))
         then
            --  Common case: target is not declared.  There was already
            --  an error message for it.
            return;
         end if;

         --  Uncommon case: target is not an object (could be a component).
         Error_Msg_Sem (+Target, "target is not a signal name");
         return;
      end if;

      Target_Prefix := Get_Object_Prefix (Target_Object);
      Targ_Obj_Kind := Get_Kind (Target_Prefix);
      case Targ_Obj_Kind is
         when Iir_Kind_Interface_Signal_Declaration =>
            if not Iir_Mode_Writable (Get_Mode (Target_Prefix)) then
               Error_Msg_Sem
                 (+Target, "%n can't be assigned", +Target_Prefix);
            else
               Sem_Add_Driver (Target_Object, Stmt);
            end if;
         when Iir_Kind_Signal_Declaration =>
            Sem_Add_Driver (Target_Object, Stmt);
            Set_Use_Flag (Target_Prefix, True);
         when Iir_Kind_Guard_Signal_Declaration =>
            Error_Msg_Sem (+Stmt, "implicit GUARD signal cannot be assigned");
            return;
         when others =>
            Error_Msg_Sem
              (+Stmt, "target (%n) is not a signal", +Get_Base_Name (Target));
            return;
      end case;
      if Get_Name_Staticness (Target_Object) < Staticness then
         Error_Msg_Sem (+Stmt, "signal name must be static");
      end if;

      --  LRM93 2.1.1.2
      --  A formal signal parameter is a guarded signal if and only if
      --  it is associated with an actual signal that is a guarded
      --  signal.
      --  GHDL: a formal signal interface of a subprogram has no static
      --   kind.  This is determined at run-time, according to the actual
      --   associated with the formal.
      --  GHDL: parent of target cannot be a function.
      if Targ_Obj_Kind = Iir_Kind_Interface_Signal_Declaration
        and then Is_Parameter (Target_Prefix)
      then
         Guarded_Target := Unknown;
      else
         if Get_Guarded_Signal_Flag (Target_Prefix) then
            Guarded_Target := True;
         else
            Guarded_Target := False;
         end if;
      end if;

      case Get_Guarded_Target_State (Stmt) is
         when Unknown =>
            Set_Guarded_Target_State (Stmt, Guarded_Target);
         when True
           | False =>
            if Get_Guarded_Target_State (Stmt) /= Guarded_Target then
               --  LRM93 9.5
               --  It is an error if the target of a concurrent signal
               --  assignment is neither a guarded target nor an
               --  unguarded target.
               Error_Msg_Sem (+Target, "guarded and unguarded target");
            end if;
      end case;
   end Check_Simple_Signal_Target;

   procedure Check_Simple_Variable_Target
     (Stmt : Iir; Target : Iir; Staticness : Iir_Staticness)
   is
      Target_Object : Iir;
      Target_Prefix : Iir;
   begin
      Target_Object := Name_To_Object (Target);
      if Target_Object = Null_Iir then
         Error_Msg_Sem (+Stmt, "target is not a variable name");
         return;
      end if;
      Target_Prefix := Get_Object_Prefix (Target_Object);
      case Get_Kind (Target_Prefix) is
         when Iir_Kind_Interface_Variable_Declaration =>
            if not Iir_Mode_Writable (Get_Mode (Target_Prefix)) then
               Error_Msg_Sem (+Target, "%n cannot be written (bad mode)",
                              +Target_Prefix);
               return;
            end if;
         when Iir_Kind_Variable_Declaration =>
            Set_Use_Flag (Target_Prefix, True);
         when Iir_Kind_Implicit_Dereference
           | Iir_Kind_Dereference  =>
            --  LRM 3.3
            --  An object designated by an access type is always an object of
            --  class variable.
            null;
         when Iir_Kind_Free_Quantity_Declaration
           | Iir_Kinds_Branch_Quantity_Declaration
           | Iir_Kind_Dot_Attribute =>
            if (Get_Kind (Get_Current_Concurrent_Statement)
                  /= Iir_Kind_Simultaneous_Procedural_Statement)
            then
               Error_Msg_Sem (+Stmt, "%n cannot be assigned", +Target_Prefix);
            end if;
         when others =>
            Error_Msg_Sem (+Stmt, "%n is not a variable to be assigned",
                           +Target_Prefix);
            return;
      end case;
      if Get_Name_Staticness (Target_Object) < Staticness then
         Error_Msg_Sem
           (+Target, "element of a target aggregate must be a static name");
      end if;
   end Check_Simple_Variable_Target;

   procedure Check_Target (Stmt : Iir; Target : Iir)
   is
      Nbr : Natural;
   begin
      if Get_Kind (Target) = Iir_Kind_Aggregate then
         Nbr := 0;
         Check_Aggregate_Target (Stmt, Target, Nbr);
         Check_Uniq_Aggregate_Associated (Target, Nbr);
      else
         case Get_Kind (Stmt) is
            when Iir_Kind_Variable_Assignment_Statement
              | Iir_Kind_Conditional_Variable_Assignment_Statement =>
               Check_Simple_Variable_Target (Stmt, Target, None);
            when others =>
               Check_Simple_Signal_Target (Stmt, Target, None);
         end case;
      end if;
   end Check_Target;

   type Resolve_Stages is (Resolve_Stage_1, Resolve_Stage_2);
   pragma Unreferenced (Resolve_Stage_2);

   procedure Sem_Signal_Assignment_Target_And_Option
     (Stmt: Iir; Sig_Type : in out Iir)
   is
      --  The target of the assignment.
      Target: Iir;
      --  The value that will be assigned.
      Expr: Iir;
   begin
      Target := Get_Target (Stmt);
      Target := Sem_Expression_Wildcard (Target, Get_Base_Type (Sig_Type));

      if Target /= Null_Iir then
         Set_Target (Stmt, Target);
         if Is_Expr_Fully_Analyzed (Target) then
            Check_Target (Stmt, Target);
            Sig_Type := Get_Type (Target);
            Sem_Types.Set_Type_Has_Signal (Sig_Type);
         end if;
      end if;

      Expr := Get_Reject_Time_Expression (Stmt);
      if Expr /= Null_Iir
        and then Is_Expr_Not_Analyzed (Expr)
      then
         Expr := Sem_Expression (Expr, Time_Type_Definition);
         if Expr /= Null_Iir then
            Check_Read (Expr);
            Set_Reject_Time_Expression (Stmt, Expr);
         end if;
      end if;
   end Sem_Signal_Assignment_Target_And_Option;

   --  Analyze a waveform_list WAVEFORM_LIST that is assigned via statement
   --  ASSIGN_STMT to a subelement or a slice of a signal SIGNAL_DECL.
   procedure Sem_Waveform_Chain (Waveform_Chain : Iir_Waveform_Element;
                                 Waveform_Type : in out Iir)
   is
      Expr: Iir;
      We: Iir_Waveform_Element;
      Time, Last_Time : Int64;
   begin
      if Get_Kind (Waveform_Chain) = Iir_Kind_Unaffected_Waveform then
         --  Unaffected.
         return;
      end if;

      --  Start with -1 to allow after 0 ns.
      Last_Time := -1;
      We := Waveform_Chain;
      while We /= Null_Iir loop
         Expr := Get_We_Value (We);
         if Get_Kind (Expr) = Iir_Kind_Null_Literal then
            --  GHDL: allowed only if target is guarded; this is checked by
            --  sem_check_waveform_list.
            null;
         else
            Expr := Sem_Expression_Wildcard (Expr, Waveform_Type, True);

            if Expr /= Null_Iir then
               if Is_Expr_Fully_Analyzed (Expr) then
                  Check_Read (Expr);
                  Expr := Eval_Expr_If_Static (Expr);
               end if;
               Set_We_Value (We, Expr);

               Merge_Wildcard_Type (Expr, Waveform_Type);
            else
               Expr := Get_We_Value (We);
               Expr := Create_Error_Expr (Expr, Waveform_Type);
               Set_We_Value (We, Expr);
            end if;
         end if;

         --  Analyze time expression.
         if Get_Time (We) /= Null_Iir then
            Expr := Get_Time (We);
            if Is_Expr_Not_Analyzed (Expr) then
               Expr := Sem_Expression (Expr, Time_Type_Definition);
               if Expr /= Null_Iir then
                  Set_Time (We, Expr);
                  Check_Read (Expr);

                  if Get_Expr_Staticness (Expr) = Locally
                    or else (Get_Kind (Expr) = Iir_Kind_Physical_Int_Literal
                               and then Flags.Flag_Time_64)
                  then
                     --  LRM 8.4
                     --  It is an error if the time expression in a waveform
                     --  element evaluates to a negative value.
                     --
                     --  LRM 8.4.1
                     --  It is an error if the sequence of new transactions is
                     --  not in ascending order with repect to time.
                     -- GHDL: this must be checked at run-time, but this is
                     --  also checked now for static expressions.
                     if Get_Expr_Staticness (Expr) = Locally then
                        --  The expression is static, and therefore may be
                        --  evaluated.
                        Expr := Eval_Expr (Expr);
                        Set_Time (We, Expr);
                        Time := Get_Value (Expr);
                     else
                        --  The expression is a physical literal (common case).
                        --  Extract its value.
                        Time := Get_Physical_Value (Expr);
                     end if;
                     if Time < 0 then
                        Error_Msg_Sem
                          (+Expr, "waveform time expression must be >= 0");
                     elsif Time <= Last_Time then
                        Error_Msg_Sem
                          (+Expr,
                           "time must be greather than previous transaction");
                     else
                        Last_Time := Time;
                     end if;
                  end if;
               end if;
            end if;
         else
            if We /= Waveform_Chain then
               --  Time expression must be in ascending order.
               Error_Msg_Sem (+We, "time expression required here");
            end if;

            --  LRM93 12.6.4
            --  It is an error if the execution of any postponed process
            --  causes a delta cycle to occur immediatly after the current
            --  simulation cycle.
            --  GHDL: try to warn for such an error; note the context may be
            --   a procedure body.
            if Current_Concurrent_Statement /= Null_Iir then
               case Get_Kind (Current_Concurrent_Statement) is
                  when Iir_Kind_Sensitized_Process_Statement
                    | Iir_Kind_Process_Statement
                    | Iir_Kind_Concurrent_Conditional_Signal_Assignment
                    | Iir_Kind_Concurrent_Selected_Signal_Assignment =>
                     if Get_Postponed_Flag (Current_Concurrent_Statement) then
                        Warning_Msg_Sem
                          (Warnid_Delta_Cycle, +We,
                           "waveform may cause a delta cycle in a " &
                             "postponed process");
                     end if;
                  when others =>
                     --  Context is a subprogram.
                     null;
               end case;
            end if;

            Last_Time := 0;
         end if;

         We := Get_Chain (We);
      end loop;
   end Sem_Waveform_Chain;

   --  Analyze a waveform chain WAVEFORM_CHAIN that is assigned via statement
   --  ASSIGN_STMT to a subelement or a slice of a signal SIGNAL_DECL.
   procedure Sem_Check_Waveform_Chain
     (Assign_Stmt: Iir; Waveform_Chain: Iir_Waveform_Element)
   is
      We: Iir_Waveform_Element;
      Expr : Iir;
      Targ_Type : Iir;
   begin
      if Get_Kind (Waveform_Chain) = Iir_Kind_Unaffected_Waveform then
         return;
      end if;

      Targ_Type := Get_Type (Get_Target (Assign_Stmt));

      We := Waveform_Chain;
      while We /= Null_Iir loop
         Expr := Get_We_Value (We);
         if Get_Kind (Expr) = Iir_Kind_Null_Literal then
            --  This is a null waveform element.
            --  LRM93 8.4.1
            --  It is an error if the target of a signal assignment statement
            --  containing a null waveform is not a guarded signal or an
            --  aggregate of guarded signals.
            if Get_Guarded_Target_State (Assign_Stmt) = False then
               Error_Msg_Sem
                 (+Assign_Stmt,
                  "null transactions can be assigned only to guarded signals");
            end if;
         else
            if Is_Valid (Get_Type (Expr))
              and then not Eval_Is_In_Bound (Expr, Targ_Type)
              and then Get_Kind (Expr) /= Iir_Kind_Overflow_Literal
            then
               Warning_Msg_Sem
                 (Warnid_Runtime_Error, +We,
                  "value constraints don't match target ones");
               Set_We_Value (We, Build_Overflow (Expr, Targ_Type));
            end if;
         end if;
         We := Get_Chain (We);
      end loop;
   end Sem_Check_Waveform_Chain;

   procedure Sem_Guard (Stmt: Iir)
   is
      Guard: Iir;
      Guard_Interpretation : Name_Interpretation_Type;
   begin
      Guard := Get_Guard (Stmt);
      if Guard = Null_Iir then
         --  This assignment is not guarded.

         --  LRM93 9.5
         --  It is an error if a concurrent signal assignment is not a guarded
         --  assignment, and the target of the concurrent signal assignment
         --  is a guarded target.
         if Get_Guarded_Target_State (Stmt) = True then
            Error_Msg_Sem
              (+Stmt, "not a guarded assignment for a guarded target");
         end if;
         return;
      end if;
      if Guard /= Stmt then
         -- if set, guard must be equal to stmt here.
         raise Internal_Error;
      end if;
      Guard_Interpretation := Get_Interpretation (Std_Names.Name_Guard);
      if not Valid_Interpretation (Guard_Interpretation) then
         Error_Msg_Sem (+Stmt, "no guard signals for this guarded assignment");
         return;
      end if;

      Guard := Get_Declaration (Guard_Interpretation);
      -- LRM93 9.5:
      -- The signal GUARD [...] an explicitly declared signal of type
      -- BOOLEAN that is visible at the point of the concurrent signal
      -- assignment statement
      -- FIXME.
      case Get_Kind (Guard) is
         when Iir_Kind_Signal_Declaration
           | Iir_Kind_Interface_Signal_Declaration
           | Iir_Kind_Guard_Signal_Declaration =>
            null;
         when others =>
            Report_Start_Group;
            Error_Msg_Sem (+Stmt, "visible GUARD object is not a signal");
            Error_Msg_Sem (+Stmt, "GUARD object is %n", +Guard);
            Report_End_Group;
            return;
      end case;

      if Get_Type (Guard) /= Boolean_Type_Definition then
         Error_Msg_Sem (+Guard, "GUARD is not of boolean type");
      end if;
      Set_Guard (Stmt, Guard);
   end Sem_Guard;

   --  Analyze optional Condition field of PARENT.
   procedure Sem_Condition_Opt (Parent : Iir)
   is
      Cond : Iir;
   begin
      Cond := Get_Condition (Parent);
      if Cond /= Null_Iir then
         Cond := Sem_Condition (Cond);
         if Cond /= Null_Iir then
            Set_Condition (Parent, Cond);
         end if;
      end if;
   end Sem_Condition_Opt;

   procedure Sem_Signal_Assignment (Stmt: Iir)
   is
      Cond_Wf : Iir_Conditional_Waveform;
      Wf_Chain : Iir_Waveform_Element;
      Target_Type : Iir;
      Done : Boolean;
   begin
      Target_Type := Wildcard_Any_Type;

      Done := False;
      for S in Resolve_Stages loop
         Sem_Signal_Assignment_Target_And_Option (Stmt, Target_Type);
         if Is_Defined_Type (Target_Type) then
            Done := True;
         end if;

         case Get_Kind (Stmt) is
            when Iir_Kind_Concurrent_Simple_Signal_Assignment
              | Iir_Kind_Simple_Signal_Assignment_Statement =>
               Wf_Chain := Get_Waveform_Chain (Stmt);
               Sem_Waveform_Chain (Wf_Chain, Target_Type);
               if Done then
                  Sem_Check_Waveform_Chain (Stmt, Wf_Chain);
               end if;

            when Iir_Kind_Concurrent_Conditional_Signal_Assignment
              | Iir_Kind_Conditional_Signal_Assignment_Statement =>
               Cond_Wf := Get_Conditional_Waveform_Chain (Stmt);
               while Cond_Wf /= Null_Iir loop
                  Wf_Chain := Get_Waveform_Chain (Cond_Wf);
                  Sem_Waveform_Chain (Wf_Chain, Target_Type);
                  if Done then
                     Sem_Check_Waveform_Chain (Stmt, Wf_Chain);
                  end if;
                  if S = Resolve_Stage_1 then
                     --  Must be analyzed only once.
                     Sem_Condition_Opt (Cond_Wf);
                  end if;
                  Cond_Wf := Get_Chain (Cond_Wf);
               end loop;

            when Iir_Kind_Concurrent_Selected_Signal_Assignment =>
               declare
                  El : Iir;
               begin
                  El := Get_Selected_Waveform_Chain (Stmt);
                  while El /= Null_Iir loop
                     Wf_Chain := Get_Associated_Chain (El);
                     if Is_Valid (Wf_Chain) then
                        --  The first choice of a list.
                        Sem_Waveform_Chain (Wf_Chain, Target_Type);
                        if Done then
                           Sem_Check_Waveform_Chain (Stmt, Wf_Chain);
                        end if;
                     end if;
                     El := Get_Chain (El);
                  end loop;
               end;

            when others =>
               raise Internal_Error;
         end case;

         exit when Done;
         if not Is_Defined_Type (Target_Type) then
            Error_Msg_Sem (+Stmt, "cannot resolve type of waveform");
            exit;
         end if;
      end loop;

      case Get_Kind (Stmt) is
         when Iir_Kind_Concurrent_Simple_Signal_Assignment
           | Iir_Kind_Concurrent_Conditional_Signal_Assignment =>
            Sem_Guard (Stmt);
         when others =>
            null;
      end case;
   end Sem_Signal_Assignment;

   procedure Sem_Conditional_Expression_Chain
     (Cond_Expr : Iir; Atype : in out Iir)
   is
      El : Iir;
      Expr : Iir;
      Cond : Iir;
   begin
      El := Cond_Expr;
      while El /= Null_Iir loop
         Expr := Get_Expression (El);
         Expr := Sem_Expression_Wildcard (Expr, Atype, True);

         if Expr /= Null_Iir then
            Set_Expression (El, Expr);

            if Is_Expr_Fully_Analyzed (Expr) then
               Check_Read (Expr);
               Expr := Eval_Expr_If_Static (Expr);
            end if;

            Merge_Wildcard_Type (Expr, Atype);
         end if;

         Cond := Get_Condition (El);
         exit when Cond = Null_Iir;

         if Is_Expr_Not_Analyzed (Cond) then
            Cond := Sem_Condition (Cond);
            Set_Condition (El, Cond);
         end if;

         El := Get_Chain (El);
      end loop;
   end Sem_Conditional_Expression_Chain;

   procedure Sem_Variable_Assignment (Stmt: Iir)
   is
      Target : Iir;
      Expr : Iir;
      Target_Type : Iir;
      Stmt_Type : Iir;
      Done : Boolean;
   begin
      --  LRM93 8.5 Variable assignment statement
      --  If the target of the variable assignment statement is in the form of
      --  an aggregate, then the type of the aggregate must be determinable
      --  from the context, excluding the aggregate itself but including the
      --  fact that the type of the aggregate must be a composite type.  The
      --  base type of the expression on the right-hand side must be the
      --  same as the base type of the aggregate.
      --
      --  GHDL: this means that the type can only be deduced from the
      --  expression (and not from the target).

      Target := Get_Target (Stmt);
      Stmt_Type := Wildcard_Any_Type;
      for S in Resolve_Stages loop
         Done := False;

         Target := Sem_Expression_Wildcard (Target, Stmt_Type);
         if Target = Null_Iir then
            Target_Type := Stmt_Type;
         else
            Set_Target (Stmt, Target);
            if Is_Expr_Fully_Analyzed (Target) then
               Check_Target (Stmt, Target);
               Done := True;
            end if;
            Target_Type := Get_Type (Target);
            Stmt_Type := Target_Type;
         end if;

         case Iir_Kinds_Variable_Assignment_Statement (Get_Kind (Stmt)) is
            when Iir_Kind_Variable_Assignment_Statement =>
               Expr := Get_Expression (Stmt);
               Expr := Sem_Expression_Wildcard (Expr, Stmt_Type, True);
               if Expr /= Null_Iir then
                  if Is_Expr_Fully_Analyzed (Expr) then
                     Check_Read (Expr);
                     Expr := Eval_Expr_If_Static (Expr);
                  end if;
                  Set_Expression (Stmt, Expr);
                  Merge_Wildcard_Type (Expr, Stmt_Type);
                  if Done
                    and then not Eval_Is_In_Bound (Expr, Target_Type)
                    and then Get_Kind (Expr) /= Iir_Kind_Overflow_Literal
                  then
                     Warning_Msg_Sem
                       (Warnid_Runtime_Error, +Stmt,
                        "expression constraints don't match target ones");
                     Set_Expression (Stmt, Build_Overflow (Expr, Target_Type));
                  end if;
               end if;

            when Iir_Kind_Conditional_Variable_Assignment_Statement =>
               Expr := Get_Conditional_Expression_Chain (Stmt);
               Sem_Conditional_Expression_Chain (Expr, Stmt_Type);
         end case;

         exit when Done;
         if not Is_Defined_Type (Stmt_Type) then
            Error_Msg_Sem (+Stmt, "cannot resolve type");
            if Get_Kind (Target) = Iir_Kind_Aggregate then
               --  Try to give an advice.
               Error_Msg_Sem (+Stmt, "use a qualified expression for the RHS");
            end if;
            exit;
         end if;
      end loop;
   end Sem_Variable_Assignment;

   procedure Sem_Return_Statement (Stmt: Iir_Return_Statement) is
      Expr: Iir;
   begin
      if Current_Subprogram = Null_Iir then
         Error_Msg_Sem (+Stmt, "return statement not in a subprogram body");
         return;
      end if;
      Expr := Get_Expression (Stmt);
      case Get_Kind (Current_Subprogram) is
         when Iir_Kind_Procedure_Declaration =>
            if Expr /= Null_Iir then
               Error_Msg_Sem
                 (+Stmt, "return in a procedure can't have an expression");
            end if;
            return;
         when Iir_Kind_Function_Declaration =>
            if Expr = Null_Iir then
               Error_Msg_Sem
                 (+Stmt, "return in a function must have an expression");
               return;
            end if;
         when Iir_Kinds_Process_Statement =>
            Error_Msg_Sem (+Stmt, "return statement not allowed in a process");
            return;
         when others =>
            Error_Kind ("sem_return_statement", Stmt);
      end case;
      Set_Type (Stmt, Get_Return_Type (Current_Subprogram));
      Expr := Sem_Expression (Expr, Get_Return_Type (Current_Subprogram));
      if Expr /= Null_Iir then
         Check_Read (Expr);
         Set_Expression (Stmt, Eval_Expr_If_Static (Expr));
      end if;
   end Sem_Return_Statement;

   procedure Sem_Report_Expression (Stmt : Iir)
   is
      Expr : Iir;
   begin
      Expr := Get_Report_Expression (Stmt);
      if Expr /= Null_Iir then
         Expr := Sem_Expression (Expr, String_Type_Definition);
         Check_Read (Expr);
         Expr := Eval_Expr_If_Static (Expr);
         Set_Report_Expression (Stmt, Expr);
      end if;
   end Sem_Report_Expression;

   -- Sem for concurrent and sequential assertion statements.
   procedure Sem_Report_Statement (Stmt : Iir)
   is
      Expr : Iir;
   begin
      Sem_Report_Expression (Stmt);

      Expr := Get_Severity_Expression (Stmt);
      if Expr /= Null_Iir then
         Expr := Sem_Expression (Expr, Severity_Level_Type_Definition);
         Check_Read (Expr);
         Set_Severity_Expression (Stmt, Expr);
      end if;
   end Sem_Report_Statement;

   procedure Sem_Assertion_Statement (Stmt: Iir)
   is
      Expr : Iir;
   begin
      Expr := Get_Assertion_Condition (Stmt);
      Expr := Sem_Condition (Expr);
      Expr := Eval_Expr_If_Static (Expr);
      Set_Assertion_Condition (Stmt, Expr);

      Sem_Report_Statement (Stmt);
   end Sem_Assertion_Statement;

   --  Analyze a list of case choice LIST, and check for correct CHOICE type.
   procedure Sem_Case_Choices
     (Choice : Iir; Chain : in out Iir; Loc : Location_Type)
   is
      --  Check restrictions on the expression of a One-Dimensional Character
      --  Array Type (ODCAT) given by LRM 8.8
      --  Return FALSE in case of violation.
      function Check_Odcat_Expression (Expr : Iir) return Boolean
      is
         Expr_Type : constant Iir := Get_Type (Expr);
      begin
         --  LRM 8.8 Case Statement
         --  If the expression is of a one-dimensional character array type,
         --  then the expression must be one of the following:
         case Get_Kind (Expr) is
            when Iir_Kinds_Object_Declaration
              | Iir_Kind_Selected_Element =>
               --  FIXME: complete the list.
               --  * the name of an object whose subtype is locally static.
               if Get_Type_Staticness (Expr_Type) /= Locally then
                  Error_Msg_Sem
                    (+Choice, "object subtype is not locally static");
                  return False;
               end if;
            when Iir_Kind_Indexed_Name =>
               --  LRM93
               --  * an indexed name whose prefix is one of the members of
               --    this list and whose indexing expressions are locally
               --    static expression.
               if Flags.Vhdl_Std = Vhdl_87 then
                  Error_Msg_Sem
                    (+Expr, "indexed name not allowed here in vhdl87");
                  return False;
               end if;
               if not Check_Odcat_Expression (Get_Prefix (Expr)) then
                  return False;
               end if;
               --  GHDL: I don't understand why the indexing expressions
               --  must be locally static.  So I don't check this in 93c.
               if (Get_Expr_Staticness
                   (Get_Nth_Element (Get_Index_List (Expr), 0)) /= Locally)
               then
                  Error_Msg_Sem
                    (+Expr, "indexing expression must be locally static");
                  return False;
               end if;
            when Iir_Kind_Slice_Name =>
               --  LRM93
               --  * a slice name whose prefix is one of the members of this
               --    list and whose discrete range is a locally static
               --    discrete range.

               --  LRM87/INT1991 IR96
               --  then the expression must be either a slice name whose
               --  discrete range is locally static, or ..
               if False and Flags.Vhdl_Std = Vhdl_87 then
                  Error_Msg_Sem
                    (+Expr, "slice not allowed as case expression in vhdl87");
                  return False;
               end if;
               if not Check_Odcat_Expression (Get_Prefix (Expr)) then
                  return False;
               end if;
               if Get_Type_Staticness (Expr_Type) /= Locally then
                  Error_Msg_Sem
                    (+Expr, "slice discrete range must be locally static");
                  return False;
               end if;
            when Iir_Kind_Function_Call =>
               --  LRM93
               --  * a function call whose return type mark denotes a
               --    locally static subtype.
               if Flags.Vhdl_Std = Vhdl_87 then
                  Error_Msg_Sem
                    (+Expr, "function call not allowed here in vhdl87");
                  return False;
               end if;
               if Get_Type_Staticness (Expr_Type) /= Locally then
                  Error_Msg_Sem
                    (+Expr, "function call type is not locally static");
               end if;
            when Iir_Kind_Qualified_Expression
              | Iir_Kind_Type_Conversion =>
               --  * a qualified expression or type conversion whose type mark
               --    denotes a locally static subtype.
               if Get_Type_Staticness (Expr_Type) /= Locally then
                  Error_Msg_Sem
                    (+Expr, "type mark is not a locally static subtype");
                  return False;
               end if;
            when Iir_Kind_Simple_Name
              | Iir_Kind_Selected_Name =>
               return Check_Odcat_Expression (Get_Named_Entity (Expr));
            when Iir_Kind_Parenthesis_Expression =>
               --  GHDL: not part of the list but expected to be allowed by
               --  IR2080 and too commonly used!
               return Check_Odcat_Expression (Get_Expression (Expr));
            when others =>
               Error_Msg_Sem
                 (+Choice, "bad form of case expression (refer to LRM 8.8)");
               return False;
         end case;
         return True;
      end Check_Odcat_Expression;

      Choice_Type : constant Iir := Get_Type (Choice);
      Low, High : Iir;
      El_Type : Iir;
   begin
      --  LRM 8.8  Case Statement
      --  The expression must be of a discrete type, or of a one-dimensional
      --  array type whose element base type is a character type.
      case Get_Kind (Choice_Type) is
         when Iir_Kinds_Discrete_Type_Definition =>
            Sem_Choices_Range
              (Chain, Choice_Type, Low, High, Loc, False, True);
         when Iir_Kind_Array_Subtype_Definition
           | Iir_Kind_Array_Type_Definition =>
            if not Is_One_Dimensional_Array_Type (Choice_Type) then
               Error_Msg_Sem
                 (+Choice,
                  "expression must be of a one-dimensional array type");
               return;
            end if;
            El_Type := Get_Base_Type (Get_Element_Subtype (Choice_Type));
            if Get_Kind (El_Type) /= Iir_Kind_Enumeration_Type_Definition
              or else not Get_Is_Character_Type (El_Type)
            then
               Error_Msg_Sem
                 (+Choice,
                  "element type of the expression must be a character type");
               return;
            end if;
            if Flags.Vhdl_Std >= Vhdl_08 then
               --  No specific restrictions in vhdl 2008.
               null;
            elsif Flags.Flag_Relaxed_Rules then
               --  In relaxed mode, only check staticness of the expression
               --  subtype, as the type of a prefix may not be locally static
               --  while the type of the expression is.
               if Get_Type_Staticness (Choice_Type) /= Locally then
                  Error_Msg_Sem
                    (+Choice, "choice subtype is not locally static");
                  return;
               end if;
            else
               if not Check_Odcat_Expression (Choice) then
                  return;
               end if;
            end if;
            Sem_String_Choices_Range (Chain, Choice);
         when others =>
            Error_Msg_Sem (+Choice, "type of expression must be discrete");
      end case;
   end Sem_Case_Choices;

   procedure Sem_Case_Statement (Stmt: Iir_Case_Statement)
   is
      Expr: Iir;
      Chain : Iir;
      El: Iir;
   begin
      Expr := Get_Expression (Stmt);
      Chain := Get_Case_Statement_Alternative_Chain (Stmt);
      -- FIXME: overload.
      Expr := Sem_Case_Expression (Expr);
      if Expr /= Null_Iir then
         Check_Read (Expr);
         Set_Expression (Stmt, Expr);

         Sem_Case_Choices (Expr, Chain, Get_Location (Stmt));
         Set_Case_Statement_Alternative_Chain (Stmt, Chain);
      end if;

      El := Chain;
      while El /= Null_Iir loop
         if not Get_Same_Alternative_Flag (El) then
            Sem_Sequential_Statements_Internal (Get_Associated_Chain (El));
         end if;
         El := Get_Chain (El);
      end loop;
   end Sem_Case_Statement;

   --  Sem the sensitivity list LIST.
   procedure Sem_Sensitivity_List (List: Iir_List)
   is
      El: Iir;
      It : List_Iterator;
      Res: Iir;
      Prefix : Iir;
   begin
      if List = Iir_List_All then
         return;
      end if;

      It := List_Iterate (List);
      while Is_Valid (It) loop
         -- El is an iir_identifier.
         El := Get_Element (It);

         if Is_Error (El) then
            pragma Assert (Flags.Flag_Force_Analysis);
            Res := Error_Mark;
         else
            Sem_Name (El);

            Res := Get_Named_Entity (El);
         end if;

         if Res = Error_Mark then
            null;
         elsif Is_Overload_List (Res) or else not Is_Object_Name (Res) then
            Error_Msg_Sem (+El, "a sensitivity element must be a signal name");
         else
            Res := Finish_Sem_Name (El);
            Prefix := Get_Object_Prefix (Res);
            case Get_Kind (Prefix) is
               when Iir_Kind_Signal_Declaration
                 | Iir_Kind_Guard_Signal_Declaration
                 | Iir_Kinds_Signal_Attribute
                 | Iir_Kind_Above_Attribute =>
                  null;
               when Iir_Kind_Interface_Signal_Declaration =>
                  if not Is_Interface_Signal_Readable (Prefix) then
                     Error_Msg_Sem
                       (+El,
                        "%n of mode out can't be in a sensivity list", +Res);
                  end if;
               when others =>
                  Error_Msg_Sem (+El,
                                 "%n is neither a signal nor a port", +Res);
            end case;
            --  LRM 9.2
            --  Only static signal names (see section 6.1) for which reading
            --  is permitted may appear in the sensitivity list of a process
            --  statement.

            --  LRM 8.1  Wait statement
            --  Each signal name in the sensitivity list must be a static
            --  signal name, and each name must denote a signal for which
            --  reading is permitted.
            if Get_Name_Staticness (Res) < Globally then
               Error_Msg_Sem
                 (+El, "sensitivity element %n must be a static name", +Res);
            end if;

            Set_Element (It, Res);
         end if;

         Next (It);
      end loop;
   end Sem_Sensitivity_List;

   --  Mark STMT and its parents as suspendable.
   procedure Mark_Suspendable (Stmt : Iir)
   is
      Parent : Iir;
   begin
      Parent := Get_Parent (Stmt);
      loop
         case Get_Kind (Parent) is
            when Iir_Kind_Function_Body
              | Iir_Kind_Sensitized_Process_Statement =>
               exit;
            when Iir_Kind_Process_Statement
              | Iir_Kind_Procedure_Body =>
               Set_Suspend_Flag (Parent, True);
               exit;
            when Iir_Kind_If_Statement
              | Iir_Kind_While_Loop_Statement
              | Iir_Kind_For_Loop_Statement
              | Iir_Kind_Case_Statement =>
               Set_Suspend_Flag (Parent, True);
               Parent := Get_Parent (Parent);
            when others =>
               Error_Kind ("mark_suspendable", Parent);
         end case;
      end loop;
   end Mark_Suspendable;

   function Sem_Real_Or_Time_Timeout (Expr : Iir) return Iir
   is
      Res : Iir;
      Res_Type : Iir;
   begin
      Res := Sem_Expression_Ov (Expr, Null_Iir);

      if Res = Null_Iir then
         --  Error occurred.
         return Res;
      end if;

      Res_Type := Get_Type (Res);
      if not Is_Overload_List (Res_Type) then
         Res_Type := Get_Base_Type (Get_Type (Res));
         if Res_Type = Time_Type_Definition
           or else Res_Type = Real_Type_Definition
         then
            Check_Read (Res);
            return Res;
         else
            Error_Msg_Sem
              (+Expr, "timeout expression must be of type time or real");
            return Expr;
         end if;
      else
         --  Many interpretations.
         declare
            Res_List : constant Iir_List := Get_Overload_List (Res_Type);
            It : List_Iterator;
            El : Iir;
            Nbr_Res : Natural;
         begin
            Nbr_Res := 0;

            --  Extract boolean interpretations.
            It := List_Iterate (Res_List);
            while Is_Valid (It) loop
               El := Get_Base_Type (Get_Element (It));
               if Are_Basetypes_Compatible (El, Time_Type_Definition)
                 /= Not_Compatible
               then
                  Res_Type := Time_Type_Definition;
                  Nbr_Res := Nbr_Res + 1;
               elsif Are_Basetypes_Compatible (El, Real_Type_Definition)
                 /= Not_Compatible
               then
                  Res_Type := Real_Type_Definition;
                  Nbr_Res := Nbr_Res + 1;
               end if;
               Next (It);
            end loop;

            if Nbr_Res = 1 then
               Res := Sem_Expression_Ov (Expr, Res_Type);
               Check_Read (Res);
               return Res;
            else
               Error_Overload (Expr);
               return Expr;
            end if;
         end;
      end if;
   end Sem_Real_Or_Time_Timeout;

   procedure Sem_Wait_Statement (Stmt: Iir_Wait_Statement)
   is
      Expr: Iir;
      Sensitivity_List : Iir_List;
   begin
      --  Check validity.
      case Get_Kind (Current_Subprogram) is
         when Iir_Kind_Process_Statement =>
            null;
         when Iir_Kind_Function_Declaration =>
            --  LRM93 8.2
            --  It is an error if a wait statement appears in a function
            --  subprogram [...]
            Error_Msg_Sem
              (+Stmt, "wait statement not allowed in a function subprogram");
            return;
         when Iir_Kind_Procedure_Declaration =>
            --  LRM93 8.2
            --  [It is an error ...] or in a procedure that has a parent that
            --  is a function subprogram.
            --  LRM93 8.2
            --  [...] or in a procedure that has a parent that is such a
            --  process statement.
            -- GHDL: this is checked at the end of analysis or during
            --  elaboration.
            Set_Wait_State (Current_Subprogram, True);
         when Iir_Kind_Sensitized_Process_Statement =>
            --  LRM93 8.2
            --  Furthermore, it is an error if a wait statement appears in an
            --  explicit process statement that includes a sensitivity list,
            --  [...]
            Error_Msg_Sem
              (+Stmt, "wait statement not allowed in a sensitized process");
            return;
         when others =>
            raise Internal_Error;
      end case;

      Sensitivity_List := Get_Sensitivity_List (Stmt);
      if Sensitivity_List /= Null_Iir_List then
         Sem_Sensitivity_List (Sensitivity_List);
      end if;

      Expr := Get_Condition_Clause (Stmt);
      if Expr /= Null_Iir then
         Expr := Sem_Condition (Expr);
         Set_Condition_Clause (Stmt, Expr);
      end if;

      Expr := Get_Timeout_Clause (Stmt);
      if Expr /= Null_Iir then
         if AMS_Vhdl then
            Expr := Sem_Real_Or_Time_Timeout (Expr);
            Set_Timeout_Clause (Stmt, Expr);
         else
            Expr := Sem_Expression (Expr, Time_Type_Definition);
            if Expr /= Null_Iir then
               Check_Read (Expr);
               Expr := Eval_Expr_If_Static (Expr);
               Set_Timeout_Clause (Stmt, Expr);
               if Get_Expr_Staticness (Expr) = Locally
                 and then Get_Physical_Value (Expr) < 0
               then
                  Error_Msg_Sem (+Stmt, "timeout value must be positive");
               end if;
            end if;
         end if;
      end if;

      Mark_Suspendable (Stmt);
   end Sem_Wait_Statement;

   procedure Sem_Exit_Next_Statement (Stmt : Iir)
   is
      Loop_Label : Iir;
      Loop_Stmt: Iir;
      P : Iir;
   begin
      --  Analyze condition (if present).
      Sem_Condition_Opt (Stmt);

      --  Analyze label.
      Loop_Label := Get_Loop_Label (Stmt);
      if Loop_Label /= Null_Iir then
         Loop_Label := Sem_Denoting_Name (Loop_Label);
         Set_Loop_Label (Stmt, Loop_Label);
         Loop_Stmt := Get_Named_Entity (Loop_Label);
         case Get_Kind (Loop_Stmt) is
            when Iir_Kind_For_Loop_Statement
              | Iir_Kind_While_Loop_Statement =>
               null;
            when others =>
               Error_Class_Match (Loop_Label, "loop statement");
               Loop_Stmt := Null_Iir;
         end case;
      else
         Loop_Stmt := Null_Iir;
      end if;

      --  Check the current statement is inside the labeled loop.
      P := Stmt;
      loop
         P := Get_Parent (P);
         case Get_Kind (P) is
            when Iir_Kind_While_Loop_Statement
              | Iir_Kind_For_Loop_Statement =>
               if Loop_Stmt = Null_Iir or else P = Loop_Stmt then
                  case Iir_Kinds_Next_Exit_Statement (Get_Kind (Stmt)) is
                     when Iir_Kind_Next_Statement =>
                        Set_Next_Flag (P, True);
                     when Iir_Kind_Exit_Statement =>
                        Set_Exit_Flag (P, True);
                  end case;
                  exit;
               end if;
            when Iir_Kind_If_Statement
              | Iir_Kind_Elsif
              | Iir_Kind_Case_Statement =>
               null;
            when others =>
               --  FIXME: should emit a message for label mismatch.
               Error_Msg_Sem (+Stmt, "exit/next must be inside a loop");
               exit;
         end case;
      end loop;
   end Sem_Exit_Next_Statement;

   function Sem_Quantity_Name (Name : Iir) return Iir
   is
      Res : Iir;
   begin
      Sem_Name (Name);

      Res := Get_Named_Entity (Name);

      if Res = Error_Mark then
         return Null_Iir;
      elsif Is_Overload_List (Res) then
         Error_Msg_Sem (+Name, "quantity name expected");
         return Null_Iir;
      else
         Res := Finish_Sem_Name (Name);
         if not Is_Quantity_Name (Res) then
            Error_Msg_Sem (+Name, "%n is not a quantity name", +Res);
            return Null_Iir;
         else
            return Res;
         end if;
      end if;
   end Sem_Quantity_Name;

   procedure Sem_Break_List (First : Iir)
   is
      El : Iir;
      Name : Iir;
      Break_Quantity : Iir;
      Sel_Quantity : Iir;
      Expr : Iir;
      Expr_Type : Iir;
   begin
      El := First;
      while El /= Null_Iir loop
         Name := Get_Break_Quantity (El);
         Break_Quantity := Sem_Quantity_Name (Name);

         --  AMS-LRM17 10.15 Break statement
         --  The break quantity, the selector quantity, and the expression
         --  shall have the same type [...]
         if Break_Quantity /= Null_Iir then
            Set_Break_Quantity (El, Break_Quantity);
            Expr_Type := Get_Type (Break_Quantity);
         else
            Expr_Type := Null_Iir;
         end if;

         Expr := Get_Expression (El);
         Expr := Sem_Expression (Expr, Expr_Type);
         if Expr /= Null_Iir then
            Set_Expression (El, Expr);
         end if;

         Sel_Quantity := Get_Selector_Quantity (El);
         if Sel_Quantity /= Null_Iir then
            Sel_Quantity := Sem_Quantity_Name (Name);
            if Sel_Quantity /= Null_Iir and then Expr_Type /= Null_Iir then
               if Is_Expr_Compatible (Expr_Type, Sel_Quantity) = Not_Compatible
               then
                  Error_Msg_Sem (+Sel_Quantity,
                                 "selector quantity must be of the same type "
                                   & "as the break quantity");
               end if;
            end if;
         end if;

         El := Get_Chain (El);
      end loop;
   end Sem_Break_List;

   procedure Sem_Break_Statement (Stmt : Iir) is
   begin
      Sem_Break_List (Get_Break_Element (Stmt));

      Sem_Condition_Opt (Stmt);
   end Sem_Break_Statement;

   -- Process is the scope, this is also the process for which drivers can
   -- be created.
   procedure Sem_Sequential_Statements_Internal (First_Stmt : Iir)
   is
      Stmt: Iir;
   begin
      Stmt := First_Stmt;
      while Stmt /= Null_Iir loop
         case Get_Kind (Stmt) is
            when Iir_Kind_Null_Statement =>
               null;
            when Iir_Kind_If_Statement =>
               declare
                  Clause: Iir := Stmt;
               begin
                  while Clause /= Null_Iir loop
                     Sem_Condition_Opt (Clause);
                     Sem_Sequential_Statements_Internal
                       (Get_Sequential_Statement_Chain (Clause));
                     Clause := Get_Else_Clause (Clause);
                  end loop;
               end;
            when Iir_Kind_For_Loop_Statement =>
               declare
                  Iterator : constant Iir :=
                    Get_Parameter_Specification (Stmt);
               begin
                  --  LRM 10.1 Declarative region
                  --  9. A loop statement.
                  Open_Declarative_Region;

                  Set_Is_Within_Flag (Stmt, True);
                  Sem_Scopes.Add_Name (Iterator);
                  Sem_Iterator (Iterator, None);
                  Set_Visible_Flag (Iterator, True);
                  Sem_Sequential_Statements_Internal
                    (Get_Sequential_Statement_Chain (Stmt));
                  Set_Is_Within_Flag (Stmt, False);

                  Close_Declarative_Region;
               end;
            when Iir_Kind_While_Loop_Statement =>
               Sem_Condition_Opt (Stmt);
               Sem_Sequential_Statements_Internal
                 (Get_Sequential_Statement_Chain (Stmt));
            when Iir_Kind_Simple_Signal_Assignment_Statement
              | Iir_Kind_Conditional_Signal_Assignment_Statement =>
               Sem_Signal_Assignment (Stmt);
               if Current_Concurrent_Statement /= Null_Iir and then
                 Get_Kind (Current_Concurrent_Statement)
                 in Iir_Kinds_Process_Statement
                 and then Get_Passive_Flag (Current_Concurrent_Statement)
               then
                  Error_Msg_Sem
                    (+Stmt, "signal statement forbidden in passive process");
               end if;
            when Iir_Kind_Variable_Assignment_Statement
              | Iir_Kind_Conditional_Variable_Assignment_Statement =>
               Sem_Variable_Assignment (Stmt);
            when Iir_Kind_Return_Statement =>
               Sem_Return_Statement (Stmt);
            when Iir_Kind_Assertion_Statement =>
               Sem_Assertion_Statement (Stmt);
            when Iir_Kind_Report_Statement =>
               Sem_Report_Statement (Stmt);
            when Iir_Kind_Case_Statement =>
               Sem_Case_Statement (Stmt);
            when Iir_Kind_Wait_Statement =>
               Sem_Wait_Statement (Stmt);
            when Iir_Kind_Break_Statement =>
               Sem_Break_Statement (Stmt);
            when Iir_Kind_Procedure_Call_Statement =>
               declare
                  Call : constant Iir := Get_Procedure_Call (Stmt);
                  Imp : Iir;
               begin
                  Sem_Procedure_Call (Call, Stmt);

                  --  Set suspend flag, if calling a suspendable procedure
                  --  from a procedure or from a process.
                  Imp := Get_Implementation (Call);
                  if Imp /= Null_Iir
                    and then Get_Kind (Imp) = Iir_Kind_Procedure_Declaration
                    and then Get_Suspend_Flag (Imp)
                    and then (Get_Kind (Get_Current_Subprogram)
                                /= Iir_Kind_Function_Declaration)
                    and then (Get_Kind (Get_Current_Subprogram)
                                /= Iir_Kind_Sensitized_Process_Statement)
                  then
                     Set_Suspend_Flag (Stmt, True);
                     Mark_Suspendable (Stmt);
                  end if;
               end;
            when Iir_Kind_Next_Statement
              | Iir_Kind_Exit_Statement =>
               Sem_Exit_Next_Statement (Stmt);
            when others =>
               Error_Kind ("sem_sequential_statements_Internal", Stmt);
         end case;
         Stmt := Get_Chain (Stmt);
      end loop;
   end Sem_Sequential_Statements_Internal;

   procedure Sem_Sequential_Statements (Decl : Iir; Body_Parent : Iir)
   is
      Outer_Subprogram: Iir;
   begin
      Outer_Subprogram := Current_Subprogram;
      Current_Subprogram := Decl;

      -- Sem declarations
      Sem_Sequential_Labels (Get_Sequential_Statement_Chain (Body_Parent));
      Sem_Declaration_Chain (Body_Parent);
      Sem_Specification_Chain (Body_Parent, Null_Iir);

      -- Sem statements.
      Sem_Sequential_Statements_Internal
        (Get_Sequential_Statement_Chain (Body_Parent));

      Check_Full_Declaration (Body_Parent, Body_Parent);

      Current_Subprogram := Outer_Subprogram;
   end Sem_Sequential_Statements;

   --  Sem the instantiated unit of STMT and return the node constaining
   --  ports and generics (either a entity_declaration or a component
   --  declaration).
   function Sem_Instantiated_Unit
     (Stmt : Iir_Component_Instantiation_Statement) return Iir
   is
      Inst : constant Iir := Get_Instantiated_Unit (Stmt);
      Comp_Name : Iir;
      Comp : Iir;
   begin
      if Get_Kind (Inst) in Iir_Kinds_Entity_Aspect then
         return Sem_Entity_Aspect (Inst);
      else
         Comp := Get_Named_Entity (Inst);
         if Comp /= Null_Iir then
            --  Already analyzed before, while trying to separate
            --  concurrent procedure calls from instantiation stmts.
            pragma Assert (Get_Kind (Comp) = Iir_Kind_Component_Declaration);
            return Comp;
         end if;

         --  Needs a denoting name
         if Get_Kind (Inst) not in Iir_Kinds_Denoting_Name then
            Error_Msg_Sem (+Inst, "name for a component expected");
            return Null_Iir;
         end if;

         --  The component may be an entity or a configuration.
         Comp_Name := Sem_Denoting_Name (Inst);
         Set_Instantiated_Unit (Stmt, Comp_Name);
         Comp := Get_Named_Entity (Comp_Name);
         if Get_Kind (Comp) /= Iir_Kind_Component_Declaration then
            Error_Class_Match (Comp_Name, "component");
            return Null_Iir;
         end if;

         return Comp;
      end if;
   end Sem_Instantiated_Unit;

   procedure Sem_Component_Instantiation_Statement
     (Stmt: Iir_Component_Instantiation_Statement; Is_Passive : Boolean)
   is
      Decl : Iir;
      Entity_Unit : Iir_Design_Unit;
      Bind : Iir_Binding_Indication;
   begin
      --  FIXME: move this check in parse ?
      if Is_Passive then
         Error_Msg_Sem (+Stmt, "component instantiation forbidden in entity");
      end if;

      --  Check for label.
      --  This cannot be moved in parse since a procedure_call may be revert
      --  into a component instantiation.
      if Get_Label (Stmt) = Null_Identifier then
         Error_Msg_Sem (+Stmt, "component instantiation requires a label");
      end if;

      --  Look for the component.
      Decl := Sem_Instantiated_Unit (Stmt);
      if Decl = Null_Iir then
         return;
      end if;

      --  The association
      Sem_Generic_Port_Association_Chain (Decl, Stmt);

      --  FIXME: add sources for signals, in order to detect multiple sources
      --  to unresolved signals.
      --  What happen if the component is not bound ?

      --  Create a default binding indication if necessary.
      if Get_Component_Configuration (Stmt) = Null_Iir
        and then Is_Component_Instantiation (Stmt)
      then
         Entity_Unit := Get_Visible_Entity_Declaration (Decl);
         if Entity_Unit = Null_Iir then
            if Is_Warning_Enabled (Warnid_Default_Binding)
              and then not Flags.Flag_Elaborate
            then
               Warning_Msg_Sem
                 (Warnid_Default_Binding, +Stmt,
                  "no default binding for instantiation of %n", +Decl);
               Explain_No_Visible_Entity (Decl);
            end if;
         elsif Flags.Flag_Elaborate
           and then (Flags.Flag_Elaborate_With_Outdated
                     or else Get_Date (Entity_Unit) in Date_Valid)
         then
            Bind := Sem_Create_Default_Binding_Indication
              (Decl, Entity_Unit, Stmt, False, True);
            Set_Default_Binding_Indication (Stmt, Bind);
         end if;
      end if;
   end Sem_Component_Instantiation_Statement;

   --  Note: a statement such as
   --    label1: name;
   --  can be parsed as a procedure call statement or as a
   --  component instantiation statement.
   --  Check now and revert in case of error.
   function Sem_Concurrent_Procedure_Call_Statement
     (Stmt : Iir; Is_Passive : Boolean) return Iir
   is
      Call : Iir_Procedure_Call;
      Decl : Iir;
      Label : Name_Id;
      N_Stmt : Iir_Component_Instantiation_Statement;
      Imp : Iir;
   begin
      Call := Get_Procedure_Call (Stmt);
      if Get_Parameter_Association_Chain (Call) = Null_Iir then
         Imp := Get_Prefix (Call);
         Sem_Name (Imp);
         Set_Prefix (Call, Imp);

         Decl := Get_Named_Entity (Imp);
         if Get_Kind (Decl) = Iir_Kind_Component_Declaration then
            N_Stmt := Create_Iir (Iir_Kind_Component_Instantiation_Statement);
            Label := Get_Label (Stmt);
            Set_Label (N_Stmt, Label);
            Set_Parent (N_Stmt, Get_Parent (Stmt));
            Set_Chain (N_Stmt, Get_Chain (Stmt));
            Set_Instantiated_Unit (N_Stmt, Finish_Sem_Name (Imp));
            Location_Copy (N_Stmt, Stmt);

            if Label /= Null_Identifier then
               --  A component instantiation statement must have
               --  a label, this condition is checked during the
               --  sem of the statement.
               Sem_Scopes.Replace_Name (Label, Stmt, N_Stmt);
            end if;

            Free_Iir (Stmt);
            Free_Iir (Call);

            Sem_Component_Instantiation_Statement (N_Stmt, Is_Passive);
            return N_Stmt;
         end if;
      end if;
      Sem_Procedure_Call (Call, Stmt);

      if Is_Passive then
         Imp := Get_Implementation (Call);
         if Imp /= Null_Iir
           and then Get_Kind (Imp) = Iir_Kind_Procedure_Declaration
         then
            Decl := Get_Interface_Declaration_Chain (Imp);
            while Decl /= Null_Iir loop
               if Get_Mode (Decl) in Iir_Out_Modes then
                  Error_Msg_Sem (+Stmt, "%n is not passive", +Imp);
                  exit;
               end if;
               Decl := Get_Chain (Decl);
            end loop;
         end if;
      end if;

      return Stmt;
   end Sem_Concurrent_Procedure_Call_Statement;

   procedure Sem_Block_Statement (Stmt: Iir_Block_Statement)
   is
      Header : constant Iir_Block_Header := Get_Block_Header (Stmt);
      Guard : constant Iir_Guard_Signal_Declaration := Get_Guard_Decl (Stmt);
      Expr: Iir;
      Generic_Chain : Iir;
      Port_Chain : Iir;
   begin
      --  LRM 10.1 Declarative region.
      --  7. A block statement.
      Open_Declarative_Region;

      Set_Is_Within_Flag (Stmt, True);

      if Header /= Null_Iir then
         Generic_Chain := Get_Generic_Chain (Header);
         Sem_Interface_Chain (Generic_Chain, Generic_Interface_List);
         Port_Chain := Get_Port_Chain (Header);
         Sem_Interface_Chain (Port_Chain, Port_Interface_List);

         --  LRM 9.1
         --  Such actuals are evaluated in the context of the enclosing
         --  declarative region.
         --  GHDL: close the declarative region...
         Set_Is_Within_Flag (Stmt, False);
         Close_Declarative_Region;

         Sem_Generic_Port_Association_Chain (Header, Header);

         --  ... and reopen-it.
         Open_Declarative_Region;
         Set_Is_Within_Flag (Stmt, True);
         Add_Declarations_From_Interface_Chain (Generic_Chain);
         Add_Declarations_From_Interface_Chain (Port_Chain);
      end if;

      --  LRM93 9.1
      --  If a guard expression appears after the reserved word BLOCK, then a
      --  signal with the simple name GUARD of predefined type BOOLEAN is
      --  implicitly declared at the beginning of the declarative part of the
      --  block, and the guard expression defined the value of that signal at
      --  any given time.
      if Guard /= Null_Iir then
         --  LRM93 9.1
         --  The type of the guard expression must be type BOOLEAN.
         --  GHDL: guard expression must be analyzed before creating the
         --   implicit GUARD signal, since the expression may reference GUARD.
         Set_Expr_Staticness (Guard, None);
         Set_Name_Staticness (Guard, Locally);
         Expr := Get_Guard_Expression (Guard);
         Expr := Sem_Condition (Expr);
         if Expr /= Null_Iir then
            Set_Guard_Expression (Guard, Expr);
         end if;

         --  FIXME: should extract sensivity now and set the has_active flag
         --  on signals, since the guard expression is evaluated when one of
         --  its signal is active.  However, how can a bug be introduced by
         --  evaluating only when signals have events ?

         --  the guard expression is an implicit definition of a signal named
         --  GUARD.  Create this definition.  This is necessary for the type.
         Set_Identifier (Guard, Std_Names.Name_Guard);
         Set_Type (Guard, Boolean_Type_Definition);
         Set_Block_Statement (Guard, Stmt);
         Sem_Scopes.Add_Name (Guard);
         Set_Visible_Flag (Guard, True);
      end if;

      Sem_Block (Stmt);
      Set_Is_Within_Flag (Stmt, False);
      Close_Declarative_Region;
   end Sem_Block_Statement;

   procedure Sem_Generate_Statement_Body (Bod : Iir) is
   begin
      Set_Is_Within_Flag (Bod, True);
      Sem_Block (Bod);
      Set_Is_Within_Flag (Bod, False);
   end Sem_Generate_Statement_Body;

   procedure Sem_For_Generate_Statement (Stmt : Iir)
   is
      Param : constant Iir := Get_Parameter_Specification (Stmt);
   begin
      --  LRM93 10.1 Declarative region.
      --  12. A generate statement.
      Open_Declarative_Region;
      Set_Is_Within_Flag (Stmt, True);

      Sem_Scopes.Add_Name (Param);

      --  LRM93 7.4.2 (Globally Static Primaries)
      --   4. a generate parameter;
      Sem_Iterator (Param, Globally);
      Set_Visible_Flag (Param, True);

      --  LRM93 9.7
      --  The discrete range in a generation scheme of the first form must
      --  be a static discrete range;
      if not Is_Error (Get_Type (Param))
        and then Get_Type_Staticness (Get_Type (Param)) < Globally
      then
         Error_Msg_Sem (+Stmt, "range must be a static discrete range");
      end if;

      --  In the same declarative region.
      Sem_Generate_Statement_Body (Get_Generate_Statement_Body (Stmt));

      Set_Is_Within_Flag (Stmt, True);
      Close_Declarative_Region;
   end Sem_For_Generate_Statement;

   procedure Sem_If_Case_Generate_Statement_Body (Bod : Iir)
   is
      Alt_Label : Name_Id;
   begin
      Alt_Label := Get_Alternative_Label (Bod);
      --  LRM08 11.8 Generate statements
      --  The alternative labels, if any, within an if generate statement or
      --  a case generate statement shall all be distinct.
      if Alt_Label /= Null_Identifier then
         --  Declare label.  This doesn't appear in the LRM (bug ?), but
         --  used here to detect duplicated labels.
         Sem_Scopes.Add_Name (Bod);
         Xref_Decl (Bod);
      end if;

      --  Contrary to the LRM, a new declarative region is declared.  This
      --  is required so that declarations in a generate statement body are
      --  not in the scope of the following generate bodies.
      Open_Declarative_Region;
      Sem_Generate_Statement_Body (Bod);
      Close_Declarative_Region;
   end Sem_If_Case_Generate_Statement_Body;

   procedure Sem_If_Generate_Statement (Stmt : Iir)
   is
      Clause : Iir;
      Condition : Iir;
   begin
      --  LRM93 10.1 Declarative region.
      --  12. A generate statement.
      Open_Declarative_Region;
      Set_Is_Within_Flag (Stmt, True);

      Clause := Stmt;
      while Clause /= Null_Iir loop
         Condition := Get_Condition (Clause);

         if Condition /= Null_Iir then
            Condition := Sem_Condition (Condition);
            --  LRM93 9.7
            --  the condition in a generation scheme of the second form must be
            --  a static expression.
            if Condition /= Null_Iir
              and then Get_Expr_Staticness (Condition) < Globally
            then
               Error_Msg_Sem
                 (+Condition, "condition must be a static expression");
            else
               Set_Condition (Clause, Condition);
            end if;
         else
            --  No condition for the last 'else' part.
            pragma Assert (Get_Generate_Else_Clause (Clause) = Null_Iir);
            null;
         end if;

         Sem_If_Case_Generate_Statement_Body
           (Get_Generate_Statement_Body (Clause));

         Clause := Get_Generate_Else_Clause (Clause);
      end loop;

      Set_Is_Within_Flag (Stmt, False);
      Close_Declarative_Region;
   end Sem_If_Generate_Statement;

   procedure Sem_Case_Generate_Statement (Stmt : Iir)
   is
      Expr : Iir;
      Chain : Iir;
      El : Iir;
   begin
      --  LRM93 10.1 Declarative region.
      --  12. A generate statement.
      Open_Declarative_Region;
      Set_Is_Within_Flag (Stmt, True);

      Expr := Get_Expression (Stmt);
      Chain := Get_Case_Statement_Alternative_Chain (Stmt);
      -- FIXME: overload.
      Expr := Sem_Case_Expression (Expr);
      if Expr /= Null_Iir then
         Check_Read (Expr);
         Set_Expression (Stmt, Expr);

         if Get_Expr_Staticness (Expr) < Globally then
            Error_Msg_Sem
              (+Expr, "case expression must be a static expression");
         end if;

         Sem_Case_Choices (Expr, Chain, Get_Location (Stmt));
         Set_Case_Statement_Alternative_Chain (Stmt, Chain);
      end if;

      El := Chain;
      while El /= Null_Iir loop
         if not Get_Same_Alternative_Flag (El) then
            Sem_If_Case_Generate_Statement_Body (Get_Associated_Block (El));
         end if;
         El := Get_Chain (El);
      end loop;

      Set_Is_Within_Flag (Stmt, False);