rautils.pas 53 KB

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