rautils.pas 53 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808
  1. {
  2. $Id$
  3. Copyright (c) 1998-2002 by Carl Eric Codere and Peter Vreman
  4. This unit implements some support routines for assembler parsing
  5. independent of the processor
  6. This program is free software; you can redistribute it and/or modify
  7. it under the terms of the GNU General Public License as published by
  8. the Free Software Foundation; either version 2 of the License, or
  9. (at your option) any later version.
  10. This program is distributed in the hope that it will be useful,
  11. but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  13. GNU General Public License for more details.
  14. You should have received a copy of the GNU General Public License
  15. along with this program; if not, write to the Free Software
  16. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  17. **********************************************************************}
  18. Unit RAUtils;
  19. {$i fpcdefs.inc}
  20. Interface
  21. Uses
  22. cutils,cclasses,
  23. globtype,aasmbase,aasmtai,cpubase,cpuinfo,cgbase,
  24. symconst,symbase,symtype,symdef,symsym;
  25. Const
  26. RPNMax = 10; { I think you only need 4, but just to be safe }
  27. OpMax = 25;
  28. {---------------------------------------------------------------------
  29. Local Label Management
  30. ---------------------------------------------------------------------}
  31. Type
  32. { Each local label has this structure associated with it }
  33. TLocalLabel = class(TNamedIndexItem)
  34. Emitted : boolean;
  35. constructor Create(const n:string);
  36. function Gettasmlabel:tasmlabel;
  37. private
  38. lab : tasmlabel;
  39. end;
  40. TLocalLabelList = class(TDictionary)
  41. procedure CheckEmitted;
  42. end;
  43. var
  44. LocalLabelList : TLocalLabelList;
  45. function CreateLocalLabel(const s: string; var hl: tasmlabel; emit:boolean):boolean;
  46. Function SearchLabel(const s: string; var hl: tasmlabel;emit:boolean): boolean;
  47. {---------------------------------------------------------------------
  48. Instruction management
  49. ---------------------------------------------------------------------}
  50. type
  51. TOprType=(OPR_NONE,OPR_CONSTANT,OPR_SYMBOL,OPR_LOCAL,
  52. OPR_REFERENCE,OPR_REGISTER,OPR_REGLIST);
  53. TOprRec = record
  54. case typ:TOprType of
  55. OPR_NONE : ();
  56. OPR_CONSTANT : (val:longint);
  57. OPR_SYMBOL : (symbol:tasmsymbol;symofs:longint);
  58. OPR_REFERENCE : (ref:treference);
  59. OPR_LOCAL : (localsym:tvarsym;localsymofs:longint;localindexreg:tregister;localgetoffset:boolean);
  60. OPR_REGISTER : (reg:tregister);
  61. {$ifdef m68k}
  62. OPR_REGLIST : (reglist:Tsupregset);
  63. {$else not m68k}
  64. OPR_REGLIST : ();
  65. {$endif m68k}
  66. end;
  67. TOperand = class
  68. hastype, { if the operand has typecasted variable }
  69. hasvar : boolean; { if the operand is loaded with a variable }
  70. size : TCGSize;
  71. opr : TOprRec;
  72. constructor create;
  73. destructor destroy;override;
  74. Procedure BuildOperand;virtual;
  75. Procedure SetSize(_size:longint;force:boolean);virtual;
  76. Procedure SetCorrectSize(opcode:tasmop);virtual;
  77. Function SetupResult:boolean;virtual;
  78. Function SetupSelf:boolean;
  79. Function SetupOldEBP:boolean;
  80. Function SetupVar(const s:string;GetOffset : boolean): Boolean;
  81. Function SetupDirectVar(const hs:string): Boolean;
  82. Procedure InitRef;
  83. end;
  84. TInstruction = class
  85. opcode : tasmop;
  86. condition : tasmcond;
  87. ops : byte;
  88. labeled : boolean;
  89. operands : array[1..max_operands] of toperand;
  90. constructor create;
  91. destructor destroy;override;
  92. Procedure InitOperands;virtual;
  93. Procedure BuildOpcode;virtual;
  94. procedure ConcatInstruction(p:TAAsmoutput);virtual;
  95. Procedure Swapoperands;
  96. end;
  97. {---------------------------------------------------------------------}
  98. { Expression parser types }
  99. {---------------------------------------------------------------------}
  100. TExprOperator = record
  101. ch: char; { operator }
  102. is_prefix: boolean; { was it a prefix, possible prefixes are +,- and not }
  103. end;
  104. String15 = String[15];
  105. {**********************************************************************}
  106. { The following operators are supported: }
  107. { '+' : addition }
  108. { '-' : subtraction }
  109. { '*' : multiplication }
  110. { '/' : modulo division }
  111. { '^' : exclusive or }
  112. { '<' : shift left }
  113. { '>' : shift right }
  114. { '&' : bitwise and }
  115. { '|' : bitwise or }
  116. { '~' : bitwise complement }
  117. { '%' : modulo division }
  118. { nnn: longint numbers }
  119. { ( and ) parenthesis }
  120. {**********************************************************************}
  121. TExprParse = class
  122. public
  123. Constructor create;
  124. Destructor Destroy;override;
  125. Function Evaluate(Expr: String): longint;
  126. Function Priority(_Operator: Char): longint;
  127. private
  128. RPNStack : Array[1..RPNMax] of longint; { Stack For RPN calculator }
  129. RPNTop : longint;
  130. OpStack : Array[1..OpMax] of TExprOperator; { Operator stack For conversion }
  131. OpTop : longint;
  132. Procedure RPNPush(Num: Longint);
  133. Function RPNPop: Longint;
  134. Procedure RPNCalc(token: String15; prefix: boolean);
  135. Procedure OpPush(_Operator: char; prefix: boolean);
  136. { In reality returns TExprOperaotr }
  137. Procedure OpPop(var _Operator:TExprOperator);
  138. end;
  139. { Evaluate an expression string to a longint }
  140. Function CalculateExpression(const expression: string): longint;
  141. {---------------------------------------------------------------------}
  142. { String routines }
  143. {---------------------------------------------------------------------}
  144. Function ValDecimal(const S:String):longint;
  145. Function ValOctal(const S:String):longint;
  146. Function ValBinary(const S:String):longint;
  147. Function ValHexaDecimal(const S:String):longint;
  148. Function PadZero(Var s: String; n: byte): Boolean;
  149. Function EscapeToPascal(const s:string): string;
  150. {---------------------------------------------------------------------
  151. Symbol helper routines
  152. ---------------------------------------------------------------------}
  153. procedure AsmSearchSym(const s:string;var srsym:tsym;var srsymtable:tsymtable);
  154. Function GetRecordOffsetSize(s:string;Var Offset: longint;var Size:longint):boolean;
  155. Function SearchType(const hs:string;var size:longint): Boolean;
  156. Function SearchRecordType(const s:string): boolean;
  157. Function SearchIConstant(const s:string; var l:longint): boolean;
  158. {---------------------------------------------------------------------
  159. Instruction generation routines
  160. ---------------------------------------------------------------------}
  161. Procedure ConcatPasString(p : TAAsmoutput;s:string);
  162. Procedure ConcatDirect(p : TAAsmoutput;s:string);
  163. Procedure ConcatLabel(p: TAAsmoutput;var l : tasmlabel);
  164. Procedure ConcatConstant(p : TAAsmoutput;value: longint; maxvalue: longint);
  165. Procedure ConcatConstSymbol(p : TAAsmoutput;const sym:string;l:longint);
  166. Procedure ConcatRealConstant(p : TAAsmoutput;value: bestreal; real_typ : tfloattype);
  167. Procedure ConcatString(p : TAAsmoutput;s:string);
  168. procedure ConcatAlign(p:TAAsmoutput;l:longint);
  169. Procedure ConcatPublic(p:TAAsmoutput;const s : string);
  170. Procedure ConcatLocal(p:TAAsmoutput;const s : string);
  171. Procedure ConcatGlobalBss(const s : string;size : longint);
  172. Procedure ConcatLocalBss(const s : string;size : longint);
  173. Implementation
  174. uses
  175. {$ifdef delphi}
  176. sysutils,
  177. {$else}
  178. strings,
  179. {$endif}
  180. defutil,systems,verbose,globals,
  181. symtable,paramgr,
  182. aasmcpu,
  183. procinfo;
  184. {*************************************************************************
  185. TExprParse
  186. *************************************************************************}
  187. Constructor TExprParse.create;
  188. Begin
  189. end;
  190. Procedure TExprParse.RPNPush(Num : longint);
  191. { Add an operand to the top of the RPN stack }
  192. begin
  193. if RPNTop < RPNMax then
  194. begin
  195. Inc(RPNTop);
  196. RPNStack[RPNTop]:=Num;
  197. end
  198. else
  199. Message(asmr_e_expr_illegal);
  200. end;
  201. Function TExprParse.RPNPop : longint;
  202. { Get the operand at the top of the RPN stack }
  203. begin
  204. if RPNTop > 0 then
  205. begin
  206. RPNPop:=RPNStack[RPNTop];
  207. Dec(RPNTop);
  208. end
  209. else
  210. Message(asmr_e_expr_illegal);
  211. end;
  212. Procedure TExprParse.RPNCalc(Token : String15; prefix:boolean); { RPN Calculator }
  213. Var
  214. Temp : longint;
  215. n1,n2 : longint;
  216. LocalError : Integer;
  217. begin
  218. { Handle operators }
  219. if (Length(Token) = 1) and (Token[1] in ['+', '-', '*', '/','&','|','%','^','~','<','>']) then
  220. Case Token[1] of
  221. '+' :
  222. Begin
  223. if not prefix then
  224. RPNPush(RPNPop + RPNPop);
  225. end;
  226. '-' :
  227. Begin
  228. if prefix then
  229. RPNPush(-(RPNPop))
  230. else
  231. begin
  232. n1:=RPNPop;
  233. n2:=RPNPop;
  234. RPNPush(n2 - n1);
  235. end;
  236. end;
  237. '*' : RPNPush(RPNPop * RPNPop);
  238. '&' :
  239. begin
  240. n1:=RPNPop;
  241. n2:=RPNPop;
  242. RPNPush(n2 and n1);
  243. end;
  244. '|' :
  245. begin
  246. n1:=RPNPop;
  247. n2:=RPNPop;
  248. RPNPush(n2 or n1);
  249. end;
  250. '~' : RPNPush(NOT RPNPop);
  251. '<' :
  252. begin
  253. n1:=RPNPop;
  254. n2:=RPNPop;
  255. RPNPush(n2 SHL n1);
  256. end;
  257. '>' :
  258. begin
  259. n1:=RPNPop;
  260. n2:=RPNPop;
  261. RPNPush(n2 SHR n1);
  262. end;
  263. '%' :
  264. begin
  265. Temp:=RPNPop;
  266. if Temp <> 0 then
  267. RPNPush(RPNPop mod Temp)
  268. else
  269. begin
  270. Message(asmr_e_expr_zero_divide);
  271. { push 1 for error recovery }
  272. RPNPush(1);
  273. end;
  274. end;
  275. '^' : RPNPush(RPNPop XOR RPNPop);
  276. '/' :
  277. begin
  278. Temp:=RPNPop;
  279. if Temp <> 0 then
  280. RPNPush(RPNPop div Temp)
  281. else
  282. begin
  283. Message(asmr_e_expr_zero_divide);
  284. { push 1 for error recovery }
  285. RPNPush(1);
  286. end;
  287. end;
  288. end
  289. else
  290. begin
  291. { Convert String to number and add to stack }
  292. Val(Token, Temp, LocalError);
  293. if LocalError = 0 then
  294. RPNPush(Temp)
  295. else
  296. begin
  297. Message(asmr_e_expr_illegal);
  298. { push 1 for error recovery }
  299. RPNPush(1);
  300. end;
  301. end;
  302. end;
  303. Procedure TExprParse.OpPush(_Operator : char;prefix: boolean);
  304. { Add an operator onto top of the stack }
  305. begin
  306. if OpTop < OpMax then
  307. begin
  308. Inc(OpTop);
  309. OpStack[OpTop].ch:=_Operator;
  310. OpStack[OpTop].is_prefix:=prefix;
  311. end
  312. else
  313. Message(asmr_e_expr_illegal);
  314. end;
  315. Procedure TExprParse.OpPop(var _Operator:TExprOperator);
  316. { Get operator at the top of the stack }
  317. begin
  318. if OpTop > 0 then
  319. begin
  320. _Operator:=OpStack[OpTop];
  321. Dec(OpTop);
  322. end
  323. else
  324. Message(asmr_e_expr_illegal);
  325. end;
  326. Function TExprParse.Priority(_Operator : Char) : longint;
  327. { Return priority of operator }
  328. { The greater the priority, the higher the precedence }
  329. begin
  330. Case _Operator OF
  331. '(' :
  332. Priority:=0;
  333. '+', '-' :
  334. Priority:=1;
  335. '*', '/','%','<','>' :
  336. Priority:=2;
  337. '|','&','^','~' :
  338. Priority:=0;
  339. else
  340. Message(asmr_e_expr_illegal);
  341. end;
  342. end;
  343. Function TExprParse.Evaluate(Expr : String):longint;
  344. Var
  345. I : LongInt;
  346. Token : String15;
  347. opr : TExprOperator;
  348. begin
  349. Evaluate:=0;
  350. { Reset stacks }
  351. OpTop :=0;
  352. RPNTop:=0;
  353. Token :='';
  354. { nothing to do ? }
  355. if Expr='' then
  356. exit;
  357. For I:=1 to Length(Expr) DO
  358. begin
  359. if Expr[I] in ['0'..'9'] then
  360. begin { Build multi-digit numbers }
  361. Token:=Token + Expr[I];
  362. if I = Length(Expr) then { Send last one to calculator }
  363. RPNCalc(Token,false);
  364. end
  365. else
  366. if Expr[I] in ['+', '-', '*', '/', '(', ')','^','&','|','%','~','<','>'] then
  367. begin
  368. if Token <> '' then
  369. begin { Send last built number to calc. }
  370. RPNCalc(Token,false);
  371. Token:='';
  372. end;
  373. Case Expr[I] OF
  374. '(' : OpPush('(',false);
  375. ')' : begin
  376. While OpStack[OpTop].ch <> '(' DO
  377. Begin
  378. OpPop(opr);
  379. RPNCalc(opr.ch,opr.is_prefix);
  380. end;
  381. OpPop(opr); { Pop off and ignore the '(' }
  382. end;
  383. '+','-','~' : Begin
  384. { workaround for -2147483648 }
  385. if (expr[I]='-') and (expr[i+1] in ['0'..'9']) then
  386. begin
  387. token:='-';
  388. expr[i]:='+';
  389. end;
  390. { if start of expression then surely a prefix }
  391. { or if previous char was also an operator }
  392. if (I = 1) or (not (Expr[I-1] in ['0'..'9','(',')'])) then
  393. OpPush(Expr[I],true)
  394. else
  395. Begin
  396. { Evaluate all higher priority operators }
  397. While (OpTop > 0) AND (Priority(Expr[I]) <= Priority(OpStack[OpTop].ch)) DO
  398. Begin
  399. OpPop(opr);
  400. RPNCalc(opr.ch,opr.is_prefix);
  401. end;
  402. OpPush(Expr[I],false);
  403. End;
  404. end;
  405. '*', '/',
  406. '^','|','&',
  407. '%','<','>' : begin
  408. While (OpTop > 0) and (Priority(Expr[I]) <= Priority(OpStack[OpTop].ch)) DO
  409. Begin
  410. OpPop(opr);
  411. RPNCalc(opr.ch,opr.is_prefix);
  412. end;
  413. OpPush(Expr[I],false);
  414. end;
  415. end; { Case }
  416. end
  417. else
  418. Message(asmr_e_expr_illegal); { Handle bad input error }
  419. end;
  420. { Pop off the remaining operators }
  421. While OpTop > 0 do
  422. Begin
  423. OpPop(opr);
  424. RPNCalc(opr.ch,opr.is_prefix);
  425. end;
  426. { The result is stored on the top of the stack }
  427. Evaluate:=RPNPop;
  428. end;
  429. Destructor TExprParse.Destroy;
  430. Begin
  431. end;
  432. Function CalculateExpression(const expression: string): longint;
  433. var
  434. expr: TExprParse;
  435. Begin
  436. expr:=TExprParse.create;
  437. CalculateExpression:=expr.Evaluate(expression);
  438. expr.Free;
  439. end;
  440. {*************************************************************************}
  441. { String conversions/utils }
  442. {*************************************************************************}
  443. Function EscapeToPascal(const s:string): string;
  444. { converts a C styled string - which contains escape }
  445. { characters to a pascal style string. }
  446. var
  447. i,len : longint;
  448. hs : string;
  449. temp : string;
  450. c : char;
  451. Begin
  452. hs:='';
  453. len:=0;
  454. i:=0;
  455. while (i<length(s)) and (len<255) do
  456. begin
  457. Inc(i);
  458. if (s[i]='\') and (i<length(s)) then
  459. Begin
  460. inc(i);
  461. case s[i] of
  462. '\' :
  463. c:='\';
  464. 'b':
  465. c:=#8;
  466. 'f':
  467. c:=#12;
  468. 'n':
  469. c:=#10;
  470. 'r':
  471. c:=#13;
  472. 't':
  473. c:=#9;
  474. '"':
  475. c:='"';
  476. '0'..'7':
  477. Begin
  478. temp:=s[i];
  479. temp:=temp+s[i+1];
  480. temp:=temp+s[i+2];
  481. inc(i,2);
  482. c:=chr(ValOctal(temp));
  483. end;
  484. 'x':
  485. Begin
  486. temp:=s[i+1];
  487. temp:=temp+s[i+2];
  488. inc(i,2);
  489. c:=chr(ValHexaDecimal(temp));
  490. end;
  491. else
  492. Begin
  493. Message1(asmr_e_escape_seq_ignored,s[i]);
  494. c:=s[i];
  495. end;
  496. end;
  497. end
  498. else
  499. c:=s[i];
  500. inc(len);
  501. hs[len]:=c;
  502. end;
  503. hs[0]:=chr(len);
  504. EscapeToPascal:=hs;
  505. end;
  506. Function ValDecimal(const S:String):longint;
  507. { Converts a decimal string to longint }
  508. var
  509. vs,c : longint;
  510. Begin
  511. vs:=0;
  512. for c:=1 to length(s) do
  513. begin
  514. vs:=vs*10;
  515. if s[c] in ['0'..'9'] then
  516. inc(vs,ord(s[c])-ord('0'))
  517. else
  518. begin
  519. Message1(asmr_e_error_converting_decimal,s);
  520. ValDecimal:=0;
  521. exit;
  522. end;
  523. end;
  524. ValDecimal:=vs;
  525. end;
  526. Function ValOctal(const S:String):longint;
  527. { Converts an octal string to longint }
  528. var
  529. vs,c : longint;
  530. Begin
  531. vs:=0;
  532. for c:=1 to length(s) do
  533. begin
  534. vs:=vs shl 3;
  535. if s[c] in ['0'..'7'] then
  536. inc(vs,ord(s[c])-ord('0'))
  537. else
  538. begin
  539. Message1(asmr_e_error_converting_octal,s);
  540. ValOctal:=0;
  541. exit;
  542. end;
  543. end;
  544. ValOctal:=vs;
  545. end;
  546. Function ValBinary(const S:String):longint;
  547. { Converts a binary string to longint }
  548. var
  549. vs,c : longint;
  550. Begin
  551. vs:=0;
  552. for c:=1 to length(s) do
  553. begin
  554. vs:=vs shl 1;
  555. if s[c] in ['0'..'1'] then
  556. inc(vs,ord(s[c])-ord('0'))
  557. else
  558. begin
  559. Message1(asmr_e_error_converting_binary,s);
  560. ValBinary:=0;
  561. exit;
  562. end;
  563. end;
  564. ValBinary:=vs;
  565. end;
  566. Function ValHexadecimal(const S:String):longint;
  567. { Converts a binary string to longint }
  568. var
  569. vs,c : longint;
  570. Begin
  571. vs:=0;
  572. for c:=1 to length(s) do
  573. begin
  574. vs:=vs shl 4;
  575. case s[c] of
  576. '0'..'9' :
  577. inc(vs,ord(s[c])-ord('0'));
  578. 'A'..'F' :
  579. inc(vs,ord(s[c])-ord('A')+10);
  580. 'a'..'f' :
  581. inc(vs,ord(s[c])-ord('a')+10);
  582. else
  583. begin
  584. Message1(asmr_e_error_converting_hexadecimal,s);
  585. ValHexadecimal:=0;
  586. exit;
  587. end;
  588. end;
  589. end;
  590. ValHexadecimal:=vs;
  591. end;
  592. Function PadZero(Var s: String; n: byte): Boolean;
  593. Begin
  594. PadZero:=TRUE;
  595. { Do some error checking first }
  596. if Length(s) = n then
  597. exit
  598. else
  599. if Length(s) > n then
  600. Begin
  601. PadZero:=FALSE;
  602. delete(s,n+1,length(s));
  603. exit;
  604. end
  605. else
  606. PadZero:=TRUE;
  607. { Fill it up with the specified character }
  608. fillchar(s[length(s)+1],n-1,#0);
  609. s[0]:=chr(n);
  610. end;
  611. {****************************************************************************
  612. TOperand
  613. ****************************************************************************}
  614. constructor TOperand.Create;
  615. begin
  616. size:=OS_NO;
  617. hastype:=false;
  618. hasvar:=false;
  619. FillChar(Opr,sizeof(Opr),0);
  620. end;
  621. destructor TOperand.destroy;
  622. begin
  623. end;
  624. Procedure TOperand.SetSize(_size:longint;force:boolean);
  625. begin
  626. if force or
  627. ((size = OS_NO) and (_size<=extended_size)) then
  628. Begin
  629. case _size of
  630. 1 : size:=OS_8;
  631. 2 : size:=OS_16{ could be S_IS};
  632. 4 : size:=OS_32{ could be S_IL or S_FS};
  633. 8 : size:=OS_64{ could be S_D or S_FL};
  634. else
  635. begin
  636. { extended_size can also be 8, resulting in a
  637. duplicate label }
  638. if _size=extended_size then
  639. size:=OS_F80;
  640. end;
  641. end;
  642. end;
  643. end;
  644. Procedure TOperand.SetCorrectSize(opcode:tasmop);
  645. begin
  646. end;
  647. Function TOperand.SetupResult:boolean;
  648. Begin
  649. SetupResult:=false;
  650. { replace by correct offset. }
  651. if (not is_void(current_procinfo.procdef.rettype.def)) then
  652. begin
  653. if (m_tp7 in aktmodeswitches) and
  654. (not paramanager.ret_in_param(current_procinfo.procdef.rettype.def,current_procinfo.procdef.proccalloption)) then
  655. begin
  656. Message(asmr_e_cannot_use_RESULT_here);
  657. exit;
  658. end;
  659. SetupResult:=setupvar('result',false)
  660. end
  661. else
  662. Message(asmr_e_void_function);
  663. end;
  664. Function TOperand.SetupSelf:boolean;
  665. Begin
  666. SetupSelf:=false;
  667. if assigned(current_procinfo.procdef._class) then
  668. SetupSelf:=setupvar('self',false)
  669. else
  670. Message(asmr_e_cannot_use_SELF_outside_a_method);
  671. end;
  672. Function TOperand.SetupOldEBP:boolean;
  673. Begin
  674. SetupOldEBP:=false;
  675. if current_procinfo.procdef.parast.symtablelevel>normal_function_level then
  676. SetupOldEBP:=setupvar('parentframe',false)
  677. else
  678. Message(asmr_e_cannot_use_OLDEBP_outside_nested_procedure);
  679. end;
  680. Function TOperand.SetupVar(const s:string;GetOffset : boolean): Boolean;
  681. function symtable_has_varsyms(st:tsymtable):boolean;
  682. var
  683. sym : tsym;
  684. begin
  685. result:=false;
  686. sym:=tsym(st.symindex.first);
  687. while assigned(sym) do
  688. begin
  689. if sym.typ=varsym then
  690. begin
  691. result:=true;
  692. exit;
  693. end;
  694. sym:=tsym(sym.indexnext);
  695. end;
  696. end;
  697. { search and sets up the correct fields in the Instr record }
  698. { for the NON-constant identifier passed to the routine. }
  699. { if not found returns FALSE. }
  700. var
  701. sym : tsym;
  702. srsymtable : tsymtable;
  703. harrdef : tarraydef;
  704. indexreg : tregister;
  705. l : longint;
  706. plist : psymlistitem;
  707. Begin
  708. SetupVar:=false;
  709. asmsearchsym(s,sym,srsymtable);
  710. if sym = nil then
  711. exit;
  712. if sym.typ=absolutesym then
  713. begin
  714. if (tabsolutesym(sym).abstyp=tovar) then
  715. begin
  716. { Only support simple loads }
  717. plist:=tabsolutesym(sym).ref.firstsym;
  718. if assigned(plist) and
  719. (plist^.sltype=sl_load) then
  720. sym:=plist^.sym
  721. else
  722. Message(asmr_e_unsupported_symbol_type);
  723. end
  724. else
  725. Message(asmr_e_unsupported_symbol_type);
  726. end;
  727. case sym.typ of
  728. varsym :
  729. begin
  730. { we always assume in asm statements that }
  731. { that the variable is valid. }
  732. tvarsym(sym).varstate:=vs_used;
  733. inc(tvarsym(sym).refs);
  734. case tvarsym(sym).owner.symtabletype of
  735. objectsymtable :
  736. begin
  737. { We return the address of the field, just like Delphi/TP }
  738. opr.typ:=OPR_CONSTANT;
  739. opr.val:=tvarsym(sym).fieldoffset;
  740. hasvar:=true;
  741. SetupVar:=true;
  742. Exit;
  743. end;
  744. globalsymtable,
  745. staticsymtable :
  746. opr.ref.symbol:=objectlibrary.newasmsymboldata(tvarsym(sym).mangledname);
  747. parasymtable,
  748. localsymtable :
  749. begin
  750. indexreg:=opr.ref.base;
  751. if opr.ref.index<>NR_NO then
  752. begin
  753. if indexreg=NR_NO then
  754. indexreg:=opr.ref.index
  755. else
  756. Message(asmr_e_multiple_index);
  757. end;
  758. if (vo_is_external in tvarsym(sym).varoptions) then
  759. opr.ref.symbol:=objectlibrary.newasmsymboldata(tvarsym(sym).mangledname)
  760. else
  761. begin
  762. opr.typ:=OPR_LOCAL;
  763. if assigned(current_procinfo.parent) and
  764. (current_procinfo.procdef.proccalloption<>pocall_inline) and
  765. (tvarsym(sym).owner<>current_procinfo.procdef.localst) and
  766. (tvarsym(sym).owner<>current_procinfo.procdef.parast) and
  767. (current_procinfo.procdef.localst.symtablelevel>normal_function_level) and
  768. symtable_has_varsyms(current_procinfo.procdef.localst) then
  769. message1(asmr_e_local_para_unreachable,s);
  770. opr.localsym:=tvarsym(sym);
  771. opr.localsymofs:=0;
  772. opr.localindexreg:=indexreg;
  773. opr.localgetoffset:=GetOffset;
  774. end;
  775. if paramanager.push_addr_param(tvarsym(sym).varspez,tvarsym(sym).vartype.def,current_procinfo.procdef.proccalloption) then
  776. SetSize(pointer_size,false);
  777. end;
  778. end;
  779. case tvarsym(sym).vartype.def.deftype of
  780. orddef,
  781. enumdef,
  782. pointerdef,
  783. floatdef :
  784. SetSize(tvarsym(sym).getsize,false);
  785. arraydef :
  786. begin
  787. { for arrays try to get the element size, take care of
  788. multiple indexes }
  789. harrdef:=tarraydef(tvarsym(sym).vartype.def);
  790. while assigned(harrdef.elementtype.def) and
  791. (harrdef.elementtype.def.deftype=arraydef) do
  792. harrdef:=tarraydef(harrdef.elementtype.def);
  793. SetSize(harrdef.elesize,false);
  794. end;
  795. end;
  796. hasvar:=true;
  797. SetupVar:=true;
  798. Exit;
  799. end;
  800. typedconstsym :
  801. begin
  802. opr.ref.symbol:=objectlibrary.newasmsymboldata(ttypedconstsym(sym).mangledname);
  803. case ttypedconstsym(sym).typedconsttype.def.deftype of
  804. orddef,
  805. enumdef,
  806. pointerdef,
  807. floatdef :
  808. SetSize(ttypedconstsym(sym).getsize,false);
  809. arraydef :
  810. begin
  811. { for arrays try to get the element size, take care of
  812. multiple indexes }
  813. harrdef:=tarraydef(ttypedconstsym(sym).typedconsttype.def);
  814. while assigned(harrdef.elementtype.def) and
  815. (harrdef.elementtype.def.deftype=arraydef) do
  816. harrdef:=tarraydef(harrdef.elementtype.def);
  817. SetSize(harrdef.elesize,false);
  818. end;
  819. end;
  820. hasvar:=true;
  821. SetupVar:=true;
  822. Exit;
  823. end;
  824. constsym :
  825. begin
  826. if tconstsym(sym).consttyp in [constint,constchar,constbool] then
  827. begin
  828. opr.typ:=OPR_CONSTANT;
  829. opr.val:=tconstsym(sym).value.valueord;
  830. SetupVar:=true;
  831. Exit;
  832. end;
  833. end;
  834. typesym :
  835. begin
  836. if ttypesym(sym).restype.def.deftype in [recorddef,objectdef] then
  837. begin
  838. opr.typ:=OPR_CONSTANT;
  839. opr.val:=0;
  840. SetupVar:=TRUE;
  841. Exit;
  842. end;
  843. end;
  844. procsym :
  845. begin
  846. if Tprocsym(sym).procdef_count>1 then
  847. Message(asmr_w_calling_overload_func);
  848. l:=opr.ref.offset;
  849. opr.typ:=OPR_SYMBOL;
  850. opr.symbol:=objectlibrary.newasmsymbol(tprocsym(sym).first_procdef.mangledname);
  851. opr.symofs:=l;
  852. hasvar:=true;
  853. SetupVar:=TRUE;
  854. Exit;
  855. end;
  856. else
  857. begin
  858. Message(asmr_e_unsupported_symbol_type);
  859. exit;
  860. end;
  861. end;
  862. end;
  863. { looks for internal names of variables and routines }
  864. Function TOperand.SetupDirectVar(const hs:string): Boolean;
  865. var
  866. p : tasmsymbol;
  867. begin
  868. SetupDirectVar:=false;
  869. p:=objectlibrary.getasmsymbol(hs);
  870. if assigned(p) then
  871. begin
  872. opr.ref.symbol:=p;
  873. hasvar:=true;
  874. SetupDirectVar:=true;
  875. end;
  876. end;
  877. procedure TOperand.InitRef;
  878. {*********************************************************************}
  879. { Description: This routine first check if the opcode is of }
  880. { type OPR_NONE, or OPR_REFERENCE , if not it gives out an error. }
  881. { If the operandtype = OPR_NONE or <> OPR_REFERENCE then it sets up }
  882. { the operand type to OPR_REFERENCE, as well as setting up the ref }
  883. { to point to the default segment. }
  884. {*********************************************************************}
  885. var
  886. l : longint;
  887. Begin
  888. case opr.typ of
  889. OPR_REFERENCE :
  890. exit;
  891. OPR_CONSTANT :
  892. begin
  893. l:=opr.val;
  894. opr.typ:=OPR_REFERENCE;
  895. Fillchar(opr.ref,sizeof(treference),0);
  896. opr.Ref.Offset:=l;
  897. end;
  898. OPR_NONE :
  899. begin
  900. opr.typ:=OPR_REFERENCE;
  901. Fillchar(opr.ref,sizeof(treference),0);
  902. end;
  903. else
  904. begin
  905. Message(asmr_e_invalid_operand_type);
  906. { Recover }
  907. opr.typ:=OPR_REFERENCE;
  908. Fillchar(opr.ref,sizeof(treference),0);
  909. end;
  910. end;
  911. end;
  912. procedure TOperand.BuildOperand;
  913. begin
  914. abstract;
  915. end;
  916. {****************************************************************************
  917. TInstruction
  918. ****************************************************************************}
  919. constructor TInstruction.create;
  920. Begin
  921. Opcode:=A_NONE;
  922. Condition:=C_NONE;
  923. Ops:=0;
  924. InitOperands;
  925. Labeled:=false;
  926. end;
  927. destructor TInstruction.destroy;
  928. var
  929. i : longint;
  930. Begin
  931. for i:=1 to 3 do
  932. Operands[i].free;
  933. end;
  934. procedure TInstruction.InitOperands;
  935. var
  936. i : longint;
  937. begin
  938. for i:=1 to 3 do
  939. Operands[i].create;
  940. end;
  941. Procedure TInstruction.Swapoperands;
  942. Var
  943. p : toperand;
  944. Begin
  945. case Ops of
  946. 2 :
  947. begin
  948. p:=Operands[1];
  949. Operands[1]:=Operands[2];
  950. Operands[2]:=p;
  951. end;
  952. 3 :
  953. begin
  954. p:=Operands[1];
  955. Operands[1]:=Operands[3];
  956. Operands[3]:=p;
  957. end;
  958. end;
  959. end;
  960. procedure TInstruction.ConcatInstruction(p:TAAsmOutput);
  961. begin
  962. abstract;
  963. end;
  964. procedure TInstruction.BuildOpcode;
  965. begin
  966. abstract;
  967. end;
  968. {***************************************************************************
  969. TLocalLabel
  970. ***************************************************************************}
  971. constructor TLocalLabel.create(const n:string);
  972. begin
  973. inherited CreateName(n);
  974. lab:=nil;
  975. emitted:=false;
  976. end;
  977. function TLocalLabel.Gettasmlabel:tasmlabel;
  978. begin
  979. if not assigned(lab) then
  980. begin
  981. objectlibrary.getlabel(lab);
  982. { this label is forced to be used so it's always written }
  983. lab.increfs;
  984. end;
  985. Gettasmlabel:=lab;
  986. end;
  987. {***************************************************************************
  988. TLocalLabelList
  989. ***************************************************************************}
  990. procedure LocalLabelEmitted(p:tnamedindexitem;arg:pointer);
  991. begin
  992. if not TLocalLabel(p).emitted then
  993. Message1(asmr_e_unknown_label_identifier,p.name);
  994. end;
  995. procedure TLocalLabelList.CheckEmitted;
  996. begin
  997. ForEach_Static({$ifdef FPCPROCVAR}@{$endif}LocalLabelEmitted,nil)
  998. end;
  999. function CreateLocalLabel(const s: string; var hl: tasmlabel; emit:boolean):boolean;
  1000. var
  1001. lab : TLocalLabel;
  1002. Begin
  1003. CreateLocalLabel:=true;
  1004. { Check if it already is defined }
  1005. lab:=TLocalLabel(LocalLabellist.Search(s));
  1006. if not assigned(lab) then
  1007. begin
  1008. lab:=TLocalLabel.Create(s);
  1009. LocalLabellist.Insert(lab);
  1010. end;
  1011. { set emitted flag and check for dup syms }
  1012. if emit then
  1013. begin
  1014. if lab.Emitted then
  1015. begin
  1016. Message1(asmr_e_dup_local_sym,lab.Name);
  1017. CreateLocalLabel:=false;
  1018. end;
  1019. lab.Emitted:=true;
  1020. end;
  1021. hl:=lab.Gettasmlabel;
  1022. end;
  1023. {****************************************************************************
  1024. Symbol table helper routines
  1025. ****************************************************************************}
  1026. procedure AsmSearchSym(const s:string;var srsym:tsym;var srsymtable:tsymtable);
  1027. var
  1028. i : integer;
  1029. begin
  1030. i:=pos('.',s);
  1031. { allow unit.identifier }
  1032. if i>0 then
  1033. begin
  1034. searchsym(Copy(s,1,i-1),srsym,srsymtable);
  1035. if assigned(srsym) then
  1036. begin
  1037. if (srsym.typ=unitsym) and
  1038. (srsym.owner.unitid=0) then
  1039. srsym:=searchsymonlyin(tunitsym(srsym).unitsymtable,Copy(s,i+1,255))
  1040. else
  1041. srsym:=nil;
  1042. end;
  1043. end
  1044. else
  1045. searchsym(s,srsym,srsymtable);
  1046. end;
  1047. Function SearchType(const hs:string;var size:longint): Boolean;
  1048. var
  1049. srsym : tsym;
  1050. srsymtable : tsymtable;
  1051. begin
  1052. result:=false;
  1053. size:=0;
  1054. asmsearchsym(hs,srsym,srsymtable);
  1055. if assigned(srsym) and
  1056. (srsym.typ=typesym) then
  1057. begin
  1058. size:=ttypesym(srsym).restype.def.size;
  1059. result:=true;
  1060. end;
  1061. end;
  1062. Function SearchRecordType(const s:string): boolean;
  1063. var
  1064. srsym : tsym;
  1065. srsymtable : tsymtable;
  1066. Begin
  1067. SearchRecordType:=false;
  1068. { Check the constants in symtable }
  1069. asmsearchsym(s,srsym,srsymtable);
  1070. if srsym <> nil then
  1071. Begin
  1072. case srsym.typ of
  1073. typesym :
  1074. begin
  1075. if ttypesym(srsym).restype.def.deftype in [recorddef,objectdef] then
  1076. begin
  1077. SearchRecordType:=true;
  1078. exit;
  1079. end;
  1080. end;
  1081. end;
  1082. end;
  1083. end;
  1084. Function SearchIConstant(const s:string; var l:longint): boolean;
  1085. {**********************************************************************}
  1086. { Description: Searches for a CONSTANT of name s in either the local }
  1087. { symbol list, then in the global symbol list, and returns the value }
  1088. { of that constant in l. Returns TRUE if successfull, if not found, }
  1089. { or if the constant is not of correct type, then returns FALSE }
  1090. { Remarks: Also handle TRUE and FALSE returning in those cases 1 and 0 }
  1091. { respectively. }
  1092. {**********************************************************************}
  1093. var
  1094. srsym : tsym;
  1095. srsymtable : tsymtable;
  1096. Begin
  1097. SearchIConstant:=false;
  1098. { check for TRUE or FALSE reserved words first }
  1099. if s = 'TRUE' then
  1100. Begin
  1101. SearchIConstant:=TRUE;
  1102. l:=1;
  1103. exit;
  1104. end;
  1105. if s = 'FALSE' then
  1106. Begin
  1107. SearchIConstant:=TRUE;
  1108. l:=0;
  1109. exit;
  1110. end;
  1111. { Check the constants in symtable }
  1112. asmsearchsym(s,srsym,srsymtable);
  1113. if srsym <> nil then
  1114. Begin
  1115. case srsym.typ of
  1116. constsym :
  1117. begin
  1118. if (tconstsym(srsym).consttyp in [constord,constint,constchar,constbool]) then
  1119. Begin
  1120. l:=tconstsym(srsym).value.valueord;
  1121. SearchIConstant:=TRUE;
  1122. exit;
  1123. end;
  1124. end;
  1125. enumsym:
  1126. Begin
  1127. l:=tenumsym(srsym).value;
  1128. SearchIConstant:=TRUE;
  1129. exit;
  1130. end;
  1131. end;
  1132. end;
  1133. end;
  1134. Function GetRecordOffsetSize(s:string;Var Offset: longint;var Size:longint):boolean;
  1135. { search and returns the offset and size of records/objects of the base }
  1136. { with field name setup in field. }
  1137. { returns FALSE if not found. }
  1138. { used when base is a variable or a typed constant name. }
  1139. var
  1140. st : tsymtable;
  1141. harrdef : tarraydef;
  1142. sym : tsym;
  1143. srsymtable : tsymtable;
  1144. i : longint;
  1145. base : string;
  1146. Begin
  1147. GetRecordOffsetSize:=FALSE;
  1148. Offset:=0;
  1149. Size:=0;
  1150. i:=pos('.',s);
  1151. if i=0 then
  1152. i:=255;
  1153. base:=Copy(s,1,i-1);
  1154. delete(s,1,i);
  1155. if base='SELF' then
  1156. st:=current_procinfo.procdef._class.symtable
  1157. else
  1158. begin
  1159. asmsearchsym(base,sym,srsymtable);
  1160. st:=nil;
  1161. { we can start with a var,type,typedconst }
  1162. case sym.typ of
  1163. varsym :
  1164. begin
  1165. case tvarsym(sym).vartype.def.deftype of
  1166. recorddef :
  1167. st:=trecorddef(tvarsym(sym).vartype.def).symtable;
  1168. objectdef :
  1169. st:=tobjectdef(tvarsym(sym).vartype.def).symtable;
  1170. end;
  1171. end;
  1172. typesym :
  1173. begin
  1174. case ttypesym(sym).restype.def.deftype of
  1175. recorddef :
  1176. st:=trecorddef(ttypesym(sym).restype.def).symtable;
  1177. objectdef :
  1178. st:=tobjectdef(ttypesym(sym).restype.def).symtable;
  1179. end;
  1180. end;
  1181. typedconstsym :
  1182. begin
  1183. case ttypedconstsym(sym).typedconsttype.def.deftype of
  1184. recorddef :
  1185. st:=trecorddef(ttypedconstsym(sym).typedconsttype.def).symtable;
  1186. objectdef :
  1187. st:=tobjectdef(ttypedconstsym(sym).typedconsttype.def).symtable;
  1188. end;
  1189. end;
  1190. end;
  1191. end;
  1192. { now walk all recordsymtables }
  1193. while assigned(st) and (s<>'') do
  1194. begin
  1195. { load next field in base }
  1196. i:=pos('.',s);
  1197. if i=0 then
  1198. i:=255;
  1199. base:=Copy(s,1,i-1);
  1200. delete(s,1,i);
  1201. if st.symtabletype=objectsymtable then
  1202. sym:=search_class_member(tobjectdef(st.defowner),base)
  1203. else
  1204. sym:=tsym(st.search(base));
  1205. if not assigned(sym) then
  1206. begin
  1207. GetRecordOffsetSize:=false;
  1208. exit;
  1209. end;
  1210. st:=nil;
  1211. case sym.typ of
  1212. varsym :
  1213. begin
  1214. inc(Offset,tvarsym(sym).fieldoffset);
  1215. Size:=tvarsym(sym).getsize;
  1216. case tvarsym(sym).vartype.def.deftype of
  1217. arraydef :
  1218. begin
  1219. { for arrays try to get the element size, take care of
  1220. multiple indexes }
  1221. harrdef:=tarraydef(tvarsym(sym).vartype.def);
  1222. while assigned(harrdef.elementtype.def) and
  1223. (harrdef.elementtype.def.deftype=arraydef) do
  1224. harrdef:=tarraydef(harrdef.elementtype.def);
  1225. size:=harrdef.elesize;
  1226. end;
  1227. recorddef :
  1228. st:=trecorddef(tvarsym(sym).vartype.def).symtable;
  1229. objectdef :
  1230. st:=tobjectdef(tvarsym(sym).vartype.def).symtable;
  1231. end;
  1232. end;
  1233. end;
  1234. end;
  1235. GetRecordOffsetSize:=(s='');
  1236. end;
  1237. Function SearchLabel(const s: string; var hl: tasmlabel;emit:boolean): boolean;
  1238. var
  1239. sym : tsym;
  1240. srsymtable : tsymtable;
  1241. hs : string;
  1242. Begin
  1243. hl:=nil;
  1244. SearchLabel:=false;
  1245. { Check for pascal labels, which are case insensetive }
  1246. hs:=upper(s);
  1247. asmsearchsym(hs,sym,srsymtable);
  1248. if sym=nil then
  1249. exit;
  1250. case sym.typ of
  1251. labelsym :
  1252. begin
  1253. hl:=tlabelsym(sym).lab;
  1254. if emit then
  1255. tlabelsym(sym).defined:=true
  1256. else
  1257. tlabelsym(sym).used:=true;
  1258. SearchLabel:=true;
  1259. exit;
  1260. end;
  1261. end;
  1262. end;
  1263. {*************************************************************************}
  1264. { Instruction Generation Utilities }
  1265. {*************************************************************************}
  1266. Procedure ConcatString(p : TAAsmoutput;s:string);
  1267. {*********************************************************************}
  1268. { PROCEDURE ConcatString(s:string); }
  1269. { Description: This routine adds the character chain pointed to in }
  1270. { s to the instruction linked list. }
  1271. {*********************************************************************}
  1272. Var
  1273. pc: PChar;
  1274. Begin
  1275. getmem(pc,length(s)+1);
  1276. p.concat(Tai_string.Create_length_pchar(strpcopy(pc,s),length(s)));
  1277. end;
  1278. Procedure ConcatPasString(p : TAAsmoutput;s:string);
  1279. {*********************************************************************}
  1280. { PROCEDURE ConcatPasString(s:string); }
  1281. { Description: This routine adds the character chain pointed to in }
  1282. { s to the instruction linked list, contrary to ConcatString it }
  1283. { uses a pascal style string, so it conserves null characters. }
  1284. {*********************************************************************}
  1285. Begin
  1286. p.concat(Tai_string.Create(s));
  1287. end;
  1288. Procedure ConcatDirect(p : TAAsmoutput;s:string);
  1289. {*********************************************************************}
  1290. { PROCEDURE ConcatDirect(s:string) }
  1291. { Description: This routine output the string directly to the asm }
  1292. { output, it is only sed when writing special labels in AT&T mode, }
  1293. { and should not be used without due consideration, since it may }
  1294. { cause problems. }
  1295. {*********************************************************************}
  1296. Var
  1297. pc: PChar;
  1298. Begin
  1299. getmem(pc,length(s)+1);
  1300. p.concat(Tai_direct.Create(strpcopy(pc,s)));
  1301. end;
  1302. Procedure ConcatConstant(p: TAAsmoutput; value: longint; maxvalue: longint);
  1303. {*********************************************************************}
  1304. { PROCEDURE ConcatConstant(value: longint; maxvalue: longint); }
  1305. { Description: This routine adds the value constant to the current }
  1306. { instruction linked list. }
  1307. { maxvalue -> indicates the size of the data to initialize: }
  1308. { $ff -> create a byte node. }
  1309. { $ffff -> create a word node. }
  1310. { $ffffffff -> create a dword node. }
  1311. {*********************************************************************}
  1312. Begin
  1313. if (maxvalue <> longint($ffffffff)) and (value > maxvalue) then
  1314. Begin
  1315. Message(asmr_e_constant_out_of_bounds);
  1316. { assuming a value of maxvalue }
  1317. value:=maxvalue;
  1318. end;
  1319. if maxvalue = $ff then
  1320. p.concat(Tai_const.Create_8bit(byte(value)))
  1321. else
  1322. if maxvalue = $ffff then
  1323. p.concat(Tai_const.Create_16bit(word(value)))
  1324. else
  1325. if maxvalue = longint($ffffffff) then
  1326. p.concat(Tai_const.Create_32bit(longint(value)));
  1327. end;
  1328. Procedure ConcatConstSymbol(p : TAAsmoutput;const sym:string;l:longint);
  1329. begin
  1330. p.concat(Tai_const_symbol.Createname_offset(sym,l));
  1331. end;
  1332. Procedure ConcatRealConstant(p : TAAsmoutput;value: bestreal; real_typ : tfloattype);
  1333. {***********************************************************************}
  1334. { PROCEDURE ConcatRealConstant(value: bestreal; real_typ : tfloattype); }
  1335. { Description: This routine adds the value constant to the current }
  1336. { instruction linked list. }
  1337. { real_typ -> indicates the type of the real data to initialize: }
  1338. { s32real -> create a single node. }
  1339. { s64real -> create a double node. }
  1340. { s80real -> create an extended node. }
  1341. { s64bit -> create a comp node. }
  1342. { f32bit -> create a fixed node. (not used normally) }
  1343. {***********************************************************************}
  1344. Begin
  1345. case real_typ of
  1346. s32real : p.concat(Tai_real_32bit.Create(value));
  1347. s64real : p.concat(Tai_real_64bit.Create(value));
  1348. s80real : p.concat(Tai_real_80bit.Create(value));
  1349. s64comp : p.concat(Tai_comp_64bit.Create(value));
  1350. end;
  1351. end;
  1352. Procedure ConcatLabel(p: TAAsmoutput;var l : tasmlabel);
  1353. {*********************************************************************}
  1354. { PROCEDURE ConcatLabel }
  1355. { Description: This routine either emits a label or a labeled }
  1356. { instruction to the linked list of instructions. }
  1357. {*********************************************************************}
  1358. begin
  1359. p.concat(Tai_label.Create(l));
  1360. end;
  1361. procedure ConcatAlign(p:TAAsmoutput;l:longint);
  1362. {*********************************************************************}
  1363. { PROCEDURE ConcatPublic }
  1364. { Description: This routine emits an global definition to the }
  1365. { linked list of instructions.(used by AT&T styled asm) }
  1366. {*********************************************************************}
  1367. begin
  1368. p.concat(Tai_align.Create(l));
  1369. end;
  1370. procedure ConcatPublic(p:TAAsmoutput;const s : string);
  1371. {*********************************************************************}
  1372. { PROCEDURE ConcatPublic }
  1373. { Description: This routine emits an global definition to the }
  1374. { linked list of instructions.(used by AT&T styled asm) }
  1375. {*********************************************************************}
  1376. begin
  1377. p.concat(Tai_symbol.Createname_global(s,0));
  1378. end;
  1379. procedure ConcatLocal(p:TAAsmoutput;const s : string);
  1380. {*********************************************************************}
  1381. { PROCEDURE ConcatLocal }
  1382. { Description: This routine emits an local definition to the }
  1383. { linked list of instructions. }
  1384. {*********************************************************************}
  1385. begin
  1386. p.concat(Tai_symbol.Createname(s,0));
  1387. end;
  1388. Procedure ConcatGlobalBss(const s : string;size : longint);
  1389. {*********************************************************************}
  1390. { PROCEDURE ConcatGlobalBss }
  1391. { Description: This routine emits an global datablock to the }
  1392. { linked list of instructions. }
  1393. {*********************************************************************}
  1394. begin
  1395. bssSegment.concat(Tai_datablock.Create_global(s,size));
  1396. end;
  1397. Procedure ConcatLocalBss(const s : string;size : longint);
  1398. {*********************************************************************}
  1399. { PROCEDURE ConcatLocalBss }
  1400. { Description: This routine emits a local datablcok to the }
  1401. { linked list of instructions. }
  1402. {*********************************************************************}
  1403. begin
  1404. bssSegment.concat(Tai_datablock.Create(s,size));
  1405. end;
  1406. end.
  1407. {
  1408. $Log$
  1409. Revision 1.74 2003-10-29 15:40:20 peter
  1410. * support indexing and offset retrieval for locals
  1411. Revision 1.73 2003/10/28 15:36:01 peter
  1412. * absolute to object field supported, fixes tb0458
  1413. Revision 1.72 2003/10/24 17:39:03 peter
  1414. * more intel parser updates
  1415. Revision 1.71 2003/10/23 17:19:11 peter
  1416. * SearchType returns also the size
  1417. Revision 1.70 2003/10/08 19:39:58 peter
  1418. * allow access to parent locals when the currnet localst has no
  1419. varsyms
  1420. Revision 1.69 2003/10/01 20:34:49 peter
  1421. * procinfo unit contains tprocinfo
  1422. * cginfo renamed to cgbase
  1423. * moved cgmessage to verbose
  1424. * fixed ppc and sparc compiles
  1425. Revision 1.68 2003/09/25 14:57:36 peter
  1426. * fix check for unreachable locals
  1427. Revision 1.67 2003/09/23 17:56:06 peter
  1428. * locals and paras are allocated in the code generation
  1429. * tvarsym.localloc contains the location of para/local when
  1430. generating code for the current procedure
  1431. Revision 1.66 2003/09/16 16:17:01 peter
  1432. * varspez in calls to push_addr_param
  1433. Revision 1.65 2003/09/03 15:55:01 peter
  1434. * NEWRA branch merged
  1435. Revision 1.64.2.1 2003/08/27 19:55:54 peter
  1436. * first tregister patch
  1437. Revision 1.64 2003/06/13 21:19:31 peter
  1438. * current_procdef removed, use current_procinfo.procdef instead
  1439. Revision 1.63 2003/06/06 14:43:29 peter
  1440. * absolutesym support
  1441. Revision 1.62 2003/05/30 23:57:08 peter
  1442. * more sparc cleanup
  1443. * accumulator removed, splitted in function_return_reg (called) and
  1444. function_result_reg (caller)
  1445. Revision 1.61 2003/05/25 08:55:49 peter
  1446. * load result using hidden parameter
  1447. Revision 1.60 2003/05/15 18:58:53 peter
  1448. * removed selfpointer_offset, vmtpointer_offset
  1449. * tvarsym.adjusted_address
  1450. * address in localsymtable is now in the real direction
  1451. * removed some obsolete globals
  1452. Revision 1.59 2003/05/12 17:22:00 jonas
  1453. * fixed (last?) remaining -tvarsym(X).address to
  1454. tg.direction*tvarsym(X).address...
  1455. Revision 1.58 2003/04/27 11:21:34 peter
  1456. * aktprocdef renamed to current_procinfo.procdef
  1457. * procinfo renamed to current_procinfo
  1458. * procinfo will now be stored in current_module so it can be
  1459. cleaned up properly
  1460. * gen_main_procsym changed to create_main_proc and release_main_proc
  1461. to also generate a tprocinfo structure
  1462. * fixed unit implicit initfinal
  1463. Revision 1.57 2003/04/27 07:29:51 peter
  1464. * current_procinfo.procdef cleanup, current_procinfo.procdef is now always nil when parsing
  1465. a new procdef declaration
  1466. * aktprocsym removed
  1467. * lexlevel removed, use symtable.symtablelevel instead
  1468. * implicit init/final code uses the normal genentry/genexit
  1469. * funcret state checking updated for new funcret handling
  1470. Revision 1.56 2003/04/25 20:59:34 peter
  1471. * removed funcretn,funcretsym, function result is now in varsym
  1472. and aliases for result and function name are added using absolutesym
  1473. * vs_hidden parameter for funcret passed in parameter
  1474. * vs_hidden fixes
  1475. * writenode changed to printnode and released from extdebug
  1476. * -vp option added to generate a tree.log with the nodetree
  1477. * nicer printnode for statements, callnode
  1478. Revision 1.55 2003/04/06 21:11:23 olle
  1479. * changed newasmsymbol to newasmsymboldata for data symbols
  1480. Revision 1.54 2003/03/28 19:16:57 peter
  1481. * generic constructor working for i386
  1482. * remove fixed self register
  1483. * esi added as address register for i386
  1484. Revision 1.53 2003/02/19 22:00:14 daniel
  1485. * Code generator converted to new register notation
  1486. - Horribily outdated todo.txt removed
  1487. Revision 1.52 2003/01/08 18:43:56 daniel
  1488. * Tregister changed into a record
  1489. Revision 1.51 2002/12/14 15:02:03 carl
  1490. * maxoperands -> max_operands (for portability in rautils.pas)
  1491. * fix some range-check errors with loadconst
  1492. + add ncgadd unit to m68k
  1493. * some bugfix of a_param_reg with LOC_CREFERENCE
  1494. Revision 1.50 2002/11/25 17:43:23 peter
  1495. * splitted defbase in defutil,symutil,defcmp
  1496. * merged isconvertable and is_equal into compare_defs(_ext)
  1497. * made operator search faster by walking the list only once
  1498. Revision 1.49 2002/11/22 22:48:10 carl
  1499. * memory optimization with tconstsym (1.5%)
  1500. Revision 1.48 2002/11/18 17:31:59 peter
  1501. * pass proccalloption to ret_in_xxx and push_xxx functions
  1502. Revision 1.47 2002/11/15 16:29:31 peter
  1503. * made tasmsymbol.refs private (merged)
  1504. Revision 1.46 2002/09/03 16:26:27 daniel
  1505. * Make Tprocdef.defs protected
  1506. Revision 1.45 2002/08/25 19:25:20 peter
  1507. * sym.insert_in_data removed
  1508. * symtable.insertvardata/insertconstdata added
  1509. * removed insert_in_data call from symtable.insert, it needs to be
  1510. called separatly. This allows to deref the address calculation
  1511. * procedures now calculate the parast addresses after the procedure
  1512. directives are parsed. This fixes the cdecl parast problem
  1513. * push_addr_param has an extra argument that specifies if cdecl is used
  1514. or not
  1515. Revision 1.44 2002/08/17 09:23:41 florian
  1516. * first part of procinfo rewrite
  1517. Revision 1.43 2002/08/16 14:24:59 carl
  1518. * issameref() to test if two references are the same (then emit no opcodes)
  1519. + ret_in_reg to replace ret_in_acc
  1520. (fix some register allocation bugs at the same time)
  1521. + save_std_register now has an extra parameter which is the
  1522. usedinproc registers
  1523. Revision 1.42 2002/08/13 18:01:52 carl
  1524. * rename swatoperands to swapoperands
  1525. + m68k first compilable version (still needs a lot of testing):
  1526. assembler generator, system information , inline
  1527. assembler reader.
  1528. Revision 1.41 2002/08/12 15:08:40 carl
  1529. + stab register indexes for powerpc (moved from gdb to cpubase)
  1530. + tprocessor enumeration moved to cpuinfo
  1531. + linker in target_info is now a class
  1532. * many many updates for m68k (will soon start to compile)
  1533. - removed some ifdef or correct them for correct cpu
  1534. Revision 1.40 2002/08/11 14:32:27 peter
  1535. * renamed current_library to objectlibrary
  1536. Revision 1.39 2002/08/11 13:24:13 peter
  1537. * saving of asmsymbols in ppu supported
  1538. * asmsymbollist global is removed and moved into a new class
  1539. tasmlibrarydata that will hold the info of a .a file which
  1540. corresponds with a single module. Added librarydata to tmodule
  1541. to keep the library info stored for the module. In the future the
  1542. objectfiles will also be stored to the tasmlibrarydata class
  1543. * all getlabel/newasmsymbol and friends are moved to the new class
  1544. Revision 1.38 2002/07/20 11:57:57 florian
  1545. * types.pas renamed to defbase.pas because D6 contains a types
  1546. unit so this would conflicts if D6 programms are compiled
  1547. + Willamette/SSE2 instructions to assembler added
  1548. Revision 1.37 2002/07/11 14:41:28 florian
  1549. * start of the new generic parameter handling
  1550. Revision 1.36 2002/07/01 18:46:25 peter
  1551. * internal linker
  1552. * reorganized aasm layer
  1553. Revision 1.35 2002/05/18 13:34:17 peter
  1554. * readded missing revisions
  1555. Revision 1.34 2002/05/16 19:46:44 carl
  1556. + defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
  1557. + try to fix temp allocation (still in ifdef)
  1558. + generic constructor calls
  1559. + start of tassembler / tmodulebase class cleanup
  1560. Revision 1.31 2002/05/12 16:53:10 peter
  1561. * moved entry and exitcode to ncgutil and cgobj
  1562. * foreach gets extra argument for passing local data to the
  1563. iterator function
  1564. * -CR checks also class typecasts at runtime by changing them
  1565. into as
  1566. * fixed compiler to cycle with the -CR option
  1567. * fixed stabs with elf writer, finally the global variables can
  1568. be watched
  1569. * removed a lot of routines from cga unit and replaced them by
  1570. calls to cgobj
  1571. * u32bit-s32bit updates for and,or,xor nodes. When one element is
  1572. u32bit then the other is typecasted also to u32bit without giving
  1573. a rangecheck warning/error.
  1574. * fixed pascal calling method with reversing also the high tree in
  1575. the parast, detected by tcalcst3 test
  1576. Revision 1.30 2002/04/20 21:32:24 carl
  1577. + generic FPC_CHECKPOINTER
  1578. + first parameter offset in stack now portable
  1579. * rename some constants
  1580. + move some cpu stuff to other units
  1581. - remove unused constents
  1582. * fix stacksize for some targets
  1583. * fix generic size problems which depend now on EXTEND_SIZE constant
  1584. Revision 1.29 2002/04/15 19:02:35 carl
  1585. + target_info.size_of_pointer -> pointer_Size
  1586. Revision 1.28 2002/04/02 17:11:29 peter
  1587. * tlocation,treference update
  1588. * LOC_CONSTANT added for better constant handling
  1589. * secondadd splitted in multiple routines
  1590. * location_force_reg added for loading a location to a register
  1591. of a specified size
  1592. * secondassignment parses now first the right and then the left node
  1593. (this is compatible with Kylix). This saves a lot of push/pop especially
  1594. with string operations
  1595. * adapted some routines to use the new cg methods
  1596. Revision 1.27 2002/01/29 21:32:03 peter
  1597. * allow accessing locals in other lexlevel when the current assembler
  1598. routine doesn't have locals.
  1599. Revision 1.26 2002/01/24 18:25:50 peter
  1600. * implicit result variable generation for assembler routines
  1601. * removed m_tp modeswitch, use m_tp7 or not(m_fpc) instead
  1602. }