diff --git a/.editorconfig b/.editorconfig new file mode 100644 index 00000000..25282144 --- /dev/null +++ b/.editorconfig @@ -0,0 +1,8 @@ +# https://editorconfig.org/ + +# Perl +[*.pl] +indent_size = 2 +indent_style = space +insert_final_newline = true +charset = utf-8 diff --git a/bin/asmfmt.pl b/bin/asmfmt.pl index 46476412..b5d5209f 100755 --- a/bin/asmfmt.pl +++ b/bin/asmfmt.pl @@ -5,15 +5,15 @@ use warnings; sub nospace($) { - my ($s) = @_; - $s =~ s/\s//g; - return $s; + my ($s) = @_; + $s =~ s/\s//g; + return $s; } sub respace_comment($) { - my ($s) = @_; - $s =~ s/^(;+)\s+(.*)/$1 $2/g; - return $s; + my ($s) = @_; + $s =~ s/^(;+)\s+(.*)/$1 $2/g; + return $s; } sub max ($$) { $_[$_[0] < $_[1]] } @@ -28,129 +28,129 @@ ($) # TODO: sigils to disable/enable formatting around blocks while () { - chomp; - my $orig = $_; - $_ =~ s/^\s+|\s+$//g; + chomp; + my $orig = $_; + $_ =~ s/^\s+|\s+$//g; - if (m/^$/) { - # empty line - ignore - $tabstop = 0; + if (m/^$/) { + # empty line - ignore + $tabstop = 0; - } elsif (m/^(;;;.*)/) { + } elsif (m/^(;;;.*)/) { - # full line comment - flush left - $_ = respace_comment($1); - $tabstop = 0; + # full line comment - flush left + $_ = respace_comment($1); + $tabstop = 0; - } elsif (m/^(;;.*)/) { + } elsif (m/^(;;.*)/) { - # indented comment - one tab stop - $_ = (' ' x $tab) . respace_comment($1); - $tabstop = 0; + # indented comment - one tab stop + $_ = (' ' x $tab) . respace_comment($1); + $tabstop = 0; - } else { + } else { - my $comment = ''; - if (m/^(.*?)(;.*)$/) { - $_ = $1; - $comment = respace_comment($2); - } + my $comment = ''; + if (m/^(.*?)(;.*)$/) { + $_ = $1; + $comment = respace_comment($2); + } - if (m/^(\w+)\s*:=\s*(.*)$/) { + if (m/^(\w+)\s*:=\s*(.*)$/) { - # equate - flush left (!!), spaced out - my ($identifier, $expression) = ($1 // '', $2 // '', $3 // ''); + # equate - flush left (!!), spaced out + my ($identifier, $expression) = ($1 // '', $2 // '', $3 // ''); - $_ = ''; - $_ .= $identifier . ' '; - $_ .= ' ' while length($_) % $tab; + $_ = ''; + $_ .= $identifier . ' '; + $_ .= ' ' while length($_) % $tab; - $tabstop = max($tabstop, length($_)); - $_ .= ' ' while length($_) < $tabstop; + $tabstop = max($tabstop, length($_)); + $_ .= ' ' while length($_) < $tabstop; - $_ .= ':= ' . $expression . ' '; + $_ .= ':= ' . $expression . ' '; - } elsif (m/^(\w+)\s*=\s*(.*)$/) { + } elsif (m/^(\w+)\s*=\s*(.*)$/) { - # symbol - flush left (!!), spaced out - my ($identifier, $expression) = ($1 // '', $2 // '', $3 // ''); + # symbol - flush left (!!), spaced out + my ($identifier, $expression) = ($1 // '', $2 // '', $3 // ''); - $_ = ''; - $_ .= $identifier . ' '; - $_ .= ' ' while length($_) % $tab; + $_ = ''; + $_ .= $identifier . ' '; + $_ .= ' ' while length($_) % $tab; - $tabstop = max($tabstop, length($_)); - $_ .= ' ' while length($_) < $tabstop; + $tabstop = max($tabstop, length($_)); + $_ .= ' ' while length($_) < $tabstop; - $_ .= '= ' . $expression . ' '; + $_ .= '= ' . $expression . ' '; - } elsif (m/^(\.(?:end)?(?:proc|scope|macro|struct|enum|params)\b)\s*(.*)$/ || - m/^(\b(?:END_)?(?:PROC_AT)\b)\s*(.*)$/) { + } elsif (m/^(\.(?:end)?(?:proc|scope|macro|struct|enum|params)\b)\s*(.*)$/ || + m/^(\b(?:END_)?(?:PROC_AT)\b)\s*(.*)$/) { - # scope - flush left - my ($opcode, $arguments) = ($1 // '', $2 // ''); - $tabstop = 0; + # scope - flush left + my ($opcode, $arguments) = ($1 // '', $2 // ''); + $tabstop = 0; - $_ = $opcode . ' ' . $arguments; + $_ = $opcode . ' ' . $arguments; - } elsif (m/^(\.(?:if\w*|elseif|else|endif)\b)\s*(.*)$/) { + } elsif (m/^(\.(?:if\w*|elseif|else|endif)\b)\s*(.*)$/) { - # conditional - flush left - my ($opcode, $arguments) = ($1 // '', $2 // ''); - $tabstop = 0; + # conditional - flush left + my ($opcode, $arguments) = ($1 // '', $2 // ''); + $tabstop = 0; - $_ = $opcode . ' ' . $arguments; + $_ = $opcode . ' ' . $arguments; - } elsif (m/^(\b(?:IF_\w+|ELSE|END_IF|DO|WHILE_\w+)\b)\s*(.*)$/) { + } elsif (m/^(\b(?:IF_\w+|ELSE|END_IF|DO|WHILE_\w+)\b)\s*(.*)$/) { - # conditional macros - dynamic indent - my ($opcode, $arguments) = ($1 // '', $2 // ''); - $tabstop = 0; + # conditional macros - dynamic indent + my ($opcode, $arguments) = ($1 // '', $2 // ''); + $tabstop = 0; - if ($opcode =~ m/^(ELSE|END_IF|WHILE_\w+)$/) { - $flow_indent -= 2; - } + if ($opcode =~ m/^(ELSE|END_IF|WHILE_\w+)$/) { + $flow_indent -= 2; + } - $_ = ' ' x $flow_indent; - $_ .= $opcode . ' ' . $arguments; + $_ = ' ' x $flow_indent; + $_ .= $opcode . ' ' . $arguments; - if ($opcode =~ m/^(IF_\w+|ELSE|DO)$/) { - $flow_indent += 2; - } + if ($opcode =~ m/^(IF_\w+|ELSE|DO)$/) { + $flow_indent += 2; + } - } elsif (m/^(@?\w*:)?\s*(\S+)?\s*(.*?)\s*(;.*)?$/) { + } elsif (m/^(@?\w*:)?\s*(\S+)?\s*(.*?)\s*(;.*)?$/) { - # label / opcode / arguments / comment - my ($label, $opcode, $arguments, $comment) = ($1 // '', $2 // '', $3 // '', $4 // ''); + # label / opcode / arguments / comment + my ($label, $opcode, $arguments, $comment) = ($1 // '', $2 // '', $3 // '', $4 // ''); - $_ = ''; - $_ .= $label . ' '; - $tabstop = 0 unless $label; + $_ = ''; + $_ .= $label . ' '; + $tabstop = 0 unless $label; - $_ .= ' ' while length($_) % $tab; + $_ .= ' ' while length($_) % $tab; - $tabstop = max($tabstop, length($_)); - $_ .= ' ' while length($_) < $tabstop; + $tabstop = max($tabstop, length($_)); + $_ .= ' ' while length($_) < $tabstop; - $_ .= $opcode . ' '; - if ($opcode =~ m/^([a-z]{3}\w*)$|^(\.(byte|word|addr|res))$/) { - $_ .= ' ' while length($_) % $tab; - } - $_ .= $arguments . ' '; + $_ .= $opcode . ' '; + if ($opcode =~ m/^([a-z]{3}\w*)$|^(\.(byte|word|addr|res))$/) { + $_ .= ' ' while length($_) % $tab; + } + $_ .= $arguments . ' '; - } else { - die "Unexpected line: $_\n"; - } + } else { + die "Unexpected line: $_\n"; + } - if ($comment ) { - $_ .= ' ' while length($_) < $comment_column; - $_ .= $comment; - } + if ($comment ) { + $_ .= ' ' while length($_) < $comment_column; + $_ .= $comment; } + } - $_ =~ s/\s+$//; # trim right + $_ =~ s/\s+$//; # trim right - die "Mismatch:\n> $orig\n<$_\n"unless nospace($_) eq nospace($orig); + die "Mismatch:\n> $orig\n<$_\n"unless nospace($_) eq nospace($orig); - print $_, "\n"; + print $_, "\n"; } diff --git a/bin/build_fonts_from_latin1.pl b/bin/build_fonts_from_latin1.pl index e39a35b5..a6c6daf0 100755 --- a/bin/build_fonts_from_latin1.pl +++ b/bin/build_fonts_from_latin1.pl @@ -38,9 +38,9 @@ ($) open SRC, '<' . $src or die $!; binmode(SRC); sub getbyte { - my $b; - read(SRC, $b, 1); - return ord($b); + my $b; + read(SRC, $b, 1); + return ord($b); } my $type = getbyte(); die "Only type 0x00 supported\n" unless $type == 0x00; @@ -51,11 +51,11 @@ sub getbyte { my @chars; for (my $i = 0; $i < $num; ++$i) { - $chars[$i] = []; + $chars[$i] = []; } my @widths; for (my $i = 0; $i < $num; ++$i) { - push @widths, getbyte(); + push @widths, getbyte(); } for (my $row = 0; $row < $height; ++$row) { diff --git a/bin/bw_font.pl b/bin/bw_font.pl index f785bbc9..8bf4d572 100755 --- a/bin/bw_font.pl +++ b/bin/bw_font.pl @@ -7,16 +7,16 @@ my $offset = 0; sub getbyte { - my $b; - read(STDIN, $b, 1) or die "EOF"; - ++$offset; - return ord($b); + my $b; + read(STDIN, $b, 1) or die "EOF"; + ++$offset; + return ord($b); } sub getword { - my $b1 = getbyte(); - my $b2 = getbyte(); - return $b2 * 256 + $b1; + my $b1 = getbyte(); + my $b2 = getbyte(); + return $b2 * 256 + $b1; } my @widths = (); @@ -37,48 +37,48 @@ sub getword { printf("EOF : %04x\n", $eof); for (my $i = 0; $i < $max-32+1; ++$i) { - printf("== char header: %d / '%c' ==\n", $i, $i+32); - my $offset = getword(); - my $width = getbyte(); + printf("== char header: %d / '%c' ==\n", $i, $i+32); + my $offset = getword(); + my $width = getbyte(); - printf(" Offset : %04x\n", $offset); - printf(" Width : %02x\n", $width); + printf(" Offset : %04x\n", $offset); + printf(" Width : %02x\n", $width); - push @offsets, $offset; - push @widths, $width; + push @offsets, $offset; + push @widths, $width; } for (my $i = 0; $i < $max-32+1; ++$i) { - my $o = $offsets[$i]; - my $width = $widths[$i]; - printf("== char: %d / '%c' / w=%d ==\n", $i, $i+32, $width); - if ($o != $offset) { - die "BAD! char $i offset $offset expected $o\n"; - } - for (my $line = 0; $line < $height; ++$line) { - my $s = sprintf("%07b", getbyte()); - my $w = $width; - while ($w > 8) { - $s = sprintf("%07b", getbyte()) . $s; - $w -= 8; - } - $s =~ tr/01/ #/; - $s = reverse($s); - print "$s\n"; + my $o = $offsets[$i]; + my $width = $widths[$i]; + printf("== char: %d / '%c' / w=%d ==\n", $i, $i+32, $width); + if ($o != $offset) { + die "BAD! char $i offset $offset expected $o\n"; + } + for (my $line = 0; $line < $height; ++$line) { + my $s = sprintf("%07b", getbyte()); + my $w = $width; + while ($w > 8) { + $s = sprintf("%07b", getbyte()) . $s; + $w -= 8; } + $s =~ tr/01/ #/; + $s = reverse($s); + print "$s\n"; + } } if ($offset != $eof) { - die "BAD EOF offset $offset expected $eof\n"; + die "BAD EOF offset $offset expected $eof\n"; } __END__ while (1) { - my $b2 = sprintf("%07b", getbyte()); - my $s = $b2 . $b1; - $s =~ tr/01/ #/; - $s = reverse($s); - print "$s\n"; + my $b2 = sprintf("%07b", getbyte()); + my $s = $b2 . $b1; + $s =~ tr/01/ #/; + $s = reverse($s); + print "$s\n"; } @@ -97,36 +97,36 @@ sub getword { my @chars; for (my $i = 0; $i < $num; ++$i) { - $chars[$i] = ''; + $chars[$i] = ''; } my @widths; for (my $i = 0; $i < $num; ++$i) { - push @widths, getbyte(); + push @widths, getbyte(); } for (my $row = 0; $row < $height; ++$row) { - for (my $col = 0; $col < $cols; ++$col) { - for (my $c = 0; $c < $num; ++$c) { - my $bits = sprintf("%07b", getbyte()); - $bits =~ tr/01/.#/; - $bits = reverse $bits; - - $chars[$c] .= $bits; - } - } + for (my $col = 0; $col < $cols; ++$col) { for (my $c = 0; $c < $num; ++$c) { - $chars[$c] .= "\n"; + my $bits = sprintf("%07b", getbyte()); + $bits =~ tr/01/.#/; + $bits = reverse $bits; + + $chars[$c] .= $bits; } + } + for (my $c = 0; $c < $num; ++$c) { + $chars[$c] .= "\n"; + } } for (my $i = 0; $i < $num; ++$i) { - $chars[$i] = - join("\n", - map { substr($_, 0, $widths[$i]) } - split("\n", $chars[$i])); + $chars[$i] = + join("\n", + map { substr($_, 0, $widths[$i]) } + split("\n", $chars[$i])); } for (my $i = 0; $i < $num; ++$i) { - print "== 0x".sprintf("%02x",$i)." ==\n$chars[$i]\n"; + print "== 0x".sprintf("%02x",$i)." ==\n$chars[$i]\n"; } diff --git a/bin/convert_font.pl b/bin/convert_font.pl index 18f5875a..f7ef0c4b 100755 --- a/bin/convert_font.pl +++ b/bin/convert_font.pl @@ -15,11 +15,11 @@ # Fill in control characters for (my $i = 0; $i < $NCCS; ++$i) { - $chars[$i] = "\x00" x 8; + $chars[$i] = "\x00" x 8; } for (my $i = 0; $i < $NCHARS - $NCCS; ++$i) { - read(STDIN, $chars[$i + $NCCS], 8); + read(STDIN, $chars[$i + $NCCS], 8); } my @out; @@ -31,51 +31,51 @@ # compute glyph widths for (my $i = 0; $i < $NCHARS; ++$i) { - my @bytes = map { ord($_) & 0x7f } split('', $chars[$i]); + my @bytes = map { ord($_) & 0x7f } split('', $chars[$i]); - # determine which bits are used for all rows in glyph - my $bits; - while (1) { - $bits = 0; - for (my $b = 0; $b < 8; ++$b) { - $bits = $bits | $bytes[$b]; - } - - last if (!$bits) || ($bits & 1); - - # trim off empty bits on left - for (my $b = 0; $b < 8; ++$b) { - $bytes[$b] = $bytes[$b] >> 1; - } + # determine which bits are used for all rows in glyph + my $bits; + while (1) { + $bits = 0; + for (my $b = 0; $b < 8; ++$b) { + $bits = $bits | $bytes[$b]; } - # update glyph - $chars[$i] = join('', map { chr } @bytes); - - # width depends on used bits; at most 7, but - # otherwise max width + 1 (for spacing) - my $w = - $bits >= (1<<6) ? 7 : - $bits >= (1<<5) ? 7 : - $bits >= (1<<4) ? 6 : - $bits >= (1<<3) ? 5 : - $bits >= (1<<2) ? 4 : - $bits >= (1<<1) ? 3 : - $bits >= (1<<0) ? 2 : 1; - - # Special treatment for space character - if ($i == 0x20 && $w < 4) { - $w = 4; - } + last if (!$bits) || ($bits & 1); - push @out, $w; + # trim off empty bits on left + for (my $b = 0; $b < 8; ++$b) { + $bytes[$b] = $bytes[$b] >> 1; + } + } + + # update glyph + $chars[$i] = join('', map { chr } @bytes); + + # width depends on used bits; at most 7, but + # otherwise max width + 1 (for spacing) + my $w = + $bits >= (1<<6) ? 7 : + $bits >= (1<<5) ? 7 : + $bits >= (1<<4) ? 6 : + $bits >= (1<<3) ? 5 : + $bits >= (1<<2) ? 4 : + $bits >= (1<<1) ? 3 : + $bits >= (1<<0) ? 2 : 1; + + # Special treatment for space character + if ($i == 0x20 && $w < 4) { + $w = 4; + } + + push @out, $w; } # bits for (my $b = 0; $b < 8; ++$b) { - for (my $i = 0; $i < $NCHARS; ++$i) { - push @out, ord(substr($chars[$i], $b, 1)); - } + for (my $i = 0; $i < $NCHARS; ++$i) { + push @out, ord(substr($chars[$i], $b, 1)); + } } # source output for ca65 diff --git a/bin/dump_font.pl b/bin/dump_font.pl index e4dc0f93..58208362 100755 --- a/bin/dump_font.pl +++ b/bin/dump_font.pl @@ -5,9 +5,9 @@ # Displays the glyphs from an MGTK font. sub getbyte { - my $b; - read(STDIN, $b, 1); - return ord($b); + my $b; + read(STDIN, $b, 1); + return ord($b); } my $type = getbyte(); @@ -24,46 +24,46 @@ sub getbyte { my @chars; for (my $i = 0; $i < $num; ++$i) { - $chars[$i] = ''; + $chars[$i] = ''; } my @widths; for (my $i = 0; $i < $num; ++$i) { - push @widths, getbyte(); + push @widths, getbyte(); } for (my $row = 0; $row < $height; ++$row) { - for (my $col = 0; $col < $cols; ++$col) { - for (my $c = 0; $c < $num; ++$c) { - my $bits = sprintf("%07b", getbyte()); - $bits =~ tr/01/.#/; - $bits = reverse $bits; - - $chars[$c] .= $bits; - } - } + for (my $col = 0; $col < $cols; ++$col) { for (my $c = 0; $c < $num; ++$c) { - # Validate that no extra bits are set; MGTK will render these - # with glitches. The bits will not appear in the output from - # this utility, however, so fonts can be "cleaned" by dumping - # and re-making the font. - my $last = (split(/\n/,$chars[$c]))[-1]; - if (substr($last, $widths[$c]) =~ m/#.*$/) { - warn sprintf("extra bits in char 0x%02x '%c', row %d (of %d)", - $c, $c, $row+1, $height); - } + my $bits = sprintf("%07b", getbyte()); + $bits =~ tr/01/.#/; + $bits = reverse $bits; - $chars[$c] .= "\n"; + $chars[$c] .= $bits; } + } + for (my $c = 0; $c < $num; ++$c) { + # Validate that no extra bits are set; MGTK will render these + # with glitches. The bits will not appear in the output from + # this utility, however, so fonts can be "cleaned" by dumping + # and re-making the font. + my $last = (split(/\n/,$chars[$c]))[-1]; + if (substr($last, $widths[$c]) =~ m/#.*$/) { + warn sprintf("extra bits in char 0x%02x '%c', row %d (of %d)", + $c, $c, $row+1, $height); + } + + $chars[$c] .= "\n"; + } } for (my $i = 0; $i < $num; ++$i) { - $chars[$i] = - join("\n", - map { substr($_, 0, $widths[$i]) } - split("\n", $chars[$i])); + $chars[$i] = + join("\n", + map { substr($_, 0, $widths[$i]) } + split("\n", $chars[$i])); } for (my $i = 0; $i < $num; ++$i) { - printf("== 0x%02x ==\n%s\n", $i, $chars[$i]); + printf("== 0x%02x ==\n%s\n", $i, $chars[$i]); } diff --git a/bin/endproc.pl b/bin/endproc.pl index 712c6123..bce72d07 100755 --- a/bin/endproc.pl +++ b/bin/endproc.pl @@ -9,13 +9,13 @@ use warnings; BEGIN { - my @stack = (); + my @stack = (); } our @stack; if (m/\.(?:proc|scope)\b\s*(\w*)/) { - push(@stack, $1); + push(@stack, $1); } elsif (m/(\.end(?:proc|scope))\b/) { - my $label = pop(@stack); - $_ = "$1 ; $label\n" if $label; + my $label = pop(@stack); + $_ = "$1 ; $label\n" if $label; } diff --git a/bin/hr2dhr.pl b/bin/hr2dhr.pl index efe2f9c3..cca96248 100755 --- a/bin/hr2dhr.pl +++ b/bin/hr2dhr.pl @@ -7,50 +7,50 @@ my @hi; for (my $i = 0; $i < 256; ++$i) { - my $bits = $i; - my $accum = 0; - for (my $b = 0; $b < 7; ++$b) { - if ($bits & 1) { - $accum = $accum | (0b11 << ($b * 2)); - } - $bits = $bits >> 1; - } - my $lo; - my $hi; + my $bits = $i; + my $accum = 0; + for (my $b = 0; $b < 7; ++$b) { if ($bits & 1) { - # palette bit set is easy case - $lo = ($accum & 0x7f); - $hi = (($accum >> 7) & 0xff); - } else { - # otherwise, encode spill bit into hi bit of main mem (hi) - my $spill = $accum & 1; - $accum = $accum >> 1; - $lo = ($accum & 0x7f); - $hi = (($accum >> 7) & 0xff) | ($spill << 7); # encode spill bit + $accum = $accum | (0b11 << ($b * 2)); } - push @lo, $lo; - push @hi, $hi; + $bits = $bits >> 1; + } + my $lo; + my $hi; + if ($bits & 1) { + # palette bit set is easy case + $lo = ($accum & 0x7f); + $hi = (($accum >> 7) & 0xff); + } else { + # otherwise, encode spill bit into hi bit of main mem (hi) + my $spill = $accum & 1; + $accum = $accum >> 1; + $lo = ($accum & 0x7f); + $hi = (($accum >> 7) & 0xff) | ($spill << 7); # encode spill bit + } + push @lo, $lo; + push @hi, $hi; } print "\n"; print ";;; HR to DHR - Aux Mem Bytes\n"; print "hr_to_dhr_aux:\n"; for (my $i = 0; $i < 256; $i += 8) { - print " .byte "; - for (my $j = 0; $j < 8; ++$j) { - print sprintf("\$%02x", $lo[$i + $j]); - print ", " unless $j == 7; - } - print "\n"; + print " .byte "; + for (my $j = 0; $j < 8; ++$j) { + print sprintf("\$%02x", $lo[$i + $j]); + print ", " unless $j == 7; + } + print "\n"; } print "\n"; print ";;; HR to DHR - Main Mem Bytes\n"; print "hr_to_dhr_main:\n"; for (my $i = 0; $i < 256; $i += 8) { - print " .byte "; - for (my $j = 0; $j < 8; ++$j) { - print sprintf("\$%02x", $hi[$i + $j]); - print ", " unless $j == 7; - } - print "\n"; + print " .byte "; + for (my $j = 0; $j < 8; ++$j) { + print sprintf("\$%02x", $hi[$i + $j]); + print ", " unless $j == 7; + } + print "\n"; } diff --git a/bin/loc_makeres.pl b/bin/loc_makeres.pl index a227b6c9..0e7ebfa3 100755 --- a/bin/loc_makeres.pl +++ b/bin/loc_makeres.pl @@ -8,70 +8,70 @@ binmode(STDERR, ':utf8'); sub trim($) { - my $s = shift; $s =~ s/^\s+|\s+$//g; return $s; + my $s = shift; $s =~ s/^\s+|\s+$//g; return $s; } sub enquote($$) { - my ($label, $value) = @_; - - if ($label =~ /^res_string_/) { - $value =~ s/"/\\x22/g; # Escape double quotes - return "\"$value\""; - } - return "\"$value\"" if $label =~ /^res_string_/; - return "'$value'" if $label =~ /^res_char_/; - return $value if $label =~ /^res_const_/; - return "\"$value\"" if $label =~ /^res_filename_/; - - die "Bad label: \"$label\" at line $.\n"; + my ($label, $value) = @_; + + if ($label =~ /^res_string_/) { + $value =~ s/"/\\x22/g; # Escape double quotes + return "\"$value\""; + } + return "\"$value\"" if $label =~ /^res_string_/; + return "'$value'" if $label =~ /^res_char_/; + return $value if $label =~ /^res_const_/; + return "\"$value\"" if $label =~ /^res_filename_/; + + die "Bad label: \"$label\" at line $.\n"; } sub indexes($$) { - my ($string, $char) = @_; - my @indexes = (); - my $index = 0; - while (1) { - $index = index($string, $char, $index); - last if $index == -1; - push @indexes, ++$index; - } - return @indexes; + my ($string, $char) = @_; + my @indexes = (); + my $index = 0; + while (1) { + $index = index($string, $char, $index); + last if $index == -1; + push @indexes, ++$index; + } + return @indexes; } # Encodes into source strings (with escaping) sub encode($$) { - my ($lang, $s) = @_; - $s =~ tr/\xA0/ /; # NBSP to regular space - $s =~ tr/\\/\xFF/; # Protect \ temporarily, for \xNN sequences (etc) - if ($lang eq 'fr') { - $s =~ tr/£à˚ç§`éùè¨/#@[\\]`{|}~/; - } elsif ($lang eq 'de') { - $s =~ tr/#§ÄÖÜ`äöüß/#@[\\]`{|}~/; - } elsif ($lang eq 'it') { - $s =~ tr/£§˚çéùàòèì/#@[\\]`{|}~/; - } elsif ($lang eq 'es') { - $s =~ tr/£§¡Ñ¿`˚ñç~/#@[\\]`{|}~/; - # unofficial extensions for A2D - $s =~ tr/áéíóú/\x10-\x14/; - } elsif ($lang eq 'nl') { - # unofficial extensions for A2D - $s =~ tr/ë/\x10/; - } elsif ($lang eq 'da') { - $s =~ tr/#@ÆØÅ`æøå~/#@[\\]`{|}~/; - } elsif ($lang eq 'sv') { - $s =~ tr/#@ÄÖÅ`äöå~/#@[\\]`{|}~/; - } elsif ($lang eq 'pt') { - $s =~ tr/õêáãâçàéíúôó/#&@[\\]_`{|}~/; # Based on TK3000 - } else { - die "Unknown lang: $lang\n"; - } - $s =~ s|\\|\\\\|g; # Escape newly generated \ - $s =~ tr/\xFF/\\/; # Restore the original \ (see above) - $s =~ s/([\x10-\x14])/sprintf("\\x%02x",ord($1))/seg; # Escape control chars - - die "Unencodable ($lang) in line $.: $s\n" unless $s =~ /^[\x20-\x7e]*$/; - - return $s; + my ($lang, $s) = @_; + $s =~ tr/\xA0/ /; # NBSP to regular space + $s =~ tr/\\/\xFF/; # Protect \ temporarily, for \xNN sequences (etc) + if ($lang eq 'fr') { + $s =~ tr/£à˚ç§`éùè¨/#@[\\]`{|}~/; + } elsif ($lang eq 'de') { + $s =~ tr/#§ÄÖÜ`äöüß/#@[\\]`{|}~/; + } elsif ($lang eq 'it') { + $s =~ tr/£§˚çéùàòèì/#@[\\]`{|}~/; + } elsif ($lang eq 'es') { + $s =~ tr/£§¡Ñ¿`˚ñç~/#@[\\]`{|}~/; + # unofficial extensions for A2D + $s =~ tr/áéíóú/\x10-\x14/; + } elsif ($lang eq 'nl') { + # unofficial extensions for A2D + $s =~ tr/ë/\x10/; + } elsif ($lang eq 'da') { + $s =~ tr/#@ÆØÅ`æøå~/#@[\\]`{|}~/; + } elsif ($lang eq 'sv') { + $s =~ tr/#@ÄÖÅ`äöå~/#@[\\]`{|}~/; + } elsif ($lang eq 'pt') { + $s =~ tr/õêáãâçàéíúôó/#&@[\\]_`{|}~/; # Based on TK3000 + } else { + die "Unknown lang: $lang\n"; + } + $s =~ s|\\|\\\\|g; # Escape newly generated \ + $s =~ tr/\xFF/\\/; # Restore the original \ (see above) + $s =~ s/([\x10-\x14])/sprintf("\\x%02x",ord($1))/seg; # Escape control chars + + die "Unencodable ($lang) in line $.: $s\n" unless $s =~ /^[\x20-\x7e]*$/; + + return $s; } sub hashes($) { my $s = shift; return join('', $s =~ m/#/g); } @@ -80,48 +80,48 @@ ($$) sub punct($) { my $s = shift; $s =~ m/([.:?!]*)\s*$/; return $1; } sub check($$$$) { - my ($lang, $label, $en, $t) = @_; - return $en unless $t; - - # Apply same leading/trailing spaces - if ($label !~ /^res_char_/) { - $t =~ s/^[ ]+|[ ]+$//g; - $t = $1 . $t . $2 if $en =~ m/^([ ]*).*?([ ]*)$/; - } - - # Ensure placeholders are still there - die "Hashes mismatch at $label, line $.: $en / $t\n" - unless hashes($en) eq hashes($t); - die "Percents mismatch at $label, line $.: $en / $t\n" - unless percents($en) eq percents($t); - die "Hexes mismatch at $label, line $.: $en / $t\n" - unless hexes($en) eq hexes($t); - die "Punctuation mismatch at $label, line $.: '$en' / '$t'\n" - unless $label =~ /^res_char_/ || punct($en) eq punct($t); - - die "Bad filename at $label, line $.: '$en' / '$t'\n" - if $label =~ /^res_filename/ && not ($t =~ /^[A-Za-z][A-Za-z0-9.]*$/ && length($t) <= 15); - - # Language specific checks: - if ($lang eq 'fr') { - die "Expect space before punctuation in $lang, line $.: $t\n" - if $t =~ m/\S[!?:]/; - } else { - die "Expect no space before punctuation in $lang, line $.: $t\n" - if $t =~ m/\s[!?:]/; - } - - die "Bad char resource in $lang, line $.: $t\n" - if $label =~ /^res_char_/ && length($t) != 1; - die "Bad const resource in $lang, line $.: $t\n" - if $label =~ /^res_const_/ && $t !~ /^\d+$/; - - if (0) { - warn "String > 2x in $lang, line $.: '$en' / '$t'\n" - if length($t) / length($en) > 2; - } - - return $t; + my ($lang, $label, $en, $t) = @_; + return $en unless $t; + + # Apply same leading/trailing spaces + if ($label !~ /^res_char_/) { + $t =~ s/^[ ]+|[ ]+$//g; + $t = $1 . $t . $2 if $en =~ m/^([ ]*).*?([ ]*)$/; + } + + # Ensure placeholders are still there + die "Hashes mismatch at $label, line $.: $en / $t\n" + unless hashes($en) eq hashes($t); + die "Percents mismatch at $label, line $.: $en / $t\n" + unless percents($en) eq percents($t); + die "Hexes mismatch at $label, line $.: $en / $t\n" + unless hexes($en) eq hexes($t); + die "Punctuation mismatch at $label, line $.: '$en' / '$t'\n" + unless $label =~ /^res_char_/ || punct($en) eq punct($t); + + die "Bad filename at $label, line $.: '$en' / '$t'\n" + if $label =~ /^res_filename/ && not ($t =~ /^[A-Za-z][A-Za-z0-9.]*$/ && length($t) <= 15); + + # Language specific checks: + if ($lang eq 'fr') { + die "Expect space before punctuation in $lang, line $.: $t\n" + if $t =~ m/\S[!?:]/; + } else { + die "Expect no space before punctuation in $lang, line $.: $t\n" + if $t =~ m/\s[!?:]/; + } + + die "Bad char resource in $lang, line $.: $t\n" + if $label =~ /^res_char_/ && length($t) != 1; + die "Bad const resource in $lang, line $.: $t\n" + if $label =~ /^res_const_/ && $t !~ /^\d+$/; + + if (0) { + warn "String > 2x in $lang, line $.: '$en' / '$t'\n" + if length($t) / length($en) > 2; + } + + return $t; } @@ -134,58 +134,58 @@ ($$$$) my %dupes = (); while () { - my ($file, $label, $comment, $en, $fr, $de, $it, $es, $pt, $sv, $da, $nl) = split(/\t/); - my %strings = (en => $en, fr => $fr, de => $de, it => $it, es => $es, pt => $pt, sv => $sv, da => $da, nl => $nl); - - next unless $file and $label; - - if ($file ne $last_file) { - $last_file = $file; - foreach my $lang (@langs) { - my $outfile = $file; - $outfile =~ s|/|/res/|; - $outfile =~ s|\.s$|.res.$lang|; - open $fhs{$lang}, '>'.$outfile or die $!; - } + my ($file, $label, $comment, $en, $fr, $de, $it, $es, $pt, $sv, $da, $nl) = split(/\t/); + my %strings = (en => $en, fr => $fr, de => $de, it => $it, es => $es, pt => $pt, sv => $sv, da => $da, nl => $nl); - %dupes = (); + next unless $file and $label; + + if ($file ne $last_file) { + $last_file = $file; + foreach my $lang (@langs) { + my $outfile = $file; + $outfile =~ s|/|/res/|; + $outfile =~ s|\.s$|.res.$lang|; + open $fhs{$lang}, '>'.$outfile or die $!; } - if (0 && $label =~ m/res_string_/) { - if (defined $dupes{$en}) { - say STDERR "Possible dupe: '$en' - $dupes{$en} / $label"; - } else { - $dupes{$en} = $label; - } + %dupes = (); + } + + if (0 && $label =~ m/res_string_/) { + if (defined $dupes{$en}) { + say STDERR "Possible dupe: '$en' - $dupes{$en} / $label"; + } else { + $dupes{$en} = $label; } + } - foreach my $lang (@langs) { - my $str = $strings{$lang}; + foreach my $lang (@langs) { + my $str = $strings{$lang}; - if ($lang ne 'en') { - $str = check($lang, $label, $en, $str); - $str = encode($lang, $str); - } else { - check($lang, $label, $en, $en); - } + if ($lang ne 'en') { + $str = check($lang, $label, $en, $str); + $str = encode($lang, $str); + } else { + check($lang, $label, $en, $en); + } - if ($str =~ m/^(.*)##(.*)$/) { - # If string has '##', split into prefix/suffix. - print {$fhs{$lang}} ".define ${label}_prefix ", enquote($label, $1), "\n"; - print {$fhs{$lang}} ".define ${label}_suffix ", enquote($label, $2), "\n"; - } else { - # Normal case. - print {$fhs{$lang}} ".define $label ", enquote($label, $str), "\n"; - - # If string is a pattern, emit constants for the offsets of #. - if ($label =~ m/^res_string_.*_pattern$/ && $str =~ m/#/) { - my $counter = 0; - foreach my $index (indexes($str, '#')) { - my $l = ($label =~ s/^res_string_/res_const_/r) . "_offset" . (++$counter); - print {$fhs{$lang}} ".define $l $index\n"; - } - } + if ($str =~ m/^(.*)##(.*)$/) { + # If string has '##', split into prefix/suffix. + print {$fhs{$lang}} ".define ${label}_prefix ", enquote($label, $1), "\n"; + print {$fhs{$lang}} ".define ${label}_suffix ", enquote($label, $2), "\n"; + } else { + # Normal case. + print {$fhs{$lang}} ".define $label ", enquote($label, $str), "\n"; + + # If string is a pattern, emit constants for the offsets of #. + if ($label =~ m/^res_string_.*_pattern$/ && $str =~ m/#/) { + my $counter = 0; + foreach my $index (indexes($str, '#')) { + my $l = ($label =~ s/^res_string_/res_const_/r) . "_offset" . (++$counter); + print {$fhs{$lang}} ".define $l $index\n"; } + } } + } } diff --git a/bin/make_font.pl b/bin/make_font.pl index da0055b0..a42e78fa 100755 --- a/bin/make_font.pl +++ b/bin/make_font.pl @@ -24,24 +24,24 @@ my @widths = (); my @chars = (); for (my $c = 0; $c < $chars; ++$c) { + $_ = ; chomp; + die "expected char header, saw $_ (line $.)\n" unless m/^== 0x(\w+) ==$/; + die sprintf("expected 0x%02x, saw 0x$1 (line $.)\n", $c) unless hex($1) == $c; + + for (my $r = 0; $r < $height; ++$r) { $_ = ; chomp; - die "expected char header, saw $_ (line $.)\n" unless m/^== 0x(\w+) ==$/; - die sprintf("expected 0x%02x, saw 0x$1 (line $.)\n", $c) unless hex($1) == $c; - - for (my $r = 0; $r < $height; ++$r) { - $_ = ; chomp; - die "expected bitmap, saw $_ (line $.)\n" unless m/^[.#]*$/; - my $len = length($_); - if (defined $widths[$c]) { - die sprintf("changed width: 0x%02x (line $.)\n", $c) unless $widths[$c] == $len; - } else { - $widths[$c] = $len; - } - - $_ =~ tr/.#/01/; - my $n = reverse($_); - $chars[$c][$r] = from2($n); + die "expected bitmap, saw $_ (line $.)\n" unless m/^[.#]*$/; + my $len = length($_); + if (defined $widths[$c]) { + die sprintf("changed width: 0x%02x (line $.)\n", $c) unless $widths[$c] == $len; + } else { + $widths[$c] = $len; } + + $_ =~ tr/.#/01/; + my $n = reverse($_); + $chars[$c][$r] = from2($n); + } } binmode STDOUT; @@ -49,12 +49,12 @@ print chr($type), chr($chars-1), chr($height); print pack('C*', @widths); for (my $r = 0; $r < $height; ++$r) { + for (my $c = 0; $c < $chars; ++$c) { + print chr($chars[$c][$r] & 0x7F); + } + if ($type == 0x80) { for (my $c = 0; $c < $chars; ++$c) { - print chr($chars[$c][$r] & 0x7F); - } - if ($type == 0x80) { - for (my $c = 0; $c < $chars; ++$c) { - print chr($chars[$c][$r] >> 7); - } + print chr($chars[$c][$r] >> 7); } + } } diff --git a/bin/packbytes.pl b/bin/packbytes.pl index 0bd8301b..056b94fc 100755 --- a/bin/packbytes.pl +++ b/bin/packbytes.pl @@ -13,70 +13,70 @@ my @singletons = (); sub dumpSingletons() { - while (scalar(@singletons)) { - my $n = scalar(@singletons); - $n = 64 if $n > 64; - # 0b00...... = 1 to 64 bytes follow - all different - #print STDERR "Packing $n singleton(s)\n"; - print chr(0b00000000 | ($n - 1)); - print shift(@singletons) while $n--; - } + while (scalar(@singletons)) { + my $n = scalar(@singletons); + $n = 64 if $n > 64; + # 0b00...... = 1 to 64 bytes follow - all different + #print STDERR "Packing $n singleton(s)\n"; + print chr(0b00000000 | ($n - 1)); + print shift(@singletons) while $n--; + } } while (scalar(@bytes)) { - my $count = 0; - my $head = $bytes[$count++]; - $count++ while ($count < scalar(@bytes)) && ($bytes[$count] eq $head); - - if ($count > 2) { - dumpSingletons(); + my $count = 0; + my $head = $bytes[$count++]; + $count++ while ($count < scalar(@bytes)) && ($bytes[$count] eq $head); - if ($count < 8 && ($count % 4)) { - # 0b01...... = 3, 5, 6, or 7 repeats of next byte - splice(@bytes, 0, $count); - #print STDERR "Packing $count repeats of $head\n"; - print chr(0b01000000 | ($count - 1)); - print $head; - } else { - # 0b11...... = 1 to 64 repeats of next byte taken as 4 bytes - $count = int($count / 4); - $count = 64 if $count > 64; - splice(@bytes, 0, $count * 4); - #print STDERR "Packing $count * 4 repeats of $head\n"; - print chr(0b11000000 | ($count - 1)); - print $head; - } + if ($count > 2) { + dumpSingletons(); - next; + if ($count < 8 && ($count % 4)) { + # 0b01...... = 3, 5, 6, or 7 repeats of next byte + splice(@bytes, 0, $count); + #print STDERR "Packing $count repeats of $head\n"; + print chr(0b01000000 | ($count - 1)); + print $head; + } else { + # 0b11...... = 1 to 64 repeats of next byte taken as 4 bytes + $count = int($count / 4); + $count = 64 if $count > 64; + splice(@bytes, 0, $count * 4); + #print STDERR "Packing $count * 4 repeats of $head\n"; + print chr(0b11000000 | ($count - 1)); + print $head; } - if (scalar(@bytes) >= 8) { - my $b0 = $bytes[0]; - my $b1 = $bytes[1]; - my $b2 = $bytes[2]; - my $b3 = $bytes[3]; - $count = 0; - while ($b0 eq $bytes[$count*4+0] && - $b1 eq $bytes[$count*4+1] && - $b2 eq $bytes[$count*4+2] && - $b3 eq $bytes[$count*4+3] && - $count < 64) { - ++$count; - } - if ($count > 1) { - dumpSingletons(); + next; + } + + if (scalar(@bytes) >= 8) { + my $b0 = $bytes[0]; + my $b1 = $bytes[1]; + my $b2 = $bytes[2]; + my $b3 = $bytes[3]; + $count = 0; + while ($b0 eq $bytes[$count*4+0] && + $b1 eq $bytes[$count*4+1] && + $b2 eq $bytes[$count*4+2] && + $b3 eq $bytes[$count*4+3] && + $count < 64) { + ++$count; + } + if ($count > 1) { + dumpSingletons(); - # 0b10...... = 1 to 64 repeats of next 4 bytes - splice(@bytes, 0, $count*4); - #print STDERR "Packing $count repeats of quad $b0$b1$b2$b3\n"; - print chr(0b10000000 | ($count - 1)); - print $b0, $b1, $b2, $b3; + # 0b10...... = 1 to 64 repeats of next 4 bytes + splice(@bytes, 0, $count*4); + #print STDERR "Packing $count repeats of quad $b0$b1$b2$b3\n"; + print chr(0b10000000 | ($count - 1)); + print $b0, $b1, $b2, $b3; - next; - } + next; } + } - push(@singletons, shift(@bytes)); + push(@singletons, shift(@bytes)); } dumpSingletons(); diff --git a/bin/refactor.pl b/bin/refactor.pl index 53ac6fb5..5d416ee5 100755 --- a/bin/refactor.pl +++ b/bin/refactor.pl @@ -6,112 +6,112 @@ my $text = do { local $/; }; my %mli = ( - '$C0' => 'CREATE', - '$C1' => 'DESTROY', - '$C2' => 'RENAME', - '$C3' => 'SET_FILE_INFO', - '$C4' => 'GET_FILE_INFO', - '$C5' => 'ON_LINE', - '$C6' => 'SET_PREFIX', - '$C7' => 'GET_PREFIX', - '$C8' => 'OPEN', - '$C9' => 'NEWLINE', - '$CA' => 'READ', - '$CB' => 'WRITE', - '$CC' => 'CLOSE', - '$CD' => 'FLUSH', - '$CE' => 'SET_MARK', - '$CF' => 'GET_MARK', - '$D0' => 'SET_EOF', - '$D1' => 'GET_EOF', - '$D2' => 'SET_BUF', - '$D3' => 'GET_BUF', - '$82' => 'GET_TIME', - '$40' => 'ALLOC_INTERRUPT', - '$41' => 'DEALLOC_INTERRUPT', - '$65' => 'QUIT', - '$80' => 'READ_BLOCK', - '$81' => 'WRITE_BLOCK', + '$C0' => 'CREATE', + '$C1' => 'DESTROY', + '$C2' => 'RENAME', + '$C3' => 'SET_FILE_INFO', + '$C4' => 'GET_FILE_INFO', + '$C5' => 'ON_LINE', + '$C6' => 'SET_PREFIX', + '$C7' => 'GET_PREFIX', + '$C8' => 'OPEN', + '$C9' => 'NEWLINE', + '$CA' => 'READ', + '$CB' => 'WRITE', + '$CC' => 'CLOSE', + '$CD' => 'FLUSH', + '$CE' => 'SET_MARK', + '$CF' => 'GET_MARK', + '$D0' => 'SET_EOF', + '$D1' => 'GET_EOF', + '$D2' => 'SET_BUF', + '$D3' => 'GET_BUF', + '$82' => 'GET_TIME', + '$40' => 'ALLOC_INTERRUPT', + '$41' => 'DEALLOC_INTERRUPT', + '$65' => 'QUIT', + '$80' => 'READ_BLOCK', + '$81' => 'WRITE_BLOCK', ); my %mgtk = ( - '$00' => 'NoOp', - '$01' => 'InitGraf', - '$02' => 'SetSwitches', - '$03' => 'InitPort', - '$04' => 'SetPort', - '$05' => 'GetPort', - '$06' => 'SetPortBits', - '$07' => 'SetPenMode', - '$08' => 'SetPattern', - '$09' => 'SetColorMasks', - '$0A' => 'SetPenSize', - '$0B' => 'SetFont', - '$0C' => 'SetTextBG', - '$0D' => 'Move', - '$0E' => 'MoveTo', - '$0F' => 'Line', - '$10' => 'LineTo', - '$11' => 'PaintRect', - '$12' => 'FrameRect', - '$13' => 'InRect', - '$14' => 'PaintBits', - '$15' => 'PaintPoly', - '$16' => 'FramePoly', - '$17' => 'InPoly', - '$18' => 'TextWidth', - '$19' => 'DrawText', - '$1A' => 'SetZP1', - '$1B' => 'SetZP2', - '$1C' => 'Version', - '$1D' => 'StartDeskTop', - '$1E' => 'StopDeskTop', - '$1F' => 'SetUserHook', - '$20' => 'AttachDriver', - '$21' => 'ScaleMouse', - '$22' => 'KeyboardMouse', - '$23' => 'GetIntHandler', - '$24' => 'SetCursor', - '$25' => 'ShowCursor', - '$26' => 'HideCursor', - '$27' => 'ObscureCursor', - '$28' => 'GetCursorAddr', - '$29' => 'CheckEvents', - '$2A' => 'GetEvent', - '$2B' => 'FlushEvents', - '$2C' => 'PeekEvent', - '$2D' => 'PostEvent', - '$2E' => 'SetKeyEvent', - '$2F' => 'InitMenu', - '$30' => 'SetMenu', - '$31' => 'MenuSelect', - '$32' => 'MenuKey', - '$33' => 'HiliteMenu', - '$34' => 'DisableMenu', - '$35' => 'DisableItem', - '$36' => 'CheckItem', - '$37' => 'SetMark', - '$38' => 'OpenWindow', - '$39' => 'CloseWindow', - '$3A' => 'CloseAll', - '$3B' => 'GetWinPtr', - '$3C' => 'GetWinPort', - '$3D' => 'SetWinPort', - '$3E' => 'BeginUpdate', - '$3F' => 'EndUpdate', - '$40' => 'FindWindow', - '$41' => 'FrontWindow', - '$42' => 'SelectWindow', - '$43' => 'TrackGoAway', - '$44' => 'DragWindow', - '$45' => 'GrowWindow', - '$46' => 'ScreenToWindow', - '$47' => 'WindowToScreen', - '$48' => 'FindControl', - '$49' => 'SetCtlMax', - '$4A' => 'TrackThumb', - '$4B' => 'UpdateThumb', - '$4C' => 'ActivateCtl', + '$00' => 'NoOp', + '$01' => 'InitGraf', + '$02' => 'SetSwitches', + '$03' => 'InitPort', + '$04' => 'SetPort', + '$05' => 'GetPort', + '$06' => 'SetPortBits', + '$07' => 'SetPenMode', + '$08' => 'SetPattern', + '$09' => 'SetColorMasks', + '$0A' => 'SetPenSize', + '$0B' => 'SetFont', + '$0C' => 'SetTextBG', + '$0D' => 'Move', + '$0E' => 'MoveTo', + '$0F' => 'Line', + '$10' => 'LineTo', + '$11' => 'PaintRect', + '$12' => 'FrameRect', + '$13' => 'InRect', + '$14' => 'PaintBits', + '$15' => 'PaintPoly', + '$16' => 'FramePoly', + '$17' => 'InPoly', + '$18' => 'TextWidth', + '$19' => 'DrawText', + '$1A' => 'SetZP1', + '$1B' => 'SetZP2', + '$1C' => 'Version', + '$1D' => 'StartDeskTop', + '$1E' => 'StopDeskTop', + '$1F' => 'SetUserHook', + '$20' => 'AttachDriver', + '$21' => 'ScaleMouse', + '$22' => 'KeyboardMouse', + '$23' => 'GetIntHandler', + '$24' => 'SetCursor', + '$25' => 'ShowCursor', + '$26' => 'HideCursor', + '$27' => 'ObscureCursor', + '$28' => 'GetCursorAddr', + '$29' => 'CheckEvents', + '$2A' => 'GetEvent', + '$2B' => 'FlushEvents', + '$2C' => 'PeekEvent', + '$2D' => 'PostEvent', + '$2E' => 'SetKeyEvent', + '$2F' => 'InitMenu', + '$30' => 'SetMenu', + '$31' => 'MenuSelect', + '$32' => 'MenuKey', + '$33' => 'HiliteMenu', + '$34' => 'DisableMenu', + '$35' => 'DisableItem', + '$36' => 'CheckItem', + '$37' => 'SetMark', + '$38' => 'OpenWindow', + '$39' => 'CloseWindow', + '$3A' => 'CloseAll', + '$3B' => 'GetWinPtr', + '$3C' => 'GetWinPort', + '$3D' => 'SetWinPort', + '$3E' => 'BeginUpdate', + '$3F' => 'EndUpdate', + '$40' => 'FindWindow', + '$41' => 'FrontWindow', + '$42' => 'SelectWindow', + '$43' => 'TrackGoAway', + '$44' => 'DragWindow', + '$45' => 'GrowWindow', + '$46' => 'ScreenToWindow', + '$47' => 'WindowToScreen', + '$48' => 'FindControl', + '$49' => 'SetCtlMax', + '$4A' => 'TrackThumb', + '$4B' => 'UpdateThumb', + '$4C' => 'ActivateCtl', ); $text =~ s/ diff --git a/bin/stats.pl b/bin/stats.pl index da468831..d311cfc3 100755 --- a/bin/stats.pl +++ b/bin/stats.pl @@ -19,31 +19,31 @@ my $depth = 0; while () { - s/;.*//; + s/;.*//; - ++$depth if m/\.proc/ || m/\.scope/; - --$depth if m/\.endproc/ || m/\.endscope/; + ++$depth if m/\.proc/ || m/\.scope/; + --$depth if m/\.endproc/ || m/\.endscope/; - next if m/\.assert|\.org|PAD_TO|ASSERT/; - s/\b[^L]\w+ \s* :?= \s* \$[0-9A-F]+//x; # trust assignments of absolutes + next if m/\.assert|\.org|PAD_TO|ASSERT/; + s/\b[^L]\w+ \s* :?= \s* \$[0-9A-F]+//x; # trust assignments of absolutes - if (m/^(L[0-9A-F]{4})(?::|\s+:=)(.*)/) { - my $def = $1; - $_ = $2; - $defs{$def} = ($defs{$def} // 0) + 1; - $unscoped{$def} = 1 if $depth < 2; - $scoped{$def} = 1 if $depth >= 2; - } + if (m/^(L[0-9A-F]{4})(?::|\s+:=)(.*)/) { + my $def = $1; + $_ = $2; + $defs{$def} = ($defs{$def} // 0) + 1; + $unscoped{$def} = 1 if $depth < 2; + $scoped{$def} = 1 if $depth >= 2; + } - foreach my $term (split /[ (),+\-*\/<>#:]/, $_) { - $term =~ s/\s+//g; - next unless $term; - if ($term =~ m/^L[0-9A-F]{4}$/) { - $refs{$term} = 1 + ($refs{$term} // 0); - } elsif ($term =~ m/^\$[0-9A-F]{4}$/) { - $raw{$term} = 1 + ($raw{$term} // 0); - } + foreach my $term (split /[ (),+\-*\/<>#:]/, $_) { + $term =~ s/\s+//g; + next unless $term; + if ($term =~ m/^L[0-9A-F]{4}$/) { + $refs{$term} = 1 + ($refs{$term} // 0); + } elsif ($term =~ m/^\$[0-9A-F]{4}$/) { + $raw{$term} = 1 + ($raw{$term} // 0); } + } } my $defs = scalar(keys %defs); @@ -52,20 +52,20 @@ my $scoped = scalar(keys %scoped); if ($command eq "unscoped") { - foreach my $def (sort keys %unscoped) { - print "$def\n"; - } + foreach my $def (sort keys %unscoped) { + print "$def\n"; + } } elsif ($command eq "scoped") { - foreach my $def (sort keys %scoped) { - print "$def\n"; - } + foreach my $def (sort keys %scoped) { + print "$def\n"; + } } elsif ($command eq "raw") { - foreach my $addr (sort keys %raw) { - print "$addr\n"; - } + foreach my $addr (sort keys %raw) { + print "$addr\n"; + } } elsif ($command eq "") { - printf("unscoped: %4d scoped: %4d raw: %4d\n", - $unscoped, $scoped, $raws); + printf("unscoped: %4d scoped: %4d raw: %4d\n", + $unscoped, $scoped, $raws); } else { - die "Unknown command: $command\n"; + die "Unknown command: $command\n"; } diff --git a/bin/targets.pl b/bin/targets.pl index 7660d81c..43c941b5 100755 --- a/bin/targets.pl +++ b/bin/targets.pl @@ -19,27 +19,27 @@ my @dirs = (); while () { - chomp(); - s/#.*$//g; - next unless $_; - - my ($target, $path, $disposition) = split(); - - if ($command eq "targets") { - print $target, "\n"; - } elsif ($command eq "dirs") { - push @dirs, $path; - } elsif ($command eq "") { - print $target, ",", $path, ",", $disposition, "\n"; - } else { - die "Unknown command: $command\n"; - } + chomp(); + s/#.*$//g; + next unless $_; + + my ($target, $path, $disposition) = split(); + + if ($command eq "targets") { + print $target, "\n"; + } elsif ($command eq "dirs") { + push @dirs, $path; + } elsif ($command eq "") { + print $target, ",", $path, ",", $disposition, "\n"; + } else { + die "Unknown command: $command\n"; + } } if ($command eq "dirs") { - my %hash; - @hash{@dirs} = (); - foreach my $dir (sort keys %hash) { - print $dir, "\n"; - } + my %hash; + @hash{@dirs} = (); + foreach my $dir (sort keys %hash) { + print $dir, "\n"; + } } diff --git a/bin/transcode.pl b/bin/transcode.pl index 982f4f15..a8a404bd 100755 --- a/bin/transcode.pl +++ b/bin/transcode.pl @@ -19,34 +19,34 @@ die "$0: dir must be 'to' or 'from'\n" unless $dir eq 'to' || $dir eq 'from'; while (<>) { - tr/\xA0/ / if $dir eq 'to'; # NBSP to regular space - - # Based on Apple IIgs Hardware Reference Table C-1 (with " incorrectly showing for °) - if ($lang eq 'fr') { - if ($dir eq 'from') { tr/#@[\\]`{|}~/£à°ç§`éùè¨/; } else { tr/£à°ç§`éùè¨/#@[\\]`{|}~/; } # ISO-646-FR (1973) / ISO-IR-025 - } elsif ($lang eq 'de') { - if ($dir eq 'from') { tr/#@[\\]`{|}~/#§ÄÖÜ`äöüß/; } else { tr/#§ÄÖÜ`äöüß/#@[\\]`{|}~/; } # ISO-646-DE / ISO-IR-021 - } elsif ($lang eq 'it') { - if ($dir eq 'from') { tr/#@[\\]`{|}~/£§°çéùàòèì/; } else { tr/£§°çéùàòèì/#@[\\]`{|}~/; } # ISO-646-IT / ISO-IR-015 - } elsif ($lang eq 'es') { - if ($dir eq 'from') { tr/#@[\\]`{|}~/£§¡Ñ¿`°ñç~/; } else { tr/£§¡Ñ¿`°ñç~/#@[\\]`{|}~/; } # ISO-646-ES / ISO-IR-017 - # unofficial extensions for A2D - if ($dir eq 'from') { tr/\x10-\x14/áéíóú/; } else { tr/áéíóú/\x10-\x14/; } - } elsif ($lang eq 'nl') { - # unofficial extensions for A2D - if ($dir eq 'from') { tr/\x10/ë/; } else { tr/ë/\x10/; } - } elsif ($lang eq 'da') { - if ($dir eq 'from') { tr/#@[\\]`{|}~/#@ÆØÅ`æøå~/; } else { tr/#@ÆØÅ`æøå~/#@[\\]`{|}~/; } # ISO-646-DK / CP01107 - } elsif ($lang eq 'sv') { - if ($dir eq 'from') { tr/#@[\\]`{|}~/#@ÄÖÅ`äöå~/; } else { tr/#@ÄÖÅ`äöå~/#@[\\]`{|}~/; } # ISO-646-SE / ISO-IR-010 (mostly) - } elsif ($lang eq 'pt') { - # Based on TK3000 - if ($dir eq 'from') { tr/#&@[\\]_`{|}~/õêáãâçàéíúôó/; } - else { tr/õêáãâçàéíúôó/#&@[\\]_`{|}~/; } - } elsif ($lang eq 'en') { - # no-op - } - else { die "$0: Unknown lang: $lang\n"; } - - print; + tr/\xA0/ / if $dir eq 'to'; # NBSP to regular space + + # Based on Apple IIgs Hardware Reference Table C-1 (with " incorrectly showing for °) + if ($lang eq 'fr') { + if ($dir eq 'from') { tr/#@[\\]`{|}~/£à°ç§`éùè¨/; } else { tr/£à°ç§`éùè¨/#@[\\]`{|}~/; } # ISO-646-FR (1973) / ISO-IR-025 + } elsif ($lang eq 'de') { + if ($dir eq 'from') { tr/#@[\\]`{|}~/#§ÄÖÜ`äöüß/; } else { tr/#§ÄÖÜ`äöüß/#@[\\]`{|}~/; } # ISO-646-DE / ISO-IR-021 + } elsif ($lang eq 'it') { + if ($dir eq 'from') { tr/#@[\\]`{|}~/£§°çéùàòèì/; } else { tr/£§°çéùàòèì/#@[\\]`{|}~/; } # ISO-646-IT / ISO-IR-015 + } elsif ($lang eq 'es') { + if ($dir eq 'from') { tr/#@[\\]`{|}~/£§¡Ñ¿`°ñç~/; } else { tr/£§¡Ñ¿`°ñç~/#@[\\]`{|}~/; } # ISO-646-ES / ISO-IR-017 + # unofficial extensions for A2D + if ($dir eq 'from') { tr/\x10-\x14/áéíóú/; } else { tr/áéíóú/\x10-\x14/; } + } elsif ($lang eq 'nl') { + # unofficial extensions for A2D + if ($dir eq 'from') { tr/\x10/ë/; } else { tr/ë/\x10/; } + } elsif ($lang eq 'da') { + if ($dir eq 'from') { tr/#@[\\]`{|}~/#@ÆØÅ`æøå~/; } else { tr/#@ÆØÅ`æøå~/#@[\\]`{|}~/; } # ISO-646-DK / CP01107 + } elsif ($lang eq 'sv') { + if ($dir eq 'from') { tr/#@[\\]`{|}~/#@ÄÖÅ`äöå~/; } else { tr/#@ÄÖÅ`äöå~/#@[\\]`{|}~/; } # ISO-646-SE / ISO-IR-010 (mostly) + } elsif ($lang eq 'pt') { + # Based on TK3000 + if ($dir eq 'from') { tr/#&@[\\]_`{|}~/õêáãâçàéíúôó/; } + else { tr/õêáãâçàéíúôó/#&@[\\]_`{|}~/; } + } elsif ($lang eq 'en') { + # no-op + } + else { die "$0: Unknown lang: $lang\n"; } + + print; } diff --git a/bin/unpackbytes.pl b/bin/unpackbytes.pl index d3f4d6ed..1139e886 100755 --- a/bin/unpackbytes.pl +++ b/bin/unpackbytes.pl @@ -5,33 +5,33 @@ $/ = \1; while () { - $_ = ord($_); - my $op = $_ & 0b11000000; - my $count = ($_ & 0b00111111) + 1; + $_ = ord($_); + my $op = $_ & 0b11000000; + my $count = ($_ & 0b00111111) + 1; - if ($op == 0b00000000) { - # 0b00...... = 1 to 64 bytes follow - all different - #print STDERR "Unpacking $count singleton(s)\n"; - while ($count--) { - my $byte = ; - print $byte; - } - } elsif ($op == 0b01000000) { - # 0b01...... = 3, 5, 6, or 7 repeats of next byte - my $byte = ; - #print STDERR "Unpacking $count repeats of $byte\n"; - print $byte x $count; - } elsif ($op == 0b10000000) { - # 0b10...... = 1 to 64 repeats of next 4 bytes - $/ = \4; - my $bytes = ; - $/ = \1; - #print STDERR "Unpacking $count repeats of quad $bytes\n"; - print $bytes x $count; - } else { - # 0b11...... = 1 to 64 repeats of next byte taken as 4 bytes - my $byte = ; - #print STDERR "Unpacking $count * 4 repeats of $byte\n"; - print $byte x ($count * 4); + if ($op == 0b00000000) { + # 0b00...... = 1 to 64 bytes follow - all different + #print STDERR "Unpacking $count singleton(s)\n"; + while ($count--) { + my $byte = ; + print $byte; } + } elsif ($op == 0b01000000) { + # 0b01...... = 3, 5, 6, or 7 repeats of next byte + my $byte = ; + #print STDERR "Unpacking $count repeats of $byte\n"; + print $byte x $count; + } elsif ($op == 0b10000000) { + # 0b10...... = 1 to 64 repeats of next 4 bytes + $/ = \4; + my $bytes = ; + $/ = \1; + #print STDERR "Unpacking $count repeats of quad $bytes\n"; + print $bytes x $count; + } else { + # 0b11...... = 1 to 64 repeats of next byte taken as 4 bytes + my $byte = ; + #print STDERR "Unpacking $count * 4 repeats of $byte\n"; + print $byte x ($count * 4); + } }