rautils.pas 52 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737
  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,
  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. size : topsize;
  68. hastype, { if the operand has typecasted variable }
  69. hasvar : boolean; { if the operand is loaded with a variable }
  70. opr : TOprRec;
  71. constructor create;
  72. destructor destroy;override;
  73. Procedure BuildOperand;virtual;
  74. Procedure SetSize(_size:longint;force:boolean);
  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. opsize : topsize;
  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): 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. symsym,symtable,paramgr,
  182. aasmcpu,
  183. cgbase;
  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:=S_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.SetCorrectSize(opcode:tasmop);
  625. begin
  626. end;
  627. Procedure TOperand.SetSize(_size:longint;force:boolean);
  628. begin
  629. if force or
  630. ((size = S_NO) and (_size<=extended_size)) then
  631. Begin
  632. case _size of
  633. 1 : size:=S_B;
  634. 2 : size:=S_W{ could be S_IS};
  635. 4 : size:=S_L{ could be S_IL or S_FS};
  636. 8 : size:=S_IQ{ could be S_D or S_FL};
  637. else
  638. begin
  639. { extended_size can also be 8, resulting in a
  640. duplicate label }
  641. if _size=extended_size then
  642. size:=S_FX;
  643. end;
  644. end;
  645. end;
  646. end;
  647. Function TOperand.SetupResult:boolean;
  648. Begin
  649. SetupResult:=false;
  650. { replace by correct offset. }
  651. if (not is_void(aktprocdef.rettype.def)) then
  652. begin
  653. if (m_tp7 in aktmodeswitches) and
  654. paramanager.ret_in_reg(aktprocdef.rettype.def,aktprocdef.proccalloption) then
  655. begin
  656. Message(asmr_e_cannot_use_RESULT_here);
  657. exit;
  658. end;
  659. opr.ref.offset:=procinfo.return_offset;
  660. opr.ref.base:= procinfo.framepointer;
  661. opr.ref.options:=ref_parafixup;
  662. { always assume that the result is valid. }
  663. tfuncretsym(aktprocdef.funcretsym).funcretstate:=vs_assigned;
  664. { increase reference count, this is also used to check
  665. if the result variable is actually used or not }
  666. inc(tfuncretsym(aktprocdef.funcretsym).refcount);
  667. SetupResult:=true;
  668. end
  669. else
  670. Message(asmr_e_void_function);
  671. end;
  672. Function TOperand.SetupSelf:boolean;
  673. Begin
  674. SetupSelf:=false;
  675. if assigned(procinfo._class) then
  676. Begin
  677. opr.typ:=OPR_REFERENCE;
  678. opr.ref.offset:=procinfo.selfpointer_offset;
  679. opr.ref.base:=procinfo.framepointer;
  680. opr.ref.options:=ref_selffixup;
  681. SetupSelf:=true;
  682. end
  683. else
  684. Message(asmr_e_cannot_use_SELF_outside_a_method);
  685. end;
  686. Function TOperand.SetupOldEBP:boolean;
  687. Begin
  688. SetupOldEBP:=false;
  689. if lexlevel>normal_function_level then
  690. Begin
  691. opr.typ:=OPR_REFERENCE;
  692. opr.ref.offset:=procinfo.framepointer_offset;
  693. opr.ref.base:=procinfo.framepointer;
  694. opr.ref.options:=ref_parafixup;
  695. SetupOldEBP:=true;
  696. end
  697. else
  698. Message(asmr_e_cannot_use_OLDEBP_outside_nested_procedure);
  699. end;
  700. Function TOperand.SetupVar(const s:string;GetOffset : boolean): Boolean;
  701. { search and sets up the correct fields in the Instr record }
  702. { for the NON-constant identifier passed to the routine. }
  703. { if not found returns FALSE. }
  704. var
  705. sym : tsym;
  706. srsymtable : tsymtable;
  707. harrdef : tarraydef;
  708. l : longint;
  709. Begin
  710. SetupVar:=false;
  711. asmsearchsym(s,sym,srsymtable);
  712. if sym = nil then
  713. exit;
  714. case sym.typ of
  715. varsym :
  716. begin
  717. { we always assume in asm statements that }
  718. { that the variable is valid. }
  719. tvarsym(sym).varstate:=vs_used;
  720. inc(tvarsym(sym).refs);
  721. case tvarsym(sym).owner.symtabletype of
  722. objectsymtable :
  723. begin
  724. { We return the address of the field, just like Delphi/TP }
  725. opr.typ:=OPR_CONSTANT;
  726. opr.val:=tvarsym(sym).address;
  727. hasvar:=true;
  728. SetupVar:=true;
  729. Exit;
  730. end;
  731. globalsymtable,
  732. staticsymtable :
  733. opr.ref.symbol:=objectlibrary.newasmsymboldata(tvarsym(sym).mangledname);
  734. parasymtable :
  735. begin
  736. { if we only want the offset we don't have to care
  737. the base will be zeroed after ! }
  738. if (lexlevel=tvarsym(sym).owner.symtablelevel) or
  739. { this below is wrong because there are two parast
  740. for global functions one of interface the second of
  741. implementation
  742. if (tvarsym(sym).owner=procinfo.def.parast) or }
  743. GetOffset then
  744. begin
  745. opr.ref.base:=procinfo.framepointer;
  746. end
  747. else
  748. begin
  749. if (aktprocdef.localst.datasize=0) and
  750. assigned(procinfo.parent) and
  751. (lexlevel=tvarsym(sym).owner.symtablelevel+1) and
  752. { same problem as above !!
  753. (procinfo.parent^.sym.definition.parast=tvarsym(sym).owner) and }
  754. (lexlevel>normal_function_level) then
  755. opr.ref.base:=procinfo.parent.framepointer
  756. else
  757. message1(asmr_e_local_para_unreachable,s);
  758. end;
  759. opr.ref.offset:=tvarsym(sym).address;
  760. if (lexlevel=tvarsym(sym).owner.symtablelevel) then
  761. begin
  762. opr.ref.offsetfixup:=aktprocdef.parast.address_fixup;
  763. opr.ref.options:=ref_parafixup;
  764. end
  765. else
  766. begin
  767. opr.ref.offsetfixup:=0;
  768. opr.ref.options:=ref_none;
  769. end;
  770. if (tvarsym(sym).varspez=vs_var) or
  771. ((tvarsym(sym).varspez=vs_const) and
  772. paramanager.push_addr_param(tvarsym(sym).vartype.def,aktprocdef.proccalloption)) then
  773. SetSize(pointer_size,false);
  774. end;
  775. localsymtable :
  776. begin
  777. if (vo_is_external in tvarsym(sym).varoptions) then
  778. opr.ref.symbol:=objectlibrary.newasmsymboldata(tvarsym(sym).mangledname)
  779. else
  780. begin
  781. { if we only want the offset we don't have to care
  782. the base will be zeroed after ! }
  783. if (lexlevel=tvarsym(sym).owner.symtablelevel) or
  784. {if (tvarsym(sym).owner=procinfo.def.localst) or}
  785. GetOffset then
  786. opr.ref.base:=procinfo.framepointer
  787. else
  788. begin
  789. if (aktprocdef.localst.datasize=0) and
  790. assigned(procinfo.parent) and
  791. (lexlevel=tvarsym(sym).owner.symtablelevel+1) and
  792. {(procinfo.parent^.sym.definition.localst=tvarsym(sym).owner) and}
  793. (lexlevel>normal_function_level) then
  794. opr.ref.base:=procinfo.parent.framepointer
  795. else
  796. message1(asmr_e_local_para_unreachable,s);
  797. end;
  798. opr.ref.offset:=-(tvarsym(sym).address);
  799. if (lexlevel=tvarsym(sym).owner.symtablelevel) then
  800. begin
  801. opr.ref.offsetfixup:=aktprocdef.localst.address_fixup;
  802. opr.ref.options:=ref_localfixup;
  803. end
  804. else
  805. begin
  806. opr.ref.offsetfixup:=0;
  807. opr.ref.options:=ref_none;
  808. end;
  809. end;
  810. if (tvarsym(sym).varspez in [vs_var,vs_out]) or
  811. ((tvarsym(sym).varspez=vs_const) and
  812. paramanager.push_addr_param(tvarsym(sym).vartype.def,aktprocdef.proccalloption)) then
  813. SetSize(pointer_size,false);
  814. end;
  815. end;
  816. case tvarsym(sym).vartype.def.deftype of
  817. orddef,
  818. enumdef,
  819. pointerdef,
  820. floatdef :
  821. SetSize(tvarsym(sym).getsize,false);
  822. arraydef :
  823. begin
  824. { for arrays try to get the element size, take care of
  825. multiple indexes }
  826. harrdef:=tarraydef(tvarsym(sym).vartype.def);
  827. while assigned(harrdef.elementtype.def) and
  828. (harrdef.elementtype.def.deftype=arraydef) do
  829. harrdef:=tarraydef(harrdef.elementtype.def);
  830. SetSize(harrdef.elesize,false);
  831. end;
  832. end;
  833. hasvar:=true;
  834. SetupVar:=true;
  835. Exit;
  836. end;
  837. typedconstsym :
  838. begin
  839. opr.ref.symbol:=objectlibrary.newasmsymboldata(ttypedconstsym(sym).mangledname);
  840. case ttypedconstsym(sym).typedconsttype.def.deftype of
  841. orddef,
  842. enumdef,
  843. pointerdef,
  844. floatdef :
  845. SetSize(ttypedconstsym(sym).getsize,false);
  846. arraydef :
  847. begin
  848. { for arrays try to get the element size, take care of
  849. multiple indexes }
  850. harrdef:=tarraydef(ttypedconstsym(sym).typedconsttype.def);
  851. while assigned(harrdef.elementtype.def) and
  852. (harrdef.elementtype.def.deftype=arraydef) do
  853. harrdef:=tarraydef(harrdef.elementtype.def);
  854. SetSize(harrdef.elesize,false);
  855. end;
  856. end;
  857. hasvar:=true;
  858. SetupVar:=true;
  859. Exit;
  860. end;
  861. constsym :
  862. begin
  863. if tconstsym(sym).consttyp in [constint,constchar,constbool] then
  864. begin
  865. opr.typ:=OPR_CONSTANT;
  866. opr.val:=tconstsym(sym).value.valueord;
  867. SetupVar:=true;
  868. Exit;
  869. end;
  870. end;
  871. typesym :
  872. begin
  873. if ttypesym(sym).restype.def.deftype in [recorddef,objectdef] then
  874. begin
  875. opr.typ:=OPR_CONSTANT;
  876. opr.val:=0;
  877. SetupVar:=TRUE;
  878. Exit;
  879. end;
  880. end;
  881. procsym :
  882. begin
  883. if Tprocsym(sym).procdef_count>1 then
  884. Message(asmr_w_calling_overload_func);
  885. l:=opr.ref.offset;
  886. opr.typ:=OPR_SYMBOL;
  887. opr.symbol:=objectlibrary.newasmsymbol(tprocsym(sym).first_procdef.mangledname);
  888. opr.symofs:=l;
  889. hasvar:=true;
  890. SetupVar:=TRUE;
  891. Exit;
  892. end;
  893. else
  894. begin
  895. Message(asmr_e_unsupported_symbol_type);
  896. exit;
  897. end;
  898. end;
  899. end;
  900. { looks for internal names of variables and routines }
  901. Function TOperand.SetupDirectVar(const hs:string): Boolean;
  902. var
  903. p : tasmsymbol;
  904. begin
  905. SetupDirectVar:=false;
  906. p:=objectlibrary.getasmsymbol(hs);
  907. if assigned(p) then
  908. begin
  909. opr.ref.symbol:=p;
  910. hasvar:=true;
  911. SetupDirectVar:=true;
  912. end;
  913. end;
  914. procedure TOperand.InitRef;
  915. {*********************************************************************}
  916. { Description: This routine first check if the opcode is of }
  917. { type OPR_NONE, or OPR_REFERENCE , if not it gives out an error. }
  918. { If the operandtype = OPR_NONE or <> OPR_REFERENCE then it sets up }
  919. { the operand type to OPR_REFERENCE, as well as setting up the ref }
  920. { to point to the default segment. }
  921. {*********************************************************************}
  922. Begin
  923. case opr.typ of
  924. OPR_REFERENCE:
  925. exit;
  926. OPR_NONE: ;
  927. else
  928. Message(asmr_e_invalid_operand_type);
  929. end;
  930. opr.typ := OPR_REFERENCE;
  931. Fillchar(opr.ref,sizeof(treference),0);
  932. {$ifdef i386}
  933. opr.ref.segment.enum:=R_INTREGISTER;
  934. {$endif}
  935. opr.ref.index.enum:=R_INTREGISTER;
  936. opr.ref.base.enum:=R_INTREGISTER;
  937. end;
  938. procedure TOperand.BuildOperand;
  939. begin
  940. abstract;
  941. end;
  942. {****************************************************************************
  943. TInstruction
  944. ****************************************************************************}
  945. constructor TInstruction.create;
  946. Begin
  947. Opcode:=A_NONE;
  948. Opsize:=S_NO;
  949. Condition:=C_NONE;
  950. Ops:=0;
  951. InitOperands;
  952. Labeled:=false;
  953. end;
  954. destructor TInstruction.destroy;
  955. var
  956. i : longint;
  957. Begin
  958. for i:=1 to 3 do
  959. Operands[i].free;
  960. end;
  961. procedure TInstruction.InitOperands;
  962. var
  963. i : longint;
  964. begin
  965. for i:=1 to 3 do
  966. Operands[i].create;
  967. end;
  968. Procedure TInstruction.Swapoperands;
  969. Var
  970. p : toperand;
  971. Begin
  972. case Ops of
  973. 2 :
  974. begin
  975. p:=Operands[1];
  976. Operands[1]:=Operands[2];
  977. Operands[2]:=p;
  978. end;
  979. 3 :
  980. begin
  981. p:=Operands[1];
  982. Operands[1]:=Operands[3];
  983. Operands[3]:=p;
  984. end;
  985. end;
  986. end;
  987. procedure TInstruction.ConcatInstruction(p:TAAsmOutput);
  988. begin
  989. abstract;
  990. end;
  991. procedure TInstruction.BuildOpcode;
  992. begin
  993. abstract;
  994. end;
  995. {***************************************************************************
  996. TLocalLabel
  997. ***************************************************************************}
  998. constructor TLocalLabel.create(const n:string);
  999. begin
  1000. inherited CreateName(n);
  1001. lab:=nil;
  1002. emitted:=false;
  1003. end;
  1004. function TLocalLabel.Gettasmlabel:tasmlabel;
  1005. begin
  1006. if not assigned(lab) then
  1007. begin
  1008. objectlibrary.getlabel(lab);
  1009. { this label is forced to be used so it's always written }
  1010. lab.increfs;
  1011. end;
  1012. Gettasmlabel:=lab;
  1013. end;
  1014. {***************************************************************************
  1015. TLocalLabelList
  1016. ***************************************************************************}
  1017. procedure LocalLabelEmitted(p:tnamedindexitem;arg:pointer);
  1018. begin
  1019. if not TLocalLabel(p).emitted then
  1020. Message1(asmr_e_unknown_label_identifier,p.name);
  1021. end;
  1022. procedure TLocalLabelList.CheckEmitted;
  1023. begin
  1024. ForEach_Static({$ifdef FPCPROCVAR}@{$endif}LocalLabelEmitted,nil)
  1025. end;
  1026. function CreateLocalLabel(const s: string; var hl: tasmlabel; emit:boolean):boolean;
  1027. var
  1028. lab : TLocalLabel;
  1029. Begin
  1030. CreateLocalLabel:=true;
  1031. { Check if it already is defined }
  1032. lab:=TLocalLabel(LocalLabellist.Search(s));
  1033. if not assigned(lab) then
  1034. begin
  1035. lab:=TLocalLabel.Create(s);
  1036. LocalLabellist.Insert(lab);
  1037. end;
  1038. { set emitted flag and check for dup syms }
  1039. if emit then
  1040. begin
  1041. if lab.Emitted then
  1042. begin
  1043. Message1(asmr_e_dup_local_sym,lab.Name);
  1044. CreateLocalLabel:=false;
  1045. end;
  1046. lab.Emitted:=true;
  1047. end;
  1048. hl:=lab.Gettasmlabel;
  1049. end;
  1050. {****************************************************************************
  1051. Symbol table helper routines
  1052. ****************************************************************************}
  1053. procedure AsmSearchSym(const s:string;var srsym:tsym;var srsymtable:tsymtable);
  1054. var
  1055. i : integer;
  1056. begin
  1057. i:=pos('.',s);
  1058. { allow unit.identifier }
  1059. if i>0 then
  1060. begin
  1061. searchsym(Copy(s,1,i-1),srsym,srsymtable);
  1062. if assigned(srsym) then
  1063. begin
  1064. if (srsym.typ=unitsym) and
  1065. (srsym.owner.unitid=0) then
  1066. srsym:=searchsymonlyin(tunitsym(srsym).unitsymtable,Copy(s,i+1,255))
  1067. else
  1068. srsym:=nil;
  1069. end;
  1070. end
  1071. else
  1072. searchsym(s,srsym,srsymtable);
  1073. end;
  1074. Function SearchType(const hs:string): Boolean;
  1075. var
  1076. srsym : tsym;
  1077. srsymtable : tsymtable;
  1078. begin
  1079. asmsearchsym(hs,srsym,srsymtable);
  1080. SearchType:=assigned(srsym) and
  1081. (srsym.typ=typesym);
  1082. end;
  1083. Function SearchRecordType(const s:string): boolean;
  1084. var
  1085. srsym : tsym;
  1086. srsymtable : tsymtable;
  1087. Begin
  1088. SearchRecordType:=false;
  1089. { Check the constants in symtable }
  1090. asmsearchsym(s,srsym,srsymtable);
  1091. if srsym <> nil then
  1092. Begin
  1093. case srsym.typ of
  1094. typesym :
  1095. begin
  1096. if ttypesym(srsym).restype.def.deftype in [recorddef,objectdef] then
  1097. begin
  1098. SearchRecordType:=true;
  1099. exit;
  1100. end;
  1101. end;
  1102. end;
  1103. end;
  1104. end;
  1105. Function SearchIConstant(const s:string; var l:longint): boolean;
  1106. {**********************************************************************}
  1107. { Description: Searches for a CONSTANT of name s in either the local }
  1108. { symbol list, then in the global symbol list, and returns the value }
  1109. { of that constant in l. Returns TRUE if successfull, if not found, }
  1110. { or if the constant is not of correct type, then returns FALSE }
  1111. { Remarks: Also handle TRUE and FALSE returning in those cases 1 and 0 }
  1112. { respectively. }
  1113. {**********************************************************************}
  1114. var
  1115. srsym : tsym;
  1116. srsymtable : tsymtable;
  1117. Begin
  1118. SearchIConstant:=false;
  1119. { check for TRUE or FALSE reserved words first }
  1120. if s = 'TRUE' then
  1121. Begin
  1122. SearchIConstant:=TRUE;
  1123. l:=1;
  1124. exit;
  1125. end;
  1126. if s = 'FALSE' then
  1127. Begin
  1128. SearchIConstant:=TRUE;
  1129. l:=0;
  1130. exit;
  1131. end;
  1132. { Check the constants in symtable }
  1133. asmsearchsym(s,srsym,srsymtable);
  1134. if srsym <> nil then
  1135. Begin
  1136. case srsym.typ of
  1137. constsym :
  1138. begin
  1139. if (tconstsym(srsym).consttyp in [constord,constint,constchar,constbool]) then
  1140. Begin
  1141. l:=tconstsym(srsym).value.valueord;
  1142. SearchIConstant:=TRUE;
  1143. exit;
  1144. end;
  1145. end;
  1146. enumsym:
  1147. Begin
  1148. l:=tenumsym(srsym).value;
  1149. SearchIConstant:=TRUE;
  1150. exit;
  1151. end;
  1152. end;
  1153. end;
  1154. end;
  1155. Function GetRecordOffsetSize(s:string;Var Offset: longint;var Size:longint):boolean;
  1156. { search and returns the offset and size of records/objects of the base }
  1157. { with field name setup in field. }
  1158. { returns FALSE if not found. }
  1159. { used when base is a variable or a typed constant name. }
  1160. var
  1161. st : tsymtable;
  1162. harrdef : tarraydef;
  1163. sym : tsym;
  1164. srsymtable : tsymtable;
  1165. i : longint;
  1166. base : string;
  1167. Begin
  1168. GetRecordOffsetSize:=FALSE;
  1169. Offset:=0;
  1170. Size:=0;
  1171. i:=pos('.',s);
  1172. if i=0 then
  1173. i:=255;
  1174. base:=Copy(s,1,i-1);
  1175. delete(s,1,i);
  1176. if base='SELF' then
  1177. st:=procinfo._class.symtable
  1178. else
  1179. begin
  1180. asmsearchsym(base,sym,srsymtable);
  1181. st:=nil;
  1182. { we can start with a var,type,typedconst }
  1183. case sym.typ of
  1184. varsym :
  1185. begin
  1186. case tvarsym(sym).vartype.def.deftype of
  1187. recorddef :
  1188. st:=trecorddef(tvarsym(sym).vartype.def).symtable;
  1189. objectdef :
  1190. st:=tobjectdef(tvarsym(sym).vartype.def).symtable;
  1191. end;
  1192. end;
  1193. typesym :
  1194. begin
  1195. case ttypesym(sym).restype.def.deftype of
  1196. recorddef :
  1197. st:=trecorddef(ttypesym(sym).restype.def).symtable;
  1198. objectdef :
  1199. st:=tobjectdef(ttypesym(sym).restype.def).symtable;
  1200. end;
  1201. end;
  1202. typedconstsym :
  1203. begin
  1204. case ttypedconstsym(sym).typedconsttype.def.deftype of
  1205. recorddef :
  1206. st:=trecorddef(ttypedconstsym(sym).typedconsttype.def).symtable;
  1207. objectdef :
  1208. st:=tobjectdef(ttypedconstsym(sym).typedconsttype.def).symtable;
  1209. end;
  1210. end;
  1211. end;
  1212. end;
  1213. { now walk all recordsymtables }
  1214. while assigned(st) and (s<>'') do
  1215. begin
  1216. { load next field in base }
  1217. i:=pos('.',s);
  1218. if i=0 then
  1219. i:=255;
  1220. base:=Copy(s,1,i-1);
  1221. delete(s,1,i);
  1222. if st.symtabletype=objectsymtable then
  1223. sym:=search_class_member(tobjectdef(st.defowner),base)
  1224. else
  1225. sym:=tsym(st.search(base));
  1226. if not assigned(sym) then
  1227. begin
  1228. GetRecordOffsetSize:=false;
  1229. exit;
  1230. end;
  1231. st:=nil;
  1232. case sym.typ of
  1233. varsym :
  1234. begin
  1235. inc(Offset,tvarsym(sym).address);
  1236. Size:=tvarsym(sym).getsize;
  1237. case tvarsym(sym).vartype.def.deftype of
  1238. arraydef :
  1239. begin
  1240. { for arrays try to get the element size, take care of
  1241. multiple indexes }
  1242. harrdef:=tarraydef(tvarsym(sym).vartype.def);
  1243. while assigned(harrdef.elementtype.def) and
  1244. (harrdef.elementtype.def.deftype=arraydef) do
  1245. harrdef:=tarraydef(harrdef.elementtype.def);
  1246. size:=harrdef.elesize;
  1247. end;
  1248. recorddef :
  1249. st:=trecorddef(tvarsym(sym).vartype.def).symtable;
  1250. objectdef :
  1251. st:=tobjectdef(tvarsym(sym).vartype.def).symtable;
  1252. end;
  1253. end;
  1254. end;
  1255. end;
  1256. GetRecordOffsetSize:=(s='');
  1257. end;
  1258. Function SearchLabel(const s: string; var hl: tasmlabel;emit:boolean): boolean;
  1259. var
  1260. sym : tsym;
  1261. srsymtable : tsymtable;
  1262. hs : string;
  1263. Begin
  1264. hl:=nil;
  1265. SearchLabel:=false;
  1266. { Check for pascal labels, which are case insensetive }
  1267. hs:=upper(s);
  1268. asmsearchsym(hs,sym,srsymtable);
  1269. if sym=nil then
  1270. exit;
  1271. case sym.typ of
  1272. labelsym :
  1273. begin
  1274. hl:=tlabelsym(sym).lab;
  1275. if emit then
  1276. tlabelsym(sym).defined:=true
  1277. else
  1278. tlabelsym(sym).used:=true;
  1279. SearchLabel:=true;
  1280. exit;
  1281. end;
  1282. end;
  1283. end;
  1284. {*************************************************************************}
  1285. { Instruction Generation Utilities }
  1286. {*************************************************************************}
  1287. Procedure ConcatString(p : TAAsmoutput;s:string);
  1288. {*********************************************************************}
  1289. { PROCEDURE ConcatString(s:string); }
  1290. { Description: This routine adds the character chain pointed to in }
  1291. { s to the instruction linked list. }
  1292. {*********************************************************************}
  1293. Var
  1294. pc: PChar;
  1295. Begin
  1296. getmem(pc,length(s)+1);
  1297. p.concat(Tai_string.Create_length_pchar(strpcopy(pc,s),length(s)));
  1298. end;
  1299. Procedure ConcatPasString(p : TAAsmoutput;s:string);
  1300. {*********************************************************************}
  1301. { PROCEDURE ConcatPasString(s:string); }
  1302. { Description: This routine adds the character chain pointed to in }
  1303. { s to the instruction linked list, contrary to ConcatString it }
  1304. { uses a pascal style string, so it conserves null characters. }
  1305. {*********************************************************************}
  1306. Begin
  1307. p.concat(Tai_string.Create(s));
  1308. end;
  1309. Procedure ConcatDirect(p : TAAsmoutput;s:string);
  1310. {*********************************************************************}
  1311. { PROCEDURE ConcatDirect(s:string) }
  1312. { Description: This routine output the string directly to the asm }
  1313. { output, it is only sed when writing special labels in AT&T mode, }
  1314. { and should not be used without due consideration, since it may }
  1315. { cause problems. }
  1316. {*********************************************************************}
  1317. Var
  1318. pc: PChar;
  1319. Begin
  1320. getmem(pc,length(s)+1);
  1321. p.concat(Tai_direct.Create(strpcopy(pc,s)));
  1322. end;
  1323. Procedure ConcatConstant(p: TAAsmoutput; value: longint; maxvalue: longint);
  1324. {*********************************************************************}
  1325. { PROCEDURE ConcatConstant(value: longint; maxvalue: longint); }
  1326. { Description: This routine adds the value constant to the current }
  1327. { instruction linked list. }
  1328. { maxvalue -> indicates the size of the data to initialize: }
  1329. { $ff -> create a byte node. }
  1330. { $ffff -> create a word node. }
  1331. { $ffffffff -> create a dword node. }
  1332. {*********************************************************************}
  1333. Begin
  1334. if (maxvalue <> longint($ffffffff)) and (value > maxvalue) then
  1335. Begin
  1336. Message(asmr_e_constant_out_of_bounds);
  1337. { assuming a value of maxvalue }
  1338. value:=maxvalue;
  1339. end;
  1340. if maxvalue = $ff then
  1341. p.concat(Tai_const.Create_8bit(byte(value)))
  1342. else
  1343. if maxvalue = $ffff then
  1344. p.concat(Tai_const.Create_16bit(word(value)))
  1345. else
  1346. if maxvalue = longint($ffffffff) then
  1347. p.concat(Tai_const.Create_32bit(longint(value)));
  1348. end;
  1349. Procedure ConcatConstSymbol(p : TAAsmoutput;const sym:string;l:longint);
  1350. begin
  1351. p.concat(Tai_const_symbol.Createname_offset(sym,l));
  1352. end;
  1353. Procedure ConcatRealConstant(p : TAAsmoutput;value: bestreal; real_typ : tfloattype);
  1354. {***********************************************************************}
  1355. { PROCEDURE ConcatRealConstant(value: bestreal; real_typ : tfloattype); }
  1356. { Description: This routine adds the value constant to the current }
  1357. { instruction linked list. }
  1358. { real_typ -> indicates the type of the real data to initialize: }
  1359. { s32real -> create a single node. }
  1360. { s64real -> create a double node. }
  1361. { s80real -> create an extended node. }
  1362. { s64bit -> create a comp node. }
  1363. { f32bit -> create a fixed node. (not used normally) }
  1364. {***********************************************************************}
  1365. Begin
  1366. case real_typ of
  1367. s32real : p.concat(Tai_real_32bit.Create(value));
  1368. s64real : p.concat(Tai_real_64bit.Create(value));
  1369. s80real : p.concat(Tai_real_80bit.Create(value));
  1370. s64comp : p.concat(Tai_comp_64bit.Create(value));
  1371. end;
  1372. end;
  1373. Procedure ConcatLabel(p: TAAsmoutput;var l : tasmlabel);
  1374. {*********************************************************************}
  1375. { PROCEDURE ConcatLabel }
  1376. { Description: This routine either emits a label or a labeled }
  1377. { instruction to the linked list of instructions. }
  1378. {*********************************************************************}
  1379. begin
  1380. p.concat(Tai_label.Create(l));
  1381. end;
  1382. procedure ConcatAlign(p:TAAsmoutput;l:longint);
  1383. {*********************************************************************}
  1384. { PROCEDURE ConcatPublic }
  1385. { Description: This routine emits an global definition to the }
  1386. { linked list of instructions.(used by AT&T styled asm) }
  1387. {*********************************************************************}
  1388. begin
  1389. p.concat(Tai_align.Create(l));
  1390. end;
  1391. procedure ConcatPublic(p:TAAsmoutput;const s : string);
  1392. {*********************************************************************}
  1393. { PROCEDURE ConcatPublic }
  1394. { Description: This routine emits an global definition to the }
  1395. { linked list of instructions.(used by AT&T styled asm) }
  1396. {*********************************************************************}
  1397. begin
  1398. p.concat(Tai_symbol.Createname_global(s,0));
  1399. end;
  1400. procedure ConcatLocal(p:TAAsmoutput;const s : string);
  1401. {*********************************************************************}
  1402. { PROCEDURE ConcatLocal }
  1403. { Description: This routine emits an local definition to the }
  1404. { linked list of instructions. }
  1405. {*********************************************************************}
  1406. begin
  1407. p.concat(Tai_symbol.Createname(s,0));
  1408. end;
  1409. Procedure ConcatGlobalBss(const s : string;size : longint);
  1410. {*********************************************************************}
  1411. { PROCEDURE ConcatGlobalBss }
  1412. { Description: This routine emits an global datablock to the }
  1413. { linked list of instructions. }
  1414. {*********************************************************************}
  1415. begin
  1416. bssSegment.concat(Tai_datablock.Create_global(s,size));
  1417. end;
  1418. Procedure ConcatLocalBss(const s : string;size : longint);
  1419. {*********************************************************************}
  1420. { PROCEDURE ConcatLocalBss }
  1421. { Description: This routine emits a local datablcok to the }
  1422. { linked list of instructions. }
  1423. {*********************************************************************}
  1424. begin
  1425. bssSegment.concat(Tai_datablock.Create(s,size));
  1426. end;
  1427. end.
  1428. {
  1429. $Log$
  1430. Revision 1.55 2003-04-06 21:11:23 olle
  1431. * changed newasmsymbol to newasmsymboldata for data symbols
  1432. Revision 1.54 2003/03/28 19:16:57 peter
  1433. * generic constructor working for i386
  1434. * remove fixed self register
  1435. * esi added as address register for i386
  1436. Revision 1.53 2003/02/19 22:00:14 daniel
  1437. * Code generator converted to new register notation
  1438. - Horribily outdated todo.txt removed
  1439. Revision 1.52 2003/01/08 18:43:56 daniel
  1440. * Tregister changed into a record
  1441. Revision 1.51 2002/12/14 15:02:03 carl
  1442. * maxoperands -> max_operands (for portability in rautils.pas)
  1443. * fix some range-check errors with loadconst
  1444. + add ncgadd unit to m68k
  1445. * some bugfix of a_param_reg with LOC_CREFERENCE
  1446. Revision 1.50 2002/11/25 17:43:23 peter
  1447. * splitted defbase in defutil,symutil,defcmp
  1448. * merged isconvertable and is_equal into compare_defs(_ext)
  1449. * made operator search faster by walking the list only once
  1450. Revision 1.49 2002/11/22 22:48:10 carl
  1451. * memory optimization with tconstsym (1.5%)
  1452. Revision 1.48 2002/11/18 17:31:59 peter
  1453. * pass proccalloption to ret_in_xxx and push_xxx functions
  1454. Revision 1.47 2002/11/15 16:29:31 peter
  1455. * made tasmsymbol.refs private (merged)
  1456. Revision 1.46 2002/09/03 16:26:27 daniel
  1457. * Make Tprocdef.defs protected
  1458. Revision 1.45 2002/08/25 19:25:20 peter
  1459. * sym.insert_in_data removed
  1460. * symtable.insertvardata/insertconstdata added
  1461. * removed insert_in_data call from symtable.insert, it needs to be
  1462. called separatly. This allows to deref the address calculation
  1463. * procedures now calculate the parast addresses after the procedure
  1464. directives are parsed. This fixes the cdecl parast problem
  1465. * push_addr_param has an extra argument that specifies if cdecl is used
  1466. or not
  1467. Revision 1.44 2002/08/17 09:23:41 florian
  1468. * first part of procinfo rewrite
  1469. Revision 1.43 2002/08/16 14:24:59 carl
  1470. * issameref() to test if two references are the same (then emit no opcodes)
  1471. + ret_in_reg to replace ret_in_acc
  1472. (fix some register allocation bugs at the same time)
  1473. + save_std_register now has an extra parameter which is the
  1474. usedinproc registers
  1475. Revision 1.42 2002/08/13 18:01:52 carl
  1476. * rename swatoperands to swapoperands
  1477. + m68k first compilable version (still needs a lot of testing):
  1478. assembler generator, system information , inline
  1479. assembler reader.
  1480. Revision 1.41 2002/08/12 15:08:40 carl
  1481. + stab register indexes for powerpc (moved from gdb to cpubase)
  1482. + tprocessor enumeration moved to cpuinfo
  1483. + linker in target_info is now a class
  1484. * many many updates for m68k (will soon start to compile)
  1485. - removed some ifdef or correct them for correct cpu
  1486. Revision 1.40 2002/08/11 14:32:27 peter
  1487. * renamed current_library to objectlibrary
  1488. Revision 1.39 2002/08/11 13:24:13 peter
  1489. * saving of asmsymbols in ppu supported
  1490. * asmsymbollist global is removed and moved into a new class
  1491. tasmlibrarydata that will hold the info of a .a file which
  1492. corresponds with a single module. Added librarydata to tmodule
  1493. to keep the library info stored for the module. In the future the
  1494. objectfiles will also be stored to the tasmlibrarydata class
  1495. * all getlabel/newasmsymbol and friends are moved to the new class
  1496. Revision 1.38 2002/07/20 11:57:57 florian
  1497. * types.pas renamed to defbase.pas because D6 contains a types
  1498. unit so this would conflicts if D6 programms are compiled
  1499. + Willamette/SSE2 instructions to assembler added
  1500. Revision 1.37 2002/07/11 14:41:28 florian
  1501. * start of the new generic parameter handling
  1502. Revision 1.36 2002/07/01 18:46:25 peter
  1503. * internal linker
  1504. * reorganized aasm layer
  1505. Revision 1.35 2002/05/18 13:34:17 peter
  1506. * readded missing revisions
  1507. Revision 1.34 2002/05/16 19:46:44 carl
  1508. + defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
  1509. + try to fix temp allocation (still in ifdef)
  1510. + generic constructor calls
  1511. + start of tassembler / tmodulebase class cleanup
  1512. Revision 1.31 2002/05/12 16:53:10 peter
  1513. * moved entry and exitcode to ncgutil and cgobj
  1514. * foreach gets extra argument for passing local data to the
  1515. iterator function
  1516. * -CR checks also class typecasts at runtime by changing them
  1517. into as
  1518. * fixed compiler to cycle with the -CR option
  1519. * fixed stabs with elf writer, finally the global variables can
  1520. be watched
  1521. * removed a lot of routines from cga unit and replaced them by
  1522. calls to cgobj
  1523. * u32bit-s32bit updates for and,or,xor nodes. When one element is
  1524. u32bit then the other is typecasted also to u32bit without giving
  1525. a rangecheck warning/error.
  1526. * fixed pascal calling method with reversing also the high tree in
  1527. the parast, detected by tcalcst3 test
  1528. Revision 1.30 2002/04/20 21:32:24 carl
  1529. + generic FPC_CHECKPOINTER
  1530. + first parameter offset in stack now portable
  1531. * rename some constants
  1532. + move some cpu stuff to other units
  1533. - remove unused constents
  1534. * fix stacksize for some targets
  1535. * fix generic size problems which depend now on EXTEND_SIZE constant
  1536. Revision 1.29 2002/04/15 19:02:35 carl
  1537. + target_info.size_of_pointer -> pointer_Size
  1538. Revision 1.28 2002/04/02 17:11:29 peter
  1539. * tlocation,treference update
  1540. * LOC_CONSTANT added for better constant handling
  1541. * secondadd splitted in multiple routines
  1542. * location_force_reg added for loading a location to a register
  1543. of a specified size
  1544. * secondassignment parses now first the right and then the left node
  1545. (this is compatible with Kylix). This saves a lot of push/pop especially
  1546. with string operations
  1547. * adapted some routines to use the new cg methods
  1548. Revision 1.27 2002/01/29 21:32:03 peter
  1549. * allow accessing locals in other lexlevel when the current assembler
  1550. routine doesn't have locals.
  1551. Revision 1.26 2002/01/24 18:25:50 peter
  1552. * implicit result variable generation for assembler routines
  1553. * removed m_tp modeswitch, use m_tp7 or not(m_fpc) instead
  1554. }