aboutsummaryrefslogtreecommitdiff
path: root/llvm/lib/Target/Sparc/Disassembler/SparcDisassembler.cpp
blob: b7581c1979d829bbb3e2b6ec120041393846ac39 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
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
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
//===- SparcDisassembler.cpp - Disassembler for Sparc -----------*- C++ -*-===//
//
// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
// See https://llvm.org/LICENSE.txt for license information.
// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
//
//===----------------------------------------------------------------------===//
//
// This file is part of the Sparc Disassembler.
//
//===----------------------------------------------------------------------===//

#include "MCTargetDesc/SparcMCTargetDesc.h"
#include "TargetInfo/SparcTargetInfo.h"
#include "llvm/MC/MCAsmInfo.h"
#include "llvm/MC/MCContext.h"
#include "llvm/MC/MCDecoderOps.h"
#include "llvm/MC/MCDisassembler/MCDisassembler.h"
#include "llvm/MC/MCInst.h"
#include "llvm/MC/TargetRegistry.h"

using namespace llvm;

#define DEBUG_TYPE "sparc-disassembler"

typedef MCDisassembler::DecodeStatus DecodeStatus;

namespace {

/// A disassembler class for Sparc.
class SparcDisassembler : public MCDisassembler {
public:
  SparcDisassembler(const MCSubtargetInfo &STI, MCContext &Ctx)
      : MCDisassembler(STI, Ctx) {}
  virtual ~SparcDisassembler() = default;

  DecodeStatus getInstruction(MCInst &Instr, uint64_t &Size,
                              ArrayRef<uint8_t> Bytes, uint64_t Address,
                              raw_ostream &CStream) const override;
};
}

static MCDisassembler *createSparcDisassembler(const Target &T,
                                               const MCSubtargetInfo &STI,
                                               MCContext &Ctx) {
  return new SparcDisassembler(STI, Ctx);
}


extern "C" LLVM_EXTERNAL_VISIBILITY void LLVMInitializeSparcDisassembler() {
  // Register the disassembler.
  TargetRegistry::RegisterMCDisassembler(getTheSparcTarget(),
                                         createSparcDisassembler);
  TargetRegistry::RegisterMCDisassembler(getTheSparcV9Target(),
                                         createSparcDisassembler);
  TargetRegistry::RegisterMCDisassembler(getTheSparcelTarget(),
                                         createSparcDisassembler);
}

static const unsigned IntRegDecoderTable[] = {
  SP::G0,  SP::G1,  SP::G2,  SP::G3,
  SP::G4,  SP::G5,  SP::G6,  SP::G7,
  SP::O0,  SP::O1,  SP::O2,  SP::O3,
  SP::O4,  SP::O5,  SP::O6,  SP::O7,
  SP::L0,  SP::L1,  SP::L2,  SP::L3,
  SP::L4,  SP::L5,  SP::L6,  SP::L7,
  SP::I0,  SP::I1,  SP::I2,  SP::I3,
  SP::I4,  SP::I5,  SP::I6,  SP::I7 };

static const unsigned FPRegDecoderTable[] = {
  SP::F0,   SP::F1,   SP::F2,   SP::F3,
  SP::F4,   SP::F5,   SP::F6,   SP::F7,
  SP::F8,   SP::F9,   SP::F10,  SP::F11,
  SP::F12,  SP::F13,  SP::F14,  SP::F15,
  SP::F16,  SP::F17,  SP::F18,  SP::F19,
  SP::F20,  SP::F21,  SP::F22,  SP::F23,
  SP::F24,  SP::F25,  SP::F26,  SP::F27,
  SP::F28,  SP::F29,  SP::F30,  SP::F31 };

static const unsigned DFPRegDecoderTable[] = {
  SP::D0,   SP::D16,  SP::D1,   SP::D17,
  SP::D2,   SP::D18,  SP::D3,   SP::D19,
  SP::D4,   SP::D20,  SP::D5,   SP::D21,
  SP::D6,   SP::D22,  SP::D7,   SP::D23,
  SP::D8,   SP::D24,  SP::D9,   SP::D25,
  SP::D10,  SP::D26,  SP::D11,  SP::D27,
  SP::D12,  SP::D28,  SP::D13,  SP::D29,
  SP::D14,  SP::D30,  SP::D15,  SP::D31 };

static const unsigned QFPRegDecoderTable[] = {
  SP::Q0,  SP::Q8,   ~0U,  ~0U,
  SP::Q1,  SP::Q9,   ~0U,  ~0U,
  SP::Q2,  SP::Q10,  ~0U,  ~0U,
  SP::Q3,  SP::Q11,  ~0U,  ~0U,
  SP::Q4,  SP::Q12,  ~0U,  ~0U,
  SP::Q5,  SP::Q13,  ~0U,  ~0U,
  SP::Q6,  SP::Q14,  ~0U,  ~0U,
  SP::Q7,  SP::Q15,  ~0U,  ~0U } ;

static const unsigned FCCRegDecoderTable[] = {
  SP::FCC0, SP::FCC1, SP::FCC2, SP::FCC3 };

static const unsigned ASRRegDecoderTable[] = {
  SP::Y,     SP::ASR1,  SP::ASR2,  SP::ASR3,
  SP::ASR4,  SP::ASR5,  SP::ASR6,  SP::ASR7,
  SP::ASR8,  SP::ASR9,  SP::ASR10, SP::ASR11,
  SP::ASR12, SP::ASR13, SP::ASR14, SP::ASR15,
  SP::ASR16, SP::ASR17, SP::ASR18, SP::ASR19,
  SP::ASR20, SP::ASR21, SP::ASR22, SP::ASR23,
  SP::ASR24, SP::ASR25, SP::ASR26, SP::ASR27,
  SP::ASR28, SP::ASR29, SP::ASR30, SP::ASR31};

static const unsigned PRRegDecoderTable[] = {
  SP::TPC, SP::TNPC, SP::TSTATE, SP::TT, SP::TICK, SP::TBA, SP::PSTATE,
  SP::TL, SP::PIL, SP::CWP, SP::CANSAVE, SP::CANRESTORE, SP::CLEANWIN,
  SP::OTHERWIN, SP::WSTATE, SP::PC
};

static const uint16_t IntPairDecoderTable[] = {
  SP::G0_G1, SP::G2_G3, SP::G4_G5, SP::G6_G7,
  SP::O0_O1, SP::O2_O3, SP::O4_O5, SP::O6_O7,
  SP::L0_L1, SP::L2_L3, SP::L4_L5, SP::L6_L7,
  SP::I0_I1, SP::I2_I3, SP::I4_I5, SP::I6_I7,
};

static const unsigned CPRegDecoderTable[] = {
  SP::C0,  SP::C1,  SP::C2,  SP::C3,
  SP::C4,  SP::C5,  SP::C6,  SP::C7,
  SP::C8,  SP::C9,  SP::C10, SP::C11,
  SP::C12, SP::C13, SP::C14, SP::C15,
  SP::C16, SP::C17, SP::C18, SP::C19,
  SP::C20, SP::C21, SP::C22, SP::C23,
  SP::C24, SP::C25, SP::C26, SP::C27,
  SP::C28, SP::C29, SP::C30, SP::C31
};


static const uint16_t CPPairDecoderTable[] = {
  SP::C0_C1,   SP::C2_C3,   SP::C4_C5,   SP::C6_C7,
  SP::C8_C9,   SP::C10_C11, SP::C12_C13, SP::C14_C15,
  SP::C16_C17, SP::C18_C19, SP::C20_C21, SP::C22_C23,
  SP::C24_C25, SP::C26_C27, SP::C28_C29, SP::C30_C31
};

static DecodeStatus DecodeIntRegsRegisterClass(MCInst &Inst, unsigned RegNo,
                                               uint64_t Address,
                                               const MCDisassembler *Decoder) {
  if (RegNo > 31)
    return MCDisassembler::Fail;
  unsigned Reg = IntRegDecoderTable[RegNo];
  Inst.addOperand(MCOperand::createReg(Reg));
  return MCDisassembler::Success;
}

static DecodeStatus DecodeI64RegsRegisterClass(MCInst &Inst, unsigned RegNo,
                                               uint64_t Address,
                                               const MCDisassembler *Decoder) {
  return DecodeIntRegsRegisterClass(Inst, RegNo, Address, Decoder);
}

// This is used for the type "ptr_rc", which is either IntRegs or I64Regs
// depending on SparcRegisterInfo::getPointerRegClass.
static DecodeStatus DecodePointerLikeRegClass0(MCInst &Inst, unsigned RegNo,
                                               uint64_t Address,
                                               const MCDisassembler *Decoder) {
  return DecodeIntRegsRegisterClass(Inst, RegNo, Address, Decoder);
}

static DecodeStatus DecodeFPRegsRegisterClass(MCInst &Inst, unsigned RegNo,
                                              uint64_t Address,
                                              const MCDisassembler *Decoder) {
  if (RegNo > 31)
    return MCDisassembler::Fail;
  unsigned Reg = FPRegDecoderTable[RegNo];
  Inst.addOperand(MCOperand::createReg(Reg));
  return MCDisassembler::Success;
}

static DecodeStatus DecodeDFPRegsRegisterClass(MCInst &Inst, unsigned RegNo,
                                               uint64_t Address,
                                               const MCDisassembler *Decoder) {
  if (RegNo > 31)
    return MCDisassembler::Fail;
  unsigned Reg = DFPRegDecoderTable[RegNo];
  Inst.addOperand(MCOperand::createReg(Reg));
  return MCDisassembler::Success;
}

static DecodeStatus DecodeQFPRegsRegisterClass(MCInst &Inst, unsigned RegNo,
                                               uint64_t Address,
                                               const MCDisassembler *Decoder) {
  if (RegNo > 31)
    return MCDisassembler::Fail;

  unsigned Reg = QFPRegDecoderTable[RegNo];
  if (Reg == ~0U)
    return MCDisassembler::Fail;
  Inst.addOperand(MCOperand::createReg(Reg));
  return MCDisassembler::Success;
}

static DecodeStatus
DecodeCoprocRegsRegisterClass(MCInst &Inst, unsigned RegNo, uint64_t Address,
                              const MCDisassembler *Decoder) {
  if (RegNo > 31)
    return MCDisassembler::Fail;
  unsigned Reg = CPRegDecoderTable[RegNo];
  Inst.addOperand(MCOperand::createReg(Reg));
  return MCDisassembler::Success;
}

static DecodeStatus DecodeFCCRegsRegisterClass(MCInst &Inst, unsigned RegNo,
                                               uint64_t Address,
                                               const MCDisassembler *Decoder) {
  if (RegNo > 3)
    return MCDisassembler::Fail;
  Inst.addOperand(MCOperand::createReg(FCCRegDecoderTable[RegNo]));
  return MCDisassembler::Success;
}

static DecodeStatus DecodeASRRegsRegisterClass(MCInst &Inst, unsigned RegNo,
                                               uint64_t Address,
                                               const MCDisassembler *Decoder) {
  if (RegNo > 31)
    return MCDisassembler::Fail;
  Inst.addOperand(MCOperand::createReg(ASRRegDecoderTable[RegNo]));
  return MCDisassembler::Success;
}

static DecodeStatus DecodePRRegsRegisterClass(MCInst &Inst, unsigned RegNo,
                                              uint64_t Address,
                                              const MCDisassembler *Decoder) {
  if (RegNo >= std::size(PRRegDecoderTable))
    return MCDisassembler::Fail;
  Inst.addOperand(MCOperand::createReg(PRRegDecoderTable[RegNo]));
  return MCDisassembler::Success;
}

static DecodeStatus DecodeIntPairRegisterClass(MCInst &Inst, unsigned RegNo,
                                               uint64_t Address,
                                               const MCDisassembler *Decoder) {
  DecodeStatus S = MCDisassembler::Success;

  if (RegNo > 31)
    return MCDisassembler::Fail;

  if ((RegNo & 1))
    S = MCDisassembler::SoftFail;

  unsigned RegisterPair = IntPairDecoderTable[RegNo/2];
  Inst.addOperand(MCOperand::createReg(RegisterPair));
  return S;
}

static DecodeStatus
DecodeCoprocPairRegisterClass(MCInst &Inst, unsigned RegNo, uint64_t Address,
                              const MCDisassembler *Decoder) {
  if (RegNo > 31)
    return MCDisassembler::Fail;

  unsigned RegisterPair = CPPairDecoderTable[RegNo/2];
  Inst.addOperand(MCOperand::createReg(RegisterPair));
  return MCDisassembler::Success;
}

static DecodeStatus DecodeCall(MCInst &Inst, unsigned insn, uint64_t Address,
                               const MCDisassembler *Decoder);
static DecodeStatus DecodeSIMM13(MCInst &Inst, unsigned insn, uint64_t Address,
                                 const MCDisassembler *Decoder);

#include "SparcGenDisassemblerTables.inc"

/// Read four bytes from the ArrayRef and return 32 bit word.
static DecodeStatus readInstruction32(ArrayRef<uint8_t> Bytes, uint64_t Address,
                                      uint64_t &Size, uint32_t &Insn,
                                      bool IsLittleEndian) {
  // We want to read exactly 4 Bytes of data.
  if (Bytes.size() < 4) {
    Size = 0;
    return MCDisassembler::Fail;
  }

  Insn = IsLittleEndian
             ? (Bytes[0] << 0) | (Bytes[1] << 8) | (Bytes[2] << 16) |
                   (Bytes[3] << 24)
             : (Bytes[3] << 0) | (Bytes[2] << 8) | (Bytes[1] << 16) |
                   (Bytes[0] << 24);

  return MCDisassembler::Success;
}

DecodeStatus SparcDisassembler::getInstruction(MCInst &Instr, uint64_t &Size,
                                               ArrayRef<uint8_t> Bytes,
                                               uint64_t Address,
                                               raw_ostream &CStream) const {
  uint32_t Insn;
  bool isLittleEndian = getContext().getAsmInfo()->isLittleEndian();
  DecodeStatus Result =
      readInstruction32(Bytes, Address, Size, Insn, isLittleEndian);
  if (Result == MCDisassembler::Fail)
    return MCDisassembler::Fail;

  // Calling the auto-generated decoder function.

  if (STI.hasFeature(Sparc::FeatureV9))
  {
    Result = decodeInstruction(DecoderTableSparcV932, Instr, Insn, Address, this, STI);
  }
  else
  {
    Result = decodeInstruction(DecoderTableSparcV832, Instr, Insn, Address, this, STI);
  }
  if (Result != MCDisassembler::Fail)
    return Result;

  Result =
      decodeInstruction(DecoderTableSparc32, Instr, Insn, Address, this, STI);

  if (Result != MCDisassembler::Fail) {
    Size = 4;
    return Result;
  }

  return MCDisassembler::Fail;
}

static bool tryAddingSymbolicOperand(int64_t Value, bool isBranch,
                                     uint64_t Address, uint64_t Offset,
                                     uint64_t Width, MCInst &MI,
                                     const MCDisassembler *Decoder) {
  return Decoder->tryAddingSymbolicOperand(MI, Value, Address, isBranch, Offset,
                                           Width, /*InstSize=*/4);
}

static DecodeStatus DecodeCall(MCInst &MI, unsigned insn, uint64_t Address,
                               const MCDisassembler *Decoder) {
  unsigned tgt = fieldFromInstruction(insn, 0, 30);
  tgt <<= 2;
  if (!tryAddingSymbolicOperand(tgt+Address, false, Address,
                                0, 30, MI, Decoder))
    MI.addOperand(MCOperand::createImm(tgt));
  return MCDisassembler::Success;
}

static DecodeStatus DecodeSIMM13(MCInst &MI, unsigned insn, uint64_t Address,
                                 const MCDisassembler *Decoder) {
  unsigned tgt = SignExtend32<13>(fieldFromInstruction(insn, 0, 13));
  MI.addOperand(MCOperand::createImm(tgt));
  return MCDisassembler::Success;
}
href='#n8842'>8842 8843 8844 8845 8846 8847 8848 8849 8850 8851 8852 8853 8854 8855 8856 8857 8858 8859 8860 8861 8862 8863 8864 8865 8866 8867 8868 8869 8870 8871 8872 8873 8874 8875 8876 8877 8878 8879 8880 8881 8882 8883 8884 8885 8886 8887 8888 8889 8890 8891 8892 8893 8894 8895 8896 8897 8898 8899 8900 8901 8902 8903 8904 8905 8906 8907 8908 8909 8910 8911 8912 8913 8914 8915 8916 8917 8918 8919 8920 8921 8922 8923 8924 8925 8926 8927 8928 8929 8930 8931 8932 8933 8934 8935 8936 8937 8938 8939 8940 8941 8942 8943 8944 8945 8946 8947 8948 8949 8950 8951 8952 8953 8954 8955 8956 8957 8958 8959 8960 8961 8962 8963 8964 8965 8966 8967 8968 8969 8970 8971 8972 8973 8974 8975 8976 8977 8978 8979 8980 8981 8982 8983 8984 8985 8986 8987 8988 8989 8990 8991 8992 8993 8994 8995 8996 8997 8998 8999 9000 9001 9002 9003 9004 9005 9006 9007 9008 9009 9010 9011 9012 9013 9014 9015 9016 9017 9018 9019 9020 9021 9022 9023 9024 9025 9026 9027 9028 9029 9030 9031 9032 9033 9034 9035 9036 9037 9038 9039 9040 9041 9042 9043 9044 9045 9046 9047 9048 9049 9050 9051 9052 9053 9054 9055 9056 9057 9058 9059 9060 9061 9062 9063 9064 9065 9066 9067 9068 9069 9070 9071 9072 9073 9074 9075 9076 9077 9078 9079 9080 9081 9082 9083 9084 9085 9086 9087 9088 9089 9090 9091 9092 9093 9094 9095 9096 9097 9098 9099 9100 9101 9102 9103 9104 9105 9106 9107 9108 9109 9110 9111 9112 9113 9114 9115 9116 9117 9118 9119 9120 9121 9122 9123 9124 9125 9126 9127 9128 9129 9130 9131 9132 9133 9134 9135 9136 9137 9138 9139 9140 9141 9142 9143 9144 9145 9146 9147 9148 9149 9150 9151 9152 9153 9154 9155 9156 9157 9158 9159 9160 9161 9162 9163 9164 9165 9166 9167 9168 9169 9170 9171 9172 9173 9174 9175 9176 9177 9178 9179 9180 9181 9182 9183 9184 9185 9186 9187 9188 9189 9190 9191 9192 9193 9194 9195 9196 9197 9198 9199 9200 9201 9202 9203 9204 9205 9206 9207 9208 9209 9210 9211 9212 9213 9214 9215 9216 9217 9218 9219 9220 9221 9222 9223 9224 9225 9226 9227 9228 9229 9230 9231 9232 9233 9234 9235 9236 9237 9238 9239 9240 9241 9242 9243 9244 9245 9246 9247 9248 9249 9250 9251 9252 9253 9254 9255 9256 9257 9258 9259 9260 9261 9262 9263 9264 9265 9266 9267 9268 9269 9270 9271 9272 9273 9274 9275 9276 9277 9278 9279 9280 9281 9282 9283 9284 9285 9286 9287 9288 9289 9290 9291 9292 9293 9294 9295 9296 9297 9298 9299 9300 9301 9302 9303 9304 9305 9306 9307 9308 9309 9310 9311 9312 9313 9314 9315 9316 9317 9318 9319 9320 9321 9322 9323 9324 9325 9326 9327 9328 9329 9330 9331 9332 9333 9334 9335 9336 9337 9338 9339 9340 9341 9342 9343 9344 9345 9346 9347 9348 9349 9350 9351 9352 9353 9354 9355 9356 9357 9358 9359 9360 9361 9362 9363 9364 9365 9366 9367 9368 9369 9370 9371 9372 9373 9374 9375 9376 9377 9378 9379 9380 9381 9382 9383 9384 9385 9386 9387 9388 9389 9390 9391 9392 9393 9394 9395 9396 9397 9398 9399 9400 9401 9402 9403 9404 9405 9406 9407 9408 9409 9410 9411 9412 9413 9414 9415 9416 9417 9418 9419 9420 9421 9422 9423 9424 9425 9426 9427 9428 9429 9430 9431 9432 9433 9434 9435 9436 9437 9438 9439 9440 9441 9442 9443 9444 9445 9446 9447 9448 9449 9450 9451 9452 9453 9454 9455 9456 9457 9458 9459 9460 9461 9462 9463 9464 9465 9466 9467 9468 9469 9470 9471 9472 9473 9474 9475 9476 9477 9478 9479 9480 9481 9482 9483 9484 9485 9486 9487 9488 9489 9490 9491 9492 9493 9494 9495 9496 9497 9498 9499 9500 9501 9502 9503 9504 9505 9506 9507 9508 9509 9510 9511 9512 9513 9514 9515 9516 9517 9518 9519 9520 9521 9522 9523 9524 9525 9526 9527 9528 9529 9530 9531 9532 9533 9534 9535 9536 9537 9538 9539 9540 9541 9542 9543 9544 9545 9546 9547 9548 9549 9550 9551 9552 9553 9554 9555 9556 9557 9558 9559 9560 9561 9562 9563 9564 9565 9566 9567 9568 9569 9570 9571 9572 9573 9574 9575 9576 9577 9578 9579 9580 9581 9582 9583 9584 9585 9586 9587 9588 9589 9590 9591 9592 9593 9594 9595 9596 9597 9598 9599 9600 9601 9602 9603 9604 9605 9606 9607 9608 9609 9610 9611 9612 9613 9614 9615 9616 9617 9618 9619 9620 9621 9622 9623 9624 9625 9626 9627 9628 9629 9630 9631 9632 9633 9634 9635 9636 9637 9638 9639 9640 9641 9642 9643 9644 9645 9646 9647 9648 9649 9650 9651 9652 9653 9654 9655 9656 9657 9658 9659 9660 9661 9662 9663 9664 9665 9666 9667 9668 9669 9670 9671 9672 9673 9674 9675 9676 9677 9678 9679 9680 9681 9682 9683 9684 9685 9686 9687 9688 9689 9690 9691 9692 9693 9694 9695 9696 9697 9698 9699 9700 9701 9702 9703 9704 9705 9706 9707 9708 9709 9710 9711 9712 9713 9714 9715 9716 9717 9718 9719 9720 9721 9722 9723 9724 9725 9726 9727 9728 9729 9730 9731 9732 9733 9734 9735 9736 9737 9738 9739 9740 9741 9742 9743 9744 9745 9746 9747 9748 9749 9750 9751 9752 9753 9754 9755 9756 9757 9758 9759 9760 9761 9762 9763 9764 9765 9766 9767 9768 9769 9770 9771 9772 9773 9774 9775 9776 9777 9778 9779 9780 9781 9782 9783 9784 9785 9786 9787 9788 9789 9790 9791 9792 9793 9794 9795 9796 9797 9798 9799 9800 9801 9802 9803 9804 9805 9806 9807 9808 9809 9810 9811 9812 9813 9814 9815 9816 9817 9818 9819 9820 9821 9822 9823 9824 9825 9826 9827 9828 9829 9830 9831 9832 9833 9834 9835 9836 9837 9838 9839 9840 9841 9842 9843 9844 9845 9846 9847 9848 9849 9850 9851 9852 9853 9854 9855 9856 9857 9858 9859 9860 9861 9862 9863 9864 9865 9866 9867 9868 9869 9870 9871 9872 9873 9874 9875 9876 9877 9878 9879 9880 9881 9882 9883 9884 9885 9886 9887 9888 9889 9890 9891 9892 9893 9894 9895 9896 9897 9898 9899 9900 9901 9902 9903 9904 9905 9906 9907 9908 9909 9910 9911 9912 9913 9914 9915 9916 9917 9918 9919 9920 9921 9922 9923 9924 9925 9926 9927 9928 9929 9930 9931 9932 9933 9934 9935 9936 9937 9938 9939 9940 9941 9942 9943 9944 9945 9946 9947 9948 9949 9950 9951 9952 9953 9954 9955 9956 9957 9958 9959 9960 9961 9962 9963 9964 9965 9966 9967 9968 9969 9970 9971 9972 9973 9974 9975 9976 9977 9978 9979 9980 9981 9982 9983 9984 9985 9986 9987 9988 9989 9990 9991 9992 9993 9994 9995 9996 9997 9998 9999 10000 10001 10002 10003 10004 10005 10006 10007 10008 10009 10010 10011 10012 10013 10014 10015 10016 10017 10018 10019 10020 10021 10022 10023 10024 10025 10026 10027 10028 10029 10030 10031 10032 10033 10034 10035 10036 10037 10038 10039 10040 10041 10042 10043 10044 10045 10046 10047 10048 10049 10050 10051 10052 10053 10054 10055 10056 10057 10058 10059 10060 10061 10062 10063 10064 10065 10066 10067 10068 10069 10070 10071 10072 10073 10074 10075 10076 10077 10078 10079 10080 10081 10082 10083 10084 10085 10086 10087 10088 10089 10090 10091 10092 10093 10094 10095 10096 10097 10098 10099 10100 10101 10102 10103 10104 10105 10106 10107 10108 10109 10110 10111 10112 10113 10114 10115 10116 10117 10118 10119 10120 10121 10122 10123 10124 10125 10126 10127 10128 10129 10130 10131 10132 10133 10134 10135 10136 10137 10138 10139 10140 10141 10142 10143 10144 10145 10146 10147 10148 10149 10150 10151 10152 10153 10154 10155 10156 10157 10158 10159 10160 10161 10162 10163 10164 10165 10166 10167 10168 10169 10170 10171 10172 10173 10174 10175 10176 10177 10178 10179 10180 10181 10182 10183 10184 10185 10186 10187 10188 10189 10190 10191 10192 10193 10194 10195 10196 10197 10198 10199 10200 10201 10202 10203 10204 10205 10206 10207 10208 10209 10210 10211 10212 10213 10214 10215 10216 10217 10218 10219 10220 10221 10222 10223 10224 10225 10226 10227 10228 10229 10230 10231 10232 10233 10234 10235 10236 10237 10238 10239 10240 10241 10242 10243 10244 10245 10246 10247 10248 10249 10250 10251 10252 10253 10254 10255 10256 10257 10258 10259 10260 10261 10262 10263 10264 10265 10266 10267 10268 10269 10270 10271 10272 10273 10274 10275 10276 10277 10278 10279 10280 10281 10282 10283 10284 10285 10286 10287 10288 10289 10290 10291 10292 10293 10294 10295 10296 10297 10298 10299 10300 10301 10302 10303 10304 10305 10306 10307 10308 10309 10310 10311 10312 10313 10314 10315 10316 10317 10318 10319 10320 10321 10322 10323 10324 10325 10326 10327 10328 10329 10330 10331 10332 10333 10334 10335 10336 10337 10338 10339 10340 10341 10342 10343 10344 10345 10346 10347 10348 10349 10350 10351 10352 10353 10354 10355 10356 10357 10358 10359 10360 10361 10362 10363 10364 10365 10366 10367 10368 10369 10370 10371 10372 10373 10374 10375 10376 10377 10378 10379 10380 10381 10382 10383 10384 10385 10386 10387 10388 10389 10390 10391 10392 10393 10394 10395 10396 10397 10398 10399 10400 10401 10402 10403 10404 10405 10406 10407 10408 10409 10410 10411 10412 10413 10414 10415 10416 10417 10418 10419 10420 10421 10422 10423 10424 10425 10426 10427 10428 10429 10430 10431 10432 10433 10434 10435 10436 10437 10438 10439 10440 10441 10442 10443 10444 10445 10446 10447 10448 10449 10450 10451 10452 10453 10454 10455 10456 10457 10458 10459 10460 10461 10462 10463 10464 10465 10466 10467 10468 10469 10470 10471 10472 10473 10474 10475 10476 10477 10478 10479 10480 10481 10482 10483 10484 10485 10486 10487 10488 10489 10490 10491 10492 10493 10494 10495 10496 10497 10498 10499 10500 10501 10502 10503 10504 10505 10506 10507 10508 10509 10510 10511 10512 10513 10514 10515 10516 10517 10518 10519 10520 10521 10522 10523 10524 10525 10526 10527 10528 10529 10530 10531 10532 10533 10534 10535 10536 10537 10538 10539 10540 10541 10542 10543 10544 10545 10546 10547 10548 10549 10550 10551 10552 10553 10554 10555 10556 10557 10558 10559 10560 10561 10562 10563 10564 10565 10566 10567 10568 10569 10570 10571 10572 10573 10574 10575 10576 10577 10578 10579 10580 10581 10582 10583 10584 10585 10586 10587 10588 10589 10590 10591 10592 10593 10594 10595 10596 10597 10598 10599 10600 10601 10602 10603 10604 10605 10606 10607 10608 10609 10610 10611 10612 10613 10614 10615 10616 10617 10618 10619 10620 10621 10622 10623 10624 10625 10626 10627 10628 10629 10630 10631 10632 10633 10634 10635 10636 10637 10638 10639 10640 10641 10642 10643 10644 10645 10646 10647 10648 10649 10650 10651 10652 10653 10654 10655 10656 10657 10658 10659 10660 10661 10662 10663 10664 10665 10666 10667 10668 10669 10670 10671 10672 10673 10674 10675 10676 10677 10678 10679 10680 10681 10682 10683 10684 10685 10686 10687 10688 10689 10690 10691 10692 10693 10694 10695 10696 10697 10698 10699 10700 10701 10702 10703 10704 10705 10706 10707 10708 10709 10710 10711 10712 10713 10714 10715 10716 10717 10718 10719 10720 10721 10722 10723 10724 10725 10726 10727 10728 10729 10730 10731 10732 10733 10734 10735 10736 10737 10738 10739 10740 10741 10742 10743 10744 10745 10746 10747 10748 10749 10750 10751 10752 10753 10754 10755 10756 10757 10758 10759 10760 10761 10762 10763 10764 10765 10766 10767 10768 10769 10770 10771 10772 10773 10774 10775 10776 10777 10778 10779 10780 10781 10782 10783 10784 10785 10786 10787 10788 10789 10790 10791 10792 10793 10794 10795 10796 10797 10798 10799 10800 10801 10802 10803 10804 10805 10806 10807 10808 10809 10810 10811 10812 10813 10814 10815 10816 10817 10818 10819 10820 10821 10822 10823 10824 10825 10826 10827 10828 10829 10830 10831 10832 10833 10834 10835 10836 10837 10838 10839 10840 10841 10842 10843 10844 10845 10846 10847 10848 10849 10850 10851 10852 10853 10854 10855 10856 10857 10858 10859 10860 10861 10862 10863 10864 10865 10866 10867 10868 10869 10870 10871 10872 10873 10874 10875 10876 10877 10878 10879 10880 10881 10882 10883 10884 10885 10886 10887 10888 10889 10890 10891 10892 10893 10894 10895 10896 10897 10898 10899 10900 10901 10902 10903 10904 10905 10906 10907 10908 10909 10910 10911 10912 10913 10914 10915 10916 10917 10918 10919 10920 10921 10922 10923 10924 10925 10926 10927 10928 10929 10930 10931 10932 10933 10934 10935 10936 10937 10938 10939 10940 10941 10942 10943 10944 10945 10946 10947 10948 10949 10950 10951 10952 10953 10954 10955 10956 10957 10958 10959 10960 10961 10962 10963 10964 10965 10966 10967 10968 10969 10970 10971 10972 10973 10974 10975 10976 10977 10978 10979 10980 10981 10982 10983 10984 10985 10986 10987 10988 10989 10990 10991 10992 10993 10994 10995 10996 10997 10998 10999 11000 11001 11002 11003 11004 11005 11006 11007 11008 11009 11010 11011 11012 11013 11014 11015 11016 11017 11018 11019 11020 11021 11022 11023 11024 11025 11026 11027 11028 11029 11030 11031 11032 11033 11034 11035 11036 11037 11038 11039 11040 11041 11042 11043 11044 11045 11046 11047 11048 11049 11050 11051 11052 11053 11054 11055 11056 11057 11058 11059 11060 11061 11062 11063 11064 11065 11066 11067 11068 11069 11070 11071 11072 11073 11074 11075 11076 11077 11078 11079 11080 11081 11082 11083 11084 11085 11086 11087 11088 11089 11090 11091 11092 11093 11094 11095 11096 11097 11098 11099 11100 11101 11102 11103 11104 11105 11106 11107 11108 11109 11110 11111 11112 11113 11114 11115 11116 11117 11118 11119 11120 11121 11122 11123 11124 11125 11126 11127 11128 11129 11130 11131 11132 11133 11134 11135 11136 11137 11138 11139 11140 11141 11142 11143 11144 11145 11146 11147 11148 11149 11150 11151 11152 11153 11154 11155 11156 11157 11158 11159 11160 11161 11162 11163 11164 11165 11166 11167 11168 11169 11170 11171 11172 11173 11174 11175 11176 11177 11178 11179 11180 11181 11182 11183 11184 11185 11186 11187 11188 11189 11190 11191 11192 11193 11194 11195 11196 11197 11198 11199 11200 11201 11202 11203 11204 11205 11206 11207 11208 11209 11210 11211 11212 11213 11214 11215 11216 11217 11218 11219 11220 11221 11222 11223 11224 11225 11226 11227 11228 11229 11230 11231 11232 11233 11234 11235 11236 11237 11238 11239 11240 11241 11242 11243 11244 11245 11246 11247 11248 11249 11250 11251 11252 11253 11254 11255 11256 11257 11258 11259 11260 11261 11262 11263 11264 11265 11266 11267 11268 11269 11270 11271 11272 11273 11274 11275 11276 11277 11278 11279 11280 11281 11282 11283 11284 11285 11286 11287 11288 11289 11290 11291 11292 11293 11294 11295 11296 11297 11298 11299 11300 11301 11302 11303 11304 11305 11306 11307 11308 11309 11310 11311 11312 11313 11314 11315 11316 11317 11318 11319 11320 11321 11322 11323 11324 11325 11326 11327 11328 11329 11330 11331 11332 11333 11334 11335 11336 11337 11338 11339 11340 11341 11342 11343 11344 11345 11346 11347 11348 11349 11350 11351 11352 11353 11354 11355 11356 11357 11358 11359 11360 11361 11362 11363 11364 11365 11366 11367 11368 11369 11370 11371 11372 11373 11374 11375 11376 11377 11378 11379 11380 11381 11382 11383 11384 11385 11386 11387 11388 11389 11390 11391 11392 11393 11394 11395 11396 11397 11398 11399 11400 11401 11402 11403 11404 11405 11406 11407 11408 11409 11410 11411 11412 11413 11414 11415 11416 11417 11418 11419 11420 11421 11422 11423 11424 11425 11426 11427 11428 11429 11430 11431 11432 11433 11434 11435 11436 11437 11438 11439 11440 11441 11442 11443 11444 11445 11446 11447 11448 11449 11450 11451 11452 11453 11454 11455 11456 11457 11458 11459 11460 11461 11462 11463 11464 11465 11466 11467 11468 11469 11470 11471 11472 11473 11474 11475 11476 11477 11478 11479 11480 11481 11482 11483 11484 11485 11486 11487 11488 11489 11490 11491 11492 11493 11494 11495 11496 11497 11498 11499 11500 11501 11502 11503 11504 11505 11506 11507 11508 11509 11510 11511 11512 11513 11514 11515 11516 11517 11518 11519 11520 11521 11522 11523 11524 11525 11526 11527 11528 11529 11530 11531 11532 11533 11534 11535 11536 11537 11538 11539 11540 11541 11542 11543 11544 11545 11546 11547 11548 11549 11550 11551 11552 11553 11554 11555 11556 11557 11558 11559 11560 11561 11562 11563 11564 11565 11566 11567 11568 11569 11570 11571 11572 11573 11574 11575 11576 11577 11578 11579 11580 11581 11582 11583 11584 11585 11586 11587 11588 11589 11590 11591 11592 11593 11594 11595 11596 11597 11598 11599 11600 11601 11602 11603 11604 11605 11606 11607 11608 11609 11610 11611 11612 11613 11614 11615 11616 11617 11618 11619 11620 11621 11622 11623 11624 11625 11626 11627 11628 11629 11630 11631 11632 11633 11634 11635 11636 11637 11638 11639 11640 11641 11642 11643 11644 11645 11646 11647 11648 11649 11650 11651 11652 11653 11654 11655 11656 11657 11658 11659 11660 11661 11662 11663 11664 11665 11666 11667 11668 11669 11670 11671 11672 11673 11674 11675 11676 11677 11678 11679 11680 11681 11682 11683 11684 11685 11686 11687 11688 11689 11690 11691 11692 11693 11694 11695 11696 11697 11698 11699 11700 11701 11702 11703 11704 11705 11706 11707 11708 11709 11710 11711 11712 11713 11714 11715 11716 11717 11718 11719 11720 11721 11722 11723 11724 11725 11726 11727 11728 11729 11730 11731 11732 11733 11734 11735 11736 11737 11738 11739 11740 11741 11742 11743 11744 11745 11746 11747 11748 11749 11750 11751 11752 11753 11754 11755 11756 11757 11758 11759 11760 11761 11762 11763 11764 11765 11766 11767 11768 11769 11770 11771 11772 11773 11774 11775 11776 11777 11778 11779 11780 11781 11782 11783 11784 11785 11786 11787 11788 11789 11790 11791 11792 11793 11794 11795 11796 11797 11798 11799 11800 11801 11802 11803 11804 11805 11806 11807 11808 11809 11810 11811 11812 11813 11814 11815 11816 11817 11818 11819 11820 11821 11822 11823 11824 11825 11826 11827 11828 11829 11830 11831 11832 11833 11834 11835 11836 11837 11838 11839 11840 11841 11842 11843 11844 11845 11846 11847 11848 11849 11850 11851 11852 11853 11854 11855 11856 11857 11858 11859 11860 11861 11862 11863 11864 11865 11866 11867 11868 11869 11870 11871 11872 11873 11874 11875 11876 11877 11878 11879 11880 11881 11882 11883 11884 11885 11886 11887 11888 11889 11890 11891 11892 11893 11894 11895 11896 11897 11898 11899 11900 11901 11902 11903 11904 11905 11906 11907 11908 11909 11910 11911 11912 11913 11914 11915 11916 11917 11918 11919 11920 11921 11922 11923 11924 11925 11926 11927 11928 11929 11930 11931 11932 11933 11934 11935 11936 11937 11938 11939 11940 11941 11942 11943 11944 11945 11946 11947 11948 11949 11950 11951 11952 11953 11954 11955 11956 11957 11958 11959 11960 11961 11962 11963 11964 11965 11966 11967 11968 11969 11970 11971 11972 11973 11974 11975 11976 11977 11978 11979 11980 11981 11982 11983 11984 11985 11986 11987 11988 11989 11990 11991 11992 11993 11994 11995 11996 11997 11998 11999 12000 12001 12002 12003 12004 12005 12006 12007 12008 12009 12010 12011 12012 12013 12014 12015 12016 12017 12018 12019 12020 12021 12022 12023 12024 12025 12026 12027 12028 12029 12030 12031 12032 12033 12034 12035 12036 12037 12038 12039 12040 12041 12042 12043 12044 12045 12046 12047 12048 12049 12050 12051 12052 12053 12054 12055 12056 12057 12058 12059 12060 12061 12062 12063 12064 12065 12066 12067 12068 12069 12070 12071 12072 12073 12074 12075 12076 12077 12078 12079 12080 12081 12082 12083 12084 12085 12086 12087 12088 12089 12090 12091 12092 12093 12094 12095 12096 12097 12098 12099 12100 12101 12102 12103 12104 12105 12106 12107 12108 12109 12110 12111 12112 12113 12114 12115 12116 12117 12118 12119 12120 12121 12122 12123 12124 12125 12126 12127 12128 12129 12130 12131 12132 12133 12134 12135 12136 12137 12138 12139 12140 12141 12142 12143 12144 12145 12146 12147 12148 12149 12150 12151 12152 12153 12154 12155 12156 12157 12158 12159 12160 12161 12162 12163 12164 12165 12166 12167 12168 12169 12170 12171 12172 12173 12174 12175 12176 12177 12178 12179 12180 12181 12182 12183 12184 12185 12186 12187 12188 12189 12190 12191 12192 12193 12194 12195 12196 12197 12198 12199 12200 12201 12202 12203 12204 12205 12206 12207 12208 12209 12210 12211 12212 12213 12214 12215 12216 12217 12218 12219 12220 12221 12222 12223 12224 12225 12226 12227 12228 12229 12230 12231 12232 12233 12234 12235 12236 12237 12238 12239 12240 12241 12242 12243 12244 12245 12246 12247 12248 12249 12250 12251 12252 12253 12254 12255 12256 12257 12258 12259 12260 12261 12262 12263 12264 12265 12266 12267 12268 12269 12270 12271 12272 12273 12274 12275 12276 12277 12278 12279 12280 12281 12282 12283 12284 12285 12286 12287 12288 12289 12290 12291 12292 12293 12294 12295 12296 12297 12298 12299 12300 12301 12302 12303 12304 12305 12306 12307 12308 12309 12310 12311 12312 12313 12314 12315 12316 12317 12318 12319 12320 12321 12322 12323 12324 12325 12326 12327 12328 12329 12330 12331 12332 12333 12334 12335 12336 12337 12338 12339 12340 12341 12342 12343 12344 12345 12346 12347 12348 12349 12350 12351 12352 12353 12354 12355 12356 12357 12358 12359 12360 12361 12362 12363 12364 12365 12366 12367 12368 12369 12370 12371 12372 12373 12374 12375 12376 12377 12378 12379 12380 12381 12382 12383 12384 12385 12386 12387 12388 12389 12390 12391 12392 12393 12394 12395 12396 12397 12398 12399 12400 12401 12402 12403 12404 12405 12406 12407 12408 12409 12410 12411 12412 12413 12414 12415 12416 12417 12418 12419 12420 12421 12422 12423 12424 12425 12426 12427 12428 12429 12430 12431 12432 12433 12434 12435 12436 12437 12438 12439 12440 12441 12442 12443 12444 12445 12446 12447 12448 12449 12450 12451 12452 12453 12454 12455 12456 12457 12458 12459 12460 12461 12462 12463 12464 12465 12466 12467 12468 12469 12470 12471 12472 12473 12474 12475 12476 12477 12478 12479 12480 12481 12482 12483 12484 12485 12486 12487 12488 12489 12490 12491 12492 12493 12494 12495 12496 12497 12498 12499 12500 12501 12502 12503 12504 12505 12506 12507 12508 12509 12510 12511 12512 12513 12514 12515 12516 12517 12518 12519 12520 12521 12522 12523 12524 12525 12526 12527 12528 12529 12530 12531 12532 12533 12534 12535 12536 12537 12538 12539 12540 12541 12542 12543 12544 12545 12546 12547 12548 12549 12550 12551 12552 12553 12554 12555 12556 12557 12558 12559 12560 12561 12562 12563 12564 12565 12566 12567 12568 12569 12570 12571 12572 12573 12574 12575 12576 12577 12578 12579 12580 12581 12582 12583 12584 12585 12586 12587 12588 12589 12590 12591 12592 12593 12594 12595 12596 12597 12598 12599 12600 12601 12602 12603 12604 12605 12606 12607 12608 12609 12610 12611 12612 12613 12614 12615 12616 12617 12618 12619 12620 12621 12622 12623 12624 12625 12626 12627 12628 12629 12630 12631 12632 12633 12634 12635 12636 12637 12638 12639 12640 12641 12642 12643 12644 12645 12646 12647 12648 12649 12650 12651 12652 12653 12654 12655 12656 12657 12658 12659 12660 12661 12662 12663 12664 12665 12666 12667 12668 12669 12670 12671 12672 12673 12674 12675 12676 12677 12678 12679 12680 12681 12682 12683 12684 12685 12686 12687 12688 12689 12690 12691 12692 12693 12694 12695 12696 12697 12698 12699 12700 12701 12702 12703 12704 12705 12706 12707 12708 12709 12710 12711 12712 12713 12714 12715 12716 12717 12718 12719 12720 12721 12722 12723 12724 12725 12726 12727 12728 12729 12730 12731 12732 12733 12734 12735 12736 12737 12738 12739 12740 12741 12742 12743 12744 12745 12746 12747 12748 12749 12750 12751 12752 12753 12754 12755 12756 12757 12758 12759 12760 12761 12762 12763 12764 12765 12766 12767 12768 12769 12770 12771 12772 12773 12774 12775 12776 12777 12778 12779 12780 12781 12782 12783 12784 12785 12786 12787 12788 12789 12790 12791 12792 12793 12794 12795 12796 12797 12798 12799 12800 12801 12802 12803 12804 12805 12806 12807 12808 12809 12810 12811 12812 12813 12814 12815 12816 12817 12818 12819 12820 12821 12822 12823 12824 12825 12826 12827 12828 12829 12830 12831 12832 12833 12834 12835 12836 12837 12838 12839 12840 12841 12842 12843 12844 12845 12846 12847 12848 12849 12850 12851 12852 12853 12854 12855 12856 12857 12858 12859 12860 12861 12862 12863 12864 12865 12866 12867 12868 12869 12870 12871 12872 12873 12874 12875 12876 12877 12878 12879 12880 12881 12882 12883 12884 12885 12886 12887 12888 12889 12890 12891 12892 12893 12894 12895 12896 12897 12898 12899 12900 12901 12902 12903 12904 12905 12906 12907 12908 12909 12910 12911 12912 12913 12914 12915 12916 12917 12918 12919 12920 12921 12922 12923 12924 12925 12926 12927 12928 12929 12930 12931 12932 12933 12934 12935 12936 12937 12938 12939 12940 12941 12942 12943 12944 12945 12946 12947 12948 12949 12950 12951 12952 12953 12954 12955 12956 12957 12958 12959 12960 12961 12962 12963 12964 12965 12966 12967 12968 12969 12970 12971 12972 12973 12974 12975 12976 12977 12978 12979 12980 12981 12982 12983 12984 12985 12986 12987 12988 12989 12990 12991 12992 12993 12994 12995 12996 12997 12998 12999 13000 13001 13002 13003 13004 13005 13006 13007 13008 13009 13010 13011 13012 13013 13014 13015 13016 13017 13018 13019 13020 13021 13022 13023 13024 13025 13026 13027 13028 13029 13030 13031 13032 13033 13034 13035 13036 13037 13038 13039 13040 13041 13042 13043 13044 13045 13046 13047 13048 13049 13050 13051 13052 13053 13054 13055 13056 13057 13058 13059 13060 13061 13062 13063 13064 13065 13066 13067 13068 13069 13070 13071 13072 13073 13074 13075 13076 13077 13078 13079 13080 13081 13082 13083 13084 13085 13086 13087 13088 13089 13090 13091 13092 13093 13094 13095 13096 13097 13098 13099 13100 13101 13102 13103 13104 13105 13106 13107 13108 13109 13110 13111 13112 13113 13114 13115 13116 13117 13118 13119 13120 13121 13122 13123 13124 13125 13126 13127 13128 13129 13130 13131 13132 13133 13134 13135 13136 13137 13138 13139 13140 13141 13142 13143 13144 13145 13146 13147 13148 13149 13150 13151 13152 13153 13154 13155 13156 13157 13158 13159 13160 13161 13162 13163 13164 13165 13166 13167 13168 13169 13170 13171 13172 13173 13174 13175 13176 13177 13178 13179 13180 13181 13182 13183 13184 13185 13186 13187 13188 13189 13190 13191 13192 13193 13194 13195 13196 13197 13198 13199 13200 13201 13202 13203 13204 13205 13206 13207 13208 13209 13210 13211 13212 13213 13214 13215 13216 13217 13218 13219 13220 13221 13222 13223 13224 13225 13226 13227 13228 13229 13230 13231 13232 13233 13234 13235 13236 13237 13238 13239 13240 13241 13242 13243 13244 13245 13246 13247 13248 13249 13250 13251 13252 13253 13254 13255 13256 13257 13258 13259 13260 13261 13262 13263 13264 13265 13266 13267 13268 13269 13270 13271 13272 13273 13274 13275 13276 13277 13278 13279 13280 13281 13282 13283 13284 13285 13286 13287 13288 13289 13290 13291 13292 13293 13294 13295 13296 13297 13298 13299 13300 13301 13302 13303 13304 13305 13306 13307 13308 13309 13310 13311 13312 13313 13314 13315 13316 13317 13318 13319 13320 13321 13322 13323 13324 13325 13326 13327 13328 13329 13330 13331 13332 13333 13334 13335 13336 13337 13338 13339 13340 13341 13342 13343 13344 13345 13346 13347 13348 13349 13350 13351 13352 13353 13354 13355 13356 13357 13358 13359 13360 13361 13362 13363 13364 13365 13366 13367 13368 13369 13370 13371 13372 13373 13374 13375 13376 13377 13378 13379 13380 13381 13382 13383 13384 13385 13386 13387 13388 13389 13390 13391 13392 13393 13394 13395 13396 13397 13398 13399 13400 13401 13402 13403 13404 13405 13406 13407 13408 13409 13410 13411 13412 13413 13414 13415 13416 13417 13418 13419 13420 13421 13422 13423 13424 13425 13426 13427 13428 13429 13430 13431 13432 13433 13434 13435 13436 13437 13438 13439 13440 13441 13442 13443 13444 13445 13446 13447 13448 13449 13450 13451 13452 13453 13454 13455 13456 13457 13458 13459 13460 13461 13462 13463 13464 13465 13466 13467 13468 13469 13470 13471 13472 13473 13474 13475 13476 13477 13478 13479 13480 13481 13482 13483 13484 13485 13486 13487 13488 13489 13490 13491 13492 13493 13494 13495 13496 13497 13498 13499 13500 13501 13502 13503 13504 13505 13506 13507 13508 13509 13510 13511 13512 13513 13514 13515 13516 13517 13518 13519 13520 13521 13522 13523 13524 13525 13526 13527 13528 13529 13530 13531 13532 13533 13534 13535 13536 13537 13538 13539 13540 13541 13542 13543 13544 13545 13546 13547 13548 13549 13550 13551 13552 13553 13554 13555 13556 13557 13558 13559 13560 13561 13562 13563 13564 13565 13566 13567 13568 13569 13570 13571 13572 13573 13574 13575 13576 13577 13578 13579 13580 13581 13582 13583 13584 13585 13586 13587 13588 13589 13590 13591 13592 13593 13594 13595 13596 13597 13598 13599 13600 13601 13602 13603 13604 13605 13606 13607 13608 13609 13610 13611 13612 13613 13614 13615 13616 13617 13618 13619 13620 13621 13622 13623 13624 13625 13626 13627 13628 13629 13630 13631 13632 13633 13634 13635 13636 13637 13638 13639 13640 13641 13642 13643 13644 13645 13646 13647 13648
/* Perform type resolution on the various structures.
   Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
   2010, 2011
   Free Software Foundation, Inc.
   Contributed by Andy Vaught

This file is part of GCC.

GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
Software Foundation; either version 3, or (at your option) any later
version.

GCC is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
for more details.

You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3.  If not see
<http://www.gnu.org/licenses/>.  */

#include "config.h"
#include "system.h"
#include "flags.h"
#include "gfortran.h"
#include "obstack.h"
#include "bitmap.h"
#include "arith.h"  /* For gfc_compare_expr().  */
#include "dependency.h"
#include "data.h"
#include "target-memory.h" /* for gfc_simplify_transfer */
#include "constructor.h"

/* Types used in equivalence statements.  */

typedef enum seq_type
{
  SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
}
seq_type;

/* Stack to keep track of the nesting of blocks as we move through the
   code.  See resolve_branch() and resolve_code().  */

typedef struct code_stack
{
  struct gfc_code *head, *current;
  struct code_stack *prev;

  /* This bitmap keeps track of the targets valid for a branch from
     inside this block except for END {IF|SELECT}s of enclosing
     blocks.  */
  bitmap reachable_labels;
}
code_stack;

static code_stack *cs_base = NULL;


/* Nonzero if we're inside a FORALL block.  */

static int forall_flag;

/* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block.  */

static int omp_workshare_flag;

/* Nonzero if we are processing a formal arglist. The corresponding function
   resets the flag each time that it is read.  */
static int formal_arg_flag = 0;

/* True if we are resolving a specification expression.  */
static int specification_expr = 0;

/* The id of the last entry seen.  */
static int current_entry_id;

/* We use bitmaps to determine if a branch target is valid.  */
static bitmap_obstack labels_obstack;

/* True when simplifying a EXPR_VARIABLE argument to an inquiry function.  */
static bool inquiry_argument = false;

int
gfc_is_formal_arg (void)
{
  return formal_arg_flag;
}

/* Is the symbol host associated?  */
static bool
is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns)
{
  for (ns = ns->parent; ns; ns = ns->parent)
    {      
      if (sym->ns == ns)
	return true;
    }

  return false;
}

/* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
   an ABSTRACT derived-type.  If where is not NULL, an error message with that
   locus is printed, optionally using name.  */

static gfc_try
resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name)
{
  if (ts->type == BT_DERIVED && ts->u.derived->attr.abstract)
    {
      if (where)
	{
	  if (name)
	    gfc_error ("'%s' at %L is of the ABSTRACT type '%s'",
		       name, where, ts->u.derived->name);
	  else
	    gfc_error ("ABSTRACT type '%s' used at %L",
		       ts->u.derived->name, where);
	}

      return FAILURE;
    }

  return SUCCESS;
}


static void resolve_symbol (gfc_symbol *sym);
static gfc_try resolve_intrinsic (gfc_symbol *sym, locus *loc);


/* Resolve the interface for a PROCEDURE declaration or procedure pointer.  */

static gfc_try
resolve_procedure_interface (gfc_symbol *sym)
{
  if (sym->ts.interface == sym)
    {
      gfc_error ("PROCEDURE '%s' at %L may not be used as its own interface",
		 sym->name, &sym->declared_at);
      return FAILURE;
    }
  if (sym->ts.interface->attr.procedure)
    {
      gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared "
		 "in a later PROCEDURE statement", sym->ts.interface->name,
		 sym->name, &sym->declared_at);
      return FAILURE;
    }

  /* Get the attributes from the interface (now resolved).  */
  if (sym->ts.interface->attr.if_source || sym->ts.interface->attr.intrinsic)
    {
      gfc_symbol *ifc = sym->ts.interface;
      resolve_symbol (ifc);

      if (ifc->attr.intrinsic)
	resolve_intrinsic (ifc, &ifc->declared_at);

      if (ifc->result)
	{
	  sym->ts = ifc->result->ts;
	  sym->result = sym;
	}
      else   
	sym->ts = ifc->ts;
      sym->ts.interface = ifc;
      sym->attr.function = ifc->attr.function;
      sym->attr.subroutine = ifc->attr.subroutine;
      gfc_copy_formal_args (sym, ifc);

      sym->attr.allocatable = ifc->attr.allocatable;
      sym->attr.pointer = ifc->attr.pointer;
      sym->attr.pure = ifc->attr.pure;
      sym->attr.elemental = ifc->attr.elemental;
      sym->attr.dimension = ifc->attr.dimension;
      sym->attr.contiguous = ifc->attr.contiguous;
      sym->attr.recursive = ifc->attr.recursive;
      sym->attr.always_explicit = ifc->attr.always_explicit;
      sym->attr.ext_attr |= ifc->attr.ext_attr;
      sym->attr.is_bind_c = ifc->attr.is_bind_c;
      /* Copy array spec.  */
      sym->as = gfc_copy_array_spec (ifc->as);
      if (sym->as)
	{
	  int i;
	  for (i = 0; i < sym->as->rank; i++)
	    {
	      gfc_expr_replace_symbols (sym->as->lower[i], sym);
	      gfc_expr_replace_symbols (sym->as->upper[i], sym);
	    }
	}
      /* Copy char length.  */
      if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
	{
	  sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
	  gfc_expr_replace_symbols (sym->ts.u.cl->length, sym);
	  if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved
	      && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
	    return FAILURE;
	}
    }
  else if (sym->ts.interface->name[0] != '\0')
    {
      gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
		 sym->ts.interface->name, sym->name, &sym->declared_at);
      return FAILURE;
    }

  return SUCCESS;
}


/* Resolve types of formal argument lists.  These have to be done early so that
   the formal argument lists of module procedures can be copied to the
   containing module before the individual procedures are resolved
   individually.  We also resolve argument lists of procedures in interface
   blocks because they are self-contained scoping units.

   Since a dummy argument cannot be a non-dummy procedure, the only
   resort left for untyped names are the IMPLICIT types.  */

static void
resolve_formal_arglist (gfc_symbol *proc)
{
  gfc_formal_arglist *f;
  gfc_symbol *sym;
  int i;

  if (proc->result != NULL)
    sym = proc->result;
  else
    sym = proc;

  if (gfc_elemental (proc)
      || sym->attr.pointer || sym->attr.allocatable
      || (sym->as && sym->as->rank > 0))
    {
      proc->attr.always_explicit = 1;
      sym->attr.always_explicit = 1;
    }

  formal_arg_flag = 1;

  for (f = proc->formal; f; f = f->next)
    {
      sym = f->sym;

      if (sym == NULL)
	{
	  /* Alternate return placeholder.  */
	  if (gfc_elemental (proc))
	    gfc_error ("Alternate return specifier in elemental subroutine "
		       "'%s' at %L is not allowed", proc->name,
		       &proc->declared_at);
	  if (proc->attr.function)
	    gfc_error ("Alternate return specifier in function "
		       "'%s' at %L is not allowed", proc->name,
		       &proc->declared_at);
	  continue;
	}
      else if (sym->attr.procedure && sym->ts.interface
	       && sym->attr.if_source != IFSRC_DECL)
	resolve_procedure_interface (sym);

      if (sym->attr.if_source != IFSRC_UNKNOWN)
	resolve_formal_arglist (sym);

      if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
	{
	  if (gfc_pure (proc) && !gfc_pure (sym))
	    {
	      gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
			 "also be PURE", sym->name, &sym->declared_at);
	      continue;
	    }

	  if (proc->attr.implicit_pure && !gfc_pure(sym))
	    proc->attr.implicit_pure = 0;

	  if (gfc_elemental (proc))
	    {
	      gfc_error ("Dummy procedure at %L not allowed in ELEMENTAL "
			 "procedure", &sym->declared_at);
	      continue;
	    }

	  if (sym->attr.function
		&& sym->ts.type == BT_UNKNOWN
		&& sym->attr.intrinsic)
	    {
	      gfc_intrinsic_sym *isym;
	      isym = gfc_find_function (sym->name);
	      if (isym == NULL || !isym->specific)
		{
		  gfc_error ("Unable to find a specific INTRINSIC procedure "
			     "for the reference '%s' at %L", sym->name,
			     &sym->declared_at);
		}
	      sym->ts = isym->ts;
	    }

	  continue;
	}

      if (sym->ts.type == BT_UNKNOWN && !proc->attr.intrinsic
	  && (!sym->attr.function || sym->result == sym))
	gfc_set_default_type (sym, 1, sym->ns);

      gfc_resolve_array_spec (sym->as, 0);

      /* We can't tell if an array with dimension (:) is assumed or deferred
	 shape until we know if it has the pointer or allocatable attributes.
      */
      if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
	  && !(sym->attr.pointer || sym->attr.allocatable))
	{
	  sym->as->type = AS_ASSUMED_SHAPE;
	  for (i = 0; i < sym->as->rank; i++)
	    sym->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind,
						  NULL, 1);
	}

      if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
	  || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
	  || sym->attr.optional)
	{
	  proc->attr.always_explicit = 1;
	  if (proc->result)
	    proc->result->attr.always_explicit = 1;
	}

      /* If the flavor is unknown at this point, it has to be a variable.
	 A procedure specification would have already set the type.  */

      if (sym->attr.flavor == FL_UNKNOWN)
	gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);

      if (gfc_pure (proc) && !sym->attr.pointer
	  && sym->attr.flavor != FL_PROCEDURE)
	{
	  if (proc->attr.function && sym->attr.intent != INTENT_IN)
	    {
	      if (sym->attr.value)
		gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Argument '%s' "
				"of pure function '%s' at %L with VALUE "
				"attribute but without INTENT(IN)", sym->name,
				proc->name, &sym->declared_at);
	      else
		gfc_error ("Argument '%s' of pure function '%s' at %L must be "
			   "INTENT(IN) or VALUE", sym->name, proc->name,
			   &sym->declared_at);
	    }

	  if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
	    {
	      if (sym->attr.value)
		gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Argument '%s' "
				"of pure subroutine '%s' at %L with VALUE "
				"attribute but without INTENT", sym->name,
				proc->name, &sym->declared_at);
	      else
		gfc_error ("Argument '%s' of pure subroutine '%s' at %L must "
		       "have its INTENT specified or have the VALUE "
		       "attribute", sym->name, proc->name, &sym->declared_at);
	    }
	}

      if (proc->attr.implicit_pure && !sym->attr.pointer
	  && sym->attr.flavor != FL_PROCEDURE)
	{
	  if (proc->attr.function && sym->attr.intent != INTENT_IN)
	    proc->attr.implicit_pure = 0;

	  if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
	    proc->attr.implicit_pure = 0;
	}

      if (gfc_elemental (proc))
	{
	  /* F2008, C1289.  */
	  if (sym->attr.codimension)
	    {
	      gfc_error ("Coarray dummy argument '%s' at %L to elemental "
			 "procedure", sym->name, &sym->declared_at);
	      continue;
	    }

	  if (sym->as != NULL)
	    {
	      gfc_error ("Argument '%s' of elemental procedure at %L must "
			 "be scalar", sym->name, &sym->declared_at);
	      continue;
	    }

	  if (sym->attr.allocatable)
	    {
	      gfc_error ("Argument '%s' of elemental procedure at %L cannot "
			 "have the ALLOCATABLE attribute", sym->name,
			 &sym->declared_at);
	      continue;
	    }

	  if (sym->attr.pointer)
	    {
	      gfc_error ("Argument '%s' of elemental procedure at %L cannot "
			 "have the POINTER attribute", sym->name,
			 &sym->declared_at);
	      continue;
	    }

	  if (sym->attr.flavor == FL_PROCEDURE)
	    {
	      gfc_error ("Dummy procedure '%s' not allowed in elemental "
			 "procedure '%s' at %L", sym->name, proc->name,
			 &sym->declared_at);
	      continue;
	    }

	  if (sym->attr.intent == INTENT_UNKNOWN)
	    {
	      gfc_error ("Argument '%s' of elemental procedure '%s' at %L must "
			 "have its INTENT specified", sym->name, proc->name,
			 &sym->declared_at);
	      continue;
	    }
	}

      /* Each dummy shall be specified to be scalar.  */
      if (proc->attr.proc == PROC_ST_FUNCTION)
	{
	  if (sym->as != NULL)
	    {
	      gfc_error ("Argument '%s' of statement function at %L must "
			 "be scalar", sym->name, &sym->declared_at);
	      continue;
	    }

	  if (sym->ts.type == BT_CHARACTER)
	    {
	      gfc_charlen *cl = sym->ts.u.cl;
	      if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
		{
		  gfc_error ("Character-valued argument '%s' of statement "
			     "function at %L must have constant length",
			     sym->name, &sym->declared_at);
		  continue;
		}
	    }
	}
    }
  formal_arg_flag = 0;
}


/* Work function called when searching for symbols that have argument lists
   associated with them.  */

static void
find_arglists (gfc_symbol *sym)
{
  if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
    return;

  resolve_formal_arglist (sym);
}


/* Given a namespace, resolve all formal argument lists within the namespace.
 */

static void
resolve_formal_arglists (gfc_namespace *ns)
{
  if (ns == NULL)
    return;

  gfc_traverse_ns (ns, find_arglists);
}


static void
resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
{
  gfc_try t;

  /* If this namespace is not a function or an entry master function,
     ignore it.  */
  if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE)
      || sym->attr.entry_master)
    return;

  /* Try to find out of what the return type is.  */
  if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL)
    {
      t = gfc_set_default_type (sym->result, 0, ns);

      if (t == FAILURE && !sym->result->attr.untyped)
	{
	  if (sym->result == sym)
	    gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
		       sym->name, &sym->declared_at);
	  else if (!sym->result->attr.proc_pointer)
	    gfc_error ("Result '%s' of contained function '%s' at %L has "
		       "no IMPLICIT type", sym->result->name, sym->name,
		       &sym->result->declared_at);
	  sym->result->attr.untyped = 1;
	}
    }

  /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character 
     type, lists the only ways a character length value of * can be used:
     dummy arguments of procedures, named constants, and function results
     in external functions.  Internal function results and results of module
     procedures are not on this list, ergo, not permitted.  */

  if (sym->result->ts.type == BT_CHARACTER)
    {
      gfc_charlen *cl = sym->result->ts.u.cl;
      if ((!cl || !cl->length) && !sym->result->ts.deferred)
	{
	  /* See if this is a module-procedure and adapt error message
	     accordingly.  */
	  bool module_proc;
	  gcc_assert (ns->parent && ns->parent->proc_name);
	  module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);

	  gfc_error ("Character-valued %s '%s' at %L must not be"
		     " assumed length",
		     module_proc ? _("module procedure")
				 : _("internal function"),
		     sym->name, &sym->declared_at);
	}
    }
}


/* Add NEW_ARGS to the formal argument list of PROC, taking care not to
   introduce duplicates.  */

static void
merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
{
  gfc_formal_arglist *f, *new_arglist;
  gfc_symbol *new_sym;

  for (; new_args != NULL; new_args = new_args->next)
    {
      new_sym = new_args->sym;
      /* See if this arg is already in the formal argument list.  */
      for (f = proc->formal; f; f = f->next)
	{
	  if (new_sym == f->sym)
	    break;
	}

      if (f)
	continue;

      /* Add a new argument.  Argument order is not important.  */
      new_arglist = gfc_get_formal_arglist ();
      new_arglist->sym = new_sym;
      new_arglist->next = proc->formal;
      proc->formal  = new_arglist;
    }
}


/* Flag the arguments that are not present in all entries.  */

static void
check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
{
  gfc_formal_arglist *f, *head;
  head = new_args;

  for (f = proc->formal; f; f = f->next)
    {
      if (f->sym == NULL)
	continue;

      for (new_args = head; new_args; new_args = new_args->next)
	{
	  if (new_args->sym == f->sym)
	    break;
	}

      if (new_args)
	continue;

      f->sym->attr.not_always_present = 1;
    }
}


/* Resolve alternate entry points.  If a symbol has multiple entry points we
   create a new master symbol for the main routine, and turn the existing
   symbol into an entry point.  */

static void
resolve_entries (gfc_namespace *ns)
{
  gfc_namespace *old_ns;
  gfc_code *c;
  gfc_symbol *proc;
  gfc_entry_list *el;
  char name[GFC_MAX_SYMBOL_LEN + 1];
  static int master_count = 0;

  if (ns->proc_name == NULL)
    return;

  /* No need to do anything if this procedure doesn't have alternate entry
     points.  */
  if (!ns->entries)
    return;

  /* We may already have resolved alternate entry points.  */
  if (ns->proc_name->attr.entry_master)
    return;

  /* If this isn't a procedure something has gone horribly wrong.  */
  gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);

  /* Remember the current namespace.  */
  old_ns = gfc_current_ns;

  gfc_current_ns = ns;

  /* Add the main entry point to the list of entry points.  */
  el = gfc_get_entry_list ();
  el->sym = ns->proc_name;
  el->id = 0;
  el->next = ns->entries;
  ns->entries = el;
  ns->proc_name->attr.entry = 1;

  /* If it is a module function, it needs to be in the right namespace
     so that gfc_get_fake_result_decl can gather up the results. The
     need for this arose in get_proc_name, where these beasts were
     left in their own namespace, to keep prior references linked to
     the entry declaration.*/
  if (ns->proc_name->attr.function
      && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
    el->sym->ns = ns;

  /* Do the same for entries where the master is not a module
     procedure.  These are retained in the module namespace because
     of the module procedure declaration.  */
  for (el = el->next; el; el = el->next)
    if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
	  && el->sym->attr.mod_proc)
      el->sym->ns = ns;
  el = ns->entries;

  /* Add an entry statement for it.  */
  c = gfc_get_code ();
  c->op = EXEC_ENTRY;
  c->ext.entry = el;
  c->next = ns->code;
  ns->code = c;

  /* Create a new symbol for the master function.  */
  /* Give the internal function a unique name (within this file).
     Also include the function name so the user has some hope of figuring
     out what is going on.  */
  snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
	    master_count++, ns->proc_name->name);
  gfc_get_ha_symbol (name, &proc);
  gcc_assert (proc != NULL);

  gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
  if (ns->proc_name->attr.subroutine)
    gfc_add_subroutine (&proc->attr, proc->name, NULL);
  else
    {
      gfc_symbol *sym;
      gfc_typespec *ts, *fts;
      gfc_array_spec *as, *fas;
      gfc_add_function (&proc->attr, proc->name, NULL);
      proc->result = proc;
      fas = ns->entries->sym->as;
      fas = fas ? fas : ns->entries->sym->result->as;
      fts = &ns->entries->sym->result->ts;
      if (fts->type == BT_UNKNOWN)
	fts = gfc_get_default_type (ns->entries->sym->result->name, NULL);
      for (el = ns->entries->next; el; el = el->next)
	{
	  ts = &el->sym->result->ts;
	  as = el->sym->as;
	  as = as ? as : el->sym->result->as;
	  if (ts->type == BT_UNKNOWN)
	    ts = gfc_get_default_type (el->sym->result->name, NULL);

	  if (! gfc_compare_types (ts, fts)
	      || (el->sym->result->attr.dimension
		  != ns->entries->sym->result->attr.dimension)
	      || (el->sym->result->attr.pointer
		  != ns->entries->sym->result->attr.pointer))
	    break;
	  else if (as && fas && ns->entries->sym->result != el->sym->result
		      && gfc_compare_array_spec (as, fas) == 0)
	    gfc_error ("Function %s at %L has entries with mismatched "
		       "array specifications", ns->entries->sym->name,
		       &ns->entries->sym->declared_at);
	  /* The characteristics need to match and thus both need to have
	     the same string length, i.e. both len=*, or both len=4.
	     Having both len=<variable> is also possible, but difficult to
	     check at compile time.  */
	  else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl
		   && (((ts->u.cl->length && !fts->u.cl->length)
			||(!ts->u.cl->length && fts->u.cl->length))
		       || (ts->u.cl->length
			   && ts->u.cl->length->expr_type
			      != fts->u.cl->length->expr_type)
		       || (ts->u.cl->length
			   && ts->u.cl->length->expr_type == EXPR_CONSTANT
		           && mpz_cmp (ts->u.cl->length->value.integer,
				       fts->u.cl->length->value.integer) != 0)))
	    gfc_notify_std (GFC_STD_GNU, "Extension: Function %s at %L with "
			    "entries returning variables of different "
			    "string lengths", ns->entries->sym->name,
			    &ns->entries->sym->declared_at);
	}

      if (el == NULL)
	{
	  sym = ns->entries->sym->result;
	  /* All result types the same.  */
	  proc->ts = *fts;
	  if (sym->attr.dimension)
	    gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
	  if (sym->attr.pointer)
	    gfc_add_pointer (&proc->attr, NULL);
	}
      else
	{
	  /* Otherwise the result will be passed through a union by
	     reference.  */
	  proc->attr.mixed_entry_master = 1;
	  for (el = ns->entries; el; el = el->next)
	    {
	      sym = el->sym->result;
	      if (sym->attr.dimension)
		{
		  if (el == ns->entries)
		    gfc_error ("FUNCTION result %s can't be an array in "
			       "FUNCTION %s at %L", sym->name,
			       ns->entries->sym->name, &sym->declared_at);
		  else
		    gfc_error ("ENTRY result %s can't be an array in "
			       "FUNCTION %s at %L", sym->name,
			       ns->entries->sym->name, &sym->declared_at);
		}
	      else if (sym->attr.pointer)
		{
		  if (el == ns->entries)
		    gfc_error ("FUNCTION result %s can't be a POINTER in "
			       "FUNCTION %s at %L", sym->name,
			       ns->entries->sym->name, &sym->declared_at);
		  else
		    gfc_error ("ENTRY result %s can't be a POINTER in "
			       "FUNCTION %s at %L", sym->name,
			       ns->entries->sym->name, &sym->declared_at);
		}
	      else
		{
		  ts = &sym->ts;
		  if (ts->type == BT_UNKNOWN)
		    ts = gfc_get_default_type (sym->name, NULL);
		  switch (ts->type)
		    {
		    case BT_INTEGER:
		      if (ts->kind == gfc_default_integer_kind)
			sym = NULL;
		      break;
		    case BT_REAL:
		      if (ts->kind == gfc_default_real_kind
			  || ts->kind == gfc_default_double_kind)
			sym = NULL;
		      break;
		    case BT_COMPLEX:
		      if (ts->kind == gfc_default_complex_kind)
			sym = NULL;
		      break;
		    case BT_LOGICAL:
		      if (ts->kind == gfc_default_logical_kind)
			sym = NULL;
		      break;
		    case BT_UNKNOWN:
		      /* We will issue error elsewhere.  */
		      sym = NULL;
		      break;
		    default:
		      break;
		    }
		  if (sym)
		    {
		      if (el == ns->entries)
			gfc_error ("FUNCTION result %s can't be of type %s "
				   "in FUNCTION %s at %L", sym->name,
				   gfc_typename (ts), ns->entries->sym->name,
				   &sym->declared_at);
		      else
			gfc_error ("ENTRY result %s can't be of type %s "
				   "in FUNCTION %s at %L", sym->name,
				   gfc_typename (ts), ns->entries->sym->name,
				   &sym->declared_at);
		    }
		}
	    }
	}
    }
  proc->attr.access = ACCESS_PRIVATE;
  proc->attr.entry_master = 1;

  /* Merge all the entry point arguments.  */
  for (el = ns->entries; el; el = el->next)
    merge_argument_lists (proc, el->sym->formal);

  /* Check the master formal arguments for any that are not
     present in all entry points.  */
  for (el = ns->entries; el; el = el->next)
    check_argument_lists (proc, el->sym->formal);

  /* Use the master function for the function body.  */
  ns->proc_name = proc;

  /* Finalize the new symbols.  */
  gfc_commit_symbols ();

  /* Restore the original namespace.  */
  gfc_current_ns = old_ns;
}


/* Resolve common variables.  */
static void
resolve_common_vars (gfc_symbol *sym, bool named_common)
{
  gfc_symbol *csym = sym;

  for (; csym; csym = csym->common_next)
    {
      if (csym->value || csym->attr.data)
	{
	  if (!csym->ns->is_block_data)
	    gfc_notify_std (GFC_STD_GNU, "Variable '%s' at %L is in COMMON "
			    "but only in BLOCK DATA initialization is "
			    "allowed", csym->name, &csym->declared_at);
	  else if (!named_common)
	    gfc_notify_std (GFC_STD_GNU, "Initialized variable '%s' at %L is "
			    "in a blank COMMON but initialization is only "
			    "allowed in named common blocks", csym->name,
			    &csym->declared_at);
	}

      if (csym->ts.type != BT_DERIVED)
	continue;

      if (!(csym->ts.u.derived->attr.sequence
	    || csym->ts.u.derived->attr.is_bind_c))
	gfc_error_now ("Derived type variable '%s' in COMMON at %L "
		       "has neither the SEQUENCE nor the BIND(C) "
		       "attribute", csym->name, &csym->declared_at);
      if (csym->ts.u.derived->attr.alloc_comp)
	gfc_error_now ("Derived type variable '%s' in COMMON at %L "
		       "has an ultimate component that is "
		       "allocatable", csym->name, &csym->declared_at);
      if (gfc_has_default_initializer (csym->ts.u.derived))
	gfc_error_now ("Derived type variable '%s' in COMMON at %L "
		       "may not have default initializer", csym->name,
		       &csym->declared_at);

      if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer)
	gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at);
    }
}

/* Resolve common blocks.  */
static void
resolve_common_blocks (gfc_symtree *common_root)
{
  gfc_symbol *sym;

  if (common_root == NULL)
    return;

  if (common_root->left)
    resolve_common_blocks (common_root->left);
  if (common_root->right)
    resolve_common_blocks (common_root->right);

  resolve_common_vars (common_root->n.common->head, true);

  gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
  if (sym == NULL)
    return;

  if (sym->attr.flavor == FL_PARAMETER)
    gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
	       sym->name, &common_root->n.common->where, &sym->declared_at);

  if (sym->attr.intrinsic)
    gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
	       sym->name, &common_root->n.common->where);
  else if (sym->attr.result
	   || gfc_is_function_return_value (sym, gfc_current_ns))
    gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
		    "that is also a function result", sym->name,
		    &common_root->n.common->where);
  else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL
	   && sym->attr.proc != PROC_ST_FUNCTION)
    gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
		    "that is also a global procedure", sym->name,
		    &common_root->n.common->where);
}


/* Resolve contained function types.  Because contained functions can call one
   another, they have to be worked out before any of the contained procedures
   can be resolved.

   The good news is that if a function doesn't already have a type, the only
   way it can get one is through an IMPLICIT type or a RESULT variable, because
   by definition contained functions are contained namespace they're contained
   in, not in a sibling or parent namespace.  */

static void
resolve_contained_functions (gfc_namespace *ns)
{
  gfc_namespace *child;
  gfc_entry_list *el;

  resolve_formal_arglists (ns);

  for (child = ns->contained; child; child = child->sibling)
    {
      /* Resolve alternate entry points first.  */
      resolve_entries (child);

      /* Then check function return types.  */
      resolve_contained_fntype (child->proc_name, child);
      for (el = child->entries; el; el = el->next)
	resolve_contained_fntype (el->sym, child);
    }
}


/* Resolve all of the elements of a structure constructor and make sure that
   the types are correct. The 'init' flag indicates that the given
   constructor is an initializer.  */

static gfc_try
resolve_structure_cons (gfc_expr *expr, int init)
{
  gfc_constructor *cons;
  gfc_component *comp;
  gfc_try t;
  symbol_attribute a;

  t = SUCCESS;

  if (expr->ts.type == BT_DERIVED)
    resolve_symbol (expr->ts.u.derived);

  cons = gfc_constructor_first (expr->value.constructor);
  /* A constructor may have references if it is the result of substituting a
     parameter variable.  In this case we just pull out the component we
     want.  */
  if (expr->ref)
    comp = expr->ref->u.c.sym->components;
  else
    comp = expr->ts.u.derived->components;

  /* See if the user is trying to invoke a structure constructor for one of
     the iso_c_binding derived types.  */
  if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
      && expr->ts.u.derived->ts.is_iso_c && cons
      && (cons->expr == NULL || cons->expr->expr_type != EXPR_NULL))
    {
      gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
		 expr->ts.u.derived->name, &(expr->where));
      return FAILURE;
    }

  /* Return if structure constructor is c_null_(fun)prt.  */
  if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
      && expr->ts.u.derived->ts.is_iso_c && cons
      && cons->expr && cons->expr->expr_type == EXPR_NULL)
    return SUCCESS;

  for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
    {
      int rank;

      if (!cons->expr)
	continue;

      if (gfc_resolve_expr (cons->expr) == FAILURE)
	{
	  t = FAILURE;
	  continue;
	}

      rank = comp->as ? comp->as->rank : 0;
      if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
	  && (comp->attr.allocatable || cons->expr->rank))
	{
	  gfc_error ("The rank of the element in the derived type "
		     "constructor at %L does not match that of the "
		     "component (%d/%d)", &cons->expr->where,
		     cons->expr->rank, rank);
	  t = FAILURE;
	}

      /* If we don't have the right type, try to convert it.  */

      if (!comp->attr.proc_pointer &&
	  !gfc_compare_types (&cons->expr->ts, &comp->ts))
	{
	  t = FAILURE;
	  if (strcmp (comp->name, "_extends") == 0)
	    {
	      /* Can afford to be brutal with the _extends initializer.
		 The derived type can get lost because it is PRIVATE
		 but it is not usage constrained by the standard.  */
	      cons->expr->ts = comp->ts;
	      t = SUCCESS;
	    }
	  else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
	    gfc_error ("The element in the derived type constructor at %L, "
		       "for pointer component '%s', is %s but should be %s",
		       &cons->expr->where, comp->name,
		       gfc_basic_typename (cons->expr->ts.type),
		       gfc_basic_typename (comp->ts.type));
	  else
	    t = gfc_convert_type (cons->expr, &comp->ts, 1);
	}

      /* For strings, the length of the constructor should be the same as
	 the one of the structure, ensure this if the lengths are known at
 	 compile time and when we are dealing with PARAMETER or structure
	 constructors.  */
      if (cons->expr->ts.type == BT_CHARACTER && comp->ts.u.cl
	  && comp->ts.u.cl->length
	  && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
	  && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length
	  && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
	  && mpz_cmp (cons->expr->ts.u.cl->length->value.integer,
		      comp->ts.u.cl->length->value.integer) != 0)
	{
	  if (cons->expr->expr_type == EXPR_VARIABLE
	      && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER)
	    {
	      /* Wrap the parameter in an array constructor (EXPR_ARRAY)
		 to make use of the gfc_resolve_character_array_constructor
		 machinery.  The expression is later simplified away to
		 an array of string literals.  */
	      gfc_expr *para = cons->expr;
	      cons->expr = gfc_get_expr ();
	      cons->expr->ts = para->ts;
	      cons->expr->where = para->where;
	      cons->expr->expr_type = EXPR_ARRAY;
	      cons->expr->rank = para->rank;
	      cons->expr->shape = gfc_copy_shape (para->shape, para->rank);
	      gfc_constructor_append_expr (&cons->expr->value.constructor,
					   para, &cons->expr->where);
	    }
	  if (cons->expr->expr_type == EXPR_ARRAY)
	    {
	      gfc_constructor *p;
	      p = gfc_constructor_first (cons->expr->value.constructor);
	      if (cons->expr->ts.u.cl != p->expr->ts.u.cl)
		{
		  gfc_charlen *cl, *cl2;

		  cl2 = NULL;
		  for (cl = gfc_current_ns->cl_list; cl; cl = cl->next)
		    {
		      if (cl == cons->expr->ts.u.cl)
			break;
		      cl2 = cl;
		    }

		  gcc_assert (cl);

		  if (cl2)
		    cl2->next = cl->next;

		  gfc_free_expr (cl->length);
		  free (cl);
		}

	      cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
	      cons->expr->ts.u.cl->length_from_typespec = true;
	      cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length);
	      gfc_resolve_character_array_constructor (cons->expr);
	    }
	}

      if (cons->expr->expr_type == EXPR_NULL
	  && !(comp->attr.pointer || comp->attr.allocatable
	       || comp->attr.proc_pointer
	       || (comp->ts.type == BT_CLASS
		   && (CLASS_DATA (comp)->attr.class_pointer
		       || CLASS_DATA (comp)->attr.allocatable))))
	{
	  t = FAILURE;
	  gfc_error ("The NULL in the derived type constructor at %L is "
		     "being applied to component '%s', which is neither "
		     "a POINTER nor ALLOCATABLE", &cons->expr->where,
		     comp->name);
	}

      if (!comp->attr.pointer || comp->attr.proc_pointer
	  || cons->expr->expr_type == EXPR_NULL)
	continue;

      a = gfc_expr_attr (cons->expr);

      if (!a.pointer && !a.target)
	{
	  t = FAILURE;
	  gfc_error ("The element in the derived type constructor at %L, "
		     "for pointer component '%s' should be a POINTER or "
		     "a TARGET", &cons->expr->where, comp->name);
	}

      if (init)
	{
	  /* F08:C461. Additional checks for pointer initialization.  */
	  if (a.allocatable)
	    {
	      t = FAILURE;
	      gfc_error ("Pointer initialization target at %L "
			 "must not be ALLOCATABLE ", &cons->expr->where);
	    }
	  if (!a.save)
	    {
	      t = FAILURE;
	      gfc_error ("Pointer initialization target at %L "
			 "must have the SAVE attribute", &cons->expr->where);
	    }
	}

      /* F2003, C1272 (3).  */
      if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE
	  && (gfc_impure_variable (cons->expr->symtree->n.sym)
	      || gfc_is_coindexed (cons->expr)))
	{
	  t = FAILURE;
	  gfc_error ("Invalid expression in the derived type constructor for "
		     "pointer component '%s' at %L in PURE procedure",
		     comp->name, &cons->expr->where);
	}

      if (gfc_implicit_pure (NULL)
	    && cons->expr->expr_type == EXPR_VARIABLE
	    && (gfc_impure_variable (cons->expr->symtree->n.sym)
		|| gfc_is_coindexed (cons->expr)))
	gfc_current_ns->proc_name->attr.implicit_pure = 0;

    }

  return t;
}


/****************** Expression name resolution ******************/

/* Returns 0 if a symbol was not declared with a type or
   attribute declaration statement, nonzero otherwise.  */

static int
was_declared (gfc_symbol *sym)
{
  symbol_attribute a;

  a = sym->attr;

  if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
    return 1;

  if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
      || a.optional || a.pointer || a.save || a.target || a.volatile_
      || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN
      || a.asynchronous || a.codimension)
    return 1;

  return 0;
}


/* Determine if a symbol is generic or not.  */

static int
generic_sym (gfc_symbol *sym)
{
  gfc_symbol *s;

  if (sym->attr.generic ||
      (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
    return 1;

  if (was_declared (sym) || sym->ns->parent == NULL)
    return 0;

  gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
  
  if (s != NULL)
    {
      if (s == sym)
	return 0;
      else
	return generic_sym (s);
    }

  return 0;
}


/* Determine if a symbol is specific or not.  */

static int
specific_sym (gfc_symbol *sym)
{
  gfc_symbol *s;

  if (sym->attr.if_source == IFSRC_IFBODY
      || sym->attr.proc == PROC_MODULE
      || sym->attr.proc == PROC_INTERNAL
      || sym->attr.proc == PROC_ST_FUNCTION
      || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
      || sym->attr.external)
    return 1;

  if (was_declared (sym) || sym->ns->parent == NULL)
    return 0;

  gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);

  return (s == NULL) ? 0 : specific_sym (s);
}


/* Figure out if the procedure is specific, generic or unknown.  */

typedef enum
{ PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
proc_type;

static proc_type
procedure_kind (gfc_symbol *sym)
{
  if (generic_sym (sym))
    return PTYPE_GENERIC;

  if (specific_sym (sym))
    return PTYPE_SPECIFIC;

  return PTYPE_UNKNOWN;
}

/* Check references to assumed size arrays.  The flag need_full_assumed_size
   is nonzero when matching actual arguments.  */

static int need_full_assumed_size = 0;

static bool
check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
{
  if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
      return false;

  /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
     What should it be?  */
  if ((e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
	  && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
	       && (e->ref->u.ar.type == AR_FULL))
    {
      gfc_error ("The upper bound in the last dimension must "
		 "appear in the reference to the assumed size "
		 "array '%s' at %L", sym->name, &e->where);
      return true;
    }
  return false;
}


/* Look for bad assumed size array references in argument expressions
  of elemental and array valued intrinsic procedures.  Since this is
  called from procedure resolution functions, it only recurses at
  operators.  */

static bool
resolve_assumed_size_actual (gfc_expr *e)
{
  if (e == NULL)
   return false;

  switch (e->expr_type)
    {
    case EXPR_VARIABLE:
      if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
	return true;
      break;

    case EXPR_OP:
      if (resolve_assumed_size_actual (e->value.op.op1)
	  || resolve_assumed_size_actual (e->value.op.op2))
	return true;
      break;

    default:
      break;
    }
  return false;
}


/* Check a generic procedure, passed as an actual argument, to see if
   there is a matching specific name.  If none, it is an error, and if
   more than one, the reference is ambiguous.  */
static int
count_specific_procs (gfc_expr *e)
{
  int n;
  gfc_interface *p;
  gfc_symbol *sym;
	
  n = 0;
  sym = e->symtree->n.sym;

  for (p = sym->generic; p; p = p->next)
    if (strcmp (sym->name, p->sym->name) == 0)
      {
	e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
				       sym->name);
	n++;
      }

  if (n > 1)
    gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
	       &e->where);

  if (n == 0)
    gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
	       "argument at %L", sym->name, &e->where);

  return n;
}


/* See if a call to sym could possibly be a not allowed RECURSION because of
   a missing RECURIVE declaration.  This means that either sym is the current
   context itself, or sym is the parent of a contained procedure calling its
   non-RECURSIVE containing procedure.
   This also works if sym is an ENTRY.  */

static bool
is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
{
  gfc_symbol* proc_sym;
  gfc_symbol* context_proc;
  gfc_namespace* real_context;

  if (sym->attr.flavor == FL_PROGRAM)
    return false;

  gcc_assert (sym->attr.flavor == FL_PROCEDURE);

  /* If we've got an ENTRY, find real procedure.  */
  if (sym->attr.entry && sym->ns->entries)
    proc_sym = sym->ns->entries->sym;
  else
    proc_sym = sym;

  /* If sym is RECURSIVE, all is well of course.  */
  if (proc_sym->attr.recursive || gfc_option.flag_recursive)
    return false;

  /* Find the context procedure's "real" symbol if it has entries.
     We look for a procedure symbol, so recurse on the parents if we don't
     find one (like in case of a BLOCK construct).  */
  for (real_context = context; ; real_context = real_context->parent)
    {
      /* We should find something, eventually!  */
      gcc_assert (real_context);

      context_proc = (real_context->entries ? real_context->entries->sym
					    : real_context->proc_name);

      /* In some special cases, there may not be a proc_name, like for this
	 invalid code:
	 real(bad_kind()) function foo () ...
	 when checking the call to bad_kind ().
	 In these cases, we simply return here and assume that the
	 call is ok.  */
      if (!context_proc)
	return false;

      if (context_proc->attr.flavor != FL_LABEL)
	break;
    }

  /* A call from sym's body to itself is recursion, of course.  */
  if (context_proc == proc_sym)
    return true;

  /* The same is true if context is a contained procedure and sym the
     containing one.  */
  if (context_proc->attr.contained)
    {
      gfc_symbol* parent_proc;

      gcc_assert (context->parent);
      parent_proc = (context->parent->entries ? context->parent->entries->sym
					      : context->parent->proc_name);

      if (parent_proc == proc_sym)
	return true;
    }

  return false;
}


/* Resolve an intrinsic procedure: Set its function/subroutine attribute,
   its typespec and formal argument list.  */

static gfc_try
resolve_intrinsic (gfc_symbol *sym, locus *loc)
{
  gfc_intrinsic_sym* isym = NULL;
  const char* symstd;

  if (sym->formal)
    return SUCCESS;

  /* We already know this one is an intrinsic, so we don't call
     gfc_is_intrinsic for full checking but rather use gfc_find_function and
     gfc_find_subroutine directly to check whether it is a function or
     subroutine.  */

  if (sym->intmod_sym_id)
    isym = gfc_intrinsic_function_by_id ((gfc_isym_id) sym->intmod_sym_id);
  else
    isym = gfc_find_function (sym->name);

  if (isym)
    {
      if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising
	  && !sym->attr.implicit_type)
	gfc_warning ("Type specified for intrinsic function '%s' at %L is"
		      " ignored", sym->name, &sym->declared_at);

      if (!sym->attr.function &&
	  gfc_add_function (&sym->attr, sym->name, loc) == FAILURE)
	return FAILURE;

      sym->ts = isym->ts;
    }
  else if ((isym = gfc_find_subroutine (sym->name)))
    {
      if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
	{
	  gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
		      " specifier", sym->name, &sym->declared_at);
	  return FAILURE;
	}

      if (!sym->attr.subroutine &&
	  gfc_add_subroutine (&sym->attr, sym->name, loc) == FAILURE)
	return FAILURE;
    }
  else
    {
      gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym->name,
		 &sym->declared_at);
      return FAILURE;
    }

  gfc_copy_formal_args_intr (sym, isym);

  /* Check it is actually available in the standard settings.  */
  if (gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)
      == FAILURE)
    {
      gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
		 " available in the current standard settings but %s.  Use"
		 " an appropriate -std=* option or enable -fall-intrinsics"
		 " in order to use it.",
		 sym->name, &sym->declared_at, symstd);
      return FAILURE;
    }

  return SUCCESS;
}


/* Resolve a procedure expression, like passing it to a called procedure or as
   RHS for a procedure pointer assignment.  */

static gfc_try
resolve_procedure_expression (gfc_expr* expr)
{
  gfc_symbol* sym;

  if (expr->expr_type != EXPR_VARIABLE)
    return SUCCESS;
  gcc_assert (expr->symtree);

  sym = expr->symtree->n.sym;

  if (sym->attr.intrinsic)
    resolve_intrinsic (sym, &expr->where);

  if (sym->attr.flavor != FL_PROCEDURE
      || (sym->attr.function && sym->result == sym))
    return SUCCESS;

  /* A non-RECURSIVE procedure that is used as procedure expression within its
     own body is in danger of being called recursively.  */
  if (is_illegal_recursion (sym, gfc_current_ns))
    gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
		 " itself recursively.  Declare it RECURSIVE or use"
		 " -frecursive", sym->name, &expr->where);
  
  return SUCCESS;
}


/* Resolve an actual argument list.  Most of the time, this is just
   resolving the expressions in the list.
   The exception is that we sometimes have to decide whether arguments
   that look like procedure arguments are really simple variable
   references.  */

static gfc_try
resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
			bool no_formal_args)
{
  gfc_symbol *sym;
  gfc_symtree *parent_st;
  gfc_expr *e;
  int save_need_full_assumed_size;

  for (; arg; arg = arg->next)
    {
      e = arg->expr;
      if (e == NULL)
	{
	  /* Check the label is a valid branching target.  */
	  if (arg->label)
	    {
	      if (arg->label->defined == ST_LABEL_UNKNOWN)
		{
		  gfc_error ("Label %d referenced at %L is never defined",
			     arg->label->value, &arg->label->where);
		  return FAILURE;
		}
	    }
	  continue;
	}

      if (e->expr_type == EXPR_VARIABLE
	    && e->symtree->n.sym->attr.generic
	    && no_formal_args
	    && count_specific_procs (e) != 1)
	return FAILURE;

      if (e->ts.type != BT_PROCEDURE)
	{
	  save_need_full_assumed_size = need_full_assumed_size;
	  if (e->expr_type != EXPR_VARIABLE)
	    need_full_assumed_size = 0;
	  if (gfc_resolve_expr (e) != SUCCESS)
	    return FAILURE;
	  need_full_assumed_size = save_need_full_assumed_size;
	  goto argument_list;
	}

      /* See if the expression node should really be a variable reference.  */

      sym = e->symtree->n.sym;

      if (sym->attr.flavor == FL_PROCEDURE
	  || sym->attr.intrinsic
	  || sym->attr.external)
	{
	  int actual_ok;

	  /* If a procedure is not already determined to be something else
	     check if it is intrinsic.  */
	  if (!sym->attr.intrinsic
	      && !(sym->attr.external || sym->attr.use_assoc
		   || sym->attr.if_source == IFSRC_IFBODY)
	      && gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
	    sym->attr.intrinsic = 1;

	  if (sym->attr.proc == PROC_ST_FUNCTION)
	    {
	      gfc_error ("Statement function '%s' at %L is not allowed as an "
			 "actual argument", sym->name, &e->where);
	    }

	  actual_ok = gfc_intrinsic_actual_ok (sym->name,
					       sym->attr.subroutine);
	  if (sym->attr.intrinsic && actual_ok == 0)
	    {
	      gfc_error ("Intrinsic '%s' at %L is not allowed as an "
			 "actual argument", sym->name, &e->where);
	    }

	  if (sym->attr.contained && !sym->attr.use_assoc
	      && sym->ns->proc_name->attr.flavor != FL_MODULE)
	    {
	      if (gfc_notify_std (GFC_STD_F2008,
				  "Fortran 2008: Internal procedure '%s' is"
				  " used as actual argument at %L",
				  sym->name, &e->where) == FAILURE)
		return FAILURE;
	    }

	  if (sym->attr.elemental && !sym->attr.intrinsic)
	    {
	      gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
			 "allowed as an actual argument at %L", sym->name,
			 &e->where);
	    }

	  /* Check if a generic interface has a specific procedure
	    with the same name before emitting an error.  */
	  if (sym->attr.generic && count_specific_procs (e) != 1)
	    return FAILURE;
	  
	  /* Just in case a specific was found for the expression.  */
	  sym = e->symtree->n.sym;

	  /* If the symbol is the function that names the current (or
	     parent) scope, then we really have a variable reference.  */

	  if (gfc_is_function_return_value (sym, sym->ns))
	    goto got_variable;

	  /* If all else fails, see if we have a specific intrinsic.  */
	  if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
	    {
	      gfc_intrinsic_sym *isym;

	      isym = gfc_find_function (sym->name);
	      if (isym == NULL || !isym->specific)
		{
		  gfc_error ("Unable to find a specific INTRINSIC procedure "
			     "for the reference '%s' at %L", sym->name,
			     &e->where);
		  return FAILURE;
		}
	      sym->ts = isym->ts;
	      sym->attr.intrinsic = 1;
	      sym->attr.function = 1;
	    }

	  if (gfc_resolve_expr (e) == FAILURE)
	    return FAILURE;
	  goto argument_list;
	}

      /* See if the name is a module procedure in a parent unit.  */

      if (was_declared (sym) || sym->ns->parent == NULL)
	goto got_variable;

      if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
	{
	  gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
	  return FAILURE;
	}

      if (parent_st == NULL)
	goto got_variable;

      sym = parent_st->n.sym;
      e->symtree = parent_st;		/* Point to the right thing.  */

      if (sym->attr.flavor == FL_PROCEDURE
	  || sym->attr.intrinsic
	  || sym->attr.external)
	{
	  if (gfc_resolve_expr (e) == FAILURE)
	    return FAILURE;
	  goto argument_list;
	}

    got_variable:
      e->expr_type = EXPR_VARIABLE;
      e->ts = sym->ts;
      if (sym->as != NULL)
	{
	  e->rank = sym->as->rank;
	  e->ref = gfc_get_ref ();
	  e->ref->type = REF_ARRAY;
	  e->ref->u.ar.type = AR_FULL;
	  e->ref->u.ar.as = sym->as;
	}

      /* Expressions are assigned a default ts.type of BT_PROCEDURE in
	 primary.c (match_actual_arg). If above code determines that it
	 is a  variable instead, it needs to be resolved as it was not
	 done at the beginning of this function.  */
      save_need_full_assumed_size = need_full_assumed_size;
      if (e->expr_type != EXPR_VARIABLE)
	need_full_assumed_size = 0;
      if (gfc_resolve_expr (e) != SUCCESS)
	return FAILURE;
      need_full_assumed_size = save_need_full_assumed_size;

    argument_list:
      /* Check argument list functions %VAL, %LOC and %REF.  There is
	 nothing to do for %REF.  */
      if (arg->name && arg->name[0] == '%')
	{
	  if (strncmp ("%VAL", arg->name, 4) == 0)
	    {
	      if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
		{
		  gfc_error ("By-value argument at %L is not of numeric "
			     "type", &e->where);
		  return FAILURE;
		}

	      if (e->rank)
		{
		  gfc_error ("By-value argument at %L cannot be an array or "
			     "an array section", &e->where);
		return FAILURE;
		}

	      /* Intrinsics are still PROC_UNKNOWN here.  However,
		 since same file external procedures are not resolvable
		 in gfortran, it is a good deal easier to leave them to
		 intrinsic.c.  */
	      if (ptype != PROC_UNKNOWN
		  && ptype != PROC_DUMMY
		  && ptype != PROC_EXTERNAL
		  && ptype != PROC_MODULE)
		{
		  gfc_error ("By-value argument at %L is not allowed "
			     "in this context", &e->where);
		  return FAILURE;
		}
	    }

	  /* Statement functions have already been excluded above.  */
	  else if (strncmp ("%LOC", arg->name, 4) == 0
		   && e->ts.type == BT_PROCEDURE)
	    {
	      if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
		{
		  gfc_error ("Passing internal procedure at %L by location "
			     "not allowed", &e->where);
		  return FAILURE;
		}
	    }
	}

      /* Fortran 2008, C1237.  */
      if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
          && gfc_has_ultimate_pointer (e))
        {
          gfc_error ("Coindexed actual argument at %L with ultimate pointer "
		     "component", &e->where);
          return FAILURE;
        }
    }

  return SUCCESS;
}


/* Do the checks of the actual argument list that are specific to elemental
   procedures.  If called with c == NULL, we have a function, otherwise if
   expr == NULL, we have a subroutine.  */

static gfc_try
resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
{
  gfc_actual_arglist *arg0;
  gfc_actual_arglist *arg;
  gfc_symbol *esym = NULL;
  gfc_intrinsic_sym *isym = NULL;
  gfc_expr *e = NULL;
  gfc_intrinsic_arg *iformal = NULL;
  gfc_formal_arglist *eformal = NULL;
  bool formal_optional = false;
  bool set_by_optional = false;
  int i;
  int rank = 0;

  /* Is this an elemental procedure?  */
  if (expr && expr->value.function.actual != NULL)
    {
      if (expr->value.function.esym != NULL
	  && expr->value.function.esym->attr.elemental)
	{
	  arg0 = expr->value.function.actual;
	  esym = expr->value.function.esym;
	}
      else if (expr->value.function.isym != NULL
	       && expr->value.function.isym->elemental)
	{
	  arg0 = expr->value.function.actual;
	  isym = expr->value.function.isym;
	}
      else
	return SUCCESS;
    }
  else if (c && c->ext.actual != NULL)
    {
      arg0 = c->ext.actual;
      
      if (c->resolved_sym)
	esym = c->resolved_sym;
      else
	esym = c->symtree->n.sym;
      gcc_assert (esym);

      if (!esym->attr.elemental)
	return SUCCESS;
    }
  else
    return SUCCESS;

  /* The rank of an elemental is the rank of its array argument(s).  */
  for (arg = arg0; arg; arg = arg->next)
    {
      if (arg->expr != NULL && arg->expr->rank > 0)
	{
	  rank = arg->expr->rank;
	  if (arg->expr->expr_type == EXPR_VARIABLE
	      && arg->expr->symtree->n.sym->attr.optional)
	    set_by_optional = true;

	  /* Function specific; set the result rank and shape.  */
	  if (expr)
	    {
	      expr->rank = rank;
	      if (!expr->shape && arg->expr->shape)
		{
		  expr->shape = gfc_get_shape (rank);
		  for (i = 0; i < rank; i++)
		    mpz_init_set (expr->shape[i], arg->expr->shape[i]);
		}
	    }
	  break;
	}
    }

  /* If it is an array, it shall not be supplied as an actual argument
     to an elemental procedure unless an array of the same rank is supplied
     as an actual argument corresponding to a nonoptional dummy argument of
     that elemental procedure(12.4.1.5).  */
  formal_optional = false;
  if (isym)
    iformal = isym->formal;
  else
    eformal = esym->formal;

  for (arg = arg0; arg; arg = arg->next)
    {
      if (eformal)
	{
	  if (eformal->sym && eformal->sym->attr.optional)
	    formal_optional = true;
	  eformal = eformal->next;
	}
      else if (isym && iformal)
	{
	  if (iformal->optional)
	    formal_optional = true;
	  iformal = iformal->next;
	}
      else if (isym)
	formal_optional = true;

      if (pedantic && arg->expr != NULL
	  && arg->expr->expr_type == EXPR_VARIABLE
	  && arg->expr->symtree->n.sym->attr.optional
	  && formal_optional
	  && arg->expr->rank
	  && (set_by_optional || arg->expr->rank != rank)
	  && !(isym && isym->id == GFC_ISYM_CONVERSION))
	{
	  gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
		       "MISSING, it cannot be the actual argument of an "
		       "ELEMENTAL procedure unless there is a non-optional "
		       "argument with the same rank (12.4.1.5)",
		       arg->expr->symtree->n.sym->name, &arg->expr->where);
	  return FAILURE;
	}
    }

  for (arg = arg0; arg; arg = arg->next)
    {
      if (arg->expr == NULL || arg->expr->rank == 0)
	continue;

      /* Being elemental, the last upper bound of an assumed size array
	 argument must be present.  */
      if (resolve_assumed_size_actual (arg->expr))
	return FAILURE;

      /* Elemental procedure's array actual arguments must conform.  */
      if (e != NULL)
	{
	  if (gfc_check_conformance (arg->expr, e,
				     "elemental procedure") == FAILURE)
	    return FAILURE;
	}
      else
	e = arg->expr;
    }

  /* INTENT(OUT) is only allowed for subroutines; if any actual argument
     is an array, the intent inout/out variable needs to be also an array.  */
  if (rank > 0 && esym && expr == NULL)
    for (eformal = esym->formal, arg = arg0; arg && eformal;
	 arg = arg->next, eformal = eformal->next)
      if ((eformal->sym->attr.intent == INTENT_OUT
	   || eformal->sym->attr.intent == INTENT_INOUT)
	  && arg->expr && arg->expr->rank == 0)
	{
	  gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
		     "ELEMENTAL subroutine '%s' is a scalar, but another "
		     "actual argument is an array", &arg->expr->where,
		     (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
		     : "INOUT", eformal->sym->name, esym->name);
	  return FAILURE;
	}
  return SUCCESS;
}


/* This function does the checking of references to global procedures
   as defined in sections 18.1 and 14.1, respectively, of the Fortran
   77 and 95 standards.  It checks for a gsymbol for the name, making
   one if it does not already exist.  If it already exists, then the
   reference being resolved must correspond to the type of gsymbol.
   Otherwise, the new symbol is equipped with the attributes of the
   reference.  The corresponding code that is called in creating
   global entities is parse.c.

   In addition, for all but -std=legacy, the gsymbols are used to
   check the interfaces of external procedures from the same file.
   The namespace of the gsymbol is resolved and then, once this is
   done the interface is checked.  */


static bool
not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
{
  if (!gsym_ns->proc_name->attr.recursive)
    return true;

  if (sym->ns == gsym_ns)
    return false;

  if (sym->ns->parent && sym->ns->parent == gsym_ns)
    return false;

  return true;
}

static bool
not_entry_self_reference  (gfc_symbol *sym, gfc_namespace *gsym_ns)
{
  if (gsym_ns->entries)
    {
      gfc_entry_list *entry = gsym_ns->entries;

      for (; entry; entry = entry->next)
	{
	  if (strcmp (sym->name, entry->sym->name) == 0)
	    {
	      if (strcmp (gsym_ns->proc_name->name,
			  sym->ns->proc_name->name) == 0)
		return false;

	      if (sym->ns->parent
		  && strcmp (gsym_ns->proc_name->name,
			     sym->ns->parent->proc_name->name) == 0)
		return false;
	    }
	}
    }
  return true;
}

static void
resolve_global_procedure (gfc_symbol *sym, locus *where,
			  gfc_actual_arglist **actual, int sub)
{
  gfc_gsymbol * gsym;
  gfc_namespace *ns;
  enum gfc_symbol_type type;

  type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;

  gsym = gfc_get_gsymbol (sym->name);

  if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
    gfc_global_used (gsym, where);

  if (gfc_option.flag_whole_file
	&& (sym->attr.if_source == IFSRC_UNKNOWN
	    || sym->attr.if_source == IFSRC_IFBODY)
	&& gsym->type != GSYM_UNKNOWN
	&& gsym->ns
	&& gsym->ns->resolved != -1
	&& gsym->ns->proc_name
	&& not_in_recursive (sym, gsym->ns)
	&& not_entry_self_reference (sym, gsym->ns))
    {
      gfc_symbol *def_sym;

      /* Resolve the gsymbol namespace if needed.  */
      if (!gsym->ns->resolved)
	{
	  gfc_dt_list *old_dt_list;
	  struct gfc_omp_saved_state old_omp_state;

	  /* Stash away derived types so that the backend_decls do not
	     get mixed up.  */
	  old_dt_list = gfc_derived_types;
	  gfc_derived_types = NULL;
	  /* And stash away openmp state.  */
	  gfc_omp_save_and_clear_state (&old_omp_state);

	  gfc_resolve (gsym->ns);

	  /* Store the new derived types with the global namespace.  */
	  if (gfc_derived_types)
	    gsym->ns->derived_types = gfc_derived_types;

	  /* Restore the derived types of this namespace.  */
	  gfc_derived_types = old_dt_list;
	  /* And openmp state.  */
	  gfc_omp_restore_state (&old_omp_state);
	}

      /* Make sure that translation for the gsymbol occurs before
	 the procedure currently being resolved.  */
      ns = gfc_global_ns_list;
      for (; ns && ns != gsym->ns; ns = ns->sibling)
	{
	  if (ns->sibling == gsym->ns)
	    {
	      ns->sibling = gsym->ns->sibling;
	      gsym->ns->sibling = gfc_global_ns_list;
	      gfc_global_ns_list = gsym->ns;
	      break;
	    }
	}

      def_sym = gsym->ns->proc_name;
      if (def_sym->attr.entry_master)
	{
	  gfc_entry_list *entry;
	  for (entry = gsym->ns->entries; entry; entry = entry->next)
	    if (strcmp (entry->sym->name, sym->name) == 0)
	      {
		def_sym = entry->sym;
		break;
	      }
	}

      /* Differences in constant character lengths.  */
      if (sym->attr.function && sym->ts.type == BT_CHARACTER)
	{
	  long int l1 = 0, l2 = 0;
	  gfc_charlen *cl1 = sym->ts.u.cl;
	  gfc_charlen *cl2 = def_sym->ts.u.cl;

	  if (cl1 != NULL
	      && cl1->length != NULL
	      && cl1->length->expr_type == EXPR_CONSTANT)
	    l1 = mpz_get_si (cl1->length->value.integer);

  	  if (cl2 != NULL
	      && cl2->length != NULL
	      && cl2->length->expr_type == EXPR_CONSTANT)
	    l2 = mpz_get_si (cl2->length->value.integer);

	  if (l1 && l2 && l1 != l2)
	    gfc_error ("Character length mismatch in return type of "
		       "function '%s' at %L (%ld/%ld)", sym->name,
		       &sym->declared_at, l1, l2);
	}

     /* Type mismatch of function return type and expected type.  */
     if (sym->attr.function
	 && !gfc_compare_types (&sym->ts, &def_sym->ts))
	gfc_error ("Return type mismatch of function '%s' at %L (%s/%s)",
		   sym->name, &sym->declared_at, gfc_typename (&sym->ts),
		   gfc_typename (&def_sym->ts));

      if (def_sym->formal && sym->attr.if_source != IFSRC_IFBODY)
	{
	  gfc_formal_arglist *arg = def_sym->formal;
	  for ( ; arg; arg = arg->next)
	    if (!arg->sym)
	      continue;
	    /* F2003, 12.3.1.1 (2a); F2008, 12.4.2.2 (2a)  */
	    else if (arg->sym->attr.allocatable
		     || arg->sym->attr.asynchronous
		     || arg->sym->attr.optional
		     || arg->sym->attr.pointer
		     || arg->sym->attr.target
		     || arg->sym->attr.value
		     || arg->sym->attr.volatile_)
	      {
		gfc_error ("Dummy argument '%s' of procedure '%s' at %L "
			   "has an attribute that requires an explicit "
			   "interface for this procedure", arg->sym->name,
			   sym->name, &sym->declared_at);
		break;
	      }
	    /* F2003, 12.3.1.1 (2b); F2008, 12.4.2.2 (2b)  */
	    else if (arg->sym && arg->sym->as
		     && arg->sym->as->type == AS_ASSUMED_SHAPE)
	      {
		gfc_error ("Procedure '%s' at %L with assumed-shape dummy "
			   "argument '%s' must have an explicit interface",
			   sym->name, &sym->declared_at, arg->sym->name);
		break;
	      }
	    /* F2008, 12.4.2.2 (2c)  */
	    else if (arg->sym->attr.codimension)
	      {
		gfc_error ("Procedure '%s' at %L with coarray dummy argument "
			   "'%s' must have an explicit interface",
			   sym->name, &sym->declared_at, arg->sym->name);
		break;
	      }
	    /* F2003, 12.3.1.1 (2c); F2008, 12.4.2.2 (2d)   */
	    else if (false) /* TODO: is a parametrized derived type  */
	      {
		gfc_error ("Procedure '%s' at %L with parametrized derived "
			   "type argument '%s' must have an explicit "
			   "interface", sym->name, &sym->declared_at,
			   arg->sym->name);
		break;
	      }
	    /* F2003, 12.3.1.1 (2d); F2008, 12.4.2.2 (2e)   */
	    else if (arg->sym->ts.type == BT_CLASS)
	      {
		gfc_error ("Procedure '%s' at %L with polymorphic dummy "
			   "argument '%s' must have an explicit interface",
			   sym->name, &sym->declared_at, arg->sym->name);
		break;
	      }
	}

      if (def_sym->attr.function)
	{
	  /* F2003, 12.3.1.1 (3a); F2008, 12.4.2.2 (3a) */
	  if (def_sym->as && def_sym->as->rank
	      && (!sym->as || sym->as->rank != def_sym->as->rank))
	    gfc_error ("The reference to function '%s' at %L either needs an "
		       "explicit INTERFACE or the rank is incorrect", sym->name,
		       where);

	  /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
	  if ((def_sym->result->attr.pointer
	       || def_sym->result->attr.allocatable)
	       && (sym->attr.if_source != IFSRC_IFBODY
		   || def_sym->result->attr.pointer
			!= sym->result->attr.pointer
		   || def_sym->result->attr.allocatable
			!= sym->result->attr.allocatable))
	    gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
		       "result must have an explicit interface", sym->name,
		       where);

	  /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c)  */
	  if (sym->ts.type == BT_CHARACTER && sym->attr.if_source != IFSRC_IFBODY
	      && def_sym->ts.u.cl->length != NULL)
	    {
	      gfc_charlen *cl = sym->ts.u.cl;

	      if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
		  && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
		{
		  gfc_error ("Nonconstant character-length function '%s' at %L "
			     "must have an explicit interface", sym->name,
			     &sym->declared_at);
		}
	    }
	}

      /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
      if (def_sym->attr.elemental && !sym->attr.elemental)
	{
	  gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
		     "interface", sym->name, &sym->declared_at);
	}

      /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
      if (def_sym->attr.is_bind_c && !sym->attr.is_bind_c)
	{
	  gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
		     "an explicit interface", sym->name, &sym->declared_at);
	}

      if (gfc_option.flag_whole_file == 1
	  || ((gfc_option.warn_std & GFC_STD_LEGACY)
	      && !(gfc_option.warn_std & GFC_STD_GNU)))
	gfc_errors_to_warnings (1);

      if (sym->attr.if_source != IFSRC_IFBODY)  
	gfc_procedure_use (def_sym, actual, where);

      gfc_errors_to_warnings (0);
    }

  if (gsym->type == GSYM_UNKNOWN)
    {
      gsym->type = type;
      gsym->where = *where;
    }

  gsym->used = 1;
}


/************* Function resolution *************/

/* Resolve a function call known to be generic.
   Section 14.1.2.4.1.  */

static match
resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
{
  gfc_symbol *s;

  if (sym->attr.generic)
    {
      s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
      if (s != NULL)
	{
	  expr->value.function.name = s->name;
	  expr->value.function.esym = s;

	  if (s->ts.type != BT_UNKNOWN)
	    expr->ts = s->ts;
	  else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
	    expr->ts = s->result->ts;

	  if (s->as != NULL)
	    expr->rank = s->as->rank;
	  else if (s->result != NULL && s->result->as != NULL)
	    expr->rank = s->result->as->rank;

	  gfc_set_sym_referenced (expr->value.function.esym);

	  return MATCH_YES;
	}

      /* TODO: Need to search for elemental references in generic
	 interface.  */
    }

  if (sym->attr.intrinsic)
    return gfc_intrinsic_func_interface (expr, 0);

  return MATCH_NO;
}


static gfc_try
resolve_generic_f (gfc_expr *expr)
{
  gfc_symbol *sym;
  match m;

  sym = expr->symtree->n.sym;

  for (;;)
    {
      m = resolve_generic_f0 (expr, sym);
      if (m == MATCH_YES)
	return SUCCESS;
      else if (m == MATCH_ERROR)
	return FAILURE;

generic:
      if (sym->ns->parent == NULL)
	break;
      gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);

      if (sym == NULL)
	break;
      if (!generic_sym (sym))
	goto generic;
    }

  /* Last ditch attempt.  See if the reference is to an intrinsic
     that possesses a matching interface.  14.1.2.4  */
  if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
    {
      gfc_error ("There is no specific function for the generic '%s' at %L",
		 expr->symtree->n.sym->name, &expr->where);
      return FAILURE;
    }

  m = gfc_intrinsic_func_interface (expr, 0);
  if (m == MATCH_YES)
    return SUCCESS;
  if (m == MATCH_NO)
    gfc_error ("Generic function '%s' at %L is not consistent with a "
	       "specific intrinsic interface", expr->symtree->n.sym->name,
	       &expr->where);

  return FAILURE;
}


/* Resolve a function call known to be specific.  */

static match
resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
{
  match m;

  if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
    {
      if (sym->attr.dummy)
	{
	  sym->attr.proc = PROC_DUMMY;
	  goto found;
	}

      sym->attr.proc = PROC_EXTERNAL;
      goto found;
    }

  if (sym->attr.proc == PROC_MODULE
      || sym->attr.proc == PROC_ST_FUNCTION
      || sym->attr.proc == PROC_INTERNAL)
    goto found;

  if (sym->attr.intrinsic)
    {
      m = gfc_intrinsic_func_interface (expr, 1);
      if (m == MATCH_YES)
	return MATCH_YES;
      if (m == MATCH_NO)
	gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
		   "with an intrinsic", sym->name, &expr->where);

      return MATCH_ERROR;
    }

  return MATCH_NO;

found:
  gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);

  if (sym->result)
    expr->ts = sym->result->ts;
  else
    expr->ts = sym->ts;
  expr->value.function.name = sym->name;
  expr->value.function.esym = sym;
  if (sym->as != NULL)
    expr->rank = sym->as->rank;

  return MATCH_YES;
}


static gfc_try
resolve_specific_f (gfc_expr *expr)
{
  gfc_symbol *sym;
  match m;

  sym = expr->symtree->n.sym;

  for (;;)
    {
      m = resolve_specific_f0 (sym, expr);
      if (m == MATCH_YES)
	return SUCCESS;
      if (m == MATCH_ERROR)
	return FAILURE;

      if (sym->ns->parent == NULL)
	break;

      gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);

      if (sym == NULL)
	break;
    }

  gfc_error ("Unable to resolve the specific function '%s' at %L",
	     expr->symtree->n.sym->name, &expr->where);

  return SUCCESS;
}


/* Resolve a procedure call not known to be generic nor specific.  */

static gfc_try
resolve_unknown_f (gfc_expr *expr)
{
  gfc_symbol *sym;
  gfc_typespec *ts;

  sym = expr->symtree->n.sym;

  if (sym->attr.dummy)
    {
      sym->attr.proc = PROC_DUMMY;
      expr->value.function.name = sym->name;
      goto set_type;
    }

  /* See if we have an intrinsic function reference.  */

  if (gfc_is_intrinsic (sym, 0, expr->where))
    {
      if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
	return SUCCESS;
      return FAILURE;
    }

  /* The reference is to an external name.  */

  sym->attr.proc = PROC_EXTERNAL;
  expr->value.function.name = sym->name;
  expr->value.function.esym = expr->symtree->n.sym;

  if (sym->as != NULL)
    expr->rank = sym->as->rank;

  /* Type of the expression is either the type of the symbol or the
     default type of the symbol.  */

set_type:
  gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);

  if (sym->ts.type != BT_UNKNOWN)
    expr->ts = sym->ts;
  else
    {
      ts = gfc_get_default_type (sym->name, sym->ns);

      if (ts->type == BT_UNKNOWN)
	{
	  gfc_error ("Function '%s' at %L has no IMPLICIT type",
		     sym->name, &expr->where);
	  return FAILURE;
	}
      else
	expr->ts = *ts;
    }

  return SUCCESS;
}


/* Return true, if the symbol is an external procedure.  */
static bool
is_external_proc (gfc_symbol *sym)
{
  if (!sym->attr.dummy && !sym->attr.contained
	&& !(sym->attr.intrinsic
	      || gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at))
	&& sym->attr.proc != PROC_ST_FUNCTION
	&& !sym->attr.proc_pointer
	&& !sym->attr.use_assoc
	&& sym->name)
    return true;

  return false;
}


/* Figure out if a function reference is pure or not.  Also set the name
   of the function for a potential error message.  Return nonzero if the
   function is PURE, zero if not.  */
static int
pure_stmt_function (gfc_expr *, gfc_symbol *);

static int
pure_function (gfc_expr *e, const char **name)
{
  int pure;

  *name = NULL;

  if (e->symtree != NULL
        && e->symtree->n.sym != NULL
        && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
    return pure_stmt_function (e, e->symtree->n.sym);

  if (e->value.function.esym)
    {
      pure = gfc_pure (e->value.function.esym);
      *name = e->value.function.esym->name;
    }
  else if (e->value.function.isym)
    {
      pure = e->value.function.isym->pure
	     || e->value.function.isym->elemental;
      *name = e->value.function.isym->name;
    }
  else
    {
      /* Implicit functions are not pure.  */
      pure = 0;
      *name = e->value.function.name;
    }

  return pure;
}


static bool
impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
		 int *f ATTRIBUTE_UNUSED)
{
  const char *name;

  /* Don't bother recursing into other statement functions
     since they will be checked individually for purity.  */
  if (e->expr_type != EXPR_FUNCTION
	|| !e->symtree
	|| e->symtree->n.sym == sym
	|| e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
    return false;

  return pure_function (e, &name) ? false : true;
}


static int
pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
{
  return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
}


static gfc_try
is_scalar_expr_ptr (gfc_expr *expr)
{
  gfc_try retval = SUCCESS;
  gfc_ref *ref;
  int start;
  int end;

  /* See if we have a gfc_ref, which means we have a substring, array
     reference, or a component.  */
  if (expr->ref != NULL)
    {
      ref = expr->ref;
      while (ref->next != NULL)
        ref = ref->next;

      switch (ref->type)
        {
        case REF_SUBSTRING:
          if (ref->u.ss.start == NULL || ref->u.ss.end == NULL
	      || gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) != 0)
	    retval = FAILURE;
          break;

        case REF_ARRAY:
          if (ref->u.ar.type == AR_ELEMENT)
            retval = SUCCESS;
          else if (ref->u.ar.type == AR_FULL)
            {
              /* The user can give a full array if the array is of size 1.  */
              if (ref->u.ar.as != NULL
                  && ref->u.ar.as->rank == 1
                  && ref->u.ar.as->type == AS_EXPLICIT
                  && ref->u.ar.as->lower[0] != NULL
                  && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
                  && ref->u.ar.as->upper[0] != NULL
                  && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
                {
		  /* If we have a character string, we need to check if
		     its length is one.	 */
		  if (expr->ts.type == BT_CHARACTER)
		    {
		      if (expr->ts.u.cl == NULL
			  || expr->ts.u.cl->length == NULL
			  || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1)
			  != 0)
                        retval = FAILURE;
		    }
		  else
		    {
		      /* We have constant lower and upper bounds.  If the
			 difference between is 1, it can be considered a
			 scalar.  
			 FIXME: Use gfc_dep_compare_expr instead.  */
		      start = (int) mpz_get_si
				(ref->u.ar.as->lower[0]->value.integer);
		      end = (int) mpz_get_si
				(ref->u.ar.as->upper[0]->value.integer);
		      if (end - start + 1 != 1)
			retval = FAILURE;
		   }
                }
              else
                retval = FAILURE;
            }
          else
            retval = FAILURE;
          break;
        default:
          retval = SUCCESS;
          break;
        }
    }
  else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
    {
      /* Character string.  Make sure it's of length 1.  */
      if (expr->ts.u.cl == NULL
          || expr->ts.u.cl->length == NULL
          || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0)
        retval = FAILURE;
    }
  else if (expr->rank != 0)
    retval = FAILURE;

  return retval;
}


/* Match one of the iso_c_binding functions (c_associated or c_loc)
   and, in the case of c_associated, set the binding label based on
   the arguments.  */

static gfc_try
gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
                          gfc_symbol **new_sym)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];
  char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
  int optional_arg = 0;
  gfc_try retval = SUCCESS;
  gfc_symbol *args_sym;
  gfc_typespec *arg_ts;
  symbol_attribute arg_attr;

  if (args->expr->expr_type == EXPR_CONSTANT
      || args->expr->expr_type == EXPR_OP
      || args->expr->expr_type == EXPR_NULL)
    {
      gfc_error ("Argument to '%s' at %L is not a variable",
		 sym->name, &(args->expr->where));
      return FAILURE;
    }

  args_sym = args->expr->symtree->n.sym;

  /* The typespec for the actual arg should be that stored in the expr
     and not necessarily that of the expr symbol (args_sym), because
     the actual expression could be a part-ref of the expr symbol.  */
  arg_ts = &(args->expr->ts);
  arg_attr = gfc_expr_attr (args->expr);
    
  if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
    {
      /* If the user gave two args then they are providing something for
	 the optional arg (the second cptr).  Therefore, set the name and
	 binding label to the c_associated for two cptrs.  Otherwise,
	 set c_associated to expect one cptr.  */
      if (args->next)
	{
	  /* two args.  */
	  sprintf (name, "%s_2", sym->name);
	  sprintf (binding_label, "%s_2", sym->binding_label);
	  optional_arg = 1;
	}
      else
	{
	  /* one arg.  */
	  sprintf (name, "%s_1", sym->name);
	  sprintf (binding_label, "%s_1", sym->binding_label);
	  optional_arg = 0;
	}

      /* Get a new symbol for the version of c_associated that
	 will get called.  */
      *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
    }
  else if (sym->intmod_sym_id == ISOCBINDING_LOC
	   || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
    {
      sprintf (name, "%s", sym->name);
      sprintf (binding_label, "%s", sym->binding_label);

      /* Error check the call.  */
      if (args->next != NULL)
        {
          gfc_error_now ("More actual than formal arguments in '%s' "
                         "call at %L", name, &(args->expr->where));
          retval = FAILURE;
        }
      else if (sym->intmod_sym_id == ISOCBINDING_LOC)
        {
	  gfc_ref *ref;
	  bool seen_section;

          /* Make sure we have either the target or pointer attribute.  */
	  if (!arg_attr.target && !arg_attr.pointer)
            {
              gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
                             "a TARGET or an associated pointer",
                             args_sym->name,
                             sym->name, &(args->expr->where));
              retval = FAILURE;
            }

	  if (gfc_is_coindexed (args->expr))
	    {
	      gfc_error_now ("Coindexed argument not permitted"
			     " in '%s' call at %L", name,
			     &(args->expr->where));
	      retval = FAILURE;
	    }

	  /* Follow references to make sure there are no array
	     sections.  */
	  seen_section = false;

	  for (ref=args->expr->ref; ref; ref = ref->next)
	    {
	      if (ref->type == REF_ARRAY)
		{
		  if (ref->u.ar.type == AR_SECTION)
		    seen_section = true;

		  if (ref->u.ar.type != AR_ELEMENT)
		    {
		      gfc_ref *r;
		      for (r = ref->next; r; r=r->next)
			if (r->type == REF_COMPONENT)
			  {
			    gfc_error_now ("Array section not permitted"
					   " in '%s' call at %L", name,
					   &(args->expr->where));
			    retval = FAILURE;
			    break;
			  }
		    }
		}
	    }

	  if (seen_section && retval == SUCCESS)
	    gfc_warning ("Array section in '%s' call at %L", name,
			 &(args->expr->where));
			 
          /* See if we have interoperable type and type param.  */
          if (verify_c_interop (arg_ts) == SUCCESS
              || gfc_check_any_c_kind (arg_ts) == SUCCESS)
            {
              if (args_sym->attr.target == 1)
                {
                  /* Case 1a, section 15.1.2.5, J3/04-007: variable that
                     has the target attribute and is interoperable.  */
                  /* Case 1b, section 15.1.2.5, J3/04-007: allocated
                     allocatable variable that has the TARGET attribute and
                     is not an array of zero size.  */
                  if (args_sym->attr.allocatable == 1)
                    {
                      if (args_sym->attr.dimension != 0 
                          && (args_sym->as && args_sym->as->rank == 0))
                        {
                          gfc_error_now ("Allocatable variable '%s' used as a "
                                         "parameter to '%s' at %L must not be "
                                         "an array of zero size",
                                         args_sym->name, sym->name,
                                         &(args->expr->where));
                          retval = FAILURE;
                        }
                    }
                  else
		    {
		      /* A non-allocatable target variable with C
			 interoperable type and type parameters must be
			 interoperable.	 */
		      if (args_sym && args_sym->attr.dimension)
			{
			  if (args_sym->as->type == AS_ASSUMED_SHAPE)
			    {
			      gfc_error ("Assumed-shape array '%s' at %L "
					 "cannot be an argument to the "
					 "procedure '%s' because "
					 "it is not C interoperable",
					 args_sym->name,
					 &(args->expr->where), sym->name);
			      retval = FAILURE;
			    }
			  else if (args_sym->as->type == AS_DEFERRED)
			    {
			      gfc_error ("Deferred-shape array '%s' at %L "
					 "cannot be an argument to the "
					 "procedure '%s' because "
					 "it is not C interoperable",
					 args_sym->name,
					 &(args->expr->where), sym->name);
			      retval = FAILURE;
			    }
			}
                              
                      /* Make sure it's not a character string.  Arrays of
                         any type should be ok if the variable is of a C
                         interoperable type.  */
		      if (arg_ts->type == BT_CHARACTER)
			if (arg_ts->u.cl != NULL
			    && (arg_ts->u.cl->length == NULL
				|| arg_ts->u.cl->length->expr_type
				   != EXPR_CONSTANT
				|| mpz_cmp_si
				    (arg_ts->u.cl->length->value.integer, 1)
				   != 0)
			    && is_scalar_expr_ptr (args->expr) != SUCCESS)
			  {
			    gfc_error_now ("CHARACTER argument '%s' to '%s' "
					   "at %L must have a length of 1",
					   args_sym->name, sym->name,
					   &(args->expr->where));
			    retval = FAILURE;
			  }
                    }
                }
              else if (arg_attr.pointer
		       && is_scalar_expr_ptr (args->expr) != SUCCESS)
                {
                  /* Case 1c, section 15.1.2.5, J3/04-007: an associated
                     scalar pointer.  */
                  gfc_error_now ("Argument '%s' to '%s' at %L must be an "
                                 "associated scalar POINTER", args_sym->name,
                                 sym->name, &(args->expr->where));
                  retval = FAILURE;
                }
            }
          else
            {
              /* The parameter is not required to be C interoperable.  If it
                 is not C interoperable, it must be a nonpolymorphic scalar
                 with no length type parameters.  It still must have either
                 the pointer or target attribute, and it can be
                 allocatable (but must be allocated when c_loc is called).  */
              if (args->expr->rank != 0 
                  && is_scalar_expr_ptr (args->expr) != SUCCESS)
                {
                  gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
                                 "scalar", args_sym->name, sym->name,
                                 &(args->expr->where));
                  retval = FAILURE;
                }
              else if (arg_ts->type == BT_CHARACTER 
                       && is_scalar_expr_ptr (args->expr) != SUCCESS)
                {
                  gfc_error_now ("CHARACTER argument '%s' to '%s' at "
                                 "%L must have a length of 1",
                                 args_sym->name, sym->name,
                                 &(args->expr->where));
                  retval = FAILURE;
                }
	      else if (arg_ts->type == BT_CLASS)
		{
		  gfc_error_now ("Parameter '%s' to '%s' at %L must not be "
				 "polymorphic", args_sym->name, sym->name,
				 &(args->expr->where));
		  retval = FAILURE;
		}
            }
        }
      else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
        {
          if (args_sym->attr.flavor != FL_PROCEDURE)
            {
              /* TODO: Update this error message to allow for procedure
                 pointers once they are implemented.  */
              gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
                             "procedure",
                             args_sym->name, sym->name,
                             &(args->expr->where));
              retval = FAILURE;
            }
	  else if (args_sym->attr.is_bind_c != 1)
	    {
	      gfc_error_now ("Parameter '%s' to '%s' at %L must be "
			     "BIND(C)",
			     args_sym->name, sym->name,
			     &(args->expr->where));
	      retval = FAILURE;
	    }
        }
      
      /* for c_loc/c_funloc, the new symbol is the same as the old one */
      *new_sym = sym;
    }
  else
    {
      gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
			  "iso_c_binding function: '%s'!\n", sym->name);
    }

  return retval;
}


/* Resolve a function call, which means resolving the arguments, then figuring
   out which entity the name refers to.  */

static gfc_try
resolve_function (gfc_expr *expr)
{
  gfc_actual_arglist *arg;
  gfc_symbol *sym;
  const char *name;
  gfc_try t;
  int temp;
  procedure_type p = PROC_INTRINSIC;
  bool no_formal_args;

  sym = NULL;
  if (expr->symtree)
    sym = expr->symtree->n.sym;

  /* If this is a procedure pointer component, it has already been resolved.  */
  if (gfc_is_proc_ptr_comp (expr, NULL))
    return SUCCESS;
  
  if (sym && sym->attr.intrinsic
      && resolve_intrinsic (sym, &expr->where) == FAILURE)
    return FAILURE;

  if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
    {
      gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
      return FAILURE;
    }

  /* If this ia a deferred TBP with an abstract interface (which may
     of course be referenced), expr->value.function.esym will be set.  */
  if (sym && sym->attr.abstract && !expr->value.function.esym)
    {
      gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
		 sym->name, &expr->where);
      return FAILURE;
    }

  /* Switch off assumed size checking and do this again for certain kinds
     of procedure, once the procedure itself is resolved.  */
  need_full_assumed_size++;

  if (expr->symtree && expr->symtree->n.sym)
    p = expr->symtree->n.sym->attr.proc;

  if (expr->value.function.isym && expr->value.function.isym->inquiry)
    inquiry_argument = true;
  no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;

  if (resolve_actual_arglist (expr->value.function.actual,
			      p, no_formal_args) == FAILURE)
    {
      inquiry_argument = false;
      return FAILURE;
    }

  inquiry_argument = false;
 
  /* Need to setup the call to the correct c_associated, depending on
     the number of cptrs to user gives to compare.  */
  if (sym && sym->attr.is_iso_c == 1)
    {
      if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
          == FAILURE)
        return FAILURE;
      
      /* Get the symtree for the new symbol (resolved func).
         the old one will be freed later, when it's no longer used.  */
      gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
    }
  
  /* Resume assumed_size checking.  */
  need_full_assumed_size--;

  /* If the procedure is external, check for usage.  */
  if (sym && is_external_proc (sym))
    resolve_global_procedure (sym, &expr->where,
			      &expr->value.function.actual, 0);

  if (sym && sym->ts.type == BT_CHARACTER
      && sym->ts.u.cl
      && sym->ts.u.cl->length == NULL
      && !sym->attr.dummy
      && !sym->ts.deferred
      && expr->value.function.esym == NULL
      && !sym->attr.contained)
    {
      /* Internal procedures are taken care of in resolve_contained_fntype.  */
      gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
		 "be used at %L since it is not a dummy argument",
		 sym->name, &expr->where);
      return FAILURE;
    }

  /* See if function is already resolved.  */

  if (expr->value.function.name != NULL)
    {
      if (expr->ts.type == BT_UNKNOWN)
	expr->ts = sym->ts;
      t = SUCCESS;
    }
  else
    {
      /* Apply the rules of section 14.1.2.  */

      switch (procedure_kind (sym))
	{
	case PTYPE_GENERIC:
	  t = resolve_generic_f (expr);
	  break;

	case PTYPE_SPECIFIC:
	  t = resolve_specific_f (expr);
	  break;

	case PTYPE_UNKNOWN:
	  t = resolve_unknown_f (expr);
	  break;

	default:
	  gfc_internal_error ("resolve_function(): bad function type");
	}
    }

  /* If the expression is still a function (it might have simplified),
     then we check to see if we are calling an elemental function.  */

  if (expr->expr_type != EXPR_FUNCTION)
    return t;

  temp = need_full_assumed_size;
  need_full_assumed_size = 0;

  if (resolve_elemental_actual (expr, NULL) == FAILURE)
    return FAILURE;

  if (omp_workshare_flag
      && expr->value.function.esym
      && ! gfc_elemental (expr->value.function.esym))
    {
      gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
		 "in WORKSHARE construct", expr->value.function.esym->name,
		 &expr->where);
      t = FAILURE;
    }

#define GENERIC_ID expr->value.function.isym->id
  else if (expr->value.function.actual != NULL
	   && expr->value.function.isym != NULL
	   && GENERIC_ID != GFC_ISYM_LBOUND
	   && GENERIC_ID != GFC_ISYM_LEN
	   && GENERIC_ID != GFC_ISYM_LOC
	   && GENERIC_ID != GFC_ISYM_PRESENT)
    {
      /* Array intrinsics must also have the last upper bound of an
	 assumed size array argument.  UBOUND and SIZE have to be
	 excluded from the check if the second argument is anything
	 than a constant.  */

      for (arg = expr->value.function.actual; arg; arg = arg->next)
	{
	  if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
	      && arg->next != NULL && arg->next->expr)
	    {
	      if (arg->next->expr->expr_type != EXPR_CONSTANT)
		break;

	      if (arg->next->name && strncmp(arg->next->name, "kind", 4) == 0)
		break;

	      if ((int)mpz_get_si (arg->next->expr->value.integer)
			< arg->expr->rank)
		break;
	    }

	  if (arg->expr != NULL
	      && arg->expr->rank > 0
	      && resolve_assumed_size_actual (arg->expr))
	    return FAILURE;
	}
    }
#undef GENERIC_ID

  need_full_assumed_size = temp;
  name = NULL;

  if (!pure_function (expr, &name) && name)
    {
      if (forall_flag)
	{
	  gfc_error ("reference to non-PURE function '%s' at %L inside a "
		     "FORALL %s", name, &expr->where,
		     forall_flag == 2 ? "mask" : "block");
	  t = FAILURE;
	}
      else if (gfc_pure (NULL))
	{
	  gfc_error ("Function reference to '%s' at %L is to a non-PURE "
		     "procedure within a PURE procedure", name, &expr->where);
	  t = FAILURE;
	}
    }

  if (!pure_function (expr, &name) && name && gfc_implicit_pure (NULL))
    gfc_current_ns->proc_name->attr.implicit_pure = 0;

  /* Functions without the RECURSIVE attribution are not allowed to
   * call themselves.  */
  if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
    {
      gfc_symbol *esym;
      esym = expr->value.function.esym;

      if (is_illegal_recursion (esym, gfc_current_ns))
      {
	if (esym->attr.entry && esym->ns->entries)
	  gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
		     " function '%s' is not RECURSIVE",
		     esym->name, &expr->where, esym->ns->entries->sym->name);
	else
	  gfc_error ("Function '%s' at %L cannot be called recursively, as it"
		     " is not RECURSIVE", esym->name, &expr->where);

	t = FAILURE;
      }
    }

  /* Character lengths of use associated functions may contains references to
     symbols not referenced from the current program unit otherwise.  Make sure
     those symbols are marked as referenced.  */

  if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
      && expr->value.function.esym->attr.use_assoc)
    {
      gfc_expr_set_symbols_referenced (expr->ts.u.cl->length);
    }

  /* Make sure that the expression has a typespec that works.  */
  if (expr->ts.type == BT_UNKNOWN)
    {
      if (expr->symtree->n.sym->result
	    && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN
	    && !expr->symtree->n.sym->result->attr.proc_pointer)
	expr->ts = expr->symtree->n.sym->result->ts;
    }

  return t;
}


/************* Subroutine resolution *************/

static void
pure_subroutine (gfc_code *c, gfc_symbol *sym)
{
  if (gfc_pure (sym))
    return;

  if (forall_flag)
    gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
	       sym->name, &c->loc);
  else if (gfc_pure (NULL))
    gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
	       &c->loc);
}


static match
resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
{
  gfc_symbol *s;

  if (sym->attr.generic)
    {
      s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
      if (s != NULL)
	{
	  c->resolved_sym = s;
	  pure_subroutine (c, s);
	  return MATCH_YES;
	}

      /* TODO: Need to search for elemental references in generic interface.  */
    }

  if (sym->attr.intrinsic)
    return gfc_intrinsic_sub_interface (c, 0);

  return MATCH_NO;
}


static gfc_try
resolve_generic_s (gfc_code *c)
{
  gfc_symbol *sym;
  match m;

  sym = c->symtree->n.sym;

  for (;;)
    {
      m = resolve_generic_s0 (c, sym);
      if (m == MATCH_YES)
	return SUCCESS;
      else if (m == MATCH_ERROR)
	return FAILURE;

generic:
      if (sym->ns->parent == NULL)
	break;
      gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);

      if (sym == NULL)
	break;
      if (!generic_sym (sym))
	goto generic;
    }

  /* Last ditch attempt.  See if the reference is to an intrinsic
     that possesses a matching interface.  14.1.2.4  */
  sym = c->symtree->n.sym;

  if (!gfc_is_intrinsic (sym, 1, c->loc))
    {
      gfc_error ("There is no specific subroutine for the generic '%s' at %L",
		 sym->name, &c->loc);
      return FAILURE;
    }

  m = gfc_intrinsic_sub_interface (c, 0);
  if (m == MATCH_YES)
    return SUCCESS;
  if (m == MATCH_NO)
    gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
	       "intrinsic subroutine interface", sym->name, &c->loc);

  return FAILURE;
}


/* Set the name and binding label of the subroutine symbol in the call
   expression represented by 'c' to include the type and kind of the
   second parameter.  This function is for resolving the appropriate
   version of c_f_pointer() and c_f_procpointer().  For example, a
   call to c_f_pointer() for a default integer pointer could have a
   name of c_f_pointer_i4.  If no second arg exists, which is an error
   for these two functions, it defaults to the generic symbol's name
   and binding label.  */

static void
set_name_and_label (gfc_code *c, gfc_symbol *sym,
                    char *name, char *binding_label)
{
  gfc_expr *arg = NULL;
  char type;
  int kind;

  /* The second arg of c_f_pointer and c_f_procpointer determines
     the type and kind for the procedure name.  */
  arg = c->ext.actual->next->expr;

  if (arg != NULL)
    {
      /* Set up the name to have the given symbol's name,
         plus the type and kind.  */
      /* a derived type is marked with the type letter 'u' */
      if (arg->ts.type == BT_DERIVED)
        {
          type = 'd';
          kind = 0; /* set the kind as 0 for now */
        }
      else
        {
          type = gfc_type_letter (arg->ts.type);
          kind = arg->ts.kind;
        }

      if (arg->ts.type == BT_CHARACTER)
	/* Kind info for character strings not needed.	*/
	kind = 0;

      sprintf (name, "%s_%c%d", sym->name, type, kind);
      /* Set up the binding label as the given symbol's label plus
         the type and kind.  */
      sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
    }
  else
    {
      /* If the second arg is missing, set the name and label as
         was, cause it should at least be found, and the missing
         arg error will be caught by compare_parameters().  */
      sprintf (name, "%s", sym->name);
      sprintf (binding_label, "%s", sym->binding_label);
    }
   
  return;
}


/* Resolve a generic version of the iso_c_binding procedure given
   (sym) to the specific one based on the type and kind of the
   argument(s).  Currently, this function resolves c_f_pointer() and
   c_f_procpointer based on the type and kind of the second argument
   (FPTR).  Other iso_c_binding procedures aren't specially handled.
   Upon successfully exiting, c->resolved_sym will hold the resolved
   symbol.  Returns MATCH_ERROR if an error occurred; MATCH_YES
   otherwise.  */

match
gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
{
  gfc_symbol *new_sym;
  /* this is fine, since we know the names won't use the max */
  char name[GFC_MAX_SYMBOL_LEN + 1];
  char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
  /* default to success; will override if find error */
  match m = MATCH_YES;

  /* Make sure the actual arguments are in the necessary order (based on the 
     formal args) before resolving.  */
  gfc_procedure_use (sym, &c->ext.actual, &(c->loc));

  if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
      (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
    {
      set_name_and_label (c, sym, name, binding_label);
      
      if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
	{
	  if (c->ext.actual != NULL && c->ext.actual->next != NULL)
	    {
	      /* Make sure we got a third arg if the second arg has non-zero
		 rank.	We must also check that the type and rank are
		 correct since we short-circuit this check in
		 gfc_procedure_use() (called above to sort actual args).  */
	      if (c->ext.actual->next->expr->rank != 0)
		{
		  if(c->ext.actual->next->next == NULL 
		     || c->ext.actual->next->next->expr == NULL)
		    {
		      m = MATCH_ERROR;
		      gfc_error ("Missing SHAPE parameter for call to %s "
				 "at %L", sym->name, &(c->loc));
		    }