github.com/wfjm.w11
1
0
Fork 0
mirror of https://github.com/wfjm/w11.git synced 2026-01-13 15:37:43 +00:00
Code Issues Releases Wiki Activity
wfjm.w11/tools/bin/dasm-11

3764 lines
122 KiB
Perl
Executable File
Raw Blame History

#!/usr/bin/perl -w
# $Id: dasm-11 1286 2022-08-25 06:53:38Z mueller $
# SPDX-License-Identifier: GPL-3.0-or-later
# Copyright 2008-2022 by Walter F.J. Mueller <W.F.J.Mueller@gsi.de>
#
# Revision History:
# Date Rev Version Comment
# 2022-08-25 1286 1.4.12 add -I, .:$RETROBASE/tools/dasm-11/lib default path
# 2022-06-09 1246 1.4.11 fix -help, fix -dmode allowed values
# 2019-07-13 1189 1.4.10 drop superfluous exists for $opts
# 2019-05-07 1147 1.4.9 two bugfixes
# 2018-12-18 1089 1.4.8 add and use bailout
# 2013-04-02 503 1.4.7 BUGFIX: correct xor and fpp, now proper rg,gr form
# fix ccops, macro-11 compliant <sec|sen> like output
# 2013-04-01 502 1.4.6 allow input from STDIN ('-' as file name)
# 2013-02-23 492 1.4.5 renamed disasm->dasm-11
# 2010-04-26 284 1.4.4 add error check for GetOptions
# 2009-09-19 239 1.4.3 use %cp.psw for new psw in mov-mov-rti sequences
# 2009-07-04 231 1.4.2 propper from addr in "location not typed '.vect'.."
# 2009-06-20 227 1.4.1 BUGFIX: S### label to 2nd imm/ind now correct;
# BUGFIX: [IN]### autolabel only when no symbolization
# add character symbolization in asci[iz] via @chars
# 2009-06-14 226 1.4 support use=xxx after .type directive; support
# op[12]sym=xxx in null directive; cleanup vect.psw
# handling; support sym mode "."; .ascooo support;
# tag data when target in mov #addr,<pointer> is typed
# BUGFIX: now correct comment for mov #nnn,<vect*>
# 2009-06-11 225 1.3.10 support user auto-labels (xx*:)
# 2009-05-31 221 1.3.9 terminator of type*[] lists now word tagged;
# allow trailing ,code in .struct; add .tryret
# 2009-05-24 219 1.3.8 catch asciz tags running over end-of-mem; add --ttlc
# proper labcref handling for pointes in typlabcref()
# 2009-05-09 213 1.3.7 preliminary addition of cis instructions
# 2009-05-02 212 1.3.6 add @data {comstr} attribute -> full string comments
# 2009-04-26 209 1.3.5 fix print_usage();
# 2009-04-25 208 1.3.4 add vector name to vector setup lcomm
# 2009-04-12 207 1.3.3 add lcomm for all vector setup's
# 2009-04-09 205 1.3.2 no code tag for 0 after mov #0; datsym all Pxxx vars
# add --info to enable -I messages.
# 2009-04-05 204 1.3.1 add lblind option/handl.; add fp11-c maint. opcodes
# scomm non 1170 opcodes; reformat scomm's;
# add .patch
# 2009-04-04 203 1.3 don't follow NULL prt for <type>*; add .code!;
# code tag .vect handler; add anoemt option/handling
# don't emitt unused gsym's; add lblimm option/handl.
# don't V label catcher setup; add .susp option
# 2009-03-29 202 1.2.6 add {anno} attributes; handle %symset of 0 correctly
# 2009-03-27 201 1.2.5 correct usage of symchr option
# 2009-03-22 200 1.2.4 add forgotten $dsc->{pc_seq} to fpp instructions
# handle mov #nnn,pc; handle sob labels
# annotate fpp instructions
# 2008-07-13 158 1.2.3 fix jmp@xxx and jsr rx,@xxx; add label upgrades;
# implement cref output
# 2008-07-11 157 1.2.2 added .enabl/.dsabl support (sym***,lbliot);
# support use= attribute, use symset's in symbolize
# 2008-07-04 156 1.2.1 added dmp.gz support; add scomm for asci pointers
# 2008-06-29 155 1.2 Many improvements (new typespec system,...)
# 2008-06-22 154 1.1 Many improvements (labels, symsets, ....)
# 2008-06-18 153 1.0 Initial version
#
# Format of 'das' DisAssember Steering file:
#
# # das comment (not visible in output)
# @<fname> {read nested das file}
# .symbol <symbol> = <addr> <alist>
# .symset <symset> = <set definition>
# .struct <tlist> {defines a structure}
# .params (iot|bpt) <list of .word directives>
# .params (trap|emt) ooo[:ooo] <list of .word directives>
# ; line comment, will preceed the next statement
# oooooo : [label:] directive [;comment]
#
# with
# directives
# <none> --> just set label for location and/or comment
#
# .params <list of .word directives> --> params for jsr at oooooo
#
# .enabl <opt> [<val>]
# .dsabl <opt> [<val>]
# with
# symchr --> convert byte immediates -> #'x if ascii char
# symimm ooo --> convert word immediates -> #label if match and >ooo
# symind ooo --> convert index -> label if match and >ooo
# lbliot ooo --> auto label and scomm iot statements (start with ooo)
# anoemt ooo --> annotate emt instructions
# lblimm --> auto-create label for an immediate value
# lblind --> auto-create label for an index value
#
# .byte --> byte
# .ascii n --> .ascii /.../
# .asciz --> .asciz /.../
# .ascooo --> .ascii /.../ up to ooo terminator
# .code --> start of code sequence
# .vect --> interrupt/trap vector
# .<typespec> <alist>
# .params <tlist>
# .susp <option>
# .patch <addr> <value>
#
# Generated label types
# Annn: asciz/ascii targets {is a .asciz/.ascii directive}
# Bnnn: branch targets {from branch instructions}
# Rnnn: call targets {from jsr instructions}
# Cnnn: code targets {from jmp instructions}
# Dnnn: data targets {from memory access of an instruction}
# Innn: {from lblimm [anno=1]}
# Lnnn: das code start {from nnn: .code}
# Nnnn: {from lblind [anno=1]}
# Pnnn: pointer targets
# Snnn+: pointing into an instruction {self referencing/modifying code}
# Vnnn: vector handler {from mv #nnn,@#<vector>}
#
# ltyp/dtyp on cross refrence table
# ltyp
# albl auto-label from code following
# asym ? seems from lblimm or lblind
# data label from das (for data and code)
# gsym ? seems from .symbol or .symset
# rlbl (comes always with vect.psw)
#
# dtyp
# word 16 bit data word
# byte 8 bit data byte
# code instruction, opcode part
# code.imm instruction, immediate value part
# code.ind instruction, index value part
# vect interrupt vector, pointer to handler
# vect.psw interrupt vector, new psw value
# ascii ascii string value (not zero terminated)
# asciz ascii string zero terminated
# ascooo ascii string <ooo> terminated
# rad50 rad50 encoded string
# flt2 single precision float
# flt4 double precision float
# <type>* pointer to an address holding <type>
# with word,byte,code,asci[iz],rad50,flt[24] and
# $<struct>
use 5.14.0; # require Perl 5.14 or higher
use strict; # require strict checking
use FileHandle;
use Getopt::Long;
my %opts = ();
GetOptions(\%opts, "help", "das:s", "dmode:s", "start:s",
"I=s@",
"info",
"draw", "dtag", "tctag", "ttlc"
)
or bailout("bad command options");
# set up default include path
unshift @{$opts{I}}, "."; # ./ is first in include path
push @{$opts{I}}, "$ENV{RETROBASE}/tools/dasm-11/lib" if defined $ENV{RETROBASE};
sub load_data; # load dmp file
sub load_steer; # load das file
sub dump_data; # dump @data array status
sub tag_code; # paint all code sections
sub tag_undef; # tag all yet undefined words/bytes
sub tag_data; # paint all data sections
sub gather_ascii; # gather ascii, asciz, or ascooo string
sub gather_blkw; # gather blkw block
sub gather_blkb; # gather blkb block
sub pass_opts1; # handle some options (symimm)
sub pass_opts2; # handle most options (symxxx,lbliot,...)
sub do_lblimmind; # helper to handle lblimm and lblind
sub do_symimmind; # helper to handle symimm, symind and symchr
sub name_labels; # name all autogenerated labels
sub anal_inst; # analyse single instruction
sub anal_operand; # analyse src or dst operand specifier
sub anal_cisops; # analyse cis operands
sub get_regname; # return register name
sub set_type; # set type tag in @data
sub write_source; # write source or list file
sub print_info; # print messages on unnamed vect or i/o space
sub symbolize; # convert oooooo -> label
sub word2byte; # add {byte} values for a {word}
sub get_lpref; # return label prefix depending on tspec
sub set_typlabcref; # setup type, label and cref
sub set_labcref; # define auto label, add cref info
sub add_adrcref; # add cref entry in adrtbl
sub add_symcref; # add cref entry in symtbl
sub set_acslabel; # define auto label from acs info
sub set_option; # setup .enabl/.dsabl option
sub set_curopt; # update current option list %curopt
sub set_susopt; # restore suspended options
sub get_word; # return word data (or undef)
sub get_byte; # return byte data (or undef)
sub get_taddr; # return target address (or undef)
sub add_symbol; # add symbol in adrtbl and symtbl
sub add_adr_rlabel; # add relative label entry in adrtbl
sub add_adr_alist; # add attribute list to adrtbl entry
sub add_adr_attr; # add attribute to adrtbl entry
sub add_sym_attr; # add attribute to symtbl entry
sub add_dat_attr; # add attribute to data word/byte
sub add_dat_alist; # add attribute list for data
sub add_ops_alist; # add attribute list for code
sub add_ctpend; # add element in code tag pending list
sub add_lcomm; # add full line comment
sub add_scomm; # add statement comment
sub add_symset; # add a new %symsettbl entry
sub add_struct; # add a new %structtbl entry
sub add_params; # add a new %paramstbl entry
sub chk_typespec; # check validity of typespec (or list)
sub chk_byte; # check availability of byte (convert if needed)
sub chk_data; # check availability of data (word or byte)
sub chk_opcode; # check existence and content of {opcode}
sub chk_op1typ; # check existence and content of {op1typ}
sub chk_op2typ; # check existence and content of {op2typ}
sub chk_op2str; # check existence and content of {op2str}
sub chk_op2str; # check existence and content of {op2str}
sub chk_type; # check whether address is typed
sub convoct; # convert 16 bit int to %6.6o octal
sub get_numoctdec; # convert oct or dec number to binary
sub print_bugcheck; # print BUGCHECK message, with line number
sub print_help; # --help or error output
my $filename_dmp; # name of the input dmp file
my $fh_out = *STDOUT;
# @data --> data table; is array of hashes
# ->{word} 16 bit value if [addr]
# ->{byte} 8 bit value if [addr]
# ->{type} type of data:
# word 16 bit data word
# byte 8 bit data byte
# code instruction, opcode part
# code.imm instruction, immediate value part
# code.ind instruction, index value part
# vect interrupt vector, pointer to handler
# vect.psw interrupt vector, new psw value
# ascii ascii string value (not zero terminated)
# asciz ascii string zero terminated
# ascooo ascii string <ooo> terminated
# rad50 rad50 encoded string
# flt2 single precision float
# flt4 double precision float
# <type>* pointer to an address holding <type>
# with word,byte,code,asci[iz],rad50,flt[24] and
# $<struct>
# ->{nb} length in bytes of item (always given)
# ->{nw} length in words of item (for word aligned items)
# ->{ibase} address of item base address (for all but first in item)
# ->{dirstr} directive name (can be word,byte,ascii,asciz,.even)
# ->{argstr} directive args (must be defined when {dirstr} defined)
# ->{comstr} full asciz string (defined when {dirstr} eq asciz)
#
my @data;
# %adrtbl --> address table; is hash (by %6.6o addr) of hashs
# ->{addr} address as integer
# ->{typ} type: "gsym", "data", "albl", "asym", "rlbl"
# ->{string} symbol string (might not be unique, might be expression)
# ->{cref} cross reference hash (indexed by from address)
# ->{$from} ref type
# ->{use} symbolization options
#
my %adrtbl; # address table
# %symtbl --> symbol table; is hash (by symbol) of hashes
# ->{val} value as integer
# ->{typ} type: "gsym", "data", set name (%xxx, @xxx)
#
my %symtbl; # symbol table
# %symsettbl --> symbol set table; is hash (by setname) of arrays of hashs
# ->[]->{sym} symbol name
# ->[]->{val} symbol value
# ->[]->{msk} symbol mask (in case of % sets)
#
my %symsettbl;
my @ctpend; # code tag pending list
# %structtbl --> struct definition table; is hash (by struct name)
# ->[<array of typespecs>]
my %structtbl = ( # struct descriptor table
'$cisdsc'=> ["word","word*"]
);
my %paramstbl; # parameter descriptor table
# %opttbl --> options table; is hash (by option name)
# ->{ena} enable state
# ->{attr}->{} hash of option attributes
#
my %opttbl = (
symchr=> {ena => 0,
attr => {anno=>"n"},
anno => 0},
symimm=> {ena => 0,
attr => {anno=>"n",
min=>"n",
max=>"n"},
anno => 0,
min => 01000,
max => 0177700},
symind=> {ena => 0,
attr => {anno=>"n",
min=>"n",
max=>"n"},
anno => 0,
min => 01000,
max => 0177700},
symwrd=> {ena => 0,
attr => {anno=>"n",
min=>"n",
max=>"n"},
anno => 0,
min => 01000,
max => 0177700},
lblimm=> {ena => 0,
attr => {anno=>"n",
min=>"n",
max=>"n"},
anno => 0,
min => 01000,
max => 0177700},
lblind=> {ena => 0,
attr => {anno=>"n",
min=>"n",
max=>"n"},
anno => 0,
min => 01000,
max => 0177700},
lbliot=> {ena => 0,
attr => {tnum=>"n"},
tnum => 1},
anoemt=> {ena => 0,
attr => {tbl=>"l",
size=>"n",
max=>"n"},
tbl => "???",
size => 0,
max => 377}
);
my %curopt = (); # current option set
my @susp_restore; # list of suspend restores
my $dmode_opt;
#
# opcode type's:
# type example decsription
# 0arg halt no operands
# 1arg jmp @#1200 one mod/reg operand
# 2arg mov #100,2(r4) two mod/reg operand
# gr mul #12,r2 reg destination, mod/reg source operand
# rg jsr pc,@#1200 reg source form, one reg, one mod/reg operand
# rts rts pc one register operand
# br br 124 one 8 bit signed displacement operand
# sob sob r2,124 register operand, 6 bit displacement
# ccop clc one 4 bit operand, opcodes or'ed
# spl spl 7 one 3 bit operand
# mark mark 12 one 6 bit operand
# trap trap 123 one 8 bit operand
# 0fpp cfcc fpp: no operands
# gfpp clrf f0 fpp: one mod/reg operand
# grfpp addf a,f0 fpp: one mod/reg operand, fpp accumulator dst
# rgfpp stf f0,a fpp: fpp accumulator src, one mod/reg operand
#
my @opcode_tbl = (
{code=>0000000, mask=>0000000, mnem=>"halt", type=>"0arg"},
{code=>0000001, mask=>0000000, mnem=>"wait", type=>"0arg"},
{code=>0000002, mask=>0000000, mnem=>"rti", type=>"0arg"},
{code=>0000003, mask=>0000000, mnem=>"bpt", type=>"0arg"},
{code=>0000004, mask=>0000000, mnem=>"iot", type=>"0arg"},
{code=>0000005, mask=>0000000, mnem=>"reset", type=>"0arg"},
{code=>0000006, mask=>0000000, mnem=>"rtt", type=>"0arg"},
{code=>0000007, mask=>0000000, mnem=>"mfpt", type=>"0arg", cpu=>"j11"},
{code=>0000100, mask=>0000077, mnem=>"jmp", type=>"1arg", dst=>"j"},
{code=>0000200, mask=>0000007, mnem=>"rts", type=>"rts"},
{code=>0000230, mask=>0000007, mnem=>"spl", type=>"spl"},
{code=>0000240, mask=>0000017, mnem=>"cl", type=>"ccop"},
{code=>0000260, mask=>0000017, mnem=>"se", type=>"ccop"},
{code=>0000300, mask=>0000077, mnem=>"swab", type=>"1arg", dst=>"m"},
{code=>0000400, mask=>0000377, mnem=>"br", type=>"br"},
{code=>0001000, mask=>0000377, mnem=>"bne", type=>"br"},
{code=>0001400, mask=>0000377, mnem=>"beq", type=>"br"},
{code=>0002000, mask=>0000377, mnem=>"bge", type=>"br"},
{code=>0002400, mask=>0000377, mnem=>"blt", type=>"br"},
{code=>0003000, mask=>0000377, mnem=>"bgt", type=>"br"},
{code=>0003400, mask=>0000377, mnem=>"ble", type=>"br"},
{code=>0004000, mask=>0000777, mnem=>"jsr", type=>"rg", dst=>"e"},
{code=>0005000, mask=>0000077, mnem=>"clr", type=>"1arg", dst=>"w"},
{code=>0005100, mask=>0000077, mnem=>"com", type=>"1arg", dst=>"m"},
{code=>0005200, mask=>0000077, mnem=>"inc", type=>"1arg", dst=>"m"},
{code=>0005300, mask=>0000077, mnem=>"dec", type=>"1arg", dst=>"m"},
{code=>0005400, mask=>0000077, mnem=>"neg", type=>"1arg", dst=>"m"},
{code=>0005500, mask=>0000077, mnem=>"adc", type=>"1arg", dst=>"m"},
{code=>0005600, mask=>0000077, mnem=>"sbc", type=>"1arg", dst=>"m"},
{code=>0005700, mask=>0000077, mnem=>"tst", type=>"1arg", dst=>"r"},
{code=>0006000, mask=>0000077, mnem=>"ror", type=>"1arg", dst=>"m"},
{code=>0006100, mask=>0000077, mnem=>"rol", type=>"1arg", dst=>"m"},
{code=>0006200, mask=>0000077, mnem=>"asr", type=>"1arg", dst=>"m"},
{code=>0006300, mask=>0000077, mnem=>"asl", type=>"1arg", dst=>"m"},
{code=>0006400, mask=>0000077, mnem=>"mark", type=>"mark"},
{code=>0006500, mask=>0000077, mnem=>"mfpi", type=>"1arg", dst=>"r"},
{code=>0006600, mask=>0000077, mnem=>"mtpi", type=>"1arg", dst=>"w"},
{code=>0006700, mask=>0000077, mnem=>"sxt", type=>"1arg", dst=>"w"},
{code=>0007000, mask=>0000077, mnem=>"csm", type=>"1arg", cpu=>"j11"},
{code=>0007200, mask=>0000077, mnem=>"tstset",type=>"1arg", cpu=>"j11"},
{code=>0007300, mask=>0000077, mnem=>"wrtlck",type=>"1arg", cpu=>"j11"},
{code=>0010000, mask=>0007777, mnem=>"mov", type=>"2arg",
src=>"r", dst=>"w"},
{code=>0020000, mask=>0007777, mnem=>"cmp", type=>"2arg",
src=>"r", dst=>"r"},
{code=>0030000, mask=>0007777, mnem=>"bit", type=>"2arg",
src=>"r", dst=>"r"},
{code=>0040000, mask=>0007777, mnem=>"bic", type=>"2arg",
src=>"r", dst=>"m"},
{code=>0050000, mask=>0007777, mnem=>"bis", type=>"2arg",
src=>"r", dst=>"m"},
{code=>0060000, mask=>0007777, mnem=>"add", type=>"2arg",
src=>"r", dst=>"m"},
{code=>0070000, mask=>0000777, mnem=>"mul", type=>"gr", dst=>"r"},
{code=>0071000, mask=>0000777, mnem=>"div", type=>"gr", dst=>"r"},
{code=>0072000, mask=>0000777, mnem=>"ash", type=>"gr", dst=>"r"},
{code=>0073000, mask=>0000777, mnem=>"ashc", type=>"gr", dst=>"r"},
{code=>0074000, mask=>0000777, mnem=>"xor", type=>"rg", dst=>"m"},
{code=>0075000, mask=>0000007, mnem=>"fadd", type=>"1reg", cpu=>"fis"},
{code=>0075010, mask=>0000007, mnem=>"fsub", type=>"1reg", cpu=>"fis"},
{code=>0075020, mask=>0000007, mnem=>"fmul", type=>"1reg", cpu=>"fis"},
{code=>0075030, mask=>0000007, mnem=>"fdiv", type=>"1reg", cpu=>"fis"},
{code=>0076020, mask=>0000007, mnem=>"ld2r", type=>"crdd", cpu=>"cis"},
{code=>0076030, mask=>0000000, mnem=>"movc", type=>"0arg", cpu=>"cis"},
{code=>0076031, mask=>0000000, mnem=>"movrc", type=>"0arg", cpu=>"cis"},
{code=>0076032, mask=>0000000, mnem=>"movtc", type=>"0arg", cpu=>"cis"},
{code=>0076040, mask=>0000000, mnem=>"locc", type=>"0arg", cpu=>"cis"},
{code=>0076041, mask=>0000000, mnem=>"skpc", type=>"0arg", cpu=>"cis"},
{code=>0076042, mask=>0000000, mnem=>"scanc", type=>"0arg", cpu=>"cis"},
{code=>0076043, mask=>0000000, mnem=>"spanc", type=>"0arg", cpu=>"cis"},
{code=>0076044, mask=>0000000, mnem=>"cmpc", type=>"0arg", cpu=>"cis"},
{code=>0076045, mask=>0000000, mnem=>"matc", type=>"0arg", cpu=>"cis"},
{code=>0076050, mask=>0000000, mnem=>"addn", type=>"0arg", cpu=>"cis"},
{code=>0076051, mask=>0000000, mnem=>"subn", type=>"0arg", cpu=>"cis"},
{code=>0076052, mask=>0000000, mnem=>"cmpn", type=>"0arg", cpu=>"cis"},
{code=>0076053, mask=>0000000, mnem=>"cvtnl", type=>"0arg", cpu=>"cis"},
{code=>0076054, mask=>0000000, mnem=>"cvtpn", type=>"0arg", cpu=>"cis"},
{code=>0076055, mask=>0000000, mnem=>"cvtnp", type=>"0arg", cpu=>"cis"},
{code=>0076056, mask=>0000000, mnem=>"ashn", type=>"0arg", cpu=>"cis"},
{code=>0076057, mask=>0000000, mnem=>"cvtln", type=>"0arg", cpu=>"cis"},
{code=>0076060, mask=>0000007, mnem=>"ld3r", type=>"crddd",cpu=>"cis"},
{code=>0076070, mask=>0000000, mnem=>"addp", type=>"0arg", cpu=>"cis"},
{code=>0076071, mask=>0000000, mnem=>"subp", type=>"0arg", cpu=>"cis"},
{code=>0076072, mask=>0000000, mnem=>"cmpp", type=>"0arg", cpu=>"cis"},
{code=>0076073, mask=>0000000, mnem=>"cvtpl", type=>"0arg", cpu=>"cis"},
{code=>0076074, mask=>0000000, mnem=>"mulp", type=>"0arg", cpu=>"cis"},
{code=>0076075, mask=>0000000, mnem=>"divp", type=>"0arg", cpu=>"cis"},
{code=>0076076, mask=>0000000, mnem=>"ashp", type=>"0arg", cpu=>"cis"},
{code=>0076077, mask=>0000000, mnem=>"cvtlp", type=>"0arg", cpu=>"cis"},
{code=>0076130, mask=>0000000, mnem=>"movci", type=>"cdda", cpu=>"cis"},
{code=>0076131, mask=>0000000, mnem=>"movrci",type=>"cdda", cpu=>"cis"},
{code=>0076132, mask=>0000000, mnem=>"movtci",type=>"cddaa",cpu=>"cis"},
{code=>0076140, mask=>0000000, mnem=>"locci", type=>"cda", cpu=>"cis"},
{code=>0076141, mask=>0000000, mnem=>"skpci", type=>"cda", cpu=>"cis"},
{code=>0076142, mask=>0000000, mnem=>"scanci",type=>"cdd", cpu=>"cis"},
{code=>0076143, mask=>0000000, mnem=>"spanci",type=>"cdd", cpu=>"cis"},
{code=>0076144, mask=>0000000, mnem=>"cmpci", type=>"cdda", cpu=>"cis"},
{code=>0076145, mask=>0000000, mnem=>"matci", type=>"cdd", cpu=>"cis"},
{code=>0076150, mask=>0000000, mnem=>"addni", type=>"cddd", cpu=>"cis"},
{code=>0076151, mask=>0000000, mnem=>"subni", type=>"cddd", cpu=>"cis"},
{code=>0076152, mask=>0000000, mnem=>"cmpni", type=>"cdd", cpu=>"cis"},
{code=>0076153, mask=>0000000, mnem=>"cvtnli",type=>"cda", cpu=>"cis"},
{code=>0076154, mask=>0000000, mnem=>"cvtpni",type=>"cdd", cpu=>"cis"},
{code=>0076155, mask=>0000000, mnem=>"cvtnpi",type=>"cdd", cpu=>"cis"},
{code=>0076156, mask=>0000000, mnem=>"ashni", type=>"cdda", cpu=>"cis"},
{code=>0076157, mask=>0000000, mnem=>"cvtlni",type=>"cdd", cpu=>"cis"},
{code=>0076170, mask=>0000000, mnem=>"addpi", type=>"cddd", cpu=>"cis"},
{code=>0076171, mask=>0000000, mnem=>"subpi", type=>"cddd", cpu=>"cis"},
{code=>0076172, mask=>0000000, mnem=>"cmppi", type=>"cdd", cpu=>"cis"},
{code=>0076173, mask=>0000000, mnem=>"cvtpli",type=>"cda", cpu=>"cis"},
{code=>0076174, mask=>0000000, mnem=>"mulpi", type=>"cddd", cpu=>"cis"},
{code=>0076175, mask=>0000000, mnem=>"divpi", type=>"cddd", cpu=>"cis"},
{code=>0076176, mask=>0000000, mnem=>"ashpi", type=>"cdda", cpu=>"cis"},
{code=>0076177, mask=>0000000, mnem=>"cvtlpi",type=>"cdd", cpu=>"cis"},
{code=>0076600, mask=>0000000, mnem=>"med", type=>"0reg", cpu=>"11/60"},
{code=>0077000, mask=>0000777, mnem=>"sob", type=>"sob"},
{code=>0100000, mask=>0000377, mnem=>"bpl", type=>"br"},
{code=>0100400, mask=>0000377, mnem=>"bmi", type=>"br"},
{code=>0101000, mask=>0000377, mnem=>"bhi", type=>"br"},
{code=>0101400, mask=>0000377, mnem=>"blos", type=>"br"},
{code=>0102000, mask=>0000377, mnem=>"bvc", type=>"br"},
{code=>0102400, mask=>0000377, mnem=>"bvs", type=>"br"},
{code=>0103000, mask=>0000377, mnem=>"bcc", type=>"br"},
{code=>0103400, mask=>0000377, mnem=>"bcs", type=>"br"},
{code=>0104000, mask=>0000377, mnem=>"emt", type=>"trap"},
{code=>0104400, mask=>0000377, mnem=>"trap", type=>"trap"},
{code=>0105000, mask=>0000077, mnem=>"clrb", type=>"1arg", dst=>"w",
bytop=>1},
{code=>0105100, mask=>0000077, mnem=>"comb", type=>"1arg", dst=>"m",
bytop=>1},
{code=>0105200, mask=>0000077, mnem=>"incb", type=>"1arg", dst=>"m",
bytop=>1},
{code=>0105300, mask=>0000077, mnem=>"decb", type=>"1arg", dst=>"m",
bytop=>1},
{code=>0105400, mask=>0000077, mnem=>"negb", type=>"1arg", dst=>"m",
bytop=>1},
{code=>0105500, mask=>0000077, mnem=>"adcb", type=>"1arg", dst=>"m",
bytop=>1},
{code=>0105600, mask=>0000077, mnem=>"sbcb", type=>"1arg", dst=>"m",
bytop=>1},
{code=>0105700, mask=>0000077, mnem=>"tstb", type=>"1arg", dst=>"r",
bytop=>1},
{code=>0106000, mask=>0000077, mnem=>"rorb", type=>"1arg", dst=>"m",
bytop=>1},
{code=>0106100, mask=>0000077, mnem=>"rolb", type=>"1arg", dst=>"m",
bytop=>1},
{code=>0106200, mask=>0000077, mnem=>"asrb", type=>"1arg", dst=>"m",
bytop=>1},
{code=>0106300, mask=>0000077, mnem=>"aslb", type=>"1arg", dst=>"m",
bytop=>1},
{code=>0106400, mask=>0000077, mnem=>"mtps", type=>"1arg", dst=>"r",
cpu=>"j11"},
{code=>0106500, mask=>0000077, mnem=>"mfpd", type=>"1arg", dst=>"r"},
{code=>0106600, mask=>0000077, mnem=>"mtpd", type=>"1arg", dst=>"w"},
{code=>0106700, mask=>0000077, mnem=>"mfps", type=>"1arg", dst=>"w",
cpu=>"j11"},
{code=>0110000, mask=>0007777, mnem=>"movb", type=>"2arg",
src=>"r", dst=>"w", bytop=>1},
{code=>0120000, mask=>0007777, mnem=>"cmpb", type=>"2arg",
src=>"r", dst=>"r", bytop=>1},
{code=>0130000, mask=>0007777, mnem=>"bitb", type=>"2arg",
src=>"r", dst=>"r", bytop=>1},
{code=>0140000, mask=>0007777, mnem=>"bicb", type=>"2arg",
src=>"r", dst=>"m", bytop=>1},
{code=>0150000, mask=>0007777, mnem=>"bisb", type=>"2arg",
src=>"r", dst=>"m", bytop=>1},
{code=>0160000, mask=>0007777, mnem=>"sub", type=>"2arg",
src=>"r", dst=>"m"},
{code=>0170000, mask=>0000000, mnem=>"cfcc", type=>"0fpp"},
{code=>0170001, mask=>0000000, mnem=>"setf", type=>"0fpp"},
{code=>0170002, mask=>0000000, mnem=>"seti", type=>"0fpp"},
{code=>0170003, mask=>0000000, mnem=>"ldub", type=>"0fpp", cpu=>"fp11"},
{code=>0170004, mask=>0000000, mnem=>"mns", type=>"0fpp", cpu=>"fp11"},
{code=>0170005, mask=>0000000, mnem=>"sta0", type=>"0fpp", cpu=>"fp11"},
{code=>0170007, mask=>0000000, mnem=>"stq0", type=>"0fpp", cpu=>"fp11"},
{code=>0170011, mask=>0000000, mnem=>"setd", type=>"0fpp"},
{code=>0170012, mask=>0000000, mnem=>"setl", type=>"0fpp"},
{code=>0170100, mask=>0000077, mnem=>"ldfps", type=>"gfpp", dst=>"r"},
{code=>0170200, mask=>0000077, mnem=>"stfps", type=>"gfpp", dst=>"w"},
{code=>0170300, mask=>0000077, mnem=>"stst", type=>"gfpp", dst=>"w"},
{code=>0170400, mask=>0000077, mnem=>"clrf", type=>"gfpp", dst=>"w"},
{code=>0170500, mask=>0000077, mnem=>"tstf", type=>"gfpp", dst=>"r"},
{code=>0170600, mask=>0000077, mnem=>"absf", type=>"gfpp", dst=>"m"},
{code=>0170700, mask=>0000077, mnem=>"negf", type=>"gfpp", dst=>"m"},
{code=>0171000, mask=>0000377, mnem=>"mulf", type=>"grfpp", dst=>"r"},
{code=>0171400, mask=>0000377, mnem=>"modf", type=>"grfpp", dst=>"r"},
{code=>0172000, mask=>0000377, mnem=>"addf", type=>"grfpp", dst=>"r"},
{code=>0172400, mask=>0000377, mnem=>"ldf", type=>"grfpp", dst=>"r"},
{code=>0173000, mask=>0000377, mnem=>"subf", type=>"grfpp", dst=>"r"},
{code=>0173400, mask=>0000377, mnem=>"cmpf", type=>"grfpp", dst=>"r"},
{code=>0174000, mask=>0000377, mnem=>"stf", type=>"rgfpp", dst=>"w"},
{code=>0174400, mask=>0000377, mnem=>"divf", type=>"grfpp", dst=>"r"},
{code=>0175000, mask=>0000377, mnem=>"stexp", type=>"rgfpp", dst=>"w"},
{code=>0175400, mask=>0000377, mnem=>"stcif", type=>"rgfpp", dst=>"w"},
{code=>0176000, mask=>0000377, mnem=>"stcfd", type=>"rgfpp", dst=>"w"},
{code=>0176400, mask=>0000377, mnem=>"ldexp", type=>"grfpp", dst=>"r"},
{code=>0177000, mask=>0000377, mnem=>"ldcif", type=>"grfpp", dst=>"r"},
{code=>0177400, mask=>0000377, mnem=>"ldcdf", type=>"grfpp", dst=>"r"}
);
# Note: the keys in %adr_info_tbl are 6 digit octal numbers. They must be
# put in '' quotes explicitely, otherwise perl converts them first to
# a number and then back into a string, but decimal without leading 0.
my %adr_info_vect = (
'000004' => "v..iit .vect missed ?",
'000010' => "v..rit .vect missed ?",
'000014' => "v..bpt .vect missed ?",
'000020' => "v..iot .vect missed ?",
'000024' => "v..pwr .vect missed ?",
'000030' => "v..emt .vect missed ?",
'000034' => "v..trp .vect missed ?",
'000060' => "v..tti .vect missed ?",
'000064' => "v..tto .vect missed ?",
'000070' => "v..ptr .vect missed ?",
'000074' => "v..ptp .vect missed ?",
'000100' => "v..kwl .vect missed ?",
'000104' => "v..kwp .vect missed ?",
'000114' => "v..mse .vect missed ?",
'000120' => "v..deu .vect missed ?",
'000160' => "v..rl .vect missed ?",
'000200' => "v..lp .vect missed ?",
'000220' => "v..rk .vect missed ?",
'000224' => "v..tm .vect missed ?",
'000240' => "v..pir .vect missed ?",
'000244' => "v..fpp .vect missed ?",
'000250' => "v..mmu .vect missed ?",
'000254' => "v..rha .vect missed ?",
'000260' => "v..iis .vect missed ?"
);
my @adr_info_iopage = (
[0177760, 0177775, "1170 reg missed ?"],
[0177740, 0177753, "1170 reg missed ?"],
[0177600, 0177677, "MMU pdr missed ?"],
[0177572, 0177577, "MMU ssr missed ?"],
[0177570, 0177571, "DISP/SW missed ?"],
[0177560, 0177567, "DL11 1st missed ?"],
[0177546, 0177547, "KW11-L missed ?"],
[0177570, 0177571, "DISP/SW missed ?"],
[0177514, 0177517, "LP11 missed ?"],
[0177500, 0177503, "IIST missed ?"],
[0177440, 0177477, "RK06 missed ?"],
[0177400, 0177417, "RK11 missed ?"],
[0177170, 0177173, "RX11 missed ?"],
[0177160, 0177165, "CR11 missed ?"],
[0177060, 0177061, "XOR Test missed ?"],
[0176700, 0176753, "RH70 missed ?"],
[0176500, 0176507, "DL11 2nd missed ?"],
[0174510, 0174517, "DEUNA missed ?"],
[0174400, 0174411, "RL11 missed ?"],
[0173000, 0173177, "m9312 boot missed ?"],
[0172540, 0172545, "KW11-P missed ?"],
[0172520, 0172533, "TM11 missed ?"],
[0172516, 0172517, "MMU ssr missed ?"],
[0172200, 0172377, "MMU pdr missed ?"],
[0172150, 0172153, "UDA50 missed ?"],
[0170200, 0170377, "UBMAP missed ?"],
[0165000, 0165777, "m9312 diag missed ?"],
[0160500, 0160517, "DH11 missed ?"],
[0160100, 0160107, "DZ11 missed ?"]
);
use constant BIT00 => 0000001;
use constant BIT01 => 0000002;
use constant BIT02 => 0000004;
use constant BIT03 => 0000010;
use constant BIT04 => 0000020;
use constant BIT05 => 0000040;
use constant BIT06 => 0000100;
use constant BIT07 => 0000200;
use constant BIT08 => 0000400;
use constant BIT09 => 0001000;
use constant BIT10 => 0002000;
use constant BIT11 => 0004000;
use constant BIT12 => 0010000;
use constant BIT13 => 0020000;
use constant BIT14 => 0040000;
use constant BIT15 => 0100000;
#
# -- Main program starts here ------------------------------------------------
#
autoflush STDOUT 1 if (-p STDOUT); # autoflush if output into pipe
autoflush STDOUT 1 if (-t STDOUT); # autoflush if output into term
if ($opts{help}) {
print_help();
exit 0;
}
bailout("specify one and only one data file") if (scalar(@ARGV) != 1);
$filename_dmp = $ARGV[0];
load_data($filename_dmp);
if (exists $opts{dmode}) {
if ($opts{dmode} =~ m{^(word|asciz|code)$} ) {
$dmode_opt = $opts{dmode};
} else {
print STDERR "dasm-11-E: word,asciz,code allowed for -dmode\n";
}
}
if (exists $opts{start}) {
my @alist = split /,/, $opts{start};
foreach my $addr (@alist) {
if ($addr =~ m{^[0-7]+$} ) {
add_ctpend(oct $addr, "--start");
} else {
print STDERR "dasm-11-E: only octal values allowed for -start\n";
}
}
}
if (exists $opts{das}) {
load_steer($opts{das});
} elsif ($filename_dmp =~ m{^(.*)\.dmp(\.gz)?$} ) {
my $filename_das = $1 . ".das";
if (-r $filename_das) {
load_steer($filename_das);
}
}
dump_data() if $opts{draw};
tag_code();
pass_opts1(); # FIXME: opts1 must run before
# tag_undef, otherwise
# data is merged (why???)
tag_undef(); # FIXME: tag_undef can tag code
tag_code() if scalar(@ctpend);
tag_data();
pass_opts2();
name_labels();
dump_data() if $opts{dtag};
write_source();
print_info() if $opts{info};
#-------------------------------------------------------------------------------
sub load_data { # load dmp file
my ($file) = @_;
my $fh;
if ($file eq '-') {
$fh = *STDIN;
} else {
bailout("input file '$file' not found") if (not -r $file);
$fh = new FileHandle;
if ($file =~ m{\.gz$}) {
$fh->open("gunzip -c $file|")
or bailout("Failed to open/unzip '$file': $!");
} else {
$fh->open("<$file")
or bailout("Failed to open data file '$file': $!");
}
}
while (<$fh>) {
chomp;
if ( m{^\s*([0-7]+)\s*:\s*([0-7]+)\s*$} ) {
my $addr = oct $1;
my $val = oct $2;
$data[$addr] = {word => $val};
} else {
print STDERR "dasm-11-E: bad data line \"$_\"\n";
}
}
}
#-------------------------------------------------------------------------------
sub load_steer { # load das file
my ($file) = @_;
my $fh = new FileHandle;
my @lcomm;
# locate das file in -I path
my $fnam = $file;
unless ($fnam =~ m|^/|) {
foreach (@{$opts{I}}) {
if (-r "$_/$fnam") {
$fnam = "$_/$fnam";
last;
}
}
}
bailout("file steer file '$file' not found") if (not -r $fnam);
$fh->open("<$fnam");
while (<$fh>) {
chomp;
while ( m{\\$} ) { # ends with \ --> get continuation line
my $cline = <$fh>;
last if not defined $cline;
chomp $cline;
$cline =~ s/^\s*//; # drop leading blanks of continuation
s/\\$//; # drop trailing \
$_ .= $cline; # and append continuation line
}
next if m{^#} ; # ignore # comment
next if m{^\s*$} ; # ignore empty line
s{^\s*}{}; # drop leading blanks
s{\s*$}{}; # drop trailing blanks
if ( m{^;} ) { # ;<line comment>
push @lcomm, $_;
next;
}
my $cmd = $_;
my $comm;
if ( m{^
(.+?) # any command --> $1
\s* #
(;.*) # ; comment --> $2
$ }x ) {
$cmd = $1;
$comm = $2;
}
if ($cmd =~ m{^\@(.+)$} ) { # @filename -> nested files
load_steer($1);
# .struct directive
} elsif ($cmd =~ m{
^\.struct \s+ # .struct
(\$[a-zA-Z][a-zA-Z0-9]*) # <name> --> $1
\s* = \s* # =
(.*?) # <tspec-list> --> $2
$ }x ) {
add_struct($1, $2);
# .params iot|bpt <list>
} elsif ($cmd =~ m{
^\.params \s+ # .params
(iot|bpt) \s+ # <trap_inst> --> $1
(.+) # <tspec-list> --> $2
$ }x ) {
add_params($1, $2);
# .params emt|trap ooo[:ooo] <list>
} elsif ($cmd =~ m{
^\.params \s+ # .params
(emt|trap) \s+ # <trap_inst> --> $1
([0-7]{1,3}) # <trap_num> --> $2
(:?) # : ? --> $3
([0-7]{0,3}) \s+ # <trap_numhigh> --> $4
(.+) # <tspec_list> --> $5
$ }x ) {
my $opcode = $1;
my $rlow = $2;
my $rdel = $3;
my $rhigh = $4;
my $plist = $5;
my $beg = oct $rlow;
my $end = ($rdel) ? oct $rhigh : $beg;
for (my $i=$beg; $i<=$end; $i++) {
my $name = sprintf "%s %3.3o", $opcode, $i;
add_params($name, $plist);
}
# .symbol <symbol> = <addr> <alist>
} elsif ($cmd =~ m{
^\.symbol \s+ # .symbol
([a-zA-Z\$\.][a-zA-Z0-9\$\.]*) # <symname> --> $1
\s* = \s* # =
([0-7]+) # <addr> --> $2
( (
\s+
[a-zA-Z][a-zA-Z0-9]* # <name>
= # =
\S+ # <value>
)* # <alist> --> $3
)
$ }x ) {
my $gsym = $1;
my $addr = oct $2;
my $alist = $3;
add_symbol($addr, $gsym, "gsym");
add_adr_alist(convoct($addr), $alist) if defined $alist;
add_sym_attr($gsym, "scomm", $comm) if defined $comm;
# .symset <symset> = <set definition>
} elsif ($cmd =~ m{
^\.symset \s+ # .symset
([\@\%][a-zA-Z][a-zA-Z0-9\.]*) # <setname> --> $1
\s* = \s* # =
(.*?) # <setdef> --> $2
$ }x ) {
my $setname = $1;
my $setdef = $2;
add_symset($setname, $setdef);
# .(en|ds)abl <option> <attr-list>
} elsif ($cmd =~ m{
^(\.enabl|\.dsabl) \s+ # .enabl or .dsabl --> $1
([a-zA-z][a-zA-Z0-9]*) # <option> --> $2
((\s+.+?)*) # <attr_list> --> $3
$ }x ) {
my $ends = $1;
my $opt = $2;
my $attr = $3;
set_option(undef, $ends, $opt, $attr);
# .patch <addr> <value>
} elsif ($cmd =~ m{
^\.patch \s+ # .patch
([0-7]+) \s+ # <addr> --> $1
([0-7]+) # <value> --> $2
$ }x ) {
my $addr = oct $1;
my $val = oct $2;
$data[$addr] = {word => $val};
add_scomm($addr, $comm) if $comm;
# <addr> : <das_stmt>
} elsif ($cmd =~ m{
^([0-7]+) # <addr> --> $1
\s* : \s* # :
(.*?) # <statement> --> $2
$ }x ) {
my $addr = oct $1;
my $stmt = $2;
my $label;
my $dire = $stmt;
if (scalar(@lcomm)) { # any previous lcomm's
foreach (@lcomm) { add_lcomm($addr, $_); } # store with addr
@lcomm = (); # reset lcomm list
}
if ($stmt =~ m{ # strip off label
^([a-zA-Z\$\.][a-zA-Z0-9\$\.]*|[a-zA-Z]+\*) # <label> --> $1
\s* : \s* # :
(.*) # <directive> --> $2
$ }x ) {
$label = $1;
$dire = $2;
my $dtyp = chk_data($addr);
if ($dtyp) {
if ($label =~ m{\*$}) { # user auto-label
my $lpref = $label;
$lpref =~ s/\*$//;
set_labcref($addr, $lpref);
} else { # user label
add_symbol($addr, $label, "data");
}
} else {
printf STDERR "dasm-11-E: label '%s' defined but no data for %6.6o," .
"will be ignored\n", $label, $addr;
}
}
if (defined $comm) { # comments available ?
if ($comm =~ m{^;\|} ) { # inline lcomm
add_lcomm($addr, $comm);
} else { # scomm
my $text = $comm;
$text =~ s{^;\s*}{}; # strip leading "; "
add_scomm($addr, $text);
}
}
# .dmode <type>
if ($dire =~ m{
^.dmode # .dmode
\s+
(byte|word|code|
asci[iz]|asc[0-7]{3}|
rad50|flt[24]) # <type> --> $1
$ }x ) {
$data[$addr]->{dmode} = $1;
# .vect
} elsif ($dire eq ".vect") { # .vect
set_type($addr , "vect");
my $vh = get_word($addr);
if (defined $vh && chk_data($vh) eq "w" && # point to data
$vh != 0 && # not null
$vh != $addr+2) { # not catcher
##printf STDERR "+++1 %6.6o -> %6.6o\n", $addr, $vh;
set_typlabcref($vh, "code", "V"); # tag it
set_typlabcref($addr, "code*"); # FIXME: wmy this ????
}
# .<typespec> <alist>
} elsif ($dire =~ m{
^\.(byte|word|code!?| # base types
asci[iz]|asc[0-7]{3}| # or asc types
rad50|flt[24]|vect| # or ext. types
\$[a-zA-Z][a-zA-Z0-9]*) # or structs -->$1
([\*\[\]\d\.]*) # range -->$2
( (
\s+
[a-zA-Z][a-zA-Z0-9]* # <name>
= # =
\S+ # <value>
)* # <alist> --> $3
)
$ }x ) {
my $tspec = $1.$2;
my $alist = $3;
set_typlabcref($addr, $tspec, "L");
add_dat_alist($addr, $alist) if defined $alist;
# .params <plist>
} elsif ($dire =~ m{
^\.params # .params
\s+
(.*) # <plist> --> $1
$ }x ) {
my $plist = $1;
my $name = sprintf "jsr %6.6o", $addr;
add_params($name, $plist);
# .(en|ds)abl <option> <attr-list>
} elsif ($dire =~ m{
^(\.enabl|\.dsabl) \s+ # .enabl or .dsabl --> $1
([a-zA-z][a-zA-Z0-9]*) # <option> --> $2
((\s+.+?)*) # <attr_list> --> $3
$ }x ) {
my $ends = $1;
my $opt = $2;
my $attr = $3;
set_option($addr, $ends, $opt, $attr);
# .susp <option>
} elsif ($dire =~ m{
^\.susp \s+ # .susp
([a-zA-z][a-zA-Z0-9]*) # <option> --> $1
$ }x ) {
my $opt = $1;
my $dsc = $data[$addr];
push @{$dsc->{optlist}}, { susp => $opt };
# 'null' directive, just <alist>
} elsif ($dire =~ m{
^( (
\s*
[a-zA-Z][a-zA-Z0-9]* # <name>
= # =
\S+ # <value>
)* # <alist> --> $1
)
$ }x ) {
my $alist = $1;
add_ops_alist($addr, $alist);
} else {
print STDERR "dasm-11-E: unknown steer directive: '$_'\n";
}
} else {
print STDERR "dasm-11-E: unknown steer directive: '$_'\n";
}
}
$fh->close();
}
#-------------------------------------------------------------------------------
sub dump_data { # dump @data array status
my $iend = scalar(@data);
for (my $i = 0; $i < $iend; $i++) {
my $dsc = $data[$i];
next if not defined $dsc;
my $dat = "";
$dat = sprintf "%6.6o", $dsc->{word} if exists $dsc->{word};
$dat = sprintf "%3.3o ", $dsc->{byte} if exists $dsc->{byte};
printf "%6.6o : %s", $i, $dat;
printf " type=%s", $dsc->{type} if $dat ne "" && defined $dsc->{type};
print "\n";
my $col = 0;
foreach my $key (sort keys %{$dsc} ) {
if ($key !~ m{^(word|byte|type|nzero|src_val|dst_val)$} ) {
my $val = $dsc->{$key};
my $len = length($key) + 3 + length($val);
if ($col && $col+$len > 68) {
print "\n";
$col = 0;
}
if ($col == 0) {
print " " x 10;
}
if ($val =~ m{^[0-9a-zA-Z\$\.\@\#]*$} ) {
printf " %s=%s;", $key, $val;
$col += $len;
} else {
printf " %s=\"%s\";", $key, $val;
$col += $len + 2;
}
}
}
print "\n" if ($col);
}
}
#-------------------------------------------------------------------------------
sub tag_code { # paint all code sections
my $ctdsc;
while (defined ($ctdsc = shift @ctpend)) { # loop over code starts to be done
my $pc = $ctdsc->{addr};
my $from = $ctdsc->{from};
my $type = $data[$pc]->{type};
next if defined $type && $type =~ m{^code} ;
printf "ctag: %6.6o queued from %s\n", $pc, $from if $opts{tctag};
while (defined $pc) { # loop over code segment
my $dsc = $data[$pc];
my $type = $dsc->{type};
if (defined $type) {
last if $type =~ m{^code} ;
if ($type =~ m{^vect}) {
add_scomm($pc, "!!vect overlay!!");
} else {
add_scomm($pc, "!!code tag stop!!");
last;
}
}
my $nw = anal_inst($pc);
if ($nw) { # valid instruction
my $opcode = $dsc->{opcode};
if (defined $dsc->{pc_jmp} && # branch label needed ?
$opcode ne "jmp" && $opcode ne "jsr") {
set_labcref($dsc->{pc_jmp}, "B", $pc, lc("B"));
if ($opcode eq "sob") { # FIXME: fragile code
$dsc->{op2sym} = "1" unless defined $dsc->{op2sym};
} else {
$dsc->{op1sym} = "1" unless defined $dsc->{op1sym};
}
}
my $op1sym = set_acslabel($dsc->{op1acs}, $dsc->{op1typ},
$dsc->{op1eai}, $pc);
my $op2sym = set_acslabel($dsc->{op2acs}, $dsc->{op2typ},
$dsc->{op2eai}, $pc);
$dsc->{op1sym} = "1" if $op1sym && ! defined $dsc->{op1sym};
$dsc->{op2sym} = "1" if $op2sym && ! defined $dsc->{op2sym};
if ($opcode =~ m{^(bpt|iot|emt|trap|jsr)$} ) { # params ?
my $key = $opcode;
if ($opcode eq "emt" || $opcode eq "trap") {
$key .= " " . $dsc->{op1str};
} elsif ($opcode eq "jsr") {
my $op2eai = $dsc->{op2eai};
my $op2typ = $dsc->{op2typ};
if (defined $op2typ && $op2typ eq "addr") {
$key .= sprintf " %6.6o", $op2eai;
}
}
##printf "+++1 $key\n";
if (defined $paramstbl{$key}) {
my $noret = 0;
my $skipret = 0;
my $p = $pc + 2*$nw;
foreach my $ptyp (@{$paramstbl{$key}}) {
if ($ptyp eq ".noret") {
$noret = 1;
} elsif ($ptyp eq ".tryret") {
$noret = (chk_type($p)) ? 1 : 0;
} elsif ($ptyp eq ".skipret") {
$skipret = 1;
} else {
my $nb_pi = set_typlabcref($p, $ptyp);
$p += $nb_pi;
}
}
$dsc->{pc_seq} = $p;
if ($noret) {
delete $dsc->{pc_seq};
}
if ($skipret) {
add_ctpend($p+2, ".skipret");
}
}
}
if ($opcode eq "mov") { # vector setup ?
my $op1eai = $dsc->{op1eai};
my $op2eai = $dsc->{op2eai};
my $vaddr;
if (chk_op1typ($pc, "const") && # mov #addr,...
defined $op2eai) { # dst address known
my $targ_addr;
my $targ_type;
if (chk_op2typ($pc, "addr")) {
$targ_addr = $op2eai;
$targ_type = $data[$op2eai]->{type};
} elsif (chk_op2typ($pc, "iaddr")) {
$targ_addr = get_word($op2eai);
if ($targ_addr &&
defined $data[$targ_addr]->{type}) {
$targ_type = $data[$targ_addr]->{type};
} else {
$targ_type = $data[$op2eai]->{type};
if ($targ_type) {
if ($targ_type =~ m/(.*)\*$/) {
$targ_type = $1;
} else {
$targ_type = undef;
}
}
}
}
if ($targ_type) {
if ($targ_type eq "vect" &&
(not chk_type($op1eai, "vect.psw"))) {
set_labcref($op1eai, "V", $pc, "i");
$dsc->{op1sym} = "1";
add_ctpend($op1eai, convoct($pc));
if (defined $targ_addr && # target ok
$adrtbl{convoct($op1eai)}->{string} =~ m{^V#####$}) {# !lbl
my $vlbl = "";
my $taddr_str = convoct($targ_addr);
if (exists $adrtbl{$taddr_str} &&
defined $adrtbl{$taddr_str}->{string} &&
$adrtbl{$taddr_str}->{string} !~ m{#####$}) {
$vlbl = "(" . $adrtbl{$taddr_str}->{string} . ")";
}
my $lcomm =
sprintf ("; vector %3.3o %s handler setup at %6.6o",
$targ_addr, $vlbl, $pc);
add_lcomm($op1eai, $lcomm);
}
} elsif ($targ_type =~ m/(.*)\*$/) {
my $tag_type = $1;
my $lpref = get_lpref($tag_type);
if ($tag_type eq "code") {
set_labcref($op1eai, "C", $pc, "i");
$dsc->{op1sym} = "1";
add_ctpend($op1eai, convoct($pc));
} elsif ($tag_type =~ m/(word|byte)/) {
set_labcref($op1eai, "D", $pc, "i");
$dsc->{op1sym} = "1";
} else {
set_typlabcref($op1eai, $tag_type, $lpref, $pc , "i");
$dsc->{op1sym} = "1";
}
}
}
}
}
if ($opcode eq "halt") { # halt followed by br or jmp ?
my $p = $pc + 2;
my $next = get_word($p);
if (defined $next && # next address has data
(not defined $data[$p]->{type})) { # and is not yet tagged
if (($next & 0177400) == 000400 || # code for br
($next & 0177700) == 000100) { # code for jmp
$dsc->{pc_seq} = $p; # consider that halt continues
add_ctpend($p, convoct($pc)); # declare 'br .-2' as code
}
}
}
# look for code sequence like
# mov #newpsw, -(sp) (optional)
# mov #newaddr,-(sp)
# rti
# and code tag 'newaddr' and use '%cp.psw' for newpsw
#
if ($opcode =~ m{^rt[it]$} ) { # mode changer via rti/rtt ?
if (chk_opcode($pc-4, "mov") &&
chk_op1typ($pc-4, "const") &&
(chk_op2str($pc-4, "-(sp)") || # --> mov #addr,-(sp) ??
chk_op2str($pc-4, "(sp)"))) { # --> mov #addr,(sp) ??
$data[$pc-4]->{op1sym} = "1";
my $pc_vec = $data[$pc-4]->{op1eai}; # get #addr
if ($pc_vec == $pc + 2) { # if target just after rti
$dsc->{pc_seq} = $pc_vec; # declare sequential exec
}
set_labcref($pc_vec, "C", $pc-4, "i");
add_ctpend($pc_vec, convoct($pc)); # declare target as code
if (chk_opcode($pc-8, "mov") &&
chk_op1typ($pc-8, "const") &&
(chk_op2str($pc-8, "-(sp)") || # --> mov #psw,-(sp) ??
chk_op2str($pc-8, "(sp)"))) {
if (! defined $data[$pc-8]->{op1sym} &&
exists $symsettbl{'%cp.psw'} ) {
$data[$pc-8]->{op1sym} = "%cp.psw";
}
}
}
}
if (defined $dsc->{pc_jmp}) { # is alternate pc available ?
my $pc_jmp = $dsc->{pc_jmp};
if (defined $data[$pc_jmp]->{word} && # if data available
(not defined $data[$pc_jmp]->{type} )) { # and not yet tagged
add_ctpend($pc_jmp, convoct($pc)); # push it on the todo list
}
}
$pc = $dsc->{pc_seq}; # proceed with next instruction, if def
} else { # invalid instruction
set_type($pc, "word");
$pc = undef;
}
} # while (defined $pc)
}
}
#-------------------------------------------------------------------------------
sub tag_undef { # tag all yet undefined words/bytes
my $dmode = $dmode_opt;
my $iend = scalar(@data);
$dmode = "word" if not defined $dmode;
for (my $p = 0; $p < $iend; $p++) {
my $dsc = $data[$p];
next if not defined $dsc;
$dmode = $dsc->{dmode} if defined $dsc->{dmode};
next if not (defined $dsc->{word} || defined $dsc->{byte});
next if defined $dsc->{type};
if ($dmode eq "code") {
add_ctpend($p, "dmode");
} elsif ($dmode eq "word") {
set_type($p, (defined $dsc->{byte}) ? "byte" : "word");
} elsif ($dmode eq "asciz") {
set_type($p, "asciz");
} else {
print_bugcheck(__LINE__, "unexpected dmode '$dmode'");
}
}
}
#-------------------------------------------------------------------------------
sub tag_data { # paint all data sections
my $iend = scalar(@data);
my $addr = 0;
while ($addr < $iend) {
my $dsc = $data[$addr];
if ((not defined $dsc) ||
(not defined $dsc->{type})) {
$addr += 1;
} elsif ($dsc->{type} eq "code") {
$addr += 2*$dsc->{nw};
} elsif ($dsc->{type} =~ m{^asc(ii|iz|[0-7]{3})$} ) {
my ($nb, $dir, $arg) = gather_ascii($addr, $dsc->{type});
$dsc->{dirstr} = $dir;
$dsc->{argstr} = $arg;
$dsc->{nb} = $nb;
if ($dsc->{type} eq "asciz") {
my ($nb, $dir, $arg) = gather_ascii($addr, $dsc->{type}, 1);
$dsc->{comstr} = $arg;
}
$addr += $nb;
} elsif ($dsc->{type} eq "word" && $dsc->{word} == 0) {
my ($nw, $dir, $arg) = gather_blkw($addr);
if ($nw == 0) { # FIXME_code: HACK
$addr += 1; # FIXME_code: HACK
next; # FIXME_code: HACK
}
if ($nw > 1) {
$dsc->{dirstr} = $dir;
$dsc->{argstr} = $arg;
$dsc->{nb} = 2*$nw;
}
$addr += 2*$nw;
} elsif ($dsc->{type} eq "byte" && $dsc->{byte} == 0) {
my ($nb, $dir, $arg) = gather_blkb($addr);
if ($nb > 1) {
$dsc->{dirstr} = $dir;
$dsc->{argstr} = $arg;
$dsc->{nb} = $nb;
} elsif ((not defined $dsc->{label}) && ($addr & 01) == 1) {
$dsc->{dirstr} = ".even";
$dsc->{argstr} = "";
$dsc->{nb} = $nb;
}
$addr += $nb;
} else {
my $type = $dsc->{type};
my $nb = 1;
$addr += $nb;
}
}
}
#-------------------------------------------------------------------------------
sub gather_ascii { # gather ascii, asciz or ascooo string
my ($addr, $type, $till0) = @_;
my $clist = "";
my $crlast = 0;
my $arg = "";
my $nb = 0;
my $dir = ".ascii";
my $symset = $symsettbl{'@chars'};
for (my $p=$addr; ; $p++) {
my $dsc = $data[$p];
last unless defined $dsc; # stop scan if no data
last if (not $till0) &&
$p != $addr &&
defined $dsc->{label}; # stop scan at a label
my $byte = $dsc->{byte};
last unless defined $byte; # stop scan if no byte data
last unless $dsc->{type} eq $type; # stop scan if not ascii/asciz/ascooo
if ($byte == 0 && $type eq "asciz") {
$nb += 1;
$arg .= wrap_ascii($clist);
$clist = "";
$dir = ".asciz";
last;
} elsif ($byte>=040 && $byte<0177) {
$nb += 1;
$clist .= chr($byte);
} else {
$nb += 1;
$arg .= wrap_ascii($clist);
$clist = "";
my $chrsym;
if (defined $symset) {
foreach my $item ( @{$symset} ) {
if ($byte == $item->{val}) {
$chrsym = $item->{sym};
add_symcref($item->{sym}, $addr) unless $till0;
last;
}
}
}
if (defined $chrsym) {
$arg .= "<$chrsym>";
} else {
$arg .= sprintf "<%3.3o>", $byte;
}
if ((not $till0) &&
length($arg) > 20 &&
chk_data($p+1) eq "b" &&
$data[$p+1]->{byte} != 0 &&
$data[$p+1]->{byte} != 012) { # FIXME !! more systematic crlf
return ($nb, ".ascii", $arg);
}
}
if ((not $till0) && $byte == 015) {
$crlast = 1;
} elsif ($crlast == 1 && $byte == 012) {
my $byte_next = get_byte($p+1);
last unless $type eq "asciz" &&
defined $byte_next &&
$byte_next == 0;
} else {
$crlast = 0;
}
}
$arg .= wrap_ascii($clist);
$arg = "//" if $arg eq "";
##printf "+++8 %1d:%6.6o %3d %s %s\n", defined $till0, $addr, $nb, $dir, $arg;
return ($nb, $dir, $arg);
}
#-------------------------------------------------------------------------------
sub wrap_ascii {
my ($clist) = @_;
return "" if $clist eq "";
my $del = "";
if ($clist !~ m{/}) {
$del = "/";
} elsif ($clist !~ m{\|}) { # FIXME: better algorithm for alternate delim
$del = "|";
} elsif ($clist !~ m{\\}) {
$del = "\\";
} elsif ($clist !~ m{\"}) {
$del = "\"";
} elsif ($clist !~ m{\'}) {
$del = "\'";
}
print_bugcheck(__LINE__, "failed to get delim for \"$clist\"") if $del eq "";
return $del . $clist . $del;
}
#-------------------------------------------------------------------------------
sub gather_blkw { # gather blkw block
my ($addr) = @_;
my $nw = 0;
my $dir = ".blkw";
my $arg = "";
for (my $p=$addr; ; $p+=2) {
my $dsc = $data[$p];
last unless defined $dsc; # stop scan if no data
last if $p != $addr && defined $dsc->{label}; # stop scan at a label
my $word = $dsc->{word};
last unless defined $word; # stop scan if no word data
last unless $dsc->{type} eq "word"; # stop scan if not word
last if $word |= 0; # stop scan if word non-zero
$nw += 1;
}
$arg = sprintf "%d.", $nw;
print_bugcheck(__LINE__, "no zero data for gather_blkw") if $nw eq 0;
return ($nw, $dir, $arg);
}
#-------------------------------------------------------------------------------
sub gather_blkb { # gather blkb block
my ($addr) = @_;
my $nb = 0;
my $dir = ".blkb";
my $arg = "";
for (my $p=$addr; ; $p++) {
my $dsc = $data[$p];
last unless defined $dsc; # stop scan if no data
last if $p != $addr && defined $dsc->{label}; # stop scan at a label
my $byte = $dsc->{byte};
last unless defined $byte; # stop scan if no byte data
last unless $dsc->{type} eq "byte"; # stop scan if not byte
last if $byte |= 0; # stop scan if byte non-zero
$nb += 1;
}
$arg = sprintf "%d.", $nb;
print_bugcheck(__LINE__, "no zero data for gather_blkb") if $nb eq 0;
return ($nb, $dir, $arg);
}
#-------------------------------------------------------------------------------
sub pass_opts1 { # handle some options (lblimm,lblind)
my $iend = scalar(@data);
my $addr = 0;
%curopt = (%opttbl); # reset current option set
@susp_restore = ();
while ($addr < $iend) {
my $dsc = $data[$addr];
if ((not defined $dsc) ||
(not defined $dsc->{type})) {
$addr += 1;
next;
}
set_susopt();
set_curopt($dsc->{optlist}) if defined $dsc->{optlist};
my $type = $dsc->{type};
if ($type eq "code") { # if instruction
do_lblimmind($addr, "op1str") unless defined $dsc->{op1sym};
do_lblimmind($addr, "op2str") unless defined $dsc->{op2sym};
}
$addr += 1;
}
}
#-------------------------------------------------------------------------------
sub pass_opts2 { # handle most options (symxxx,lbliot,...)
my $iend = scalar(@data);
my $addr = 0;
%curopt = (%opttbl); # reset current option set
@susp_restore = ();
while ($addr < $iend) {
my $dsc = $data[$addr];
if ((not defined $dsc) ||
(not defined $dsc->{type})) {
$addr += 1;
next;
}
set_susopt();
set_curopt($dsc->{optlist}) if defined $dsc->{optlist};
my $type = $dsc->{type};
if ($type eq "code") { # if instruction
do_symimmind($addr, "op1str", "op1sym") unless defined $dsc->{op1sym};
do_symimmind($addr, "op2str", "op2sym") unless defined $dsc->{op2sym};
if ($curopt{lbliot}->{ena} && # if iot and lbliot enabled
$dsc->{opcode} eq "iot") {
my $tnum = $curopt{lbliot}->{tnum}++;
unshift @{ $dsc->{lcomm} }, ";" unless exists $dsc->{lcomm};
unshift @{ $dsc->{lcomm} },
sprintf "; Test %3.3o ------------------------------------", $tnum;
unshift @{ $dsc->{lcomm} }, ";";
my $addr_str = convoct($addr);
my $iotlbl = sprintf("tst%3.3o", $tnum);
my $do_iotlbl = 1;
$do_iotlbl = 0 if exists $symtbl{$iotlbl};
$do_iotlbl = 0 if exists $adrtbl{$addr_str} &&
$adrtbl{$addr_str}->{typ} ne "albl" ;
add_symbol($addr, $iotlbl, "data") if $do_iotlbl;
}
if ($curopt{anoemt}->{ena} && # if emt and anoemt enabled tbl,size
$dsc->{opcode} eq "emt") {
my $emtnum = get_word($addr);
if (defined $emtnum) {
$emtnum = $emtnum & 0377;
if ($emtnum == 0377 && $curopt{anoemt}->{max} > 0377) {
$emtnum = get_word($addr+2) if defined get_word($addr+2);
}
} else {
$emtnum = 0;
}
if ($emtnum > 0 &&
$emtnum <= $curopt{anoemt}->{max} &&
exists $symtbl{$curopt{anoemt}->{tbl}}) {
my $tbas = $symtbl{$curopt{anoemt}->{tbl}}->{val};
my $tent = $tbas + ($emtnum-1) * $curopt{anoemt}->{size};
my $pt0 = get_word($tent);
my $pt1 = get_word($tent+2);
my $t0 = undef;
my $t1 = undef;
$t0 = $data[$pt0]->{comstr} if (chk_type($pt0, "asciz"));
$t1 = $data[$pt1]->{comstr} if (chk_type($pt1, "asciz"));
$t0 = "?" unless defined $t0;
$t1 = "?" unless defined $t1;
##printf STDERR "+++1 %6.6o %3.3o %d %d\n", $addr, $emtnum,
## (chk_type($pt0, "asciz")), (chk_type($pt1, "asciz"));
add_lcomm($addr, sprintf ("; error %3.3o", $emtnum));
add_lcomm($addr, "; ".$t0);
add_lcomm($addr, "; ".$t1);
}
}
} elsif ($type eq "word") {
my $targ = $dsc->{word};
my $targ_str = convoct($targ);
my $targ_lbl = (exists $adrtbl{$targ_str} &&
defined $adrtbl{$targ_str}->{string}) ? 1 : 0;
if ($curopt{symwrd}->{ena} &&
$targ >= $curopt{symwrd}->{min} &&
$targ <= $curopt{symwrd}->{max}) {
add_scomm($addr, "{symwrd $targ_lbl}") if $curopt{symwrd}->{anno};
$dsc->{datsym} = "1" if $targ_lbl;
}
}
$addr += 1;
}
}
#-------------------------------------------------------------------------------
sub do_lblimmind { # helper to handle lblimm and lblind
my ($addr, $keystr) = @_;
my $dsc = $data[$addr];
my $str = $dsc->{$keystr};
return unless defined $str;
if ($str =~ m{([0-7]{6})} ) {
my $targ = oct $1;
my $targ_str = convoct($targ);
my $targ_lbl = (exists $adrtbl{$targ_str} &&
defined $adrtbl{$targ_str}->{string}) ? 1 : 0;
##printf STDERR "+++1 %6.6o %s %s\n",$addr, $keystr, $str;
if (!$targ_lbl && chk_data($targ)) {
if ($str =~ m{\#} &&
$curopt{lblimm}->{ena} &&
$targ >= $curopt{lblimm}->{min} &&
$targ <= $curopt{lblimm}->{max}) {
add_scomm($addr, "{lblimm}") if $curopt{lblimm}->{anno};
set_labcref($targ, "I", $addr, "i");
} elsif ($str =~ m{\(.*\)$} &&
$curopt{lblind}->{ena} &&
$targ >= $curopt{lblind}->{min} &&
$targ <= $curopt{lblind}->{max}) {
add_scomm($addr, "{lblind}") if $curopt{lblind}->{anno};
set_labcref($targ, "N", $addr, "n");
}
}
}
}
#-------------------------------------------------------------------------------
sub do_symimmind { # helper to handle symimm, symind and symchr
my ($addr, $keystr, $keysym) = @_;
my $dsc = $data[$addr];
my $str = $dsc->{$keystr};
return unless defined $str;
if ($str =~ m{([0-7]{6})} ) {
my $targ = oct $1;
my $targ_str = convoct($targ);
my $targ_lbl = (exists $adrtbl{$targ_str} &&
defined $adrtbl{$targ_str}->{string}) ? 1 : 0;
if ($str =~ m{\#} &&
$curopt{symimm}->{ena} &&
$targ >= $curopt{symimm}->{min} &&
$targ <= $curopt{symimm}->{max}) {
add_scomm($addr, "{symimm $targ_lbl}") if $curopt{symimm}->{anno};
$dsc->{$keysym} = "1" if $targ_lbl;
} elsif ($str =~ m{\(.*\)$} &&
$curopt{symind}->{ena} &&
$targ >= $curopt{symind}->{min} &&
$targ <= $curopt{symind}->{max}) {
add_scomm($addr, "{symind $targ_lbl}") if $curopt{symind}->{anno};
$dsc->{$keysym} = "1" if $targ_lbl;
}
} elsif ($str =~ m{^\#([0-7]{3})$} ) {
my $val = oct $1;
if ($curopt{symchr}->{ena} && $val > 040 && $val < 0177) {
add_scomm($addr, "{symchr}") if $curopt{symchr}->{anno};
$dsc->{$keysym} = "1";
}
}
}
#-------------------------------------------------------------------------------
sub name_labels { # name all autogenerated labels
my $iend = scalar(@data);
my %lnum;
#
# 1st pass, handle references pointing into an instruction
#
foreach my $key (sort keys %adrtbl) {
if ($adrtbl{$key}->{typ} eq "albl") {
my $addr = $adrtbl{$key}->{addr};
if ($data[$addr]->{type} =~ m{^code\.(imm|ind)$} ) {
my $pc = $addr - 2;
$pc = $pc - 2 if $data[$pc]->{type} =~ m{^code\.(imm|ind)$} ;
my $pc_str = convoct($pc);
if (not exists $adrtbl{$pc_str}) {
add_symbol($pc, "S#####", "albl");
}
$adrtbl{$key}->{string} = sprintf "%s+%o",$pc_str, $addr-$pc;
}
}
}
foreach my $key (sort keys %adrtbl) {
if ($adrtbl{$key}->{string} =~ m{^(.+?)\#{5}$}) {
$lnum{$1} = 0 unless defined $lnum{$1};
while (1) {
my $symbol = sprintf "%s%3.3d", $1, $lnum{$1};
$lnum{$1} += 1;
if (not exists $symtbl{$symbol} ) {
$adrtbl{$key}->{string} = $symbol;
$symtbl{$symbol}->{val} = oct $key;
$symtbl{$symbol}->{typ} = $adrtbl{$key}->{typ};
last;
}
}
} elsif ($adrtbl{$key}->{string} =~ m{^([0-7]{6})\+([0-7]+)$} ) {
my $pc_str = $1;
my $off = $2;
$adrtbl{$key}->{string} = $adrtbl{$pc_str}->{string} . "+" . $off;
}
}
}
#-------------------------------------------------------------------------------
#
# Analyse single instruction
#
# $nw = anal_inst($pc)
#
# with
# $pc pc pointing to instruction in @data
# returns
# $nw number of word to advance pc
# 0 for invalid instruction, or 1-3 for a valid one
#
# @data[$pc] {only for valid instructions}
# ->{type} set to 'code'
# ->{opcode} opcode mnemonic
# ->{nw} number of words of instruction (1-3)
# ->{pc_seq} next pc in case of sequential execution or jsr/trap return
# ->{pc_jmp} target address of taken cond. branches, jmp's or jsr's
# ->{op1str} string representation of 1st operand
# ->{op1typ} type of 1st operand (const, addr, iaddr)
# ->{op1eai} eff.address or immediate value of 1st operand, if available
# ->{op2str} string representation of 2nd operand
# ->{op2typ} type of 2nd operand (const, addr, iaddr)
# ->{op2eai} eff.address or immediate value of 2nd operand, if available
#
sub anal_inst { # analyse single instruction
my ($pc) = @_;
my $dsc = $data[$pc];
if ((not defined $dsc) || (not defined $dsc->{word}) ) {
printf STDERR "dasm-11-E: anal_inst: no data for pc=%6.6o\n", $pc;
return 0;
}
my $pc_inst = $pc; # pc of instruction
my $inst = $dsc->{word}; # 1st word of instruction
my $isfpp = $inst >= 0170000; # true if FPP instruction
$pc += 2;
foreach my $ele (@opcode_tbl) {
if (($inst & (~($ele->{mask})) ) == $ele->{code}) {
my $mnem = $ele->{mnem};
my $type = $ele->{type};
my $bytop = $ele->{bytop};
my $src_nw = 0;
my $src_str;
my $src_typ;
my $src_eai;
my $src_sym;
my $dst_nw = 0;
my $dst_str;
my $dst_typ;
my $dst_eai;
my $dst_sym;
if (defined $ele->{src}) { # src mod/reg field used
($src_nw,$src_str,$src_typ,$src_eai,$src_sym) =
anal_operand(($inst>>6) & 077, $pc, $bytop, $isfpp);
$pc += 2*$src_nw if $src_nw >= 0;
}
if (defined $ele->{dst} && $src_nw >= 0) { # dst mod/reg field used
($dst_nw,$dst_str,$dst_typ,$dst_eai,$dst_sym) =
anal_operand($inst & 077, $pc, $bytop, $isfpp);
$pc += 2*$dst_nw if $dst_nw >= 0;
}
if ($src_nw < 0 || $dst_nw < 0) {
printf STDERR
"dasm-11-W: code tag clash at pc=%6.6o inst=%6.6o '%s'\n" .
" word at addr=%6.6o already tagged '%s'\n",
$pc_inst, $inst, $mnem, $pc, $data[$pc]->{type};
add_scomm($pc_inst, "!!code tag clash!!");
return 0;
}
set_type($pc_inst,"code");
$dsc->{opcode} = $mnem;
$dsc->{nw} = 1;
if ($type eq "0arg" or # no argument opcodes (halt,..,cfcc,..)
$type eq "0fpp") {
$dsc->{pc_seq} = $pc unless ($mnem =~ m{^(halt|rti|rtt)$} );
} elsif ($type eq "1arg") { # 1 argument opcodes (jmp,clr,....)
$dsc->{nw} += $dst_nw;
$dsc->{op1str} = $dst_str;
$dsc->{op1typ} = $dst_typ if defined $dst_typ;
$dsc->{op1eai} = $dst_eai if defined $dst_eai;
$dsc->{op1acs} = $ele->{dst};
$dsc->{pc_seq} = $pc unless ($mnem eq "jmp");
if ($mnem eq "jmp") {
my $taddr = get_taddr($dst_eai, $dst_typ);
$dsc->{pc_jmp} = $taddr if defined $taddr;
}
} elsif ($type eq "2arg") { # 2 argument opcodes (mov,...)
$dsc->{nw} += $src_nw;
$dsc->{op1str} = $src_str;
$dsc->{op1typ} = $src_typ if defined $src_typ;
$dsc->{op1eai} = $src_eai if defined $src_eai;
$dsc->{op1acs} = $ele->{src};
$dsc->{nw} += $dst_nw;
$dsc->{op2str} = $dst_str;
$dsc->{op2typ} = $dst_typ if defined $dst_typ;
$dsc->{op2eai} = $dst_eai if defined $dst_eai;
$dsc->{op2acs} = $ele->{dst};
$dsc->{pc_seq} = $pc;
if (defined $src_typ && $src_typ eq "const" &&
defined $dst_sym && ! defined $dsc->{op1sym}) {
##print "+++7a $mnem $src_str, $dst_str\n";
$dsc->{op1sym} = $dst_sym;
}
if (defined $dst_typ && $dst_typ eq "const" &&
defined $src_sym && ! defined $dsc->{op2sym}) {
##print "+++7b $mnem $src_str, $dst_str\n";
$dsc->{op2sym} = $src_sym;
}
} elsif ($type eq "gr") { # register dest opcodes (mul,...)
$dsc->{nw} += $dst_nw;
$dsc->{op1str} = $dst_str;
$dsc->{op1typ} = $dst_typ if defined $dst_typ;
$dsc->{op1eai} = $dst_eai if defined $dst_eai;
$dsc->{op1acs} = $ele->{dst};
$dsc->{op2str} = get_regname(($inst>>6) & 07);
$dsc->{pc_seq} = $pc;
} elsif ($type eq "rg") { # rg opcode
$dsc->{op1str} = get_regname(($inst>>6) & 07);
$dsc->{nw} += $dst_nw;
$dsc->{op2str} = $dst_str;
$dsc->{op2typ} = $dst_typ if defined $dst_typ;
$dsc->{op2eai} = $dst_eai if defined $dst_eai;
$dsc->{op2acs} = $ele->{dst};
$dsc->{pc_seq} = $pc;
my $taddr = get_taddr($dst_eai, $dst_typ);
$dsc->{pc_jmp} = $taddr if defined $taddr && $mnem eq "jsr";
} elsif ($type eq "rts") { # rts opcode
$dsc->{op1str} = get_regname($inst & 07);
} elsif ($type eq "1reg") { # 1 reg opcodes (fis)
$dsc->{op1str} = get_regname($inst & 07);
$dsc->{pc_seq} = $pc;
} elsif ($type eq "br") { # branch opcodes
my $off = $inst & 0177;
$off = -(((~$off) & 0177)+1) if ($inst & 0200);
my $pc_jmp = ($pc + 2*$off) & 0177777;
$dsc->{op1str} = sprintf "%6.6o", $pc_jmp;
$dsc->{pc_jmp} = $pc_jmp;
$dsc->{pc_seq} = $pc unless ($mnem eq "br");
} elsif ($type eq "sob") { # sob opcode
my $off = $inst & 077;
my $pc_jmp = ($pc - 2*$off) & 0177777;
$dsc->{op1str} = get_regname(($inst>>6) & 07);
$dsc->{op2str} = sprintf "%6.6o", $pc_jmp;
$dsc->{pc_jmp} = $pc_jmp;
$dsc->{pc_seq} = $pc;
} elsif ($type eq "ccop") { # condition code opcodes
my $cc = $inst & 017;
my $code = "";
my $del = "";
if ($cc == 0) {
$code = "nop";
} elsif ($inst == 0257) {
$code = "ccc";
} elsif ($inst == 0277) {
$code = "scc";
} else {
if ($cc & 010) { $code .= $del . $mnem . "n"; $del = "!" }
if ($cc & 004) { $code .= $del . $mnem . "z"; $del = "!" }
if ($cc & 002) { $code .= $del . $mnem . "v"; $del = "!" }
if ($cc & 001) { $code .= $del . $mnem . "c"; $del = "!" }
$code = "<" . $code . ">" if $code =~ m/!/;
}
$dsc->{opcode} = $code;
$dsc->{pc_seq} = $pc;
} elsif ($type eq "spl") { # spl opcode
$dsc->{op1str} = sprintf "%1.1o", $inst & 07;
$dsc->{pc_seq} = $pc;
} elsif ($type eq "mark") { # mark opcode
$dsc->{op1str} = sprintf "%3.3o", $inst & 077;
$dsc->{pc_seq} = $pc;
} elsif ($type eq "trap") { # trap of arg opcodes (trap,emt)
$dsc->{op1str} = sprintf "%3.3o", $inst & 0377;
$dsc->{pc_seq} = $pc;
} elsif ($type eq "gfpp") { # fpp 1 operand opcodes
$dsc->{nw} += $dst_nw;
$dsc->{op1str} = $dst_str;
$dsc->{op1typ} = $dst_typ if defined $dst_typ;
$dsc->{op1eai} = $dst_eai if defined $dst_eai;
$dsc->{op1acs} = $ele->{dst};
$dsc->{pc_seq} = $pc;
} elsif ($type eq "grfpp") { # 1 operand + fpp reg opcodes
$dsc->{op2str} = sprintf "f%o", ($inst>>6) & 03;
$dsc->{nw} += $dst_nw;
$dsc->{op1str} = $dst_str;
$dsc->{op1typ} = $dst_typ if defined $dst_typ;
$dsc->{op1eai} = $dst_eai if defined $dst_eai;
$dsc->{op1acs} = $ele->{dst};
$dsc->{pc_seq} = $pc;
} elsif ($type eq "rgfpp") { # fpp reg + 1 operand opcodes
$dsc->{op1str} = sprintf "f%o", ($inst>>6) & 03;
$dsc->{nw} += $dst_nw;
$dsc->{op2str} = $dst_str;
$dsc->{op2typ} = $dst_typ if defined $dst_typ;
$dsc->{op2eai} = $dst_eai if defined $dst_eai;
$dsc->{op2acs} = $ele->{dst};
$dsc->{pc_seq} = $pc;
} elsif ($type eq "crdd") { # cis: reg,desc,desc (ld2r)
anal_cisops($pc, 2, 0);
$pc += 2*2;
$dsc->{pc_seq} = $pc;
} elsif ($type eq "crddd") { # cis: reg,desc,desc,desc (ld3r)
anal_cisops($pc, 3, 0);
$pc += 3*2;
$dsc->{pc_seq} = $pc;
} elsif ($type eq "cda") { # cis: desc,arg
anal_cisops($pc, 1, 1);
$pc += 2*2;
$dsc->{pc_seq} = $pc;
} elsif ($type eq "cdd") { # cis: desc,desc
anal_cisops($pc, 2, 0);
$pc += 2*2;
$dsc->{pc_seq} = $pc;
} elsif ($type eq "cdda") { # cis: desc,desc,arg
anal_cisops($pc, 2, 1);
$pc += 3*2;
$dsc->{pc_seq} = $pc;
} elsif ($type eq "cddaa") { # cis: desc,desc,arg,arg
anal_cisops($pc, 2, 2);
$pc += 4*2;
$dsc->{pc_seq} = $pc;
} elsif ($type eq "cddd") { # cis: desc,desc,desc
anal_cisops($pc, 3, 0);
$pc += 3*2;
$dsc->{pc_seq} = $pc;
} else {
print_bugcheck(__LINE__, "unexpected type $type");
}
if (defined $dsc->{op2acs} &&
$dsc->{op2acs} =~ m{[mw]} &&
$dsc->{op2str} eq "pc") {
delete $dsc->{pc_seq};
} elsif (defined $dsc->{op1acs} &&
$dsc->{op1acs} =~ m{[mw]} &&
$dsc->{op1str} eq "pc") {
delete $dsc->{pc_seq};
}
# some tests use mov #nnn,pc instead of jmp @#nnn. Some even use
# mov #0,pc and write the jmp target into the code (e.g. emjad0, zqkce0)
# thus handle mov #nnn,pc like a jmp, but only if address != 0
if ($mnem eq "mov" && $dst_str eq "pc") { # look for mov ...,pc
if (defined $src_typ &&
$src_typ eq "const" && # mov #nnn,pc
$dsc->{op1eai} != 0) { # but not mov #0,pc
$dsc->{pc_jmp} = $dsc->{op1eai}; # handle like a jmp
} elsif ($src_str eq "pc") { # mov pc,pc
$dsc->{pc_seq} = $pc; # just a nop
}
}
if (1 && $type =~ m{fpp$}) { # add [fpp] comment
add_scomm($pc_inst, "{fpp}");
}
if (1 && exists $ele->{cpu}) { # add [cpu:] comment
my $cpu = $ele->{cpu};
add_scomm($pc_inst, "{cpu:$cpu}");
}
return $dsc->{nw};
}
}
add_scomm($pc_inst, "!!inv. instr!!");
return 0;
}
#-------------------------------------------------------------------------------
#
# Analyse the 6 bit address-mode, register field of an operand
#
# ($nw, $str, $typ, $eai) = anal_operand($regmod, $pc, $isfpp)
#
# with
# $regmod 6 bit src/dst specifier (mod,reg)
# $pc pc, pointing to current index or immediate part of operand
# $bytop 1 if byte instruction
# $isfpp 1 if fpp instruction (will affect register names)
#
# returns
# $nw number of immediate or index words (0 or 1). Returns -1 if
# the imm or ind word is already code tagged
# $str string representation of src/dst operand specifier
# 0x rx with rx=r0,...,r5,sp,pc
# 1x (rx)
# 2x (rx)+
# 27 #oooooo
# 3x @(rx)+
# 37 @#oooooo
# 4x -(rx)
# 5x @-(rx)
# 6x oooooo(rx)
# 67 oooooo with oooooo=effective address
# 7x @oooooo(rx)
# 77 @oooooo with oooooo=effective address
# $typ type: const (27), addr (37,67) ,iaddr (77)
# $eai eff.address or imm.value, if available (27,37,67,77)
# $sym symbolize options from {use} attributes
#
# @data[$pc]
# ->{type} set to code.imm (27,37) or code.ind (6x,7x)
#
sub anal_operand { # analyse src or dst operand specifier
my ($regmod, $pc, $bytop, $isfpp) = @_;
my $mod = ($regmod>>3) & 07;
my $reg = $regmod & 07;
my $nw = 0;
my $eai = undef; # eff.address or imm.value
my $typ = undef; # value type: const,addr,iaddr
my $str = undef;
my $sym = undef;
my $reg_str = get_regname($reg);
my $ind = (($mod & 01) == 1) ? "@" : "";
if ($mod == 0) { # mode 0: Rx
$str = ($isfpp && $reg<=5) ? "f$reg" : $reg_str;
} elsif ($mod == 1) { # mode 1: (Rx)
$str = "($reg_str)";
} elsif ($mod == 2 || $mod == 3) { # mode 2/3: (Rx)+ @(Rx)+
if ($reg == 7) { # if reg == pc
$nw = 1;
if (defined $data[$pc]->{word}) {
if (defined $data[$pc]->{type} && $data[$pc]->{type} =~ m{^code} ) {
$nw = -1;
} else {
set_type($pc, "code.imm");
}
$eai = $data[$pc]->{word};
} else {
$eai = 0;
printf STDERR "dasm-11-E: anal_operand: no data for pc=%6.6o\n", $pc;
}
$typ = ($mod == 2) ? "const" : "addr";
if ($mod == 2 && $bytop) { # is byte immediate ?
$str = sprintf "#%3.3o", $eai; # than use #ooo format
} else {
$str = sprintf "%s#%6.6o", $ind, $eai;
}
} else { # if reg != pc
$str = "$ind($reg_str)+";
}
} elsif ($mod == 4 || $mod == 5) { # mode 4/5: -(Rx) @-(Rx)
$str = "$ind-($reg_str)";
} elsif ($mod == 6 || $mod == 7) { # mode 6/7: nn(Rx) @nn(Rx)
$nw = 1;
my $off = 0;
if (defined $data[$pc]->{word}) {
if (defined $data[$pc]->{type} && $data[$pc]->{type} =~ m{^code} ) {
$nw = -1;
} else {
set_type($pc, "code.ind");
}
$off = $data[$pc]->{word};
} else {
printf STDERR "dasm-11-E: anal_operand: no data for pc=%6.6o\n", $pc;
}
if ($reg == 7) { # if reg == pc
$eai = ($pc + 2 + $off) & 0177777;
$typ = ($mod == 6) ? "addr" : "iaddr";
$str = sprintf "%s%6.6o", $ind, $eai;
} else { # if reg != pc
$str = sprintf "%s%6.6o(%s)", $ind, $off, $reg_str;
}
}
if (defined $eai && defined $typ && $typ =~ m{^(addr|iaddr)$} ) {
##printf "+++6a $typ %s\n", convoct($eai);
my $taddr = $eai;
if ($typ eq "iaddr" && chk_data($eai) eq "w") {
my $iaddr = $data[$eai]->{word};
##printf "+++6b $typ %s\n", convoct($iaddr);
$taddr = $iaddr;
}
my $taddr_str = convoct($taddr);
if (exists $adrtbl{$taddr_str} && defined $adrtbl{$taddr_str}->{use}) {
##print "+++6c $typ $taddr_str\n";
$sym = $adrtbl{$taddr_str}->{use};
}
}
return ($nw, $str, $typ, $eai, $sym);
}
#-------------------------------------------------------------------------------
#
# Analyse operands of a cis instruction
#
# anal_cisops($pc, $ndsc, $narg)
#
sub anal_cisops { # analyse cis operands
my ($pc, $ndsc, $narg) = @_;
my $ntot = $ndsc + $narg;
for (my $i=0; $i < $ntot; $i++) {
if ($i < $ndsc) {
set_typlabcref($pc, '$cisdsc*');
} else {
set_typlabcref($pc, "word");
}
$pc += 2;
}
}
#-------------------------------------------------------------------------------
#
# $str = get_regname($reg)
#
# with
# $reg register number (0-7)
# returns
# $str string with symbolic register name
# 0-5 r0,....r5
# 6 sp
# 7 pc
#
sub get_regname { # return register name
my ($reg) = @_;
my $str = "r$reg";
$str = "sp" if $reg == 6;
$str = "pc" if $reg == 7;
return $str;
}
#-------------------------------------------------------------------------------
sub set_type { # set type tag in @data
my ($addr, $type) = @_;
my $dsc = $data[$addr];
my $nb = 0;
if (not chk_data($addr)) {
printf STDERR "dasm-11-E: set_type: no data for addr=%6.6o\n", $addr;
return 0;
}
my $type_old = $dsc->{type};
$type_old = "" if not defined $type_old;
return 0 if $type_old =~ m{^code}; # never overwrite code type
return 0 if $type_old =~ m{^vect}; # never overwrite vect type
if ($type =~ m{^(byte|ascii)$}) { # byte or ascii
word2byte($addr);
$dsc->{type} = $type;
$nb = 1;
} elsif ($type =~ m/^asc(iz|[0-7]{3})$/) { # asciz or ascooo
my $term = ($1 eq "iz") ? 0 : oct $1;
for (my $p = $addr; ; $p++) {
if (defined $data[$p]->{type}) {
add_scomm($p, "!!$type tag stop!!");
last;
}
word2byte($p);
if (not defined $data[$p]->{byte}) {
printf STDERR "dasm-11-W set_type($type) ran beyond defined memory\n";
last;
}
$data[$p]->{type} = $type;
$nb += 1;
last if $data[$p]->{byte} == 0;
last if $data[$p]->{byte} == $term;
}
} elsif ($type =~ m{^ # code
(code|code\.imm|code\.ind)
$ }x ) {
$dsc->{type} = $type;
$nb = 2;
} elsif ($type eq "vect") { # vect
$dsc->{type} = $type;
if (chk_data($addr+2)) {
$data[$addr+2]->{type} = "vect.psw";
add_adr_rlabel($addr+2, $addr);
add_dat_alist($addr+2, 'use=%cp.psw') if exists $symsettbl{'%cp.psw'};
if ($data[$addr]->{word} == $addr+2) { # if just catcher
delete $data[$addr+2]->{datsym}; # remove datsym, it's code...
}
} else {
printf STDERR "dasm-11-E: no data for psw part of .vect at %6.6o\n", $addr;
}
$nb = 4;
} elsif ($type =~ m{^ # word or rad50
(word|rad50)
$ }x ) {
$dsc->{type} = $type;
$nb = 2;
} elsif ($type =~ m{^flt([24])$} ) { # flt2 or flt4
my $nw = int $1;
for (my $i = 0; $i<$nw; $i++) {
my $p = $addr + 2*$i;
$data[$p]->{type} = $type if chk_data($p);
$nb += 2;
}
} elsif ($type =~ m{\*$}) { # pointer to
$dsc->{type} = $type;
$nb = 2;
} else {
print_bugcheck(__LINE__, "unexpected type $type in set_type()");
}
return $nb;
}
#-------------------------------------------------------------------------------
sub write_source { # write source or list file
my $pc = -1;
my $lst = 1;
print $fh_out "\t.enable\tlc\n";
print $fh_out "\t.asect\n";
foreach my $key (sort keys %adrtbl) {
if ($adrtbl{$key}->{typ} =~ m{^(gsym|asym)$}) {
next if ($adrtbl{$key}->{typ} eq "gsym" && # skip unused gsym's
(not defined $adrtbl{$key}->{cref}));
printf $fh_out "\t%s=%s\n", $adrtbl{$key}->{string}, $key;
}
}
foreach my $key (sort keys %symsettbl) {
printf $fh_out "\t;\n";
printf $fh_out "\t; symbol definitions for set %s\n", $key;
printf $fh_out "\t;\n";
foreach my $item ( @{ $symsettbl{$key} } ) {
printf $fh_out "\t%s=%6.6o\n", $item->{sym}, $item->{val};
}
}
my $iend = scalar(@data);
my $addr = 0;
%curopt = (%opttbl); # reset current option set
@susp_restore = ();
while ($addr < $iend) {
my $dsc = $data[$addr];
if ((not defined $dsc) ||
(not defined $dsc->{type})) {
$addr += 1;
next;
}
set_susopt();
set_curopt($dsc->{optlist}) if defined $dsc->{optlist};
my $scomm = "";
$scomm = join "//", @{ $dsc->{scomm} } if defined $dsc->{scomm};
if ($pc != $addr) {
$pc = $addr;
printf $fh_out "%6.6o\t\t\t\t", $pc if ($lst);
printf $fh_out "\t.=%6.6o\n", $pc;
}
if (defined $dsc->{lcomm}) {
foreach (@{ $dsc->{lcomm} }) {
printf $fh_out "%6.6o\t\t\t\t", $pc if ($lst);
print $fh_out $_,"\n";
}
}
printf $fh_out "%6.6o\t", $pc if ($lst);
my $label_str = "";
if (defined $data[$pc]->{label}) {
$label_str = $adrtbl{$data[$pc]->{label}}->{string} . ":";
}
if (defined $dsc->{opcode}) {
if ($lst) {
for (my $i=0; $i<3; $i++) {
if ($i < $dsc->{nw}) {
printf $fh_out "%6.6o\t", $data[$pc+2*$i]->{word};
} else {
print $fh_out "\t";
}
}
}
my $op1str = symbolize($addr, $dsc->{op1str}, $dsc->{op1sym});
my $op2str = symbolize($addr, $dsc->{op2str}, $dsc->{op2sym});
printf $fh_out "%s\t%s\t", $label_str, $dsc->{opcode};
printf $fh_out "%s", $op1str if defined $op1str;
printf $fh_out ",%s", $op2str if defined $op2str;
printf $fh_out " ; %s", $scomm if $scomm ne ""; # FIXME !!!
print $fh_out "\n";
$addr += 2*$dsc->{nw};
$pc += 2*$dsc->{nw};
} elsif (defined $dsc->{dirstr}) {
if ($lst) {
if ($dsc->{dirstr} =~ m{^\.asci} ) {
for (my $i=0; $i<6; $i++) {
if ($i < $dsc->{nb}) {
printf $fh_out "%3.3o ", $data[$pc+$i]->{byte};
} else {
print $fh_out " ";
}
}
} else {
printf $fh_out "\t\t\t";
}
}
printf $fh_out "%s\t", $label_str;
printf $fh_out "%s\t%s", $dsc->{dirstr}, $dsc->{argstr};
print $fh_out "\n";
if ($lst && $dsc->{dirstr} =~ m{^\.asci} && $dsc->{nb} > 6) {
for (my $i=6; $i<$dsc->{nb}; $i++) {
printf $fh_out "%6.6o\t", $addr+$i if $i%6 == 0;
printf $fh_out "%3.3o ", $data[$pc+$i]->{byte};
printf $fh_out "\n", if $i%6 == 5 || $i == $dsc->{nb}-1;
}
}
$addr += $dsc->{nb};
$pc += $dsc->{nb};
} else {
if (defined $dsc->{byte}) {
printf $fh_out "%3.3o\t\t\t%s\t.byte\t%3.3o",
$dsc->{byte}, $label_str, $dsc->{byte};
printf $fh_out " ; %s", $scomm if $scomm ne ""; # FIXME !!!
print $fh_out "\n";
$addr += 1;
$pc += 1;
} else {
my $str = symbolize($addr, convoct($dsc->{word}), $dsc->{datsym});
if ($dsc->{datsym} && $scomm eq "" &&
defined $data[$dsc->{word}]->{dirstr} &&
$data[$dsc->{word}]->{dirstr} =~ m{^\.asci}) {
if (defined $data[$dsc->{word}]->{comstr}) {
$scomm = " -> " . $data[$dsc->{word}]->{comstr};
} else {
$scomm = " -> " . $data[$dsc->{word}]->{argstr};
}
}
printf $fh_out "%6.6o\t\t\t%s\t.word\t%s",
$dsc->{word}, $label_str, $str;
printf $fh_out " ; %s", $scomm if $scomm ne ""; # FIXME !!!
print $fh_out "\n";
$addr += 2;
$pc += 2;
}
}
}
print $fh_out "\t.end\t1\n";
if (1) { # write symtab
my $nsym = 0;
print $fh_out "\n";
print $fh_out "---------- symbol table ----------\n";
print $fh_out "\n";
print $fh_out "symbol value type ".
"symbol value type ".
"symbol value type ".
"symbol value type \n";
print $fh_out "\n";
foreach my $item (sort keys %symtbl) {
my $val = $symtbl{$item}->{val};
my $typ = $symtbl{$item}->{typ};
next if ($typ eq "gsym" &&
(not defined $adrtbl{convoct($val)}->{cref})); # skip unused gsym's
if ($nsym > 3) {
print $fh_out "\n";
$nsym = 0;
}
printf $fh_out "%-6s %6.6o %-10s",
$item, $val, $typ;
$nsym += 1;
}
print $fh_out "\n";
}
if (1) { # write adrtbl cref
print $fh_out "\n";
print $fh_out "---------- cross reference for address labels ----------\n";
print $fh_out "\n";
print $fh_out "addr symbol ltyp dtyp crefs\n";
print $fh_out "\n";
foreach my $addr_str (sort keys %adrtbl) {
my $addr = $adrtbl{$addr_str}->{addr};
my $ltyp = $adrtbl{$addr_str}->{typ};
my $str = $adrtbl{$addr_str}->{string};
my $cref = $adrtbl{$addr_str}->{cref};
my $dtyp = "";
my $nref = 0;
$dtyp = $data[$addr]->{type} if chk_data($addr);
next if $ltyp eq "gsym" && (not defined $cref); # skip unused gsym's
printf $fh_out "%6s %-10s %4s %-10s", $addr_str, $str, $ltyp, $dtyp;
if ($cref) {
foreach my $item (sort keys %{$cref}) {
if ($nref >=4) {
print $fh_out "\n";
print $fh_out " " x 35;
$nref = 0;
}
printf $fh_out " %6s %-2s", $item, $cref->{$item};
$nref += 1;
}
}
printf $fh_out "\n";
}
}
if (1) { # write symtbl cref
print $fh_out "\n";
print $fh_out "---------- cross reference for symset symbols ----------\n";
print $fh_out "\n";
print $fh_out "symbol value symset crefs\n";
print $fh_out "\n";
foreach my $symbol (sort keys %symtbl) {
my $typ = $symtbl{$symbol}->{typ};
next unless $typ =~ m{^[\@\%]};
my $val = $symtbl{$symbol}->{val};
my $cref = $symtbl{$symbol}->{cref};
my $nref = 0;
printf $fh_out "%-6s %6.6o %-8s", $symbol, $val, $typ;
if ($cref) {
foreach my $item (sort keys %{$cref}) {
if ($nref >=8) {
print $fh_out "\n";
print $fh_out " " x 24;
$nref = 0;
}
printf $fh_out " %6s", $item;
$nref += 1;
}
}
printf $fh_out "\n";
}
}
if (1) { # write statistic
print $fh_out "\n";
print $fh_out "---------- statistics ----------------------------------\n";
my %stat_type;
foreach my $dsc (@data) {
next unless defined $dsc;
next unless defined $dsc->{type};
$stat_type{$dsc->{type}} += 1;
}
foreach my $key (sort keys %stat_type) {
printf $fh_out "%12s : %5d\n", $key, $stat_type{$key};
}
}
}
#-------------------------------------------------------------------------------
sub print_info { # print messages on unnamed vect or i/o space
foreach my $addr_str (sort keys %adrtbl) {
my $addr = $adrtbl{$addr_str}->{addr};
next unless ($addr < 000300 || $addr > 0160000);
my $label = $adrtbl{$addr_str}->{string};
next unless ($label =~ m{^D\d\d\d+$});
my $msg;
if ((($addr > 0000 && $addr < 0040) ||
($addr >= 0060 && $addr < 0300)) &&
$addr%4 == 0) {
$msg = "unnamed vector ?";
$msg = $adr_info_vect{$addr_str} if (exists $adr_info_vect{$addr_str});
} elsif ($addr >= 0160000) {
$msg = "unnamed device register ?";
foreach my $dsc (@adr_info_iopage) {
if ($addr >= $dsc->[0] && $addr <= $dsc->[1]) {
$msg = $dsc->[2];
}
}
} else {
next;
}
printf STDERR "dasm-11-I: %s : %s; %s\n", $addr_str, $label, $msg;
}
}
#-------------------------------------------------------------------------------
sub symbolize { # convert oooooo -> label
my ($pc, $str, $sym) = @_;
return undef if not defined $str;
if ($sym) { # any symbolization hint given ?
if ($str =~ m{^(.*?)([0-7]{6})(.*)$} ) {
my $pref = $1;
my $addr_str = $2;
my $addr = oct $2;
my $suff = $3;
if ($sym =~ m{^[\@\%]} ) { # use symset
if (exists $symsettbl{$sym}) {
my $symset = $symsettbl{$sym};
if ($sym =~ m{^\@} ) { # type @ symset
foreach my $item ( @{$symset} ) {
if ($addr == $item->{val}) {
$str = $pref . $item->{sym} . $suff;
add_symcref($item->{sym}, $pc);
last;
}
}
} else { # type % symset
my $rest = $addr;
my $snew = "";
my $delim = "";
foreach my $item ( @{$symset} ) {
my $msk = (defined $item->{msk}) ? $item->{msk} : $item->{val};
my $part = $rest & $msk;
if ($part == $item->{val}) {
$snew .= $delim . $item->{sym};
$delim = "+";
$rest &= ~ $msk;
add_symcref($item->{sym}, $pc);
}
}
$snew .= $delim . convoct($rest) if ($rest != 0);
$snew = "000000" if ($snew eq "");
$str = $pref . $snew . $suff;
}
} else {
print_bugcheck(__LINE__, "symbolize: symset '$sym' missing");
}
} elsif ($sym eq ".") { # decimal conversion
my $num = $addr;
$num = -((-$num) & 0177777) if ($num >= 0100000); # FIXME (sign extend)
$str = $pref . sprintf("%d.", $num) . $suff;
} elsif ($sym eq "1") { # default label symbolization
if (exists $adrtbl{$addr_str} &&
defined $adrtbl{$addr_str}->{string}) {
my $atyp = "?";
$atyp = "p" if $data[$pc]->{type} !~ m{^code};
$atyp = "i" if $pref eq "#";
$atyp = "x" if $suff =~ m{^\(};
add_adrcref($addr_str, $pc, $atyp);
return $pref . $adrtbl{$addr_str}->{string} . $suff;
}
} else {
print_bugcheck(__LINE__, "symbolize: unexpected sym string '$sym'");
}
} elsif ($str =~ m{^#([0-7]{3})$} ) {
my $val = oct $1;
if ($val > 040 && $val < 0177) {
return "#'" . chr($val);
}
}
}
$str =~ s{^\@000000\(}{\@\(}; # edit @000000(xx) -> @(xx)
return $str;
}
#-------------------------------------------------------------------------------
sub word2byte { # add {byte} values for a {word}
my ($addr) = @_;
$addr &= 0177776; # clear lsb, byte->word address
return if not defined $data[$addr];
return if not defined $data[$addr]->{word};
return if defined $data[$addr]->{byte};
my $word = $data[$addr]->{word};
$data[$addr]->{byte} = $word & 0377; # store lsb in [0]
$data[$addr+1]->{byte} = ($word>>8) & 0377; # store msb in [1]
}
#-------------------------------------------------------------------------------
sub get_lpref { # return label prefix depending on tspec
my ($tspec) = @_;
my $lpref;
if ($tspec =~ m{\*$} ) {
$lpref = "P";
} elsif ($tspec eq "code") {
$lpref = "C";
} elsif ($tspec =~ m{^asc}) {
$lpref = "A";
} else {
$lpref = "D";
}
return $lpref;
}
#-------------------------------------------------------------------------------
#
# Setup type, auto-label and cref-info for an address. Will recursively handle
# all references and array's of a typespec
#
# $nb = set_typlabcref($addr,$tspec,$lpref,$from,$atyp)
# with
# $addr address to be tagged/labeled
# $tspec typespec to be used
# $lpref autolabel prefix
# $from from address for cross references
# $atyp access type for cross references
# returns
# $nb number of bytes typed, 0 in case of error
#
sub set_typlabcref { # setup type, label and cref
my ($addr, $tspec, $lpref, $from, $atyp) = @_;
my $addr_str = convoct($addr);
my $nb = 0;
if ($opts{ttlc}) {
printf "typlabcref: %s <- %-16s lpref=%s atyp=%s from=%s\n",
$addr_str, $tspec,
(defined $lpref) ? $lpref : "-",
(defined $atyp) ? $atyp : "-",
(defined $from) ? convoct($from) : "-";
}
if (defined $lpref && $lpref eq "?") {
$lpref = get_lpref($tspec);
}
set_labcref($addr, $lpref, $from, $atyp) if defined $lpref;
if ($tspec eq "vect") {
if (chk_type($addr, "vect")) {
return 2;
} else {
printf STDERR "dasm-11-E: location %6.6o not typed '.vect' " .
"but refered as 'vect' from %6.6o\n", $addr,
(defined $from) ? $from : 0;
return 0;
}
}
if ($tspec =~ /^code!?$/) { # tspec == "code" or "code!"
my $from_str = ".code";
$from_str = convoct($from) if defined $from;
if ($tspec eq "code") {
add_ctpend($addr, $from_str);
} else { # handle code!, tag this immediately
my @ctpend_save = @ctpend; # save pending code list
@ctpend = (); # reset it
add_ctpend($addr, $from_str); # queue it
tag_code(); # tag it
@ctpend = @ctpend_save; # restore list
}
$lpref = "C" unless defined $lpref;
return 2; # note: return 2 to signal success
# nothing tagged for "code", only queued
} elsif ($tspec =~ m{^
(ascii|asciz|asc[0-7]{3}|rad50)
$ }x ) {
$nb = set_type($addr, $tspec);
return $nb;
}
if (not chk_typespec($tspec)) {
print_bugcheck(__LINE__, "bad typespec '$tspec' in set_typlabcref()");
return 0;
}
if (not chk_data($addr)) {
print_bugcheck(__LINE__, "no data at $addr_str in set_typlabcref()");
return 0;
}
if ($tspec =~ m{^
(word|byte|flt[24])
$ }x ) {
$nb = set_type($addr, $tspec);
} elsif ($tspec =~ m{^ # pointer to type ?
(.+) # <type> --> $1
\* # *
$ }x ) {
my $tspec_targ = $1;
$nb = set_type($addr, $tspec);
my $p = get_word($addr);
if ($p != 0) { # if not a null pointer
$data[$addr]->{datsym} = "1"; # allow to symbolize pointer
if (chk_data($p)) { # if real data
if (not chk_type($p)) { # and not yet typed, type it
set_typlabcref($p, $tspec_targ, "?", $addr, "p");
} else {
set_labcref($p, get_lpref($tspec_targ), $addr, "p");
}
}
}
$nb = 2;
} elsif ($tspec =~ m{^ # array of type ?
(.+) # <type> --> $1
(\[\d*\.?\]) # [<dim>] --> $2
$ }x ) {
my $tspec_targ = $1;
my $dim_str = $2;
my $dim = 0;
if ($dim_str eq "[]") {
$dim = 0;
} elsif ($dim_str =~ m{\[([0-7]+)\]}) {
$dim = oct $1;
} elsif ($dim_str =~ m{\[([0-9]+)\.\]}) {
$dim = int $1;
} else {
print_bugcheck(__LINE__, "bad dimension '$dim_str' in set_typlabcref()");
}
if ($dim == 0) {
while (1) {
if (not chk_data($addr)) {
printf STDERR "dasm-11-W: typetag '%s' stopped at %6.6o," .
" no data\n", $tspec, $addr;
last;
}
my $otype = chk_type($addr);
if ($otype) {
printf STDERR "dasm-11-W: typetag '%s' stopped at %6.6o," .
" already typed '%s'\n", $tspec, $addr, $otype;
last;
}
my $nb_ai;
my $quit;
my $p = get_word($addr);
if ( $p != 0 && $p != 0177777 && chk_data($p) ) {
$nb_ai = set_typlabcref($addr, $tspec_targ);
} else {
$nb_ai = set_typlabcref($addr, "word");
$quit = 1;
}
if ($nb_ai <= 0) {
my $addr_str = convoct($addr);
print_bugcheck(__LINE__,
"array '$tspec' abort " .
"at $addr_str in set_typlabcref()");
return 0;
} else {
$addr += $nb_ai;
$nb += $nb_ai;
last if $quit;
}
}
} else {
for (my $i=0; $i<$dim; $i++) {
last unless chk_data($addr);
last if chk_type($addr);
my $nb_ai = set_typlabcref($addr, $tspec_targ);
if ($nb_ai <= 0) {
my $addr_str = convoct($addr);
print_bugcheck(__LINE__,
"array '$tspec' abort " .
"at $addr_str in set_typlabcref()");
return 0;
} else {
$addr += $nb_ai;
$nb += $nb_ai;
}
}
}
} elsif ($tspec =~ m{^(\$[a-zA-Z][a-zA-Z0-9]*)$} ) { # struct ?
my $sname = $1;
my $sdsc = $structtbl{$sname};
if (defined $sdsc) {
foreach my $tspec_si ( @{$sdsc} ) {
if ($tspec_si eq "code") { # handle trailing ,code
add_ctpend($addr, $sname);
return $nb;
}
my $nb_si = set_typlabcref($addr, $tspec_si);
if ($nb_si <= 0) {
my $addr_str = convoct($addr);
print_bugcheck(__LINE__,
"struct '$sname' abort for $tspec_si " .
"at $addr_str in set_typlabcref()");
return 0;
} else {
$addr += $nb_si;
$nb += $nb_si;
}
}
} else {
print_bugcheck(__LINE__, "struct '$sname' undefined in set_typlabcref()");
return 0;
}
} else {
print_bugcheck(__LINE__, "unexpected '$tspec' in set_typlabcref()");
return 0;
}
return $nb;
}
#-------------------------------------------------------------------------------
#
# L > D > P , B > C > R > S
#
sub set_labcref { # define auto label, add cref info
my ($addr, $lpref, $from, $atyp) = @_;
my $addr_str = $data[$addr]->{label};
if (not $addr_str) { # not yet labeled
$addr_str = convoct($addr);
if (not exists $adrtbl{$addr_str}) {
my $typ = chk_data($addr) ? "albl" : "asym";
add_symbol($addr, $lpref . "#####", $typ);
}
} else { # already labeled
if ($adrtbl{$addr_str}->{typ} eq "albl") {
if ($adrtbl{$addr_str}->{string} =~ m{^(.)\#{5}$} ) {
my $opref = $1;
my $npref = undef;
$npref = $lpref if ($opref eq "D" and $lpref eq "P"); # D > P
$npref = $lpref if ($opref eq "B" and $lpref eq "C"); # B > C
$npref = $lpref if ($opref =~ /[BC]/ and $lpref eq "R"); # BC > R
$npref = $lpref if ($opref eq "L"); # L > .
$npref = $lpref if ($lpref eq "S"); # . > S
$adrtbl{$addr_str}->{string} = $npref . "#####" if $npref;
## print "+++4 upgrade $addr_str: $opref -> $npref\n" if $npref;
}
}
}
##printf "+++7 %6.6o %s %6.6o\n", $addr, (defined $atyp) ? $atyp : "??",
## (defined $from) ? $from : -1;
add_adrcref($addr_str, $from, $atyp) if defined $from;
}
#-------------------------------------------------------------------------------
sub add_adrcref { # add cref entry in adrtbl
my ($addr_str, $from, $atyp) = @_;
return unless defined $from && defined $atyp;
return unless defined $adrtbl{$addr_str};
$adrtbl{$addr_str}->{cref} = {} unless exists $adrtbl{$addr_str}->{cref};
my $cref = $adrtbl{$addr_str}->{cref};
my $from_str = convoct($from);
return if exists $cref->{$from_str};
$cref->{$from_str} = $atyp;
}
#-------------------------------------------------------------------------------
sub add_symcref { # add cref entry in symtbl
my ($symbol, $from) = @_;
return unless defined $from;
return unless defined $symtbl{$symbol};
$symtbl{$symbol}->{cref} = {} unless exists $symtbl{$symbol}->{cref};
my $cref = $symtbl{$symbol}->{cref};
my $from_str = convoct($from);
return if exists $cref->{$from_str};
$cref->{$from_str} = 1;
}
#-------------------------------------------------------------------------------
sub set_option { # setup .enabl/.dsabl option
my ($addr, $ends, $opt, $alist_str) = @_;
$alist_str =~ s{^\s+}{}; # drop leading space
$alist_str =~ s{\s+$}{}; # drop trailing space
my @alist = split /\s+/, $alist_str;
if (not exists $opttbl{$opt}) {
print STDERR "dasm-11-E: unknown .enabl/.dsabl option '$opt', ignored\n";
return;
}
my $odsc = $opttbl{$opt};
if ($ends eq ".dsabl" && scalar(@alist) > 0) {
print STDERR "dasm-11-E: attributes '$alist_str' ignored for .dsabl $opt\n";
}
my %newattr = (ena => ($ends eq ".enabl") ? 1 : 0);
if ($ends eq ".enabl") {
foreach my $attr (@alist) {
if ($attr =~ m{^([a-zA-z][a-zA-Z0-9]*) # <attr_name>
= # =
(.*) # <attr_value>
$ }x ) {
my $aname = $1;
my $aval = $2;
if (exists $odsc->{attr}->{$aname}) {
my $atype = $odsc->{attr}->{$aname};
if ($atype eq "n") { # atype = n (number oct/dec)
if ($aval =~ m{^([0-7]+|[0-9]+\.)$}) {
$newattr{$aname} = get_numoctdec($aval);
} else {
printf STDERR "dasm-11-E: bad dec/oct number: '$aval'" .
" in '$ends $opt $alist_str'\n";
}
} elsif ($atype eq "l") { # atype = l (label)
$newattr{$aname} = $aval;
} else {
print_bugcheck(__LINE__, "unexpected atype '$atype'");
}
} else {
printf STDERR "dasm-11-E: unknown attribute: '$aname'" .
" in '$ends $opt $alist_str'\n";
}
} else {
printf STDERR "dasm-11-E: bad attribute syntax: '$attr'" .
" in '$ends $opt $alist_str'\n";
}
}
}
if (defined $addr) {
my $dsc = $data[$addr];
push @{$dsc->{optlist}}, { opt => $opt,
alist => { %newattr } };
} else {
foreach (keys %newattr) {
$odsc->{$_} = $newattr{$_};
}
}
}
#-------------------------------------------------------------------------------
sub set_curopt { # update current option list %curopt
my ($optlist) = @_;
return unless defined $optlist;
foreach my $odsc (@{$optlist}) {
if (exists $odsc->{susp}) {
my $opt = $odsc->{susp};
push @susp_restore, [$opt, $curopt{$opt}->{ena}];
$curopt{$opt}->{ena} = 0;
##print STDERR "+++8a set_curopt: susp=$opt\n";
} else {
my $opt = $odsc->{opt};
my $alist = $odsc->{alist};
foreach (keys %{$alist}) {
$curopt{$opt}->{$_} = $alist->{$_};
##print STDERR "+++8b set_curopt: opt=$opt attr=$_ val=$alist->{$_}\n";
}
}
}
}
#-------------------------------------------------------------------------------
sub set_susopt { # restore suspended options
my $dsc;
while ($dsc = shift @susp_restore) {
my $opt = $dsc->[0];
my $oena = $dsc->[1];
$curopt{$opt}->{ena} = $oena;
##print STDERR "+++8c set_susopt: $opt = $oena\n";
}
}
#-------------------------------------------------------------------------------
sub set_acslabel { # define auto label from acs info
my ($acs, $typ, $eai, $pc) = @_;
return 0 if not defined $acs;
return 0 if not defined $typ;
if ($acs =~ m{^[rwm]$} ) {
if ($typ eq "addr") {
set_labcref($eai, "D", $pc, $acs);
return 1;
} elsif ($typ eq "iaddr") {
set_labcref($eai, "P", $pc, "@"); # label pointer variable
my $taddr = get_word($eai);
if (defined $taddr && $taddr > 0) {
set_labcref($taddr, "D", $pc, "@".$acs); # label final target
$data[$eai]->{datsym} = "1"; # FIXME: see 2009-04-10 TODO
}
return 1;
}
} elsif ($acs =~ m{^[je]$} ) {
my $lblpref = ($acs eq "e") ? "R" : "C";
if ($typ eq "addr") {
set_labcref($eai, $lblpref, $pc, $acs);
return 1;
} elsif ($typ eq "iaddr") {
set_labcref($eai, "P", $pc, "@");
my $taddr = get_word($eai);
if (defined $taddr && $taddr > 0 && # if indirect target non-zero
chk_data($taddr) eq "w") { # and pointing to data
set_labcref($taddr, $lblpref, $pc, "@".$acs); # setup auto label
$data[$eai]->{datsym} = "1"; # FIXME: see 2009-04-10 TODO
}
return 1;
}
}
return 0;
}
#-------------------------------------------------------------------------------
#
# Access word data
#
# $word = get_word($addr)
# with
# $addr address (undef is allowed)
# returns
# $word $data[$addr]->{word} or undef if byte mode or not available
#
sub get_word { # return word data (or undef)
my ($addr) = @_;
return undef unless defined $addr;
return undef unless defined $data[$addr];
return undef unless defined $data[$addr]->{word};
return undef if defined $data[$addr]->{byte};
return $data[$addr]->{word};
}
#-------------------------------------------------------------------------------
#
# Access byte data
#
# $byte = get_byte($addr)
# with
# $addr address (undef is allowed)
# returns
# $byte $data[$addr]->{byte} or undef if no byte data available
#
sub get_byte { # return byte data (or undef)
my ($addr) = @_;
return undef unless defined $addr;
return undef unless defined $data[$addr];
return undef unless defined $data[$addr]->{byte};
return $data[$addr]->{byte};
}
#-------------------------------------------------------------------------------
#
# Get target address of instruction
#
# $word = get_taddr($eai, $typ)
# with
# $eai effective address
# $typ operand type (addr or iaddr; other cause undef return)
# returns
# $addr target address ($eai or get_word($eai))
#
# will return $eai if $typ is "addr", and the contents of location $eai
# if $typ is "iaddr" and the target address if non-zero.
#
sub get_taddr { # return target address (or undef)
my ($eai, $typ) = @_;
return undef unless defined $eai;
return undef unless defined $typ;
my $taddr = undef;
if ($typ eq "addr") {
$taddr = $eai;
} elsif ($typ eq "iaddr") {
$taddr = get_word($eai);
$taddr = undef if defined $taddr && $taddr == 0;
}
return $taddr;
}
#-------------------------------------------------------------------------------
sub add_adr_rlabel { # add relative label entry in adrtbl
my ($addr, $base) = @_;
my $addr_str = convoct($addr);
my $base_str = convoct($base);
my $string = ($addr>=$base) ?
sprintf "%s+%o", $base_str, $addr-$base :
sprintf "%s-%o", $base_str, $base-$addr;
$adrtbl{$addr_str}->{addr} = $addr;
$adrtbl{$addr_str}->{typ} = "rlbl";
$adrtbl{$addr_str}->{string} = $string;
}
#-------------------------------------------------------------------------------
sub add_adr_alist { # add attribute list to adrtbl entry
my ($addr_str, $alist_str) = @_;
$alist_str =~ s{\s*}{}; # drop leading blanks
my @alist = split /\s+/, $alist_str;
foreach my $item (@alist) {
if ($item =~ m{([a-zA-Z][a-zA-Z0-9]*)=(\S+)} ) {
my $attr = $1;
my $val = $2;
if ($attr =~ m{^(use)$} ) {
add_adr_attr($addr_str, $attr, $val);
} else {
print STDERR "dasm-11-E: invalid attribute '$item', ignored\n";
}
} else {
print_bugcheck(__LINE__, "bad attribute spec '$item'");
}
}
}
#-------------------------------------------------------------------------------
sub add_adr_attr { # add attribute to adrtbl entry
my ($addr_str, $attr, $val) = @_;
if (exists $adrtbl{$addr_str}) {
$adrtbl{$addr_str}->{$attr} = $val;
} else {
print_bugcheck(__LINE__, "add_adr_attr: no adrtbl entry for '$addr_str'");
}
}
#-------------------------------------------------------------------------------
sub add_sym_attr { # add attribute to symtbl entry
my ($symbol, $attr, $val) = @_;
if (exists $symtbl{$symbol}) {
$symtbl{$symbol}->{$attr} = $val;
} else {
print_bugcheck(__LINE__, "add_sym_attr: no symtbl entry for '$symbol'");
}
}
#-------------------------------------------------------------------------------
sub add_dat_attr { # add attribute to data word/byte
my ($addr, $attr, $val) = @_;
if (chk_data($addr)) {
$data[$addr]->{$attr} = $val;
} else {
my $addr_str = convoct($addr);
print_bugcheck(__LINE__, "add_dat_attr: no data available for '$addr_str'");
}
}
#-------------------------------------------------------------------------------
sub add_dat_alist { # add attribute list for data
my ($addr, $alist_str) = @_;
my $addr_str = convoct($addr);
$alist_str =~ s{\s*}{}; # drop leading blanks
my @alist = split /\s+/, $alist_str;
foreach my $item (@alist) {
if ($item =~ m{([a-zA-Z][a-zA-Z0-9]*)=(\S+)} ) {
my $attr = $1;
my $val = $2;
if ($attr eq "use" ) {
add_adr_attr($addr_str, "use", $val);
add_dat_attr($addr, "datsym", $val);
} else {
print STDERR "dasm-11-E: invalid attribute '$item', ignored\n";
}
} else {
print_bugcheck(__LINE__, "add_dat_alist: bad attribute spec '$item'");
}
}
}
#-------------------------------------------------------------------------------
sub add_ops_alist { # add attribute list for code
my ($addr, $alist_str) = @_;
$alist_str =~ s{\s*}{}; # drop leading blanks
my @alist = split /\s+/, $alist_str;
foreach my $item (@alist) {
if ($item =~ m{([a-zA-Z][a-zA-Z0-9]*)=(\S+)} ) {
my $attr = $1;
my $val = $2;
if ($attr =~ m{^op[12]sym$} ) {
add_dat_attr($addr, $attr, $val);
} else {
print STDERR "dasm-11-E: invalid attribute '$item', ignored\n";
}
} else {
print_bugcheck(__LINE__, "add_ops_alist: bad attribute spec '$item'");
}
}
}
#-------------------------------------------------------------------------------
sub add_symbol { # add symbol in adrtbl and symtbl
my ($addr, $symbol, $typ) = @_;
my $addr_str = convoct($addr);
word2byte($addr) if chk_data($addr) eq "o";
if ($typ eq "data" && exists $symtbl{$symbol}) {
printf STDERR "dasm-11-E: symbol '%s' already defined, value=%6.6o, " .
"new definition for %6.6o will be ignored\n",
$symbol, $symtbl{$symbol}->{val}, $addr;
return;
}
if (exists $adrtbl{$addr_str}) {
if ($adrtbl{$addr_str}->{typ} eq "albl" && $typ eq "data") {
$adrtbl{$addr_str}->{typ} = $typ;
$adrtbl{$addr_str}->{string} = $symbol;
$symtbl{$symbol} = {val => $addr,
typ => $typ};
return;
}
printf STDERR "dasm-11-E: addr=%6.6o already labeled '%s', " .
"new definition '%s' will be ignored\n",
$addr, $adrtbl{$addr_str}->{string}, $symbol;
return;
}
$adrtbl{$addr_str} = {addr => $addr,
typ => $typ,
string => $symbol};
if ($typ =~ m{^(data|gsym)$} ) {
$symtbl{$symbol} = {val => $addr,
typ => $typ};
}
if ($typ =~ m{^(data|albl|asym)$} &&
chk_data($addr) =~ m{[bw]} ) {
$data[$addr]->{label} = $addr_str;
}
}
#-------------------------------------------------------------------------------
sub add_ctpend { # add element in cod tag pending list
my ($addr, $from) = @_;
return unless chk_data($addr) eq "w"; # FIXME: review logic
return if defined $data[$addr]->{type} && $data[$addr]->{type} eq "code";
push @ctpend, {addr=>$addr, from=>$from};
}
#-------------------------------------------------------------------------------
sub add_lcomm { # add full line comment
my ($addr, $lcomm) = @_;
while ($lcomm =~ m{^;\|(.*?)(;\|.*)$} ) {
push @{ $data[$addr]->{lcomm} }, ";".$1;
$lcomm = $2;
}
$lcomm =~ s{;\|}{;};
push @{ $data[$addr]->{lcomm} }, $lcomm;
}
#-------------------------------------------------------------------------------
sub add_scomm { # add statement comment
my ($addr, $scomm) = @_;
if ($scomm =~ m{^!!.*!!$} ) { # if "!!...!!" generated comment
foreach (@{ $data[$addr]->{scomm} }) {
return if $scomm eq $_; # quit if already present
}
}
push @{ $data[$addr]->{scomm} }, $scomm;
}
#-------------------------------------------------------------------------------
sub add_symset { # add a new %symsettbl entry
my ($setname, $setdef) = @_;
if (defined $symsettbl{$setname}) {
printf STDERR "dasm-11-E: symbol set '%s' already defined\n", $setname;
} else {
foreach my $item (split /,/,$setdef) {
if ($item =~ m{^
([a-zA-Z\$\.][a-zA-Z0-9\$\.]*)
=
([0-7]+)(:[0-7]+)?
$ }x ){
my $name = $1;
my $val = oct $2;
my $mask = $3;
if (exists $symtbl{$name}) {
printf STDERR "dasm-11-E: symbol '%s' already defined, " .
"value=%6.6o, new definition for set '%s' " .
"will be ignored\n",
$name, $symtbl{$name}->{val}, $setname;
next;
}
my $href = { sym => $name,
val => $val};
if (defined $mask && $mask ne "") {
if ($setname =~ m{^\%} ) {
$mask =~ s/://;
$href->{msk} = oct $mask;
} else {
printf STDERR "dasm-11-E: mask field in '%s' " .
"for symbol \$ type set '%s' ignored\n",
$item, $setname;
}
}
push @{ $symsettbl{$setname} }, $href;
$symtbl{$name}->{val} = $val;
$symtbl{$name}->{typ} = $setname;
} else {
printf STDERR "dasm-11-E: bad item '%s' for symbol set '%s'\n",
$item, $setname;
}
}
}
}
#-------------------------------------------------------------------------------
sub add_struct { # add a new %structtbl entry
my ($sname, $tspeclist) = @_;
if (exists $structtbl{$sname}) {
print STDERR "dasm-11-E: \"$sname\" already defined, .struct ignored\n";
return;
}
$structtbl{$sname} = undef; # define blank to allow self ref's
my $tspeclist_chk = $tspeclist;
$tspeclist_chk =~ s{,code$}{}; # hide a trailing 'code'
my $ok = chk_typespec($tspeclist_chk, 1); # to typespec checker
if (not $ok) {
delete $structtbl{$sname}; # undo blank def in case of error
print STDERR "dasm-11-E: errors in typespec-list, .struct $sname ignored\n";
return;
}
$structtbl{$sname} = [ split /\s*,\s*/,$tspeclist ];
}
#-------------------------------------------------------------------------------
sub add_params { # add a new %paramstbl entry
my ($name, $pstr) = @_;
my @plist = split /,/, $pstr;
my $pstr_nodir = $pstr;
$pstr_nodir =~ s{,?\.(no|skip|try)ret$}{}; # drop trailing . no|skip|try ret
if (chk_typespec($pstr_nodir, 1)) {
$paramstbl{$name} = [ @plist ];
} else {
print STDERR "dasm-11-E: invalid .params argument '$pstr'," .
" .params $name ignored\n";
}
}
#-------------------------------------------------------------------------------
sub chk_typespec { # check validity of typespec (or list)
my ($text, $list) = @_;
my @tspeclist = split /\s*,\s*/, $text;
if (scalar(@tspeclist) > 1 && (not $list)) {
print STDERR "dasm-11-E: only single typespec allowed but list \"" .
$text . "\" found\n";
return 0;
}
foreach my $tspec (@tspeclist) {
if ($tspec =~ m { ^
(byte|word|code|
asci[iz]|asc[0-7]{3}|
rad50|flt[24]|vect|
\$[a-zA-Z][a-zA-Z0-9]*)
(\*?)
((\[\d*\.?\])?)
(\**)
$ }x ) {
my $tname = $1;
my $ptr1 = $2;
my $arr = $3;
my $ptr2 = $4;
if ($tname =~ m{^\$} && not exists $structtbl{$tname}) {
print STDERR "dasm-11-E: bad type in typespec '$tspec':" .
" '$tname' not yet defined\n";
return 0;
}
if ($tname =~ m{^(rad50|flt[24])$} ) {
print STDERR "dasm-11-E: bad type in typespec '$tspec':" .
" '$tname' not yet supported\n";
return 0;
}
if ($arr && $arr ne "[]") {
if ($arr !~ m{^ \[
([1-7][0-7]*|
[1-9][0-9]*\.)
\]
$ }x ) {
print STDERR "dasm-11-E: bad array spec in typespec '$tspec'\n";
return 0;
}
}
if ($tname =~ m{^(code|vect)$} && (not $ptr1)) {
print STDERR "dasm-11-E: bad typespec '$tspec': ".
"'*' required after $tname\n";
return 0;
}
if ($tname =~ m{^(ascii|rad50)$} && $ptr1) {
print STDERR "dasm-11-E: bad typespec '$tspec': ".
"$tname* not allowed\n";
return 0;
}
if ($tname =~ m{^(ascii|rad50)$} && ((not $arr) || $arr eq "[]") ) {
print STDERR "dasm-11-E: bad typespec '$tspec': ".
"[nn] required after $tname\n";
return 0;
}
if ($tname =~ m{^(asciz|code)$} && (not $ptr1) && $arr) {
print STDERR "dasm-11-E: bad typespec '$tspec': ".
"[nn] not allowed after $tname\n";
return 0;
}
if ($arr && $arr eq "[]" && (not $ptr1)) {
print STDERR "dasm-11-E: bad typespec '$tspec': ".
"[] only allowed after *\n";
}
} else {
print STDERR "dasm-11-E: bad typespec \"$tspec\"\n";
return 0;
}
}
return 1;
}
#-------------------------------------------------------------------------------
# Check availability of byte data, and convert {word}->{byte} if needed
#
# $rc = chk_byte($addr)
# with
# $addr address
# returns
# $rc "" if no data available
# "b" if {byte} available
#
sub chk_byte { # check availability of byte (convert if needed)
my ($addr) = @_;
my $rc = chk_data($addr);
if ($rc eq "w" || $rc eq "o") {
word2byte($addr);
$rc = "b";
}
return $rc;
}
#-------------------------------------------------------------------------------
#
# Check availability of data
#
# $rc = chk_data($addr)
# with
# $addr address
# returns
# $rc "" if no data available
# "b" if {byte} available
# "w" if {word} available and no {byte} defined yet
# "o" if odd address of an available {word} and no {byte} yet
#
sub chk_data { # check availability of data (word or byte)
my ($addr) = @_;
return "b" if defined $data[$addr]->{byte};
return "w" if defined $data[$addr]->{word};
return "o" if defined $data[$addr & 0177776]->{word};
return "";
}
#-------------------------------------------------------------------------------
sub chk_opcode { # check existence and content of {opcode}
my ($pc, $txt) = @_;
my $val = $data[$pc]->{opcode};
return (defined $val && $val eq $txt);
}
#-------------------------------------------------------------------------------
sub chk_op1typ { # check existence and content of {op1typ}
my ($pc, $txt) = @_;
my $val = $data[$pc]->{op1typ};
return (defined $val && $val eq $txt);
}
#-------------------------------------------------------------------------------
sub chk_op2typ { # check existence and content of {op2typ}
my ($pc, $txt) = @_;
my $val = $data[$pc]->{op2typ};
return (defined $val && $val eq $txt);
}
#-------------------------------------------------------------------------------
sub chk_op2str { # check existence and content of {op2str}
my ($pc, $txt) = @_;
my $val = $data[$pc]->{op2str};
return (defined $val && $val eq $txt);
}
#-------------------------------------------------------------------------------
sub chk_type { # check whether address is typed
my ($addr, $type) = @_;
return 0 unless defined $addr;
return 0 unless defined $data[$addr];
return 0 unless defined $data[$addr]->{type};
if (defined $type) {
return $type eq $data[$addr]->{type};
} else {
return 1;
}
}
#-------------------------------------------------------------------------------
sub convoct { # convert 16 bit int to %6.6o octal
my ($dat) = @_;
return sprintf "%6.6o", $dat;
}
#-------------------------------------------------------------------------------
sub get_numoctdec { # convert oct or dec number to binary
my ($str) = @_;
if ($str =~ m{^(\d+)\.$} ) {
return int $1;
} elsif ($str =~ m{^([0-7]+)$} ) {
return oct $1;
}
printf STDERR "dasm-11-E: bad dec/oct number: '$str'\n";
return undef;
}
#-------------------------------------------------------------------------------
sub print_bugcheck { # print BUGCHECK message, with line number
my ($line, $text) = @_;
print STDERR "dasm-11-E: BUGCHECK in line $line: $text\n";
}
#-------------------------------------------------------------------------------
sub bailout {
my ($msg) = @_;
print STDERR "dasm-11-F: $msg\n";
exit 1;
}
#-------------------------------------------------------------------------------
sub print_help { # --help or error output
print "usage: dasm-11 [OPTIONS]... FILE\n";
print " --I=path adds path to the das include search path\n";
print " --das=file specify steering file (default FILE.das if exists)\n";
print " --dmode=mode default mode for untagged data\n";
print " --start=nn[,..] list of code start addresses\n";
print " --info print info on unnamed vector and iospace addresses\n";
print " --draw dump raw data\n";
print " --dtag dump tagged data\n";
print " --tctag trace code tagging\n";
print " --ttlc trace typlabcref calls\n";
print " --help this message\n";
}
Reference in New Issue View Git Blame Copy Permalink