aboutsummaryrefslogtreecommitdiffstats
path: root/data/bin2bac.pl
blob: edc67bd4a768195a1a4879c25b8bc151eb1ceb21 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
#!/usr/bin/perl

use bytes;

sub genpad($$) {
    my($left, $final) = @_;

    my $o = ($final ? "\x01" : "\x00") . ("\x00" x $$left);
    $$left = 252;		# Bytes left in block minus end marker

    return $o;
}

sub bacstmt($$$) {
    my($line, $left, $data) = @_;
    my $l = length($data) + 4;
    my $d = pack("Cv", $l, $line) . $data . "\x0d";

    if ($l > $$left) {
	$d = genpad($left,0).$d;
    }

    $$left -= $l;
    return $pad.$d;
}

# Take a list of relocations as 16-bit numbers and convert them
# to packed form.  Returns a list of two elements: the adjusted
# data block (including the packed relocations) and the final
# position of the address pointer.
sub pack_relocs($$) {
    my($data, $bin_relocs) = @_;
    my @relocs = sort { $a <=> $b } unpack('v*', $bin_relocs);
    my $l = length($data);

    my $ptr = 0;		# Address pointer
    my $prels = '';		# Packed relocations
    foreach my $rel ( @relocs ) {
	if ($rel > $l-1) {
	    die sprintf("$0: relocation past end of data: %d (0x%x)\n",
			$rel, $rel);
	}

	my $delta = $rel - $ptr;

	if ($delta < 0) {
	    die "$0: negative relocation jump: $delta\n";
	} elsif ($delta <= 0x7f) {
	    $prels .= pack('C', $delta);
	} elsif ($delta <= 0x7eff) {
	    # This is *bigendian*, with an offset of 0x8100
	    $prels .= pack('n', $delta + 0x8100);
	} else {
	    die sprintf("$0: impossibly large relocation jump: %d (0x%x)\n",
			$delta, $delta);
	}

	# Adjust data bytes to make relocations self-relative
	my $a = unpack("v", substr($data, $rel, 2));
	substr($data, $rel, 2) = pack("v", $a - $rel);

	$ptr = $rel + 2;
    }

    $prels .= pack('C', 0x80);	# Relocation end marker

    return ($data.$prels, $ptr);
}

sub makebac($$$$) {
    my($data, $addr, $entrypt, $relocs) = @_;

    my $packed_rels;
    my $bld;

    if (defined($addr)) {
	# <bacldr.asm code> - fixed load address

	# 0x00C9 is the address for END in all ABC80 BASIC interpreters
	$entrypt = 0x00c9 unless(defined($entrypt));

	$bld  = "\x2a\x1c\xfe\x06\x00\x4e\x09\x11";
	$bld .= pack('v', $addr);	# 16-bit load address
	$bld .= "\x06\x00\x7e\xd6\x08\xda";
	$bld .= pack('v', $entrypt);	# 16-bit entry point
	$bld .= "\x0e\x06\x09\x4f\xed\xb0\x23\x23\x18\xf0";
    } else {
	# <bacldrr.asm> - relocatable data loaded at BOFA

	# Default to entry = BOFA
	$entrypt = 0 unless(defined($entrypt));

	# Raw data length, must be recorded before pack_relocs()
	my $data_len = length($data);

	my $relptr;
	($data, $relptr) = pack_relocs($data, $relocs);

	$bld  = "\x01\xc9\x00\xc5\x2a\x1c\xfe\xe5\x5d\x54\x4e\x09";
	$bld .= "\x7e\xd6\x08\x38\x0a\x0e\x06\x09\x4f\xed\xb0";
	$bld .= "\x23\x23\x18\xf1\x21";
	# 16-bit length of data not including relocations
	$bld .= pack('v', $data_len);
	$bld .= "\xd1\x19\xeb\x1a\x13\xfe\x80\x30\x0e\x4f\x06\x00";
	$bld .= "\x09\x7d\x86\x77\x7c\x23\x8e\x77\x23\x18\xec";
	$bld .= "\xd6\x81\x38\x06\x47\x1a\x13\x4f\x18\xeb\x01";
	# 16-bit offset from final relocation to entry point
	$bld .= pack('v', $entrypt - $relptr);
	$bld .= "\x09\xe9";
    }

    my $q  = "\x82";		# Output (program start marker)
    my $left = 251;		# Bytes left in block
    my $r = 0;			# Last emitted line number

    # Address 65054 is EOFA
    # 1 Z%=CALL(PEEK(65054%)+SWAP%(PEEK(65055%))-<loader offset>)
    $q .= bacstmt(++$r, \$left,
		  "\x83\xc1\xf1\x5a\x00\xbb\xc7\x1e\xfe\xce\x36\xc7".
		  "\x1f\xfe\xce\x36\xce\x34\xf5\xc7".
		  pack("v", length($bld)+2). # +2 for statement trailer
		  "\xf8\xce\x3a\xb7");

    my $i = 0;
    my $dl = length($data);
    while ($i < $dl) {
	my $l = $dl - $i;

	# 8 byte overhead:
	# - 1 byte instruction length
	# - 2 bytes line number
	# - 2 bytes CB 22 [string expression in " quotes]
	# - 1 byte data length
	#     <data bytes>
	# - 1 byte BB (drop expression)
	# - 1 byte <CR> (end of statement)

	$q .= genpad(\$left,0) if ($left <= 8);
	$l = $left-8 if ($l > $left-8);

	# String expression + data + return
	$q .= bacstmt(++$r, \$left,
		      "\xcb\"" . pack("C", $l) . substr($data,$i,$l)."\xbb");

	$i += $l;
	$addr += $l;
    }

    # Terminal END statement
    $q .= bacstmt(++$r, \$left, "\x86\x8a"); # END

    # Loader code (string expression)
    $q .= bacstmt(++$r, \$left, "\xcb\"".pack("C",length($bld)).$bld."\xbb");
    $q .= genpad(\$left,1);

    return $q;
}

($file, $org, $entry, $entryname) = @ARGV;

if (!defined($file)) {
    die "Usage: $0 inputfile {load_addr|relocfile} [entrypoint|deffile [entryname]]\n";
}

if ($org !~ /^[0-9]/) {
    $relocfile = $org;
    undef $org;
} else {
    $org = oct $org if ( $org =~ /^0/ );
}

if ($entry !~ /^[0-9]/) {
    $entryfile = $entry;
    $entryname = '_start' unless(defined($entryname));
    undef $entry;

    open(DEF, '<', $entryfile) or die "$0: $entryfile: $!\n";
    while ($line = <DEF>) {
	chomp $line;
	@l = split(/\s+/, $line);
	if ($l[0] =~ /^DEFC$/i && $l[1] eq $entryname && $l[2] eq '=' &&
	    $l[3] =~ /^\$([0-9a-f]+)$/i) {
	    $entry = hex $1;
	    last;
	}
    }
    close(DEF);
    if (!defined($entry)) {
	die "$0: symbol $entryname not found in file $entryfile\n";
    }
} else {
    $entry = oct $entry if ( $entry =~ /^0/ );
}

open(FILE, '<:raw', $file) or die "$0: $file: $!\n";
read(FILE, $dd, 65536);
close(FILE);

if (defined($relocfile)) {
    if (defined($org)) {
	die "$0: cannot specify load address and relocation file both\n";
    }

    open(REL, '<:raw', $relocfile) or die "$0: $file: $!\n";
    read(REL, $relocs, 2*65536);
    close(REL);
}

print makebac($dd, $org, $entry, $relocs);