1 {
2 Copyright (c) 1998-2002 by Carl Eric Codere and Peter Vreman
3
4 This unit implements some support routines for assembler parsing
5 independent of the processor
6
7 This program is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2 of the License, or
10 (at your option) any later version.
11
12 This program is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with this program; if not, write to the Free Software
19 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
20
21 **********************************************************************}
22 Unit RAUtils;
23
24 {$i fpcdefs.inc}
25
26 Interface
27
28 Uses
29 cutils,cclasses,
30 globtype,aasmbase,aasmtai,aasmdata,cpubase,cpuinfo,cgbase,cgutils,
31 symconst,symbase,symtype,symdef,symsym,constexp,symcpu;
32
33 Const
34 RPNMax = 10; { I think you only need 4, but just to be safe }
35 OpMax = 25;
36
SearchLabelnull37 Function SearchLabel(const s: string; var hl: tasmlabel;emit:boolean): boolean;
38
39
40 {---------------------------------------------------------------------
41 Instruction management
42 ---------------------------------------------------------------------}
43
44 type
45 TOprType=(OPR_NONE,OPR_CONSTANT,OPR_SYMBOL,OPR_LOCAL,
46 OPR_REFERENCE,OPR_REGISTER,OPR_COND,OPR_REGSET,
47 OPR_SHIFTEROP,OPR_MODEFLAGS,OPR_SPECIALREG,
48 OPR_REGPAIR);
49
50 TOprRec = record
51 case typ:TOprType of
52 OPR_NONE : ();
53 {$if defined(AVR)}
54 OPR_CONSTANT : (val:longint);
55 {$elseif defined(i8086)}
56 OPR_CONSTANT : (val:longint);
57 {$else}
58 OPR_CONSTANT : (val:aint);
59 {$endif}
60 OPR_SYMBOL : (symbol:tasmsymbol;symofs:aint;symseg:boolean;sym_farproc_entry:boolean);
61 OPR_REFERENCE : (varsize:asizeint; constoffset: asizeint;ref_farproc_entry:boolean;ref:treference);
62 OPR_LOCAL : (localvarsize, localconstoffset: asizeint;localsym:tabstractnormalvarsym;localsymofs:aint;localsegment,localindexreg:tregister;localscale:byte;localgetoffset,localforceref:boolean);
63 OPR_REGISTER : (reg:tregister);
64 {$ifdef m68k}
65 OPR_REGSET : (regsetdata,regsetaddr,regsetfpu : tcpuregisterset);
66 OPR_REGPAIR : (reghi,reglo: tregister);
67 {$endif m68k}
68 {$ifdef powerpc}
69 OPR_COND : (cond : tasmcond);
70 {$endif powerpc}
71 {$ifdef POWERPC64}
72 OPR_COND : (cond : tasmcond);
73 {$endif POWERPC64}
74 {$ifdef arm}
75 OPR_REGSET : (regset : tcpuregisterset; regtype: tregistertype; subreg: tsubregister; usermode: boolean);
76 OPR_SHIFTEROP : (shifterop : tshifterop);
77 OPR_COND : (cc : tasmcond);
78 OPR_MODEFLAGS : (flags : tcpumodeflags);
79 OPR_SPECIALREG: (specialreg : tregister; specialregflags : tspecialregflags);
80 {$endif arm}
81 {$ifdef aarch64}
82 OPR_SHIFTEROP : (shifterop : tshifterop);
83 OPR_COND : (cc : tasmcond);
84 {$endif aarch64}
85 end;
86
87 TOperand = class
88 opr : TOprRec;
89 typesize : byte;
90 haslabelref, { if the operand has a label, used in a reference like a
91 var (e.g. 'mov ax, word ptr [label+5]', but *not*
92 e.g. 'jmp label') }
93 hasproc, { if the operand has a procedure/function reference }
94 hastype, { if the operand has typecasted variable }
95 hasvar : boolean; { if the operand is loaded with a variable }
96 size : TCGSize;
97 constructor create;virtual;
98 destructor destroy;override;
99 Procedure SetSize(_size:longint;force:boolean);virtual;
100 Procedure SetCorrectSize(opcode:tasmop);virtual;
SetupResultnull101 Function SetupResult:boolean;virtual;
SetupSelfnull102 Function SetupSelf:boolean;
SetupOldEBPnull103 Function SetupOldEBP:boolean;
SetupVarnull104 Function SetupVar(const s:string;GetOffset : boolean): Boolean;
CheckOperandnull105 Function CheckOperand: boolean; virtual;
106 Procedure InitRef;
107 Procedure InitRefConvertLocal;
108 protected
109 Procedure InitRefError;
110 end;
111 TCOperand = class of TOperand;
112
113 TInstruction = class
114 operands : array[1..max_operands] of toperand;
115 opcode : tasmop;
116 condition : tasmcond;
117 ops : byte;
118 labeled : boolean;
119 filepos : tfileposinfo;
120 constructor create(optype : tcoperand);virtual;
121 destructor destroy;override;
122 { converts the instruction to an instruction how it's used by the assembler writer
123 and concats it to the passed list. The newly created item is returned if the
124 instruction was valid, otherwise nil is returned }
ConcatInstructionnull125 function ConcatInstruction(p:TAsmList) : tai;virtual;
126 end;
127
128 {---------------------------------------------------------------------}
129 { Expression parser types }
130 {---------------------------------------------------------------------}
131
132 TExprOperator = record
133 ch: char; { operator }
134 is_prefix: boolean; { was it a prefix, possible prefixes are +,- and not }
135 end;
136
137 {**********************************************************************}
138 { The following operators are supported: }
139 { '+' : addition }
140 { '-' : subtraction }
141 { '*' : multiplication }
142 { '/' : modulo division }
143 { '^' : exclusive or }
144 { '<' : shift left }
145 { '>' : shift right }
146 { '&' : bitwise and }
147 { '|' : bitwise or }
148 { '~' : bitwise complement }
149 { '%' : modulo division }
150 { nnn: longint numbers }
151 { ( and ) parenthesis }
152 { [ and ] another kind of parenthesis }
153 {**********************************************************************}
154
155 TExprParse = class
156 public
157 Constructor create;
158 Destructor Destroy;override;
Evaluatenull159 Function Evaluate(Expr: String): tcgint;
Prioritynull160 Function Priority(_Operator: Char): aint;
161 private
162 RPNStack : Array[1..RPNMax] of tcgint; { Stack For RPN calculator }
163 RPNTop : tcgint;
164 OpStack : Array[1..OpMax] of TExprOperator; { Operator stack For conversion }
165 OpTop : tcgint;
166 Procedure RPNPush(Num: tcgint);
RPNPopnull167 Function RPNPop: tcgint;
168 Procedure RPNCalc(const token: String; prefix: boolean);
169 Procedure OpPush(_Operator: char; prefix: boolean);
170 { In reality returns TExprOperaotr }
171 Procedure OpPop(var _Operator:TExprOperator);
172 end;
173
174 { Evaluate an expression string to a tcgint }
CalculateExpressionnull175 Function CalculateExpression(const expression: string): tcgint;
176
177 {---------------------------------------------------------------------}
178 { String routines }
179 {---------------------------------------------------------------------}
180
ParseValnull181 Function ParseVal(const S:String;base:byte):tcgint;
PadZeronull182 Function PadZero(Var s: String; n: byte): Boolean;
EscapeToPascalnull183 Function EscapeToPascal(const s:string): string;
184
185 {---------------------------------------------------------------------
186 Symbol helper routines
187 ---------------------------------------------------------------------}
188
189 procedure AsmSearchSym(const s:string;out srsym:tsym;out srsymtable:TSymtable);
GetRecordOffsetSizenull190 Function GetRecordOffsetSize(s:string;out Offset: tcgint;out Size:tcgint; out mangledname: string; needvmtofs: boolean; out hastypecast: boolean):boolean;
SearchTypenull191 Function SearchType(const hs:string;out size:tcgint): Boolean;
SearchRecordTypenull192 Function SearchRecordType(const s:string): boolean;
SearchIConstantnull193 Function SearchIConstant(const s:string; var l:tcgint): boolean;
AsmRegisterParanull194 Function AsmRegisterPara(sym: tabstractnormalvarsym): boolean;
195
196 {---------------------------------------------------------------------
197 Instruction generation routines
198 ---------------------------------------------------------------------}
199
200 Procedure ConcatLabel(p: TAsmList;var l : tasmlabel);
201 Procedure ConcatConstant(p : TAsmList;value: tcgint; constsize:byte);
202 Procedure ConcatConstSymbol(p : TAsmList;const sym:string;symtyp:tasmsymtype;l:tcgint;constsize:byte;isofs:boolean);
203 Procedure ConcatRealConstant(p : TAsmList;value: bestreal; real_typ : tfloattype);
204 Procedure ConcatString(p : TAsmList;s:string);
205 procedure ConcatAlign(p:TAsmList;l:tcgint);
206 Procedure ConcatPublic(p:TAsmList;const s : string);
207 Procedure ConcatLocal(p:TAsmList;const s : string);
208
209
210 Implementation
211
212 uses
213 SysUtils,
214 defutil,systems,verbose,globals,
215 symtable,paramgr,
216 aasmcpu,
217 procinfo;
218
219 {*************************************************************************
220 TExprParse
221 *************************************************************************}
222
223 Constructor TExprParse.create;
224 Begin
225 end;
226
227
228 Procedure TExprParse.RPNPush(Num : tcgint);
229 { Add an operand to the top of the RPN stack }
230 begin
231 if RPNTop < RPNMax then
232 begin
233 Inc(RPNTop);
234 RPNStack[RPNTop]:=Num;
235 end
236 else
237 Message(asmr_e_expr_illegal);
238 end;
239
240
TExprParse.RPNPopnull241 Function TExprParse.RPNPop : tcgint;
242 { Get the operand at the top of the RPN stack }
243 begin
244 RPNPop:=0;
245 if RPNTop > 0 then
246 begin
247 RPNPop:=RPNStack[RPNTop];
248 Dec(RPNTop);
249 end
250 else
251 Message(asmr_e_expr_illegal);
252 end;
253
254
255 Procedure TExprParse.RPNCalc(const Token : String; prefix:boolean); { RPN Calculator }
256 Var
257 Temp : tcgint;
258 n1,n2 : tcgint;
259 LocalError : Integer;
260 begin
261 { Handle operators }
262 if (Length(Token) = 1) and (Token[1] in ['+', '-', '*', '/','&','|','%','^','~','<','>']) then
263 Case Token[1] of
264 '+' :
265 Begin
266 if not prefix then
267 RPNPush(RPNPop + RPNPop);
268 end;
269 '-' :
270 Begin
271 if prefix then
272 RPNPush(-(RPNPop))
273 else
274 begin
275 n1:=RPNPop;
276 n2:=RPNPop;
277 RPNPush(n2 - n1);
278 end;
279 end;
280 '*' : RPNPush(RPNPop * RPNPop);
281 '&' :
282 begin
283 n1:=RPNPop;
284 n2:=RPNPop;
285 RPNPush(n2 and n1);
286 end;
287 '|' :
288 begin
289 n1:=RPNPop;
290 n2:=RPNPop;
291 RPNPush(n2 or n1);
292 end;
293 '~' : RPNPush(NOT RPNPop);
294 '<' :
295 begin
296 n1:=RPNPop;
297 n2:=RPNPop;
298 RPNPush(n2 SHL n1);
299 end;
300 '>' :
301 begin
302 n1:=RPNPop;
303 n2:=RPNPop;
304 RPNPush(n2 SHR n1);
305 end;
306 '%' :
307 begin
308 Temp:=RPNPop;
309 if Temp <> 0 then
310 RPNPush(RPNPop mod Temp)
311 else
312 begin
313 Message(asmr_e_expr_zero_divide);
314 { push 1 for error recovery }
315 RPNPush(1);
316 end;
317 end;
318 '^' : RPNPush(RPNPop XOR RPNPop);
319 '/' :
320 begin
321 Temp:=RPNPop;
322 if Temp <> 0 then
323 RPNPush(RPNPop div Temp)
324 else
325 begin
326 Message(asmr_e_expr_zero_divide);
327 { push 1 for error recovery }
328 RPNPush(1);
329 end;
330 end;
331 end
332 else
333 begin
334 { Convert String to number and add to stack }
335 Val(Token, Temp, LocalError);
336 if LocalError = 0 then
337 RPNPush(Temp)
338 else
339 begin
340 Message(asmr_e_expr_illegal);
341 { push 1 for error recovery }
342 RPNPush(1);
343 end;
344 end;
345 end;
346
347
348 Procedure TExprParse.OpPush(_Operator : char;prefix: boolean);
349 { Add an operator onto top of the stack }
350 begin
351 if OpTop < OpMax then
352 begin
353 Inc(OpTop);
354 OpStack[OpTop].ch:=_Operator;
355 OpStack[OpTop].is_prefix:=prefix;
356 end
357 else
358 Message(asmr_e_expr_illegal);
359 end;
360
361
362 Procedure TExprParse.OpPop(var _Operator:TExprOperator);
363 { Get operator at the top of the stack }
364 begin
365 if OpTop > 0 then
366 begin
367 _Operator:=OpStack[OpTop];
368 Dec(OpTop);
369 end
370 else
371 Message(asmr_e_expr_illegal);
372 end;
373
374
TExprParse.Prioritynull375 Function TExprParse.Priority(_Operator : Char) : aint;
376 { Return priority of operator }
377 { The greater the priority, the higher the precedence }
378 begin
379 Priority:=0;
380 Case _Operator OF
381 '(','[' :
382 Priority:=0;
383 '|','^','~' : // the lowest priority: OR, XOR, NOT
384 Priority:=0;
385 '&' : // bigger priority: AND
386 Priority:=1;
387 '+', '-' : // bigger priority: +, -
388 Priority:=2;
389 '*', '/','%','<','>' : // the highest priority: *, /, MOD, SHL, SHR
390 Priority:=3;
391 else
392 Message(asmr_e_expr_illegal);
393 end;
394 end;
395
396
TExprParse.Evaluatenull397 Function TExprParse.Evaluate(Expr : String):tcgint;
398 Var
399 I : longint;
400 Token : String;
401 opr : TExprOperator;
402 begin
403 Evaluate:=0;
404 { Reset stacks }
405 OpTop :=0;
406 RPNTop:=0;
407 Token :='';
408 { nothing to do ? }
409 if Expr='' then
410 exit;
411 For I:=1 to Length(Expr) DO
412 begin
413 if Expr[I] in ['0'..'9'] then
414 begin { Build multi-digit numbers }
415 Token:=Token + Expr[I];
416 if I = Length(Expr) then { Send last one to calculator }
417 RPNCalc(Token,false);
418 end
419 else
420 if Expr[I] in ['+', '-', '*', '/', '(', ')','[',']','^','&','|','%','~','<','>'] then
421 begin
422 if Token <> '' then
423 begin { Send last built number to calc. }
424 RPNCalc(Token,false);
425 Token:='';
426 end;
427
428 Case Expr[I] OF
429 '[' : OpPush('[',false);
430 ']' : begin
431 While (OpTop>0) and (OpStack[OpTop].ch <> '[') DO
432 Begin
433 OpPop(opr);
434 RPNCalc(opr.ch,opr.is_prefix);
435 end;
436 OpPop(opr); { Pop off and ignore the '[' }
437 end;
438 '(' : OpPush('(',false);
439 ')' : begin
440 While (OpTop>0) and (OpStack[OpTop].ch <> '(') DO
441 Begin
442 OpPop(opr);
443 RPNCalc(opr.ch,opr.is_prefix);
444 end;
445 OpPop(opr); { Pop off and ignore the '(' }
446 end;
447 '+','-','~' : Begin
448 { workaround for -2147483648 }
449 if (expr[I]='-') and (expr[i+1] in ['0'..'9']) then
450 begin
451 token:='-';
452 expr[i]:='+';
453 end;
454 { if start of expression then surely a prefix }
455 { or if previous char was also an operator }
456 if (I = 1) or (not (Expr[I-1] in ['0'..'9',')'])) then
457 OpPush(Expr[I],true)
458 else
459 Begin
460 { Evaluate all higher priority operators }
461 While (OpTop > 0) AND (Priority(Expr[I]) <= Priority(OpStack[OpTop].ch)) DO
462 Begin
463 OpPop(opr);
464 RPNCalc(opr.ch,opr.is_prefix);
465 end;
466 OpPush(Expr[I],false);
467 End;
468 end;
469 '*', '/',
470 '^','|','&',
471 '%','<','>' : begin
472 While (OpTop > 0) and (Priority(Expr[I]) <= Priority(OpStack[OpTop].ch)) DO
473 Begin
474 OpPop(opr);
475 RPNCalc(opr.ch,opr.is_prefix);
476 end;
477 OpPush(Expr[I],false);
478 end;
479 end; { Case }
480 end
481 else
482 Message(asmr_e_expr_illegal); { Handle bad input error }
483 end;
484
485 { Pop off the remaining operators }
486 While OpTop > 0 do
487 Begin
488 OpPop(opr);
489 RPNCalc(opr.ch,opr.is_prefix);
490 end;
491
492 { The result is stored on the top of the stack }
493 Evaluate:=RPNPop;
494 end;
495
496
497 Destructor TExprParse.Destroy;
498 Begin
499 end;
500
501
CalculateExpressionnull502 Function CalculateExpression(const expression: string): tcgint;
503 var
504 expr: TExprParse;
505 Begin
506 expr:=TExprParse.create;
507 CalculateExpression:=expr.Evaluate(expression);
508 expr.Free;
509 end;
510
511
512 {*************************************************************************}
513 { String conversions/utils }
514 {*************************************************************************}
515
EscapeToPascalnull516 Function EscapeToPascal(const s:string): string;
517 { converts a C styled string - which contains escape }
518 { characters to a pascal style string. }
519 var
520 i,len : asizeint;
521 hs : string;
522 temp : string;
523 c : char;
524 Begin
525 hs:='';
526 len:=0;
527 i:=0;
528 while (i<length(s)) and (len<255) do
529 begin
530 Inc(i);
531 if (s[i]='\') and (i<length(s)) then
532 Begin
533 inc(i);
534 case s[i] of
535 '\' :
536 c:='\';
537 'b':
538 c:=#8;
539 'f':
540 c:=#12;
541 'n':
542 c:=#10;
543 'r':
544 c:=#13;
545 't':
546 c:=#9;
547 '"':
548 c:='"';
549 '0'..'7':
550 Begin
551 temp:=s[i];
552 temp:=temp+s[i+1];
553 temp:=temp+s[i+2];
554 inc(i,2);
555 c:=chr(ParseVal(temp,8));
556 end;
557 'x':
558 Begin
559 temp:=s[i+1];
560 temp:=temp+s[i+2];
561 inc(i,2);
562 c:=chr(ParseVal(temp,16));
563 end;
564 else
565 Begin
566 Message1(asmr_e_escape_seq_ignored,s[i]);
567 c:=s[i];
568 end;
569 end;
570 end
571 else
572 c:=s[i];
573 inc(len);
574 hs[len]:=c;
575 end;
576 hs[0]:=chr(len);
577 EscapeToPascal:=hs;
578 end;
579
580
ParseValnull581 Function ParseVal(const S:String;base:byte):tcgint;
582 { Converts a decimal string to tcgint }
583 var
584 code : integer;
585 errmsg : word;
586 prefix : string[2];
587 Begin
588 case base of
589 2 :
590 begin
591 errmsg:=asmr_e_error_converting_binary;
592 prefix:='%';
593 end;
594 8 :
595 begin
596 errmsg:=asmr_e_error_converting_octal;
597 prefix:='&';
598 end;
599 10 :
600 begin
601 errmsg:=asmr_e_error_converting_decimal;
602 prefix:='';
603 end;
604 16 :
605 begin
606 errmsg:=asmr_e_error_converting_hexadecimal;
607 prefix:='$';
608 end;
609 else
610 internalerror(200501202);
611 end;
612 val(prefix+s,result,code);
613 if code<>0 then
614 begin
615 val(prefix+s,result,code);
616 if code<>0 then
617 begin
618 Message1(errmsg,s);
619 result:=0;
620 end;
621 end;
622 end;
623
624
PadZeronull625 Function PadZero(Var s: String; n: byte): Boolean;
626 Begin
627 PadZero:=TRUE;
628 { Do some error checking first }
629 if Length(s) = n then
630 exit
631 else
632 if Length(s) > n then
633 Begin
634 PadZero:=FALSE;
635 delete(s,n+1,length(s));
636 exit;
637 end
638 else
639 PadZero:=TRUE;
640 { Fill it up with the specified character }
641 fillchar(s[length(s)+1],n-1,#0);
642 s[0]:=chr(n);
643 end;
644
645
646 {****************************************************************************
647 TOperand
648 ****************************************************************************}
649
650 constructor TOperand.Create;
651 begin
652 size:=OS_NO;
653 hasproc:=false;
654 hastype:=false;
655 hasvar:=false;
656 FillChar(Opr,sizeof(Opr),0);
657 end;
658
659
660 destructor TOperand.destroy;
661 begin
662 end;
663
664
665 Procedure TOperand.SetSize(_size:longint;force:boolean);
666 begin
667 if force or
668 ((size = OS_NO) and (_size<=16)) then
669 Begin
670 case _size of
671 1 : size:=OS_8;
672 2 : size:=OS_16{ could be S_IS};
673 4 : size:=OS_32{ could be S_IL or S_FS};
674 8 : size:=OS_64{ could be S_D or S_FL};
675 10 : size:=OS_F80;
676 16 : size:=OS_128;
677 end;
678 end;
679 end;
680
681
682 Procedure TOperand.SetCorrectSize(opcode:tasmop);
683 begin
684 end;
685
686
SetupResultnull687 function TOperand.SetupResult:boolean;
688
689 begin
690 SetupResult:=false;
691 { replace by correct offset. }
692 with current_procinfo.procdef do
693 if (not is_void(returndef)) then
694 begin
695 if (m_tp7 in current_settings.modeswitches) and
696 not (df_generic in defoptions) and
697 (po_assembler in procoptions) and
698 (not paramanager.ret_in_param(returndef,current_procinfo.procdef)) then
699 begin
700 message(asmr_e_cannot_use_RESULT_here);
701 exit;
702 end;
703 SetupResult:=setupvar('result',false)
704 end
705 else
706 message(asmr_e_void_function);
endnull707 end;
708
709
TOperand.SetupSelfnull710 Function TOperand.SetupSelf:boolean;
711 Begin
712 SetupSelf:=false;
713 if assigned(current_structdef) then
714 SetupSelf:=setupvar('self',false)
715 else
716 Message(asmr_e_cannot_use_SELF_outside_a_method);
717 end;
718
719
TOperand.SetupOldEBPnull720 Function TOperand.SetupOldEBP:boolean;
721 Begin
722 SetupOldEBP:=false;
723 if current_procinfo.procdef.parast.symtablelevel>normal_function_level then
724 SetupOldEBP:=setupvar('parentframe',false)
725 else
726 Message(asmr_e_cannot_use_OLDEBP_outside_nested_procedure);
727 end;
728
729
TOperand.SetupVarnull730 Function TOperand.SetupVar(const s:string;GetOffset : boolean): Boolean;
731
symtable_has_localvarsymsnull732 function symtable_has_localvarsyms(st:TSymtable):boolean;
733 var
734 sym : tsym;
735 i : longint;
736 begin
737 result:=false;
738 for i:=0 to st.SymList.Count-1 do
739 begin
740 sym:=tsym(st.SymList[i]);
741 if sym.typ=localvarsym then
742 begin
743 result:=true;
744 exit;
745 end;
746 end;
747 end;
748
749 procedure setconst(l:aint);
750 begin
751 { We return the address of the field, just like Delphi/TP }
752 case opr.typ of
753 OPR_NONE :
754 begin
755 opr.typ:=OPR_CONSTANT;
756 opr.val:=l;
757 end;
758 OPR_CONSTANT :
759 inc(opr.val,l);
760 OPR_REFERENCE :
761 inc(opr.ref.offset,l);
762 OPR_LOCAL :
763 inc(opr.localsymofs,l);
764 else
765 Message(asmr_e_invalid_operand_type);
766 end;
767 end;
768
769
770 procedure setvarsize(sym: tabstractvarsym);
771 var
772 harrdef: tarraydef;
773 l: asizeint;
774 begin
775 case sym.vardef.typ of
776 orddef,
777 enumdef,
778 pointerdef,
779 procvardef,
780 floatdef :
781 SetSize(sym.getsize,false);
782 arraydef :
783 begin
784 { for arrays try to get the element size, take care of
785 multiple indexes }
786 harrdef:=tarraydef(sym.vardef);
787
788 { calc array size }
789 if is_special_array(harrdef) then
790 l := -1
791 else
792 l := harrdef.size;
793
794 case opr.typ of
795 OPR_REFERENCE: opr.varsize := l;
796 OPR_LOCAL: opr.localvarsize := l;
797 end;
798
799
800 while assigned(harrdef.elementdef) and
801 (harrdef.elementdef.typ=arraydef) do
802 harrdef:=tarraydef(harrdef.elementdef);
803 if not is_packed_array(harrdef) then
804 SetSize(harrdef.elesize,false)
805 else
806 if (harrdef.elepackedbitsize mod 8) = 0 then
807 SetSize(harrdef.elepackedbitsize div 8,false);
808 end;
809 recorddef:
810 case opr.typ of
811 OPR_REFERENCE: opr.varsize := sym.getsize;
812 OPR_LOCAL: opr.localvarsize := sym.getsize;
813 end;
814 end;
815 end;
816
817 { search and sets up the correct fields in the Instr record }
818 { for the NON-constant identifier passed to the routine. }
819 { if not found returns FALSE. }
820 var
821 sym : tsym;
822 srsymtable : TSymtable;
823 {$ifdef x86}
824 segreg,
825 {$endif x86}
826 indexreg : tregister;
827 plist : ppropaccesslistitem;
828 size_set_from_absolute : boolean = false;
829 { offset fixup (in bytes), coming from an absolute declaration with an index
830 (e.g. var tralala: word absolute moo[5]; ) }
831 absoffset: asizeint=0;
832 harrdef: tarraydef;
833 tmpprocinfo: tprocinfo;
834 Begin
835 SetupVar:=false;
836 asmsearchsym(s,sym,srsymtable);
837 if sym = nil then
838 exit;
839 if sym.typ=absolutevarsym then
840 begin
841 case tabsolutevarsym(sym).abstyp of
842 tovar:
843 begin
844 { Only support simple loads }
845 plist:=tabsolutevarsym(sym).ref.firstsym;
846 if assigned(plist) and
847 (plist^.sltype=sl_load) then
848 begin
849 setvarsize(tabstractvarsym(sym));
850 size_set_from_absolute:=true;
851 sym:=plist^.sym;
852 { resolve the chain of array indexes (if there are any) }
853 harrdef:=nil;
854 while assigned(plist^.next) do
855 begin
856 plist:=plist^.next;
857 if (plist^.sltype=sl_vec) and (tabstractvarsym(sym).vardef.typ=arraydef) then
858 begin
859 if harrdef=nil then
860 harrdef:=tarraydef(tabstractvarsym(sym).vardef)
861 else if harrdef.elementdef.typ=arraydef then
862 harrdef:=tarraydef(harrdef.elementdef)
863 else
864 begin
865 Message(asmr_e_unsupported_symbol_type);
866 exit;
867 end;
868 if is_special_array(harrdef) then
869 begin
870 Message(asmr_e_unsupported_symbol_type);
871 exit;
872 end;
873 if not is_packed_array(harrdef) then
874 Inc(absoffset,asizeint(Int64(plist^.value-harrdef.lowrange))*harrdef.elesize)
875 else if (Int64(plist^.value-harrdef.lowrange)*harrdef.elepackedbitsize mod 8)=0 then
876 Inc(absoffset,asizeint(Int64(plist^.value-harrdef.lowrange)*harrdef.elepackedbitsize div 8))
877 else
878 Message(asmr_e_packed_element);
879 end
880 else
881 begin
882 Message(asmr_e_unsupported_symbol_type);
883 exit;
884 end;
885 end;
886 end
887 else
888 begin
889 Message(asmr_e_unsupported_symbol_type);
890 exit;
891 end;
892 end;
893 toaddr:
894 begin
895 initref;
896 opr.ref.offset:=tabsolutevarsym(sym).addroffset;
897 setvarsize(tabstractvarsym(sym));
898 size_set_from_absolute:=true;
899 hasvar:=true;
900 Result:=true;
901 exit;
902 end;
903 else
904 begin
905 Message(asmr_e_unsupported_symbol_type);
906 exit;
907 end;
908 end;
909 end;
910 case sym.typ of
911 fieldvarsym :
912 begin
913 if not tabstractrecordsymtable(sym.owner).is_packed then
914 setconst(absoffset+tfieldvarsym(sym).fieldoffset)
915 else if tfieldvarsym(sym).fieldoffset mod 8 = 0 then
916 setconst(absoffset+tfieldvarsym(sym).fieldoffset div 8)
917 else
918 Message(asmr_e_packed_element);
919 if not size_set_from_absolute then
920 setvarsize(tabstractvarsym(sym));
921 hasvar:=true;
922 SetupVar:=true;
923 end;
924 staticvarsym,
925 localvarsym,
926 paravarsym :
927 begin
928 { we always assume in asm statements that }
929 { that the variable is valid. }
930 tabstractvarsym(sym).varstate:=vs_readwritten;
931 inc(tabstractvarsym(sym).refs);
932 { variable can't be placed in a register }
933 tabstractvarsym(sym).varregable:=vr_none;
934 { and anything may happen with its address }
935 tabstractvarsym(sym).addr_taken:=true;
936 case sym.typ of
937 staticvarsym :
938 begin
939 initref;
940 opr.ref.symbol:=current_asmdata.RefAsmSymbol(tstaticvarsym(sym).mangledname,AT_DATA);
941 Inc(opr.ref.offset,absoffset);
942 end;
943 paravarsym,
944 localvarsym :
945 begin
946 tmpprocinfo:=current_procinfo;
947 while assigned(tmpprocinfo) do
948 begin
949 if (sym.owner=tmpprocinfo.procdef.localst) or
950 (sym.owner=tmpprocinfo.procdef.parast) then
951 begin
952 tmpprocinfo.procdef.init_paraloc_info(calleeside);
953 break;
954 end;
955 tmpprocinfo:=tmpprocinfo.parent;
956 end;
957 if opr.typ=OPR_REFERENCE then
958 begin
959 {$ifdef x86}
960 segreg:=opr.ref.segment;
961 {$endif x86}
962 indexreg:=opr.ref.base;
963 if opr.ref.index<>NR_NO then
964 begin
965 if indexreg=NR_NO then
966 indexreg:=opr.ref.index
967 else
968 Message(asmr_e_multiple_index);
969 end;
970 end
971 else
972 begin
973 {$ifdef x86}
974 segreg:=NR_NO;
975 {$endif x86}
976 indexreg:=NR_NO;
977 end;
978 opr.typ:=OPR_LOCAL;
979 if assigned(current_procinfo.parent) and
980 not(po_inline in current_procinfo.procdef.procoptions) and
981 (sym.owner<>current_procinfo.procdef.localst) and
982 (sym.owner<>current_procinfo.procdef.parast) and
983 (current_procinfo.procdef.localst.symtablelevel>normal_function_level) and
984 symtable_has_localvarsyms(current_procinfo.procdef.localst) then
985 message1(asmr_e_local_para_unreachable,s);
986 opr.localsym:=tabstractnormalvarsym(sym);
987 opr.localsymofs:=absoffset;
988 {$ifdef x86}
989 opr.localsegment:=segreg;
990 {$endif x86}
991 opr.localindexreg:=indexreg;
992 opr.localscale:=0;
993 opr.localgetoffset:=GetOffset;
994 if paramanager.push_addr_param(tabstractvarsym(sym).varspez,tabstractvarsym(sym).vardef,current_procinfo.procdef.proccalloption) then
995 SetSize(sizeof(pint),false);
996 end;
997 end;
998 if not size_set_from_absolute then
999 setvarsize(tabstractvarsym(sym));
1000 hasvar:=true;
1001 SetupVar:=true;
1002 Exit;
1003 end;
1004 constsym :
1005 begin
1006 if tconstsym(sym).consttyp=constord then
1007 begin
1008 setconst(tconstsym(sym).value.valueord.svalue);
1009 SetupVar:=true;
1010 Exit;
1011 end;
1012 end;
1013 typesym :
1014 begin
1015 if ttypesym(sym).typedef.typ in [recorddef,objectdef] then
1016 begin
1017 setconst(0);
1018 SetupVar:=TRUE;
1019 Exit;
1020 end;
1021 end;
1022 procsym :
1023 begin
1024 if Tprocsym(sym).ProcdefList.Count>1 then
1025 Message(asmr_w_calling_overload_func);
1026 case opr.typ of
1027 OPR_REFERENCE:
1028 begin
1029 opr.ref.symbol:=current_asmdata.RefAsmSymbol(tprocdef(tprocsym(sym).ProcdefList[0]).mangledname,AT_FUNCTION);
Incnull1030 Inc(opr.ref.offset,absoffset);
1031 {$ifdef i8086}
1032 opr.ref_farproc_entry:=is_proc_far(tprocdef(tprocsym(sym).ProcdefList[0]))
1033 and not (po_interrupt in tprocdef(tprocsym(sym).ProcdefList[0]).procoptions);
1034 {$endif i8086}
1035 end;
1036 OPR_NONE:
1037 begin
1038 opr.typ:=OPR_SYMBOL;
1039 opr.symbol:=current_asmdata.RefAsmSymbol(tprocdef(tprocsym(sym).ProcdefList[0]).mangledname,AT_FUNCTION);
1040 {$ifdef i8086}
1041 opr.sym_farproc_entry:=is_proc_far(tprocdef(tprocsym(sym).ProcdefList[0]))
1042 and not (po_interrupt in tprocdef(tprocsym(sym).ProcdefList[0]).procoptions);
1043 {$endif i8086}
1044 opr.symofs:=absoffset;
1045 end;
1046 else
1047 Message(asmr_e_invalid_operand_type);
1048 end;
1049 hasproc:=true;
1050 hasvar:=true;
1051 SetupVar:=TRUE;
1052 Exit;
1053 end;
1054 {$ifdef i8086}
1055 labelsym :
1056 begin
1057 case opr.typ of
1058 OPR_REFERENCE:
1059 begin
1060 opr.ref.symbol:=current_asmdata.RefAsmSymbol(tlabelsym(sym).mangledname,AT_FUNCTION);
Incnull1061 Inc(opr.ref.offset,absoffset);
1062 if opr.ref.segment=NR_NO then
1063 opr.ref.segment:=NR_CS;
1064 end;
1065 else
1066 begin
1067 Message(asmr_e_unsupported_symbol_type);
1068 exit;
1069 end;
1070 end;
1071 haslabelref:=true;
1072 hasvar:=true;
1073 SetupVar:=TRUE;
1074 Exit;
1075 end
1076 {$endif i8086}
1077 else
1078 begin
1079 Message(asmr_e_unsupported_symbol_type);
1080 exit;
1081 end;
1082 end;
1083 end;
1084
1085
1086 procedure TOperand.InitRef;
1087 {*********************************************************************}
1088 { Description: This routine first check if the opcode is of }
1089 { type OPR_NONE, or OPR_REFERENCE , if not it gives out an error. }
1090 { If the operandtype = OPR_NONE or <> OPR_REFERENCE then it sets up }
1091 { the operand type to OPR_REFERENCE, as well as setting up the ref }
1092 { to point to the default segment. }
1093 {*********************************************************************}
1094 var
1095 l : aint;
1096 hsymofs : aint;
1097 hsymbol : tasmsymbol;
1098 reg : tregister;
1099 hsym_farprocentry: Boolean;
1100 Begin
1101 case opr.typ of
1102 OPR_REFERENCE :
1103 exit;
1104 OPR_CONSTANT :
1105 begin
1106 l:=opr.val;
1107 opr.typ:=OPR_REFERENCE;
1108 Fillchar(opr.ref,sizeof(treference),0);
1109 opr.Ref.Offset:=l;
1110 opr.varsize:=0;
1111 opr.constoffset:=0;
1112 opr.ref_farproc_entry:=false;
1113 end;
1114 OPR_NONE :
1115 begin
1116 opr.typ:=OPR_REFERENCE;
1117 opr.varsize:=0;
1118 opr.constoffset:=0;
1119 opr.ref_farproc_entry:=false;
1120 Fillchar(opr.ref,sizeof(treference),0);
1121 end;
1122 OPR_REGISTER :
1123 begin
1124 reg:=opr.reg;
1125 opr.typ:=OPR_REFERENCE;
1126 opr.varsize:=0;
1127 opr.constoffset:=0;
1128 opr.ref_farproc_entry:=false;
1129 Fillchar(opr.ref,sizeof(treference),0);
1130 opr.Ref.base:=reg;
1131 end;
1132 OPR_SYMBOL :
1133 begin
1134 hsymbol:=opr.symbol;
1135 hsymofs:=opr.symofs;
1136 hsym_farprocentry:=opr.sym_farproc_entry;
1137 opr.typ:=OPR_REFERENCE;
1138 opr.varsize:=0;
1139 opr.constoffset:=0;
1140 Fillchar(opr.ref,sizeof(treference),0);
1141 opr.ref.symbol:=hsymbol;
1142 opr.ref.offset:=hsymofs;
1143 opr.ref_farproc_entry:=hsym_farprocentry;
1144 end;
1145 else
1146 InitRefError;
1147 end;
1148 end;
1149
1150 procedure TOperand.InitRefConvertLocal;
1151 var
1152 localvarsize,localconstoffset: asizeint;
1153 localsym:tabstractnormalvarsym;
1154 localsymofs:aint;
1155 {$ifdef x86}
1156 localsegment,
1157 {$endif x86}
1158 localindexreg:tregister;
1159 localscale:byte;
1160 begin
1161 if opr.typ=OPR_LOCAL then
1162 begin
1163 if AsmRegisterPara(opr.localsym) and
1164 not opr.localgetoffset then
1165 begin
1166 localvarsize:=opr.localvarsize;
1167 localconstoffset:=opr.localconstoffset;
1168 localsym:=opr.localsym;
1169 localsymofs:=opr.localsymofs;
1170 {$ifdef x86}
1171 localsegment:=opr.localsegment;
1172 {$endif x86}
1173 localindexreg:=opr.localindexreg;
1174 localscale:=opr.localscale;;
1175 opr.typ:=OPR_REFERENCE;
1176 hasvar:=false;
1177 Fillchar(opr.ref,sizeof(treference),0);
1178 opr.varsize:=localvarsize;
1179 opr.constoffset:=localconstoffset;
1180 opr.ref_farproc_entry:=false;
1181 opr.ref.base:=tparavarsym(localsym).paraloc[calleeside].Location^.register;
1182 opr.ref.offset:=localsymofs;
1183 {$ifdef x86}
1184 opr.ref.segment:=localsegment;
1185 {$endif x86}
1186 opr.ref.index:=localindexreg;
1187 opr.ref.scalefactor:=localscale;
1188 end
1189 else
1190 InitRefError;
1191 end
1192 else
1193 InitRef;
1194 end;
1195
1196 procedure TOperand.InitRefError;
1197 begin
1198 Message(asmr_e_invalid_operand_type);
1199 { Recover }
1200 opr.typ:=OPR_REFERENCE;
1201 opr.varsize:=0;
1202 opr.constoffset:=0;
1203 opr.ref_farproc_entry:=false;
1204 Fillchar(opr.ref,sizeof(treference),0);
1205 end;
1206
TOperand.CheckOperandnull1207 Function TOperand.CheckOperand: boolean;
1208 {*********************************************************************}
1209 { Description: This routine checks if the operand is of }
1210 { valid, and returns false if it isn't. Does nothing by default. }
1211 {*********************************************************************}
1212 begin
1213 result:=true;
1214 end;
1215
1216
1217 {****************************************************************************
1218 TInstruction
1219 ****************************************************************************}
1220
1221 constructor TInstruction.create(optype : tcoperand);
1222 var
1223 i : longint;
1224 Begin
1225 { these field are set to 0 anyways by the constructor helper (FK)
1226 Opcode:=A_NONE;
1227 Condition:=C_NONE;
1228 Ops:=0;
1229 }
1230 filepos:=current_filepos;
1231 for i:=1 to max_operands do
1232 Operands[i]:=optype.create;
1233 Labeled:=false;
1234 end;
1235
1236
1237 destructor TInstruction.destroy;
1238 var
1239 i : longint;
1240 Begin
1241 for i:=1 to max_operands do
1242 Operands[i].free;
1243 end;
1244
1245
TInstruction.ConcatInstructionnull1246 function TInstruction.ConcatInstruction(p:TAsmList) : tai;
1247 var
1248 ai : taicpu;
1249 i : longint;
1250 begin
1251 for i:=1 to Ops do
1252 operands[i].CheckOperand;
1253
1254 ai:=taicpu.op_none(opcode);
1255 ai.fileinfo:=filepos;
1256 ai.Ops:=Ops;
1257 ai.Allocate_oper(Ops);
1258 for i:=1 to Ops do
1259 with operands[i].opr do
1260 begin
1261 case typ of
1262 OPR_CONSTANT :
1263 ai.loadconst(i-1,val);
1264 OPR_REGISTER:
1265 ai.loadreg(i-1,reg);
1266 OPR_SYMBOL:
1267 ai.loadsymbol(i-1,symbol,symofs);
1268 OPR_LOCAL :
1269 begin
1270 ai.loadlocal(i-1,localsym,localsymofs,localindexreg,
1271 localscale,localgetoffset,localforceref);
1272 {$ifdef x86}
1273 ai.oper[i-1]^.localoper^.localsegment:=localsegment;
1274 {$endif x86}
1275 end;
1276 OPR_REFERENCE:
1277 ai.loadref(i-1,ref);
1278 {$ifdef m68k}
1279 OPR_REGSET:
1280 ai.loadregset(i-1,regsetdata,regsetaddr,regsetfpu);
1281 OPR_REGPAIR:
1282 ai.loadregpair(i-1,reghi,reglo);
1283 {$endif}
1284 {$ifdef ARM}
1285 OPR_REGSET:
1286 ai.loadregset(i-1,regtype,subreg,regset,usermode);
1287 OPR_MODEFLAGS:
1288 ai.loadmodeflags(i-1,flags);
1289 OPR_SPECIALREG:
1290 ai.loadspecialreg(i-1,specialreg,specialregflags);
1291 {$endif ARM}
1292 {$if defined(arm) or defined(aarch64)}
1293 OPR_SHIFTEROP:
1294 ai.loadshifterop(i-1,shifterop);
1295 OPR_COND:
1296 ai.loadconditioncode(i-1,cc);
1297 {$endif arm or aarch64}
1298 { ignore wrong operand }
1299 OPR_NONE:
1300 ;
1301 else
1302 internalerror(200501051);
1303 end;
1304 end;
1305 ai.SetCondition(condition);
1306 { Concat the opcode or give an error }
1307 if assigned(ai) then
1308 p.concat(ai)
1309 else
1310 Message(asmr_e_invalid_opcode_and_operand);
1311 result:=ai;
1312 end;
1313
1314
1315 {****************************************************************************
1316 Symbol table helper routines
1317 ****************************************************************************}
1318
1319 procedure AsmSearchSym(const s:string;out srsym:tsym;out srsymtable:TSymtable);
1320 var
1321 i : integer;
1322 begin
1323 i:=pos('.',s);
1324 { allow unit.identifier }
1325 if i>0 then
1326 begin
1327 searchsym(Copy(s,1,i-1),srsym,srsymtable);
1328 if assigned(srsym) then
1329 begin
1330 if (srsym.typ=unitsym) and
1331 (srsym.owner.symtabletype in [staticsymtable,globalsymtable]) and
1332 srsym.owner.iscurrentunit then
1333 searchsym_in_module(tunitsym(srsym).module,Copy(s,i+1,255),srsym,srsymtable)
1334 else
1335 begin
1336 srsym:=nil;
1337 srsymtable:=nil;
1338 end;
1339 end;
1340 end
1341 else
1342 searchsym(s,srsym,srsymtable);
1343 { in asm routines, the function result variable, that matches the function
1344 name should be avoided, because:
1345 1) there's already a @Result directive (even in TP7) that can be used, if
1346 you want to access the function result
1347 2) there's no other way to disambiguate between the function result variable
1348 and the function's address (using asm syntax only)
1349
1350 This fixes code, such as:
1351
1352 function test1: word;
1353 begin
1354 asm
1355 mov ax, offset test1
1356 end;
1357 end;
1358
1359 and makes it work in a consistent manner as this code:
1360
1361 procedure test2;
1362 begin
1363 asm
1364 mov ax, offset test2
1365 end;
1366 end; }
1367 if assigned(srsym) and
1368 assigned(srsymtable) and
1369 (srsym.typ=absolutevarsym) and
1370 (vo_is_funcret in tabsolutevarsym(srsym).varoptions) and
1371 (srsymtable.symtabletype=localsymtable) and
1372 assigned(srsymtable.defowner) and
1373 (srsymtable.defowner.typ=procdef) and
1374 (tprocdef(srsymtable.defowner).procsym.name=tabsolutevarsym(srsym).Name) then
1375 begin
1376 srsym:=tprocdef(srsymtable.defowner).procsym;
1377 srsymtable:=srsym.Owner;
1378 end;
1379 end;
1380
1381
SearchTypenull1382 Function SearchType(const hs:string;out size:tcgint): Boolean;
1383 var
1384 srsym : tsym;
1385 srsymtable : TSymtable;
1386 begin
1387 result:=false;
1388 size:=0;
1389 asmsearchsym(hs,srsym,srsymtable);
1390 if assigned(srsym) and
1391 (srsym.typ=typesym) then
1392 begin
1393 size:=ttypesym(srsym).typedef.size;
1394 result:=true;
1395 end;
1396 end;
1397
1398
1399
SearchRecordTypenull1400 Function SearchRecordType(const s:string): boolean;
1401 var
1402 srsym : tsym;
1403 srsymtable : TSymtable;
1404 Begin
1405 SearchRecordType:=false;
1406 { Check the constants in symtable }
1407 asmsearchsym(s,srsym,srsymtable);
1408 if srsym <> nil then
1409 Begin
1410 case srsym.typ of
1411 typesym :
1412 begin
1413 if ttypesym(srsym).typedef.typ in [recorddef,objectdef] then
1414 begin
1415 SearchRecordType:=true;
1416 exit;
1417 end;
1418 end;
1419 fieldvarsym :
1420 begin
1421 if (tfieldvarsym(srsym).vardef.typ in [recorddef,objectdef]) then
1422 begin
1423 SearchRecordType:=true;
1424 exit;
1425 end;
1426 end;
1427 end;
1428 end;
1429 end;
1430
1431
SearchIConstantnull1432 Function SearchIConstant(const s:string; var l:tcgint): boolean;
1433 {**********************************************************************}
1434 { Description: Searches for a CONSTANT of name s in either the local }
1435 { symbol list, then in the global symbol list, and returns the value }
1436 { of that constant in l. Returns TRUE if successfull, if not found, }
1437 { or if the constant is not of correct type, then returns FALSE }
1438 { Remarks: Also handle TRUE and FALSE returning in those cases 1 and 0 }
1439 { respectively. }
1440 {**********************************************************************}
1441 var
1442 srsym : tsym;
1443 srsymtable : TSymtable;
1444 Begin
1445 SearchIConstant:=false;
1446 { check for TRUE or FALSE reserved words first }
1447 if s = 'TRUE' then
1448 Begin
1449 SearchIConstant:=TRUE;
1450 l:=1;
1451 exit;
1452 end;
1453 if s = 'FALSE' then
1454 Begin
1455 SearchIConstant:=TRUE;
1456 l:=0;
1457 exit;
1458 end;
1459 { Check the constants in symtable }
1460 asmsearchsym(s,srsym,srsymtable);
1461 if srsym <> nil then
1462 Begin
1463 case srsym.typ of
1464 constsym :
1465 begin
1466 if tconstsym(srsym).consttyp=constord then
1467 Begin
1468 l:=tconstsym(srsym).value.valueord.svalue;
1469 SearchIConstant:=TRUE;
1470 exit;
1471 end;
1472 end;
1473 enumsym:
1474 Begin
1475 l:=tenumsym(srsym).value;
1476 SearchIConstant:=TRUE;
1477 exit;
1478 end;
1479 end;
1480 end;
1481 end;
1482
1483
AsmRegisterParanull1484 function AsmRegisterPara(sym: tabstractnormalvarsym): boolean;
1485 begin
1486 result:=
1487 (po_assembler in current_procinfo.procdef.procoptions) and
1488 (sym.typ=paravarsym) and
1489 (tparavarsym(sym).paraloc[calleeside].Location^.Loc=LOC_REGISTER);
1490 end;
1491
1492
GetRecordOffsetSizenull1493 Function GetRecordOffsetSize(s:string;out Offset: tcgint;out Size:tcgint; out mangledname: string; needvmtofs: boolean; out hastypecast: boolean):boolean;
1494 { search and returns the offset and size of records/objects of the base }
1495 { with field name setup in field. }
1496 { returns FALSE if not found. }
1497 { used when base is a variable or a typed constant name. }
1498 var
1499 st : TSymtable;
1500 harrdef : tarraydef;
1501 sym : tsym;
1502 srsymtable : TSymtable;
1503 i : longint;
1504 base : string;
1505 procdef: tprocdef;
1506 Begin
1507 GetRecordOffsetSize:=FALSE;
1508 Offset:=0;
1509 Size:=0;
1510 mangledname:='';
1511 hastypecast:=false;
1512 i:=pos('.',s);
1513 if i=0 then
1514 i:=255;
1515 base:=Copy(s,1,i-1);
1516 delete(s,1,i);
1517 if base='SELF' then
1518 st:=current_structdef.symtable
1519 else
1520 begin
1521 asmsearchsym(base,sym,srsymtable);
1522 { allow unitname.identifier }
1523 if assigned(sym) and (sym.typ=unitsym) then
1524 begin
1525 i:=pos('.',s);
1526 if i=0 then
1527 i:=255;
1528 base:=base+'.'+Copy(s,1,i-1);
1529 delete(s,1,i);
1530 asmsearchsym(base,sym,srsymtable);
1531 end;
1532 st:=nil;
1533 { we can start with a var,type,typedconst }
1534 if assigned(sym) then
1535 case sym.typ of
1536 staticvarsym,
1537 localvarsym,
1538 paravarsym :
1539 st:=Tabstractvarsym(sym).vardef.GetSymtable(gs_record);
1540 typesym :
1541 st:=Ttypesym(sym).typedef.GetSymtable(gs_record);
1542 end
1543 else
1544 s:='';
1545 end;
1546 { now walk all recordsymtables }
1547 while assigned(st) and (s<>'') do
1548 begin
1549 { load next field in base }
1550 i:=pos('.',s);
1551 if i=0 then
1552 i:=255;
1553 base:=Copy(s,1,i-1);
1554 delete(s,1,i);
1555 sym:=search_struct_member(tabstractrecorddef(st.defowner),base);
1556 if not assigned(sym) then
1557 begin
1558 GetRecordOffsetSize:=false;
1559 exit;
1560 end;
1561 st:=nil;
1562 case sym.typ of
1563 fieldvarsym :
1564 with Tfieldvarsym(sym) do
1565 begin
1566 if not tabstractrecordsymtable(sym.owner).is_packed then
1567 inc(Offset,fieldoffset)
1568 else if tfieldvarsym(sym).fieldoffset mod 8 = 0 then
1569 inc(Offset,fieldoffset div 8)
1570 else
1571 Message(asmr_e_packed_element);
1572 size:=getsize;
1573 case vardef.typ of
1574 arraydef :
1575 begin
1576 { for arrays try to get the element size, take care of
1577 multiple indexes }
1578 harrdef:=tarraydef(vardef);
1579 while assigned(harrdef.elementdef) and
1580 (harrdef.elementdef.typ=arraydef) do
1581 harrdef:=tarraydef(harrdef.elementdef);
1582 if not is_packed_array(harrdef) then
1583 size:=harrdef.elesize
1584 else
1585 begin
1586 if (harrdef.elepackedbitsize mod 8) <> 0 then
1587 Message(asmr_e_packed_element);
1588 size := (harrdef.elepackedbitsize + 7) div 8;
1589 end;
1590 end;
1591 recorddef :
1592 st:=trecorddef(vardef).symtable;
1593 objectdef :
1594 st:=tobjectdef(vardef).symtable;
1595 end;
1596 end;
1597 procsym:
1598 begin
1599 st:=nil;
1600 if Tprocsym(sym).ProcdefList.Count>1 then
1601 Message(asmr_w_calling_overload_func);
1602 procdef:=tprocdef(tprocsym(sym).ProcdefList[0]);
1603 if (not needvmtofs) then
1604 begin
1605 mangledname:=procdef.mangledname;
1606 end
1607 else
1608 begin
1609 { can only get the vmtoffset of virtual methods }
1610 if not(po_virtualmethod in procdef.procoptions) or
1611 is_objectpascal_helper(procdef.struct) then
1612 Message1(asmr_e_no_vmtoffset_possible,FullTypeName(procdef,nil))
1613 else
1614 begin
1615 { size = sizeof(target_system_pointer) }
1616 size:=sizeof(pint);
1617 offset:=tobjectdef(procdef.struct).vmtmethodoffset(procdef.extnumber)
1618 end;
1619 end;
1620 { if something comes after the procsym, it's invalid assembler syntax }
1621 GetRecordOffsetSize:=(s='');
1622 exit;
1623 end;
1624 end;
1625 end;
1626 { Support Field.Type as typecasting }
1627 if (st=nil) and (s<>'') then
1628 begin
1629 asmsearchsym(s,sym,srsymtable);
1630 if assigned(sym) and (sym.typ=typesym) then
1631 begin
1632 size:=ttypesym(sym).typedef.size;
1633 s:='';
1634 hastypecast:=true;
1635 end;
1636 end;
1637 GetRecordOffsetSize:=(s='');
1638 end;
1639
1640
SearchLabelnull1641 Function SearchLabel(const s: string; var hl: tasmlabel;emit:boolean): boolean;
1642 var
1643 sym : tsym;
1644 srsymtable : TSymtable;
1645 hs : string;
1646 Begin
1647 hl:=nil;
1648 SearchLabel:=false;
1649 { Check for pascal labels, which are case insensetive }
1650 hs:=upper(s);
1651 asmsearchsym(hs,sym,srsymtable);
1652 if sym=nil then
1653 exit;
1654 case sym.typ of
1655 labelsym :
1656 begin
1657 if symtablestack.top.symtablelevel<>srsymtable.symtablelevel then
1658 begin
1659 Tlabelsym(sym).nonlocal:=true;
1660 if emit then
1661 exclude(current_procinfo.procdef.procoptions,po_inline);
1662 end;
1663 if not(assigned(tlabelsym(sym).asmblocklabel)) then
1664 if Tlabelsym(sym).nonlocal then
1665 current_asmdata.getglobaljumplabel(tlabelsym(sym).asmblocklabel)
1666 else
1667 current_asmdata.getjumplabel(tlabelsym(sym).asmblocklabel);
1668 hl:=tlabelsym(sym).asmblocklabel;
1669 if emit then
1670 begin
1671 if tlabelsym(sym).defined then
1672 Message(sym_e_label_already_defined);
1673 tlabelsym(sym).defined:=true
1674 end
1675 else
1676 tlabelsym(sym).used:=true;
1677 SearchLabel:=true;
1678 end;
1679 end;
1680 end;
1681
1682
1683 {*************************************************************************}
1684 { Instruction Generation Utilities }
1685 {*************************************************************************}
1686
1687
1688 Procedure ConcatString(p : TAsmList;s:string);
1689 {*********************************************************************}
1690 { PROCEDURE ConcatString(s:string); }
1691 { Description: This routine adds the character chain pointed to in }
1692 { s to the instruction linked list. }
1693 {*********************************************************************}
1694 Begin
1695 p.concat(Tai_string.Create(s));
1696 end;
1697
1698
1699 Procedure ConcatConstant(p: TAsmList; value: tcgint; constsize:byte);
1700 {*********************************************************************}
1701 { PROCEDURE ConcatConstant(value: aint; maxvalue: aint); }
1702 { Description: This routine adds the value constant to the current }
1703 { instruction linked list. }
1704 { maxvalue -> indicates the size of the data to initialize: }
1705 { $ff -> create a byte node. }
1706 { $ffff -> create a word node. }
1707 { $ffffffff -> create a dword node. }
1708 {*********************************************************************}
1709 var
1710 rangelo,rangehi : int64;
1711 Begin
1712 case constsize of
1713 1 :
1714 begin
1715 p.concat(Tai_const.Create_8bit(byte(value)));
1716 rangelo:=low(shortint);
1717 rangehi:=high(byte);
1718 end;
1719 2 :
1720 begin
1721 p.concat(Tai_const.Create_16bit(word(value)));
1722 rangelo:=low(smallint);
1723 rangehi:=high(word);
1724 end;
1725 4 :
1726 begin
1727 p.concat(Tai_const.Create_32bit(longint(value)));
1728 rangelo:=low(longint);
1729 rangehi:=high(cardinal);
1730 end;
1731 8 :
1732 begin
1733 p.concat(Tai_const.Create_64bit(int64(value)));
1734 rangelo:=0;
1735 rangehi:=0;
1736 end;
1737 else
1738 internalerror(200405011);
1739 end;
1740 { check for out of bounds }
1741 if (rangelo<>0) and
1742 ((value>rangehi) or (value<rangelo)) then
1743 Message(asmr_e_constant_out_of_bounds);
1744 end;
1745
1746
1747 Procedure ConcatConstSymbol(p : TAsmList;const sym:string;symtyp:tasmsymtype;l:tcgint;constsize:byte;isofs:boolean);
1748 begin
1749 {$ifdef i8086}
1750 { 'DW xx' as well as 'DW OFFSET xx' are just near pointers }
1751 if constsize=2 then
1752 p.concat(Tai_const.Createname_near(sym,l))
1753 else if constsize=4 then
1754 begin
1755 if isofs then
1756 begin
1757 { 'DD OFFSET xx' is a 32-bit offset; since we don't produce 32-bit
1758 relocations yet, just do a 16-bit one and set the high word to 0 }
1759 p.concat(Tai_const.Createname_near(sym,l));
1760 p.concat(Tai_const.Create_16bit(0));
1761 end
1762 else
1763 { 'DD xx' is a far pointer }
1764 p.concat(Tai_const.Createname_far(sym,l));
1765 end
1766 else
1767 internalerror(2018020701);
1768 {$else i8086}
1769 p.concat(Tai_const.Createname(sym,l));
1770 {$endif i8086}
1771 end;
1772
1773
1774 Procedure ConcatRealConstant(p : TAsmList;value: bestreal; real_typ : tfloattype);
1775 {***********************************************************************}
1776 { PROCEDURE ConcatRealConstant(value: bestreal; real_typ : tfloattype); }
1777 { Description: This routine adds the value constant to the current }
1778 { instruction linked list. }
1779 { real_typ -> indicates the type of the real data to initialize: }
1780 { s32real -> create a single node. }
1781 { s64real -> create a double node. }
1782 { s80real -> create an extended node. }
1783 { s64bit -> create a comp node. }
1784 { f32bit -> create a fixed node. (not used normally) }
1785 {***********************************************************************}
1786 Begin
1787 case real_typ of
1788 s32real : p.concat(tai_realconst.create_s32real(value));
1789 s64real :
1790 {$ifdef ARM}
1791 if is_double_hilo_swapped then
1792 p.concat(tai_realconst.create_s64real_hiloswapped(value))
1793 else
1794 {$endif ARM}
1795 p.concat(tai_realconst.create_s64real(value));
1796 s80real : p.concat(tai_realconst.create_s80real(value,s80floattype.size));
1797 sc80real : p.concat(tai_realconst.create_s80real(value,sc80floattype.size));
1798 s64comp : p.concat(tai_realconst.create_s64compreal(trunc(value)));
1799 else
1800 internalerror(2014050608);
1801 end;
1802 end;
1803
1804 Procedure ConcatLabel(p: TAsmList;var l : tasmlabel);
1805 {*********************************************************************}
1806 { PROCEDURE ConcatLabel }
1807 { Description: This routine either emits a label or a labeled }
1808 { instruction to the linked list of instructions. }
1809 {*********************************************************************}
1810 begin
1811 p.concat(Tai_label.Create(l));
1812 end;
1813
1814 procedure ConcatAlign(p:TAsmList;l:tcgint);
1815 {*********************************************************************}
1816 { PROCEDURE ConcatPublic }
1817 { Description: This routine emits an global definition to the }
1818 { linked list of instructions.(used by AT&T styled asm) }
1819 {*********************************************************************}
1820 begin
1821 p.concat(Tai_align.Create(l));
1822 end;
1823
1824 procedure ConcatPublic(p:TAsmList;const s : string);
1825 {*********************************************************************}
1826 { PROCEDURE ConcatPublic }
1827 { Description: This routine emits an global definition to the }
1828 { linked list of instructions.(used by AT&T styled asm) }
1829 {*********************************************************************}
1830 begin
1831 p.concat(Tai_symbol.Createname_global(s,AT_LABEL,0,voidcodepointertype));
1832 end;
1833
1834 procedure ConcatLocal(p:TAsmList;const s : string);
1835 {*********************************************************************}
1836 { PROCEDURE ConcatLocal }
1837 { Description: This routine emits an local definition to the }
1838 { linked list of instructions. }
1839 {*********************************************************************}
1840 begin
1841 p.concat(Tai_symbol.Createname(s,AT_LABEL,0,voidcodepointertype));
1842 end;
1843
1844
1845 end.
1846