1#!/usr/bin/perl
2
3# Z88DK Z80 Macro Assembler
4#
5# Copyright (C) Gunther Strube, InterLogic 1993-99
6# Copyright (C) Paulo Custodio, 2011-2019
7# License: The Artistic License 2.0, http://www.perlfoundation.org/artistic_license_2_0
8# Repository: https://github.com/z88dk/z88dk
9#
10# Test generation of listfiles by z80asm
11
12package t::Listfile;
13
14use Modern::Perl;
15use Object::Tiny::RW qw(
16		LINENR
17		LINENR_STACK
18		ADDR
19		LABEL_ADDR
20		LABEL_TYPE
21		LABEL_SCOPE
22		LIST_ASM
23		LIST_BIN
24		LIST_LST
25		LIST_ON
26		LABELS
27);
28use Test::More;
29use Test::Differences;
30use File::Slurp;
31use List::Uniq 'uniq';
32BEGIN {
33	use lib '.';
34	use t::TestZ80asm; *z80asm = \&::z80asm; # z80asm already imported in another package
35};
36
37my $LABEL_RE = qr/\b[A-Z_][A-Z0-9_]*/;
38my $MAX_LINE = 255-2;
39my $COLUMN_WIDTH = 32;
40
41#------------------------------------------------------------------------------
42# Class methods
43#------------------------------------------------------------------------------
44sub max_line { return $MAX_LINE; }
45
46#------------------------------------------------------------------------------
47# Construct a list test object
48#------------------------------------------------------------------------------
49sub new {
50	my($class, %args) = @_;
51	return bless {
52		LINENR			=> 1,
53		LINENR_STACK	=> [],
54		ADDR 			=> 0,
55		LABEL_ADDR		=> {},
56		LABEL_TYPE		=> {},
57		LABEL_SCOPE		=> {},
58		LIST_ASM		=> [],
59		LIST_BIN		=> [],
60		LIST_LST		=> [],
61		LIST_ON 		=> 1,
62	}, $class;
63}
64
65sub line_nr {
66	my($self) = @_;
67	return $self->{LINENR};
68}
69
70#------------------------------------------------------------------------------
71# advance list line number
72#------------------------------------------------------------------------------
73sub next_line {
74	my($self) = @_;
75	$self->LINENR( $self->LINENR + 1 );
76}
77
78#------------------------------------------------------------------------------
79# push list line - interpreets any ALL_CAPS word as a label
80#------------------------------------------------------------------------------
81sub push_asm {
82	my($self, $asm, @bytes) = @_;
83
84	my $new_list_on = $self->LIST_ON;
85
86	# handle asm, interpreet labels
87	if ($asm) {
88		push @{$self->LIST_ASM}, $asm
89			unless @{$self->LINENR_STACK};			# not if inside include
90
91		if ($asm =~ /^\s*($LABEL_RE)\s*:/) {		# define label
92			$self->LABEL_ADDR->{$1} = $self->ADDR;
93			$self->LABEL_TYPE->{$1} = 'addr';
94			$self->LABEL_SCOPE->{$1} ||= 'local';
95		}
96		elsif ($asm =~ /^\s*defc\s+($LABEL_RE)\s*=\s*(.*)/) {		# define constant
97			$self->LABEL_ADDR->{$1} = 0+eval($2);
98			$self->LABEL_TYPE->{$1} = 'const';
99			$self->LABEL_SCOPE->{$1} ||= 'local';
100		}
101		elsif ($asm =~ /(?i:public)\s+($LABEL_RE)/) {	# global label
102			$self->LABEL_SCOPE->{$1} = 'public';
103		}
104		elsif ($asm =~ /^\s*lstoff\s*$/i) {
105			$new_list_on = 0;
106		}
107		elsif ($asm =~ /^\s*lston\s*$/i) {
108			$new_list_on = 1;
109		}
110		else {
111		}
112	}
113
114	# handle bin
115	push @{$self->LIST_BIN}, pack("C*", @bytes);
116
117	# handle list
118	my $lst = sprintf("%-5d %04X  ", $self->LINENR, $self->ADDR);
119
120	my @lst_bytes = @bytes;
121	while (@lst_bytes) {
122		my @lst_block = splice(@lst_bytes, 0, 32);
123		$lst .= join('', map {sprintf("%02X ", $_)} @lst_block);
124		$self->ADDR( $self->ADDR + @lst_block );
125
126		# still for another row?
127		if (@lst_bytes) {
128			if ($self->LIST_ON) {
129				push @{$self->LIST_LST}, $lst;
130				$self->next_line();
131				$self->LINENR( $self->LINENR - 1 );
132			}
133			$lst = sprintf("%5s %04X  ", "", $self->ADDR);
134		}
135	}
136
137	# assembly
138	if (@bytes <= 4) {
139		$lst = sprintf("%-24s%s", $lst, $asm // '');
140	}
141	else {
142		if ($self->LIST_ON) {
143			push @{$self->LIST_LST}, $lst;
144			$self->next_line();
145			$self->LINENR( $self->LINENR - 1 );
146		}
147		$lst = sprintf("%-24s%s", "", $asm // '');
148	}
149
150	if ($self->LIST_ON) {
151		push @{$self->LIST_LST}, $lst;
152		$self->next_line();
153	}
154	else {
155		$self->LINENR( $self->LINENR + 1 );
156	}
157
158	$self->LIST_ON( $new_list_on );
159}
160
161#------------------------------------------------------------------------------
162# hanble includes
163#------------------------------------------------------------------------------
164sub push_include {
165	my($self, $file) = @_;
166	$self->push_asm("include \"$file\"");
167	push @{$self->LINENR_STACK}, $self->LINENR;
168	$self->LINENR( 1 );
169}
170
171sub pop_include {
172	my($self) = @_;
173	$self->push_asm();
174	@{$self->LINENR_STACK} or die;
175	$self->LINENR( pop( @{$self->LINENR_STACK} ) );
176}
177
178#------------------------------------------------------------------------------
179# compare result file with list of expected lines
180#------------------------------------------------------------------------------
181sub compare_list_file {
182	my($self, $file, @expected) = @_;
183
184	note "Test at ",join(" ", caller);
185
186	my @got = sort(read_file($file));
187	chomp(@got);
188	@expected = sort(@expected);
189
190	is_text( \@got, \@expected, "compare $file" );
191}
192
193#------------------------------------------------------------------------------
194# Return list of lines of symbol table
195sub sym_lines {
196	my($self) = @_;
197	my @sym;
198
199	for (keys %{$self->LABEL_ADDR}) {
200		my $line = sprintf("%-*s = \$%04X ; %-7s %-7s",
201					 $COLUMN_WIDTH - 1, $_,
202					 $self->LABEL_ADDR->{$_},
203					 $self->LABEL_TYPE->{$_},
204					 $self->LABEL_SCOPE->{$_});
205		$line =~ s/\s+$//;
206		push @sym, $line;
207
208	}
209	return @sym;
210}
211
212#------------------------------------------------------------------------------
213# test list file
214#------------------------------------------------------------------------------
215sub test {
216	my($self) = @_;
217
218	my $asm = join("\n", @{$self->LIST_ASM});
219	my $bin = join('',   @{$self->LIST_BIN});
220
221	$self->push_asm();
222
223	unlink('test.lis', 'test.sym');
224	z80asm(
225		asm		=> $asm,
226		bin		=> $bin,
227		options	=> "-b",
228	);
229	ok ! -f "test.lis", "no test.lis file";
230	ok ! -f "test.sym", "no test.sym file";
231
232	unlink('test.lis', 'test.sym');
233	z80asm(
234		asm		=> $asm,
235		bin		=> $bin,
236		options	=> "-l -b",
237	);
238	ok   -f "test.lis", "test.lis file";
239	ok ! -f "test.sym", "no test.sym file";
240	$self->compare_list_file("test.lis", @{$self->LIST_LST});
241
242	unlink('test.lis', 'test.sym');
243	z80asm(
244		asm		=> $asm,
245		bin		=> $bin,
246		options	=> "-s -b",
247	);
248	ok ! -f "test.lis", "no test.lis file";
249	ok   -f "test.sym", "test.sym file";
250	$self->compare_list_file("test.sym", $self->sym_lines());
251
252	unlink('test.lis', 'test.sym');
253	z80asm(
254		asm		=> $asm,
255		bin		=> $bin,
256		options	=> "-s -l -b",
257	);
258	ok -f "test.lis", "test.lis file";
259	ok -f "test.sym", "test.sym file";
260	$self->compare_list_file("test.lis", @{$self->LIST_LST});
261	$self->compare_list_file("test.sym", $self->sym_lines());
262}
263
2641;
265