-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathsymtab_m.f90
241 lines (210 loc) · 7.46 KB
/
symtab_m.f90
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
module SYMTAB_M
! Symbol table for 1401 Autocoder
implicit NONE
private
type, public :: SYMBOL_T
character(6) :: LABEL ! From label field of input
integer :: VALUE ! Typically an address
integer :: LC ! Location counter for VALUE. -1..99. Zero is
! not relocatable, negative means external.
integer :: INDEX ! Index register number, 0..3
character(3) :: DEV ! Device %<letter><number> if LABEL is on EQU
logical :: REF
end type SYMBOL_T
type(symbol_t), save, allocatable :: SYMBOLS(:)
integer, parameter, public :: REF = -30000
integer, save :: NUM_SYMS
integer, parameter :: INIT_SIZE = 100
! Location counter table. 0 => not in use, -1 => relocatable, 1 => absolute
integer, parameter, public :: LC_MAX = 9
character(*), parameter, public :: LC_MAX_T = '9' ! for error messages
integer, save, public :: LC_TAB(0:LC_MAX)
data lc_tab(0) /1/, lc_tab(1:LC_MAX) / LC_MAX*0 /
public :: DUMP_SYMTAB, ENTER, INIT_SYM_TABLE, LOOKUP, SYMBOLS
contains
! ------------------------------------------------ DUMP_SYMTAB -----
subroutine DUMP_SYMTAB ( Unit, Heading, Sort )
use BCD_TO_ASCII_m, only: BCD_to_ASCII, B_AMPER
integer, intent(in), optional :: Unit ! stdout if absent or negative
character(len=*), intent(in), optional :: Heading ! printed before the dump
logical, intent(in), optional :: Sort ! Sort, default false
integer :: I, J, K, MyUnit
logical MySort
integer :: N ! Symbols per line
type(symbol_t) :: OneSym
character(5) :: Value(6)
character(2) :: LC(6)
character(3) :: X(6)
integer, parameter :: Nun = 17 ! Number of unreferenced symbols per line
character(7*Nun) :: Line
logical :: Unref ! At least one symbol was not referenced
if ( num_syms == 0 ) return
myUnit = -1
if ( present(unit) ) myUnit = unit
if ( present(heading) ) then
if ( myUnit < 0 ) then
print *
print *, trim(heading)
else
write ( myUnit, * )
write ( myUnit, * ) trim(heading)
end if
end if
mySort = .false.
if ( present(sort) ) mySort = sort
n = 4
if ( mySort ) then
n = 6
! First put the smallest one at location 1
oneSym = symbols(1)
j = 1
do i = 2, num_syms
if ( symbols(i)%label < oneSym%label ) then
oneSym = symbols(i)
j = i
end if
end do ! i
symbols(j) = symbols(1)
symbols(1) = oneSym
! Now do an insertion sort
do i = 2, num_syms
oneSym = symbols(i)
j = i
do
if ( oneSym%label > symbols(j-1)%label ) then
symbols(j) = oneSym
exit
end if
symbols(j) = symbols(j-1)
j = j - 1
end do ! j
end do ! i
end if
unref = .false.
do i = 1, num_syms, n
do j = 1, n
if ( i+j-1 > num_syms ) exit
unref = unref .or. .not. symbols(i+j-1)%ref
x(j) = ''
write ( lc(j), '(i2)' ) symbols(i+j-1)%lc
if ( symbols(i+j-1)%value <= ref ) then
value(j) = 'UNDEF'
lc(j) = '##'
else if ( symbols(i+j-1)%dev /= '' ) then
value(j) = symbols(i+j-1)%dev
else
write ( value(j), '(i5.4)' ) symbols(i+j-1)%value
if ( symbols(i+j-1)%index /= 0 ) &
& write ( x(j), '(a,"X",i1)' ) &
& bcd_to_ascii(b_amper), symbols(i+j-1)%index
end if
end do
if ( myUnit < 0 ) then
if ( mySort ) then
print 10, (symbols(i+k-1)%label, value(k), lc(k), x(k), k = 1, j-1)
10 format ( 6(1x, a6, 2x, a5, ':', a2, a3) )
else
print 20, i, (symbols(i+k-1)%label, value(k), lc(k), x(k), k = 1, j-1)
20 format ( i4, ':', 6(1x, a6, 2x, a5, ':', a2, a3) )
end if
else
if ( mySort ) then
write ( myUnit, 10 ) (symbols(i+k-1)%label, value(k), lc(k), x(k), k = 1, j-1)
else
write ( myUnit, 20 ) i, (symbols(i+k-1)%label, value(k), lc(k), x(k), k = 1, j-1)
end if
end if
end do
if ( unref ) then
write ( myUnit, '(/"0UNREFERENCED SYMBOLS"/)' )
n = 2
line = ''
do i = 1, num_syms
if ( .not. symbols(i)%ref ) then
if ( n >= len(line) ) then
write ( myUnit, '(a)' ) trim(line)
line = ''
n = 2
end if
line(n:n+5) = symbols(i)%label
n = n + 7
end if
end do
write ( myUnit, '(a)' ) trim(line)
end if
end subroutine DUMP_SYMTAB
! ------------------------------------------------------ ENTER -----
subroutine ENTER ( LABEL, VALUE, LC, INDEX, NUM, DUPLICATE, DEV )
! Enter LABEL into the symbol table with VALUE, LC and INDEX.
! Return DUPLICATE = "It was already there!" -- but never if Value <= REF
! or if the value found <= REF. Return NUM where it was found or inserted,
! or -1 if label == ''
character(*), intent(in) :: LABEL
integer, intent(in) :: VALUE ! REF for references, else the value
integer, intent(in) :: LC ! Location counter for definitions
integer, intent(in) :: INDEX
integer, intent(out), optional :: NUM ! Where it was found or created
logical, intent(out), optional :: DUPLICATE
character(3), intent(in), optional :: DEV ! If label is on EQU
character(3) :: MyDev
integer :: I
type(symbol_t), allocatable :: TEMP(:)
if ( present(duplicate) ) duplicate = .false.
if ( present(num) ) num = -1
if ( label == '' ) return
myDev = ' '
if ( present(dev) ) myDev = dev
! Create the symbol table if it doesn't exist
if ( .not. allocated(symbols) ) call init_sym_table
! Check for duplicate definition
do i = 1, num_syms
if ( label == symbols(i)%label ) then
if ( symbols(i)%value <= ref ) then
symbols(i)%value = value
symbols(i)%index = index
symbols(i)%lc = lc
else
if (present(duplicate) ) duplicate = value > ref
end if
symbols(i)%ref = symbols(i)%ref .or. value == ref
if ( present(num) ) num = i
return
end if
end do
! Increase the size of the symbol table if necessary
if ( num_syms >= size(symbols) ) then
allocate ( temp(num_syms) )
temp = symbols
deallocate ( symbols )
allocate ( symbols(2*num_syms) )
symbols(:num_syms) = temp
deallocate ( temp )
end if
num_syms = num_syms + 1
if ( present(num) ) num = num_syms
symbols(num_syms) = symbol_t ( label, value, lc, index, myDev, value==ref )
end subroutine ENTER
! --------------------------------------------- INIT_SYM_TABLE -----
subroutine INIT_SYM_TABLE
if ( allocated(symbols) ) deallocate ( symbols )
allocate ( symbols(init_size) )
num_syms = 0
end subroutine INIT_SYM_TABLE
! ----------------------------------------------------- LOOKUP -----
subroutine LOOKUP ( LABEL, WHERE )
! Look up LABEL. Return its location in SYMBOLS in WHERE. If not
! found, return WHERE = -1
character(*), intent(in) :: LABEL
integer, intent(out), optional :: WHERE
integer :: I
if ( .not. allocated(symbols) ) call init_sym_table
do i = 1, num_syms
if ( label == symbols(i)%label ) then
if ( present(where) ) where = i
return
end if
end do
if ( present(where) ) where = -1
end subroutine LOOKUP
end module SYMTAB_M
!>> 2011-08-14 Location counter number