src/jscope2.pl

#!/usr/bin/env perl
# jscope2 -- the nscc symbol/scope stage, third stage of the nscc
# pipeline. owns: symbol tables, name resolution, declaration vs
# definition merging, the global keyword -> linkage flag, extern-style
# forward decls (a decl with no body/init never allocates anything and
# may stay unresolved forever -- linking is the user's problem, same as
# c), shadowing (a block-local may reuse an outer name; a second decl
# of the same name in the SAME scope is an error), and redefinition
# errors (two bodies for one function, two initializers for one global).
# break/continue outside any loop or switch is rejected here, while the
# loop/switch structure still exists to check against.
#
# output format .ast.j2: the same tree shape as the cst, but every
# (var NAME) is now (ref ID), every (call NAME ...) is (call ID name=X
# ...), every func/fdecl/gvar gains sym=N and linkage=local|global
# atoms, and every local decl gains sym=N. a (call NAME ...) whose NAME
# is no function but a variable becomes (icall (ref ID) ARG...), an
# indirect call through the variable's value; (addr (var NAME)) whose
# NAME is no variable but a function becomes (addr (ref ID)) with the
# function's sym (a function designator: it appears nowhere else). a
# function name wins in call position and a variable wins under &, so
# neither rule changes what any existing name meant. ids are assigned in
# walk order starting at 1 -- they are the unit's only identity for
# names from here on; the name= atom stays on calls (and gvar/func
# nodes) purely so jlower5/jselect6/jemit8 can spell the symbol in the
# final asm without a symbol table of their own.
#
# this stage's own mini pipeline: in -- preproc -- proc -- out, where
# preproc is the cst deserialization (jcplib::tree) and proc is the
# resolve proper.
use v5.16;
use strict;
use warnings FATAL => 'all';
use FindBin;
use lib "$FindBin::Bin";
use jcplib::util qw(stage_err);
use jcplib::tree qw(read_tree write_tree mk find_kid);
 
my $RAW = do { local $/; <STDIN>; };
 
my %FUNCS;      # name -> sym
my %GVARS;      # name -> sym
my %TDEFS;      # typedef/enum name -> underlying type text (alias chain resolved here)
my %STRUCTS;    # struct name -> [field names/types]
my %ENUMS;      # enumerator name -> {id, enum => enum-name, value => expr node}
my $NEXT_ID = 1;
my $FILE = $ENV{NSCC_FILE} || 'input';
 
sub new_id { return $NEXT_ID++; }
 
sub err_at {
	my ($node, $msg) = @_;
	my ($at) = grep { /^at=/ } @{$node->{atoms}};
	$at //= 'at=?:?';
	$at =~ s/^at=//;
	stage_err("jscope2: $FILE:$at: $msg");
}
 
sub atoms_have {
	my ($node, $re) = @_;
	return scalar grep { /$re/ } @{$node->{atoms}};
}
 
# the builtin scalar type names (not struct/array/alias).
sub is_scalar_type {
	my ($t) = @_;
	return $t eq 'i8' || $t eq 'i16' || $t eq 'i32' || $t eq 'i64'
	    || $t eq 'u8' || $t eq 'u16' || $t eq 'u32' || $t eq 'u64'
	    || $t eq 'ptr' || $t eq 'void';
}
 
# resolve one type atom to a concrete type: [N]T recurses, struct.NAME
# validates, typedef/enum names follow their alias chain. returns undef
# when the atom is no type at all -- the caller reinterprets that case
# (an (IDENT) cast that was really a parenthesized expression).
sub resolve_type_atom {
	my ($t) = @_;
	return $t if is_scalar_type($t);
	if($t =~ /^\[(\d+)\](.+)$/) {
		my $inner = resolve_type_atom($2);
		return defined $inner ? "[$1]$inner" : undef;
	}
	if($t =~ /^struct\.(.+)$/) {
		stage_err('jscope2: unknown struct type struct.$1') unless $STRUCTS{$1};
		return $t;
	}
	my $depth = 0;
	while(defined $TDEFS{$t}) {
		$t = $TDEFS{$t};
		stage_err('jscope2: typedef cycle') if ++$depth > 100;
	}
	return $t if is_scalar_type($t) || $t =~ /^struct\./ || $t =~ /^\[/;
	return undef;
}
 
 
sub param_sig {
	my ($params) = @_;
	return join(',', map { $_->{atoms}[1] } @{$params->{kids}});
}
 
sub collect_toplevel {
	my ($unit) = @_;
	for my $top (@{$unit->{kids}}) {
		if($top->{op} eq 'func' || $top->{op} eq 'fdecl') {
			my $name = $top->{atoms}[0];
			my ($ret) = map { /^ret=(.+)$/ ? $1 : () } @{$top->{atoms}};
			my $params = find_kid($top, 'params');
			my $sig = param_sig($params);
			my $global = atoms_have($top, '^linkage=global$');
			my $has_body = $top->{op} eq 'func';
			if(my $sym = $FUNCS{$name}) {
				err_at($top, "redefinition of function '$name'") if $sym->{defined} && $has_body;
				err_at($top, "inconsistent signature for '$name': ($sig) vs ($sym->{sig})") unless $sig eq $sym->{sig};
				err_at($top, "inconsistent return type for '$name'") unless $ret eq $sym->{ret};
				# the DEFINITION's own linkage always wins, in either
				# direction: global i32 f(){} after a bare prototype
				# i32 f(); must upgrade a prototype-only 'local' up to
				# 'global' just as much as a non-global definition
				# downgrades one -- this is exactly what a shared
				# header (include "x.nsh") produces everywhere it's
				# included before the real global-linked definition
				# is reached, so getting only the downgrade direction
				# right (the bug this comment used to describe) made
				# a header's own defining file silently lose linkage
				# on everything it declared a prototype for first. a
				# bodyless (no-body) re-declaration, before or after
				# the real definition, still never touches linkage at
				# all -- only reached inside this $has_body block.
				$sym->{linkage} = $global ? 'global' : 'local' if $has_body;
				$sym->{defined} = 1 if $has_body;
				$top->{atoms} = [$name, "ret=$ret", "linkage=" . $sym->{linkage}, "sym=" . $sym->{id}, grep { /^at=/ } @{$top->{atoms}}];
			}
			else {
				my $sym = {id => new_id(), kind => 'func', name => $name, ret => $ret, sig => $sig,
					linkage => $global ? 'global' : 'local', defined => $has_body};
				$FUNCS{$name} = $sym;
				$top->{atoms} = [$name, "ret=$ret", "linkage=" . $sym->{linkage}, "sym=" . $sym->{id}, grep { /^at=/ } @{$top->{atoms}}];
			}
			next;
		}
		if($top->{op} eq 'gvar') {
			my $name = $top->{atoms}[0];
			my $ty = $top->{atoms}[1];
			my $global = atoms_have($top, '^linkage=global$');
			my $const = atoms_have($top, '^const=1$');
			my $init = find_kid($top, 'init');
			if(my $sym = $GVARS{$name}) {
				err_at($top, "redefinition of global '$name'") if $sym->{defined} && $init;
				err_at($top, "conflicting types for global '$name'") unless $ty eq $sym->{type};
				# same fix, same reasoning, as the function case above,
				# broadened one step further: a gvar occurrence can be
				# a real (initialized) definition OR a tentative one
				# (global, no initializer -- jlower5/jemit8 emit that
				# as a .comm symbol, real storage, just zeroed) -- both
				# carry a real opinion about linkage and both need to
				# be able to upgrade a prototype-only 'local' up to
				# 'global', not just the initialized case. a bare
				# reference (no global, no init) is pure reference,
				# never touches linkage in either direction.
				$sym->{linkage} = $global ? 'global' : 'local' if $init || $global;
				$sym->{defined} = 1 if $init;
				$top->{atoms} = [$name, $ty, "linkage=" . $sym->{linkage}, "sym=" . $sym->{id}, grep { /^at=|^const=/ } @{$top->{atoms}}];
			}
			else {
				my $sym = {id => new_id(), kind => 'gvar', name => $name, type => $ty,
					linkage => $global ? 'global' : 'local', defined => $init ? 1 : 0, const => $const};
				$GVARS{$name} = $sym;
				$top->{atoms} = [$name, $ty, "linkage=" . $sym->{linkage}, "sym=" . $sym->{id}, grep { /^at=|^const=/ } @{$top->{atoms}}];
			}
			next;
		}
		if($top->{op} eq 'typedef') {
			my $name = $top->{atoms}[0];
			err_at($top, "redefinition of type name '$name'") if exists $TDEFS{$name};
			# store the alias RAW; resolve_type_atom follows chains
			# when the name is actually used, so forward references
			# and re-aliasing both work.
			$TDEFS{$name} = $top->{atoms}[1];
			next;
		}
		if($top->{op} eq 'struct') {
			my $name = $top->{atoms}[0];
			err_at($top, "redefinition of struct '$name'") if exists $STRUCTS{$name};
			my %fields;
			my @order;
			for my $f (@{$top->{kids}}) {
				err_at($top, "duplicate field '$f->{atoms}[0]' in struct '$name'") if exists $fields{$f->{atoms}[0]};
				$fields{$f->{atoms}[0]} = 1;
				push @order, $f->{atoms}[1];
			}
			err_at($top, "struct '$name' has no fields") unless @order;
			$STRUCTS{$name} = \@order;
			next;
		}
		if($top->{op} eq 'enum') {
			my $name = $top->{atoms}[0];
			err_at($top, "redefinition of type name '$name'") if exists $TDEFS{$name};
			$TDEFS{$name} = 'i32';
			my $prev_id;
			for my $v (@{$top->{kids}}) {
				my $vn = $v->{atoms}[0];
				err_at($top, "redefinition of enumerator '$vn'") if exists $ENUMS{$vn};
				my $en = {id => new_id(), enum => $name, value => $v->{kids}[0]};
				$ENUMS{$vn} = $en;
				# an enumerator without '=' is the previous one + 1
				# (the first is 0); synthesized here so jtype3 folds
				# it exactly like an explicit value.
				$v->{kids} = [$v->{kids}[0]] if @{$v->{kids}};
				unless(@{$v->{kids}}) {
					$v->{kids} = [$prev_id ? mk('binop', ['+'], [mk('ref', [$prev_id]), mk('intlit', [1])]) : mk('intlit', [0])];
				}
				$v->{atoms} = [$vn, "sym=" . $en->{id}];
				$prev_id = $en->{id};
			}
			next;
		}
		stage_err("jscope2: unknown toplevel node: $top->{op}");
	}
	return;
}
 
# resolve every type atom in the tree (params, decls, gvars, fields,
# ret=, cast and sizeof(type) atoms), following typedef/enum aliases;
# drop the typedef decls (fully consumed here -- struct and enum nodes
# survive, jtype3 needs their fields/values); reinterpret an (IDENT)
# cast whose name is no type as the grouping parens it really was.
sub resolve_types_pass {
	my ($unit) = @_;
	my $walk;
	$walk = sub {
		my ($n) = @_;
		return $n unless ref $n;
		for my $i (0 .. $#{$n->{kids}}) {
			$n->{kids}[$i] = $walk->($n->{kids}[$i]);
		}
		if($n->{op} eq 'func' || $n->{op} eq 'fdecl') {
			$n->{atoms} = [map { /^ret=(.+)$/ ? 'ret=' . (resolve_type_atom($1) // (stage_err("jscope2: unknown type '$1'"), 'i32')) : $_ } @{$n->{atoms}}];
		}
		elsif($n->{op} eq 'param' || $n->{op} eq 'decl' || $n->{op} eq 'gvar' || $n->{op} eq 'field') {
			my $res = resolve_type_atom($n->{atoms}[1]);
			stage_err('jscope2: unknown type ' . $n->{atoms}[1]) unless defined $res;
			$n->{atoms}[1] = $res;
		}
		elsif($n->{op} eq 'cast') {
			my $res = resolve_type_atom($n->{atoms}[0]);
			if(defined $res) {
				$n->{atoms}[0] = $res;
			}
			else {
				# (x)e where x is no type: grouping parens.
				return $n->{kids}[0];
			}
		}
		elsif($n->{op} eq 'sizeof' && !@{$n->{kids}}) {
			my $res = resolve_type_atom($n->{atoms}[0]);
			if(defined $res) {
				$n->{atoms}[0] = $res;
			}
			else {
				# sizeof(x) where x is no type: the expression form.
				# the var node resolves through resolve_expr later.
				my $name = $n->{atoms}[0];
				$n->{atoms} = [];
				$n->{kids} = [mk('var', [$name], [])];
			}
		}
		return $n;
	};
	my @kept;
	for my $top (@{$unit->{kids}}) {
		my $n = $walk->($top);
		push @kept, $n unless $n->{op} eq 'typedef';
	}
	$unit->{kids} = \@kept;
	return;
}
 
 
# scopes: a stack of name->id hashes; the top scope is the innermost.
# params land in the function scope, every block opens a fresh scope.
 
my @SCOPES;
my @CTX;    # 'loop'|'switch' stack for break/continue checking
 
sub push_scope { push @SCOPES, {}; return; }
sub pop_scope { pop @SCOPES; return; }
 
sub declare_local {
	my ($node, $name, $ty) = @_;
	err_at($node, "redefinition of '$name' in the same scope") if exists $SCOPES[-1]{$name};
	my $id = new_id();
	$SCOPES[-1]{$name} = $id;
	$node->{atoms} = [$name, $ty, "sym=$id", grep { /^at=|^const=/ } @{$node->{atoms}}];
	return $id;
}
 
sub find_local {
	my ($name) = @_;
	for(my $i = $#SCOPES; $i >= 0; $i--) {
		return $SCOPES[$i]{$name} if exists $SCOPES[$i]{$name};
	}
	# a name that isn't local falls back to a global variable, then
	# to an enumerator -- functions are only reachable through
	# (call ...) and &name, never as a bare (var ...).
	if(my $sym = $GVARS{$name}) {
		return $sym->{id};
	}
	if(my $en = $ENUMS{$name}) {
		return $en->{id};
	}
	return undef;
}
 
sub lookup_local {
	my ($node, $name) = @_;
	my $id = find_local($name);
	return $id if defined $id;
	err_at($node, "'$name' is a function, not a value: take its address with &$name") if $FUNCS{$name};
	err_at($node, "use of undeclared identifier '$name'");
}
 
# lvalue expressions an assign/++/-- may target: a (soon to be
# resolved) var, a deref, a member, or an index.
sub check_lvalue {
	my ($node, $ctx) = @_;
	return if $node->{op} eq 'var' || $node->{op} eq 'deref' || $node->{op} eq 'member' || $node->{op} eq 'index';
	err_at($ctx // $node, "not an assignable expression");
}
 
sub resolve_expr {
	my ($e, $ctx) = @_;
	$ctx = $e unless $ctx;
	my $op = $e->{op};
 
	if($op eq 'var') {
		$e->{op} = 'ref';
		$e->{atoms} = [lookup_local($ctx, $e->{atoms}[0])];
		return;
	}
	if($op eq 'call') {
		my $name = $e->{atoms}[0];
		my $sym = $FUNCS{$name};
		if(!$sym) {
			# not a function: a variable of that name makes this an
			# indirect call through its value, (icall (ref ID) ARG...)
			# -- jtype3 insists it is a ptr. a function name always
			# wins in call position, so every call that compiled
			# before function pointers existed still means exactly
			# what it did.
			my $id = find_local($name);
			err_at($ctx, "call to undeclared function '$name'") unless defined $id;
			$e->{op} = 'icall';
			$e->{atoms} = [];
			$e->{kids} = [mk('ref', [$id], []), @{$e->{kids}}];
			resolve_expr($_, $ctx) for @{$e->{kids}}[1 .. $#{$e->{kids}}];
			return;
		}
		$e->{atoms} = [$sym->{id}, "name=$name"];
		resolve_expr($_, $ctx) for @{$e->{kids}};
		return;
	}
	if($op eq 'icall') {
		resolve_expr($_, $ctx) for @{$e->{kids}};
		return;
	}
	if($op eq 'addr' && $e->{kids}[0]{op} eq 'var') {
		# &name: a variable (local, global) wins, exactly as before;
		# only a name that is no variable but IS a function becomes
		# the function's address -- (addr (ref ID)) with the
		# function's sym, the same shape &globalvar has.
		my $name = $e->{kids}[0]{atoms}[0];
		if(!defined find_local($name) && (my $fs = $FUNCS{$name})) {
			$e->{kids}[0] = mk('ref', [$fs->{id}], []);
			return;
		}
		resolve_expr($e->{kids}[0], $ctx);
		return;
	}
	if($op eq 'assign') {
		check_lvalue($e->{kids}[0], $ctx);
		resolve_expr($e->{kids}[0], $ctx);
		resolve_expr($e->{kids}[1], $ctx);
		return;
	}
	if($op eq 'binop' || $op eq 'cond') {
		resolve_expr($_, $ctx) for @{$e->{kids}};
		return;
	}
	if($op eq 'unop' || $op eq 'addr' || $op eq 'deref' || $op eq 'cast' || $op eq 'sizeof') {
		resolve_expr($e->{kids}[0], $ctx) if @{$e->{kids}};
		return;
	}
	if($op eq 'member' || $op eq 'index' || $op eq 'initlist') {
		resolve_expr($_, $ctx) for @{$e->{kids}};
		return;
	}
	if($op eq 'preinc' || $op eq 'postinc' || $op eq 'predec' || $op eq 'postdec') {
		check_lvalue($e->{kids}[0], $ctx);
		resolve_expr($e->{kids}[0], $ctx);
		return;
	}
	# intlit/charlit/strlit/ref: leaves, nothing to resolve.
	return;
}
 
sub resolve_stmt {
	my ($s) = @_;
	my $op = $s->{op};
 
	if($op eq 'block') {
		push_scope();
		resolve_stmt($_) for @{$s->{kids}};
		pop_scope();
		return;
	}
	if($op eq 'decl') {
		declare_local($s, $s->{atoms}[0], $s->{atoms}[1]);
		my $init = find_kid($s, 'init');
		resolve_expr($init->{kids}[0], $s) if $init;
		return;
	}
	if($op eq 'stmt') {
		resolve_expr($s->{kids}[0], $s);
		return;
	}
	if($op eq 'assign') {
		resolve_expr($s);
		return;
	}
	if($op eq 'ret') {
		resolve_expr($s->{kids}[0], $s) if @{$s->{kids}};
		return;
	}
	if($op eq 'if') {
		resolve_expr($s->{kids}[0], $s);
		resolve_stmt($s->{kids}[1]);
		if(@{$s->{kids}} > 2) {
			my $else = $s->{kids}[2];
			resolve_stmt($else->{kids}[0]);
		}
		return;
	}
	if($op eq 'while') {
		resolve_expr($s->{kids}[0], $s);
		push @CTX, 'loop';
		resolve_stmt($s->{kids}[1]);
		pop @CTX;
		return;
	}
	if($op eq 'switch') {
		resolve_expr($s->{kids}[0], $s);
		push @CTX, 'switch';
		for my $k (@{$s->{kids}}[1 .. $#{$s->{kids}}]) {
			if($k->{op} eq 'case') { resolve_expr($k->{kids}[0], $k); resolve_stmt($_) for @{$k->{kids}}[1 .. $#{$k->{kids}}]; }
			else { resolve_stmt($_) for @{$k->{kids}}; }
		}
		pop @CTX;
		return;
	}
	if($op eq 'break' || $op eq 'continue') {
		err_at($s, "'$op' outside any loop or switch") unless @CTX;
		return;
	}
	if($op eq 'goto' || $op eq 'label') {
		return;  # never reach here in the cst, but harmless
	}
	stage_err("jscope2: unknown statement node: $op");
}
 
sub resolve_func_body {
	my ($func) = @_;
	my $body = find_kid($func, 'body');
	return unless $body;
	my $params = find_kid($func, 'params');
	push_scope();
	for my $p (@{$params->{kids}}) {
		declare_local($p, $p->{atoms}[0], $p->{atoms}[1]);
	}
	@CTX = ();
	resolve_stmt($_) for @{$body->{kids}};
	pop_scope();
	return;
}
 
sub preproc {
	my ($text) = @_;
	return read_tree($text);
}
 
sub proc {
	my ($unit) = @_;
	collect_toplevel($unit);
	resolve_types_pass($unit);
	# enum value exprs (they may reference earlier enumerators), and
	# gvar initializers (they may reference enumerators too).
	for my $top (@{$unit->{kids}}) {
		if($top->{op} eq 'enum') {
			for my $v (@{$top->{kids}}) {
				resolve_expr($v->{kids}[0], $v) if @{$v->{kids}};
			}
			next;
		}
		if($top->{op} eq 'gvar') {
			my $init = find_kid($top, 'init');
			resolve_expr($init->{kids}[0], $top) if $init;
			next;
		}
	}
	for my $top (@{$unit->{kids}}) {
		next unless $top->{op} eq 'func';
		resolve_func_body($top);
	}
	return write_tree($unit);
}
 
print proc(preproc($RAW));