asmutils.pas 58 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637
  1. {
  2. $Id$
  3. Copyright (c) 1998 Carl Eric Codere
  4. This unit implements some support routines for assembler parsing
  5. This program is free software; you can redistribute it and/or modify
  6. it under the terms of the GNU General Public License as published by
  7. the Free Software Foundation; either version 2 of the License, or
  8. (at your option) any later version.
  9. This program is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  12. GNU General Public License for more details.
  13. You should have received a copy of the GNU General Public License
  14. along with this program; if not, write to the Free Software
  15. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  16. **********************************************************************}
  17. Unit AsmUtils;
  18. {*************************************************************************}
  19. { This unit implements some objects as well as utilities which will be }
  20. { used by all inline assembler parsers (non-processor specific). }
  21. { }
  22. { Main routines/objects herein: }
  23. { o Object TExprParse is a simple expression parser to resolve assembler }
  24. { expressions. (Based generally on some code by Thai Tran from SWAG). }
  25. { o Object TInstruction is a simple object used for instructions }
  26. { o Record TOperand is a simple record used to store information on }
  27. { each operand. }
  28. { o String conversion routines from octal,binary and hex to decimal. }
  29. { o A linked list object/record for local labels }
  30. { o Routines for retrieving symbols (local and global) }
  31. { o Object for a linked list of strings (with duplicate strings not }
  32. { allowed). }
  33. { o Non-processor dependant routines for adding instructions to the }
  34. { instruction list. }
  35. {*************************************************************************}
  36. {--------------------------------------------------------------------}
  37. { LEFT TO DO: }
  38. { o Fix the remaining bugs in the expression parser, such as with }
  39. { 4+-3 }
  40. { o Add support for local typed constants search. }
  41. { o Add support for private/protected fields in method assembler }
  42. { routines. }
  43. {--------------------------------------------------------------------}
  44. Interface
  45. Uses
  46. symtable,aasm,hcodegen,verbose,systems,globals,files,strings,
  47. cobjects,
  48. {$ifdef i386}
  49. i386;
  50. {$endif}
  51. {$ifdef m68k}
  52. m68k;
  53. {$endif}
  54. Const
  55. RPNMax = 10; { I think you only need 4, but just to be safe }
  56. OpMax = 25;
  57. maxoperands = 3; { Maximum operands for assembler instructions }
  58. Type
  59. {---------------------------------------------------------------------}
  60. { Label Management types }
  61. {---------------------------------------------------------------------}
  62. PAsmLabel = ^TAsmLabel;
  63. PString = ^String;
  64. { Each local label has this structure associated with it }
  65. TAsmLabel = record
  66. name: PString; { pointer to a pascal string name of label }
  67. lab: PLabel; { pointer to a label as defined in FPC }
  68. emitted: boolean; { as the label itself been emitted ? }
  69. next: PAsmLabel; { next node }
  70. end;
  71. TAsmLabelList = Object
  72. public
  73. First: PAsmLabel;
  74. Constructor Init;
  75. Destructor Done;
  76. Procedure Insert(s:string; lab: PLabel; emitted: boolean);
  77. Function Search(const s: string): PAsmLabel;
  78. private
  79. Last: PAsmLabel;
  80. Function NewPasStr(s:string): PString;
  81. end;
  82. {---------------------------------------------------------------------}
  83. { Instruction management types }
  84. {---------------------------------------------------------------------}
  85. toperandtype = (OPR_NONE,OPR_REFERENCE,OPR_CONSTANT,OPR_REGISTER,OPR_LABINSTR,
  86. OPR_REGLIST,OPR_SYMBOL);
  87. { When the TReference field isintvalue = TRUE }
  88. { then offset points to an ABSOLUTE address }
  89. { otherwise isintvalue should always be false }
  90. { Special cases: }
  91. { For the M68k Target, size is UNUSED, the }
  92. { opcode determines the size of the }
  93. { instruction. }
  94. { DIVS/DIVU/MULS/MULU of the form dn,dn:dn }
  95. { is stored as three operands!! }
  96. { Each instruction operand can be of this type }
  97. TOperand = record
  98. size: topsize;
  99. opinfo: longint; { ao_xxxx flags }
  100. case operandtype:toperandtype of
  101. { the size of the opr_none field should be at least equal to each }
  102. { other field as to facilitate initialization. }
  103. OPR_NONE: (l: array[1..sizeof(treference)] of byte);
  104. OPR_REFERENCE: (ref:treference);
  105. OPR_CONSTANT: (val: longint);
  106. OPR_REGISTER: (reg:tregister);
  107. OPR_LABINSTR: (hl: plabel);
  108. { Register list such as in the movem instruction }
  109. OPR_REGLIST: (list: set of tregister);
  110. OPR_SYMBOL : (symbol:pstring);
  111. end;
  112. TInstruction = object
  113. public
  114. operands: array[1..maxoperands] of TOperand;
  115. { if numops = zero, a size may still be valid in operands[1] }
  116. { it still should be checked. }
  117. numops: byte;
  118. { set to TRUE if the instruction is labeled. }
  119. labeled: boolean;
  120. { This is used for instructions such A_CMPSB... etc, to determine }
  121. { the size of the instruction. }
  122. stropsize: topsize;
  123. procedure init;
  124. { sets up the prefix field with the instruction pointed to in s }
  125. procedure addprefix(tok: tasmop);
  126. { sets up the instruction with the instruction pointed to in s }
  127. procedure addinstr(tok: tasmop);
  128. { get the current instruction of this object }
  129. function getinstruction: tasmop;
  130. { get the current prefix of this instruction }
  131. function getprefix: tasmop;
  132. private
  133. prefix: tasmop;
  134. instruction: tasmop;
  135. end;
  136. {---------------------------------------------------------------------}
  137. { Expression parser types }
  138. {---------------------------------------------------------------------}
  139. { expression parser error codes }
  140. texpr_error =
  141. (zero_divide, { divide by zero. }
  142. stack_overflow, { stack overflow. }
  143. stack_underflow, { stack underflow. }
  144. invalid_number, { invalid conversion }
  145. invalid_op); { invalid operator }
  146. TExprOperator = record
  147. ch: char; { operator }
  148. is_prefix: boolean; { was it a prefix, possible prefixes are +,- and not }
  149. end;
  150. String15 = String[15];
  151. {**********************************************************************}
  152. { The following operators are supported: }
  153. { '+' : addition }
  154. { '-' : subtraction }
  155. { '*' : multiplication }
  156. { '/' : modulo division }
  157. { '^' : exclusive or }
  158. { '<' : shift left }
  159. { '>' : shift right }
  160. { '&' : bitwise and }
  161. { '|' : bitwise or }
  162. { '~' : bitwise complement }
  163. { '%' : modulo division }
  164. { nnn: longint numbers }
  165. { ( and ) parenthesis }
  166. {**********************************************************************}
  167. TExprParse = Object
  168. public
  169. Constructor Init;
  170. Destructor Done;
  171. Function Evaluate(Expr: String): longint;
  172. Procedure Error(anerror: texpr_error); virtual;
  173. Function Priority(_Operator: Char): Integer; virtual;
  174. private
  175. RPNStack : Array[1..RPNMax] of longint; { Stack For RPN calculator }
  176. RPNTop : Integer;
  177. OpStack : Array[1..OpMax] of TExprOperator; { Operator stack For conversion }
  178. OpTop : Integer;
  179. Procedure RPNPush(Num: Longint);
  180. Function RPNPop: Longint;
  181. Procedure RPNCalc(token: String15; prefix: boolean);
  182. Procedure OpPush(_Operator: char; prefix: boolean);
  183. { In reality returns TExprOperaotr }
  184. Procedure OpPop(var _Operator:TExprOperator);
  185. end;
  186. {---------------------------------------------------------------------}
  187. { String routines }
  188. {---------------------------------------------------------------------}
  189. {*********************************************************************}
  190. { PROCEDURE PadZero; }
  191. { Description: Makes sure that the string specified is of the given }
  192. { length, by padding it with binary zeros, or truncating if necessary}
  193. { Remark: The return value is determined BEFORE any eventual padding.}
  194. { Return Value: TRUE = if length of string s was <= then n }
  195. { FALSE = if length of string s was > then n }
  196. {*********************************************************************}
  197. Function PadZero(Var s: String; n: byte): Boolean;
  198. { Converts an Hex digit string to a Decimal string }
  199. { Returns '' if there was an error. }
  200. Function HexToDec(const S:String): String;
  201. { Converts a binary digit string to a Decimal string }
  202. { Returns '' if there was an error. }
  203. Function BinaryToDec(const S:String): String;
  204. { Converts an octal digit string to a Decimal string }
  205. { Returns '' if there was an error. }
  206. Function OctalToDec(const S:String): String;
  207. { Converts a string containing C styled escape sequences to }
  208. { a pascal style string. }
  209. Function EscapeToPascal(const s:string): string;
  210. Procedure ConcatPasString(p : paasmoutput;s:string);
  211. { Writes the string s directly to the assembler output }
  212. Procedure ConcatDirect(p : paasmoutput;s:string);
  213. {---------------------------------------------------------------------}
  214. { Symbol helper routines }
  215. {---------------------------------------------------------------------}
  216. Function GetTypeOffset(const base: string; const field: string;
  217. Var Offset: longint):boolean;
  218. Function GetVarOffset(const base: string; const field: string;
  219. Var Offset: longint):boolean;
  220. Function SearchIConstant(const s:string; var l:longint): boolean;
  221. Function SearchLabel(const s: string; var hl: plabel): boolean;
  222. Function CreateVarInstr(var Instr: TInstruction; const hs:string;
  223. operandnum:byte):boolean;
  224. {*********************************************************************}
  225. { FUNCTION NewPasStr(s:string): PString }
  226. { Description: This routine allocates a string on the heap and }
  227. { returns a pointer to the allocated string. }
  228. { }
  229. { Remarks: The string allocated should not be modified, since it's }
  230. { length will be less then 255. }
  231. { Remarks: It is assumed that HeapError will be called if an }
  232. { allocation fails. }
  233. {*********************************************************************}
  234. Function newpasstr(s: string): Pointer;
  235. Procedure SetupResult(Var Instr:TInstruction; operandnum: byte);
  236. Procedure FWaitWarning;
  237. {---------------------------------------------------------------------}
  238. { Instruction generation routines }
  239. {---------------------------------------------------------------------}
  240. { swaps in the case of a 2/3 operand opcode the destination and the }
  241. { source as to put it in AT&T style instruction format. }
  242. Procedure SwapOperands(Var instr: TInstruction);
  243. Procedure ConcatLabel(p : paasmoutput;op : tasmop;var l : plabel);
  244. Procedure ConcatConstant(p : paasmoutput;value: longint; maxvalue: longint);
  245. Procedure ConcatRealConstant(p : paasmoutput;value: bestreal; real_typ : tfloattype);
  246. Procedure ConcatString(p : paasmoutput;s:string);
  247. Procedure ConcatPublic(p:paasmoutput;const s : string);
  248. Procedure ConcatLocal(p:paasmoutput;const s : string);
  249. Procedure ConcatGlobalBss(const s : string;size : longint);
  250. Procedure ConcatLocalBss(const s : string;size : longint);
  251. { add to list of external labels }
  252. Procedure ConcatExternal(const s : string;typ : texternal_typ);
  253. { add to internal list of labels }
  254. Procedure ConcatInternal(const s : string;typ : texternal_typ);
  255. Implementation
  256. {*************************************************************************}
  257. { Expression Parser }
  258. {*************************************************************************}
  259. Constructor TExprParse.Init;
  260. Begin
  261. end;
  262. Procedure TExprParse.Error(anerror:texpr_error);
  263. var
  264. t : tmsgconst;
  265. Begin
  266. case anerror of
  267. zero_divide: t:=assem_f_ev_zero_divide;
  268. stack_overflow: t:=assem_f_ev_stack_overflow;
  269. stack_underflow: t:=assem_f_ev_stack_underflow;
  270. invalid_number: t:=assem_f_ev_invalid_number;
  271. invalid_op: t:=assem_f_ev_invalid_op;
  272. else
  273. t:=assem_f_ev_unknown;
  274. end;
  275. Message(t);
  276. end;
  277. Procedure TExprParse.RPNPush(Num : longint); { Add an operand to the top of the RPN stack }
  278. begin
  279. if RPNTop < RPNMax then
  280. begin
  281. Inc(RPNTop);
  282. RPNStack[RPNTop] := Num;
  283. end
  284. else
  285. Error(stack_overflow); { Put some error handler here }
  286. end;
  287. Function TExprParse.RPNPop : longint; { Get the operand at the top of the RPN stack }
  288. begin
  289. if RPNTop > 0 then
  290. begin
  291. RPNPop := RPNStack[RPNTop];
  292. Dec(RPNTop);
  293. end
  294. else { Put some error handler here }
  295. Error(stack_underflow);
  296. end;
  297. Procedure TExprParse.RPNCalc(Token : String15; prefix:boolean); { RPN Calculator }
  298. Var
  299. Temp : longint;
  300. LocalError : Integer;
  301. begin
  302. { Write(Token, ' '); This just outputs the RPN expression }
  303. if (Length(Token) = 1) and (Token[1] in ['+', '-', '*', '/','&','|','%','^','~','<','>']) then
  304. Case Token[1] of { Handle operators }
  305. '+' : Begin
  306. if prefix then
  307. else
  308. RPNPush(RPNPop + RPNPop);
  309. end;
  310. '-' : Begin
  311. if prefix then
  312. RPNPush(-(RPNPop))
  313. else
  314. RPNPush(RPNPop - RPNPop);
  315. end;
  316. '*' : RPNPush(RPNPop * RPNPop);
  317. '&' : RPNPush(RPNPop AND RPNPop);
  318. '|' : RPNPush(RPNPop OR RPNPop);
  319. '~' : RPNPush(NOT RPNPop);
  320. '<' : RPNPush(RPNPop SHL RPNPop);
  321. '>' : RPNPush(RPNPop SHR RPNPop);
  322. '%' : begin
  323. Temp := RPNPop;
  324. if Temp <> 0 then
  325. RPNPush(RPNPop mod Temp)
  326. else Error(zero_divide); { Handle divide by zero error }
  327. end;
  328. '^' : RPNPush(RPNPop XOR RPNPop);
  329. '/' :
  330. begin
  331. Temp := RPNPop;
  332. if Temp <> 0 then
  333. RPNPush(RPNPop div Temp)
  334. else Error(zero_divide);{ Handle divide by 0 error }
  335. end;
  336. end
  337. else
  338. begin { Convert String to number and add to stack }
  339. if token='-2147483648' then
  340. begin
  341. temp:=$80000000;
  342. localerror:=0;
  343. end
  344. else
  345. Val(Token, Temp, LocalError);
  346. if LocalError = 0 then
  347. RPNPush(Temp)
  348. else Error(invalid_number);{ Handle error }
  349. end;
  350. end;
  351. Procedure TExprParse.OpPush(_Operator : char;prefix: boolean); { Add an operator onto top of the stack }
  352. begin
  353. if OpTop < OpMax then
  354. begin
  355. Inc(OpTop);
  356. OpStack[OpTop].ch := _Operator;
  357. OpStack[OpTop].is_prefix := prefix;
  358. end
  359. else Error(stack_overflow); { Put some error handler here }
  360. end;
  361. Procedure TExprParse.OpPop(var _Operator:TExprOperator); { Get operator at the top of the stack }
  362. begin
  363. if OpTop > 0 then
  364. begin
  365. _Operator := OpStack[OpTop];
  366. Dec(OpTop);
  367. end
  368. else Error(stack_underflow); { Put some error handler here }
  369. end;
  370. Function TExprParse.Priority(_Operator : Char) : Integer; { Return priority of operator }
  371. { The greater the priority, the higher the precedence }
  372. begin
  373. Case _Operator OF
  374. '(' : Priority := 0;
  375. '+', '-' : Priority := 1;
  376. '*', '/','%','<','>' : Priority := 2;
  377. '|','&','^','~': Priority := 0;
  378. else Error(invalid_op);{ More error handling }
  379. end;
  380. end;
  381. Function TExprParse.Evaluate(Expr : String):longint;
  382. Var
  383. I : Integer;
  384. Token : String15;
  385. opr: TExprOperator;
  386. begin
  387. OpTop := 0; { Reset stacks }
  388. RPNTop := 0;
  389. Token := '';
  390. For I := 1 to Length(Expr) DO
  391. if Expr[I] in ['0'..'9'] then
  392. begin { Build multi-digit numbers }
  393. Token := Token + Expr[I];
  394. if I = Length(Expr) then { Send last one to calculator }
  395. RPNCalc(Token,false);
  396. end
  397. else
  398. if Expr[I] in ['+', '-', '*', '/', '(', ')','^','&','|','%','~','<','>'] then
  399. begin
  400. if Token <> '' then
  401. begin { Send last built number to calc. }
  402. RPNCalc(Token,false);
  403. Token := '';
  404. end;
  405. Case Expr[I] OF
  406. '(' : OpPush('(',false);
  407. ')' :
  408. begin
  409. While OpStack[OpTop].ch <> '(' DO
  410. Begin
  411. OpPop(opr);
  412. RPNCalc(opr.ch,opr.is_prefix);
  413. end;
  414. OpPop(opr); { Pop off and ignore the '(' }
  415. end;
  416. '+','-','~': Begin
  417. While (OpTop > 0) AND
  418. (Priority(Expr[I]) <= Priority(OpStack[OpTop].ch)) DO
  419. Begin
  420. OpPop(opr);
  421. RPNCalc(opr.ch,opr.is_prefix);
  422. end;
  423. { if start of expression then surely a prefix }
  424. { or if previous char was also an operator }
  425. { push it and don't evaluate normally }
  426. { workaround for -2147483648 }
  427. if (expr[I]='-') and (expr[i+1] in ['0'..'9']) then
  428. begin
  429. token:='-';
  430. expr[i]:='+';
  431. end;
  432. if (I = 1) or (not (Expr[I-1] in ['0'..'9','(',')'])) then
  433. OpPush(Expr[I],true)
  434. else
  435. OpPush(Expr[I],false);
  436. end;
  437. '*', '/','^','|','&','%','<','>' :
  438. begin
  439. While (OpTop > 0) AND
  440. (Priority(Expr[I]) <= Priority(OpStack[OpTop].ch)) DO
  441. Begin
  442. OpPop(opr);
  443. RPNCalc(opr.ch,opr.is_prefix);
  444. end;
  445. OpPush(Expr[I],false);
  446. end;
  447. end; { Case }
  448. end
  449. else Error(invalid_op);
  450. { Handle bad input error }
  451. While OpTop > 0 do { Pop off the remaining operators }
  452. Begin
  453. OpPop(opr);
  454. RPNCalc(opr.ch,opr.is_prefix);
  455. end;
  456. { The result is stored on the top of the stack }
  457. Evaluate := RPNPop;
  458. end;
  459. Destructor TExprParse.Done;
  460. Begin
  461. end;
  462. {*************************************************************************}
  463. { String conversions/utils }
  464. {*************************************************************************}
  465. Function newpasstr(s: string): Pointer;
  466. Var
  467. StrPtr: PString;
  468. Begin
  469. GetMem(StrPtr, length(s)+1);
  470. Move(s,StrPtr^,length(s)+1);
  471. newpasstr:= Strptr;
  472. end;
  473. Function EscapeToPascal(const s:string): string;
  474. { converts a C styled string - which contains escape }
  475. { characters to a pascal style string. }
  476. var
  477. i,j: word;
  478. str: string;
  479. temp: string;
  480. value: byte;
  481. code: integer;
  482. Begin
  483. str:='';
  484. i:=1;
  485. j:=1;
  486. repeat
  487. if s[i] = '\' then
  488. Begin
  489. Inc(i);
  490. if i > 255 then
  491. Begin
  492. EscapeToPascal:=str;
  493. exit;
  494. end;
  495. case s[i] of
  496. '\': insert('\',str,j);
  497. 'b': insert(#08,str,j);
  498. 'f': insert(#12,str,j);
  499. 'n': insert(#10,str,j);
  500. 'r': insert(#13,str,j);
  501. 't': insert(#09,str,j);
  502. '"': insert('"',str,j);
  503. { octal number }
  504. '0'..'7': Begin
  505. temp:=s[i];
  506. temp:=temp+s[i+1];
  507. temp:=temp+s[i+2];
  508. inc(i,2);
  509. val(octaltodec(temp),value,code);
  510. if (code <> 0) then
  511. Message(assem_w_invalid_numeric);
  512. insert(chr(value),str,j);
  513. end;
  514. { hexadecimal number }
  515. 'x': Begin
  516. temp:=s[i+1];
  517. temp:=temp+s[i+2];
  518. inc(i,2);
  519. val(hextodec(temp),value,code);
  520. if (code <> 0) then
  521. Message(assem_w_invalid_numeric);
  522. insert(chr(value),str,j);
  523. end;
  524. else
  525. Begin
  526. Message1(assem_e_escape_seq_ignored,s[i]);
  527. insert(s[i],str,j);
  528. end;
  529. end; {end case }
  530. Inc(i);
  531. end
  532. else
  533. Begin
  534. Insert(s[i],str,j);
  535. Inc(i);
  536. if i > 255 then
  537. Begin
  538. EscapeToPascal:=str;
  539. exit;
  540. end;
  541. end;
  542. Inc(j);
  543. until (i > length(s)) or (j > 255);
  544. EscapeToPascal:=str;
  545. end;
  546. Function OctalToDec(const S:String): String;
  547. { Converts an octal string to a Decimal string }
  548. { Returns '' if there was an error. }
  549. var vs: longint;
  550. c: byte;
  551. st: string;
  552. Begin
  553. vs := 0;
  554. for c:=1 to length(s) do
  555. begin
  556. case s[c] of
  557. '0': vs:=vs shl 3;
  558. '1': vs:=vs shl 3+1;
  559. '2': vs:=vs shl 3+2;
  560. '3': vs:=vs shl 3+3;
  561. '4': vs:=vs shl 3+4;
  562. '5': vs:=vs shl 3+5;
  563. '6': vs:=vs shl 3+6;
  564. '7': vs:=vs shl 3+7;
  565. else
  566. begin
  567. OctalToDec := '';
  568. exit;
  569. end;
  570. end;
  571. end;
  572. str(vs,st);
  573. OctalToDec := st;
  574. end;
  575. Function BinaryToDec(const S:String): String;
  576. { Converts a binary string to a Decimal string }
  577. { Returns '' if there was an error. }
  578. var vs: longint;
  579. c: byte;
  580. st: string;
  581. Begin
  582. vs := 0;
  583. for c:=1 to length(s) do
  584. begin
  585. if s[c] = '0' then
  586. vs:=vs shl 1
  587. else
  588. if s[c]='1' then
  589. vs:=vs shl 1+1
  590. else
  591. begin
  592. BinaryToDec := '';
  593. exit;
  594. end;
  595. end;
  596. str(vs,st);
  597. BinaryToDec := st;
  598. end;
  599. Function HexToDec(const S:String): String;
  600. var vs: longint;
  601. c: byte;
  602. st: string;
  603. Begin
  604. vs := 0;
  605. for c:=1 to length(s) do
  606. begin
  607. case upcase(s[c]) of
  608. '0': vs:=vs shl 4;
  609. '1': vs:=vs shl 4+1;
  610. '2': vs:=vs shl 4+2;
  611. '3': vs:=vs shl 4+3;
  612. '4': vs:=vs shl 4+4;
  613. '5': vs:=vs shl 4+5;
  614. '6': vs:=vs shl 4+6;
  615. '7': vs:=vs shl 4+7;
  616. '8': vs:=vs shl 4+8;
  617. '9': vs:=vs shl 4+9;
  618. 'A': vs:=vs shl 4+10;
  619. 'B': vs:=vs shl 4+11;
  620. 'C': vs:=vs shl 4+12;
  621. 'D': vs:=vs shl 4+13;
  622. 'E': vs:=vs shl 4+14;
  623. 'F': vs:=vs shl 4+15;
  624. else
  625. begin
  626. HexToDec := '';
  627. exit;
  628. end;
  629. end;
  630. end;
  631. str(vs,st);
  632. HexToDec := st;
  633. end;
  634. Function PadZero(Var s: String; n: byte): Boolean;
  635. Begin
  636. PadZero := TRUE;
  637. { Do some error checking first }
  638. if Length(s) = n then
  639. exit
  640. else
  641. if Length(s) > n then
  642. Begin
  643. PadZero := FALSE;
  644. delete(s,n+1,length(s));
  645. exit;
  646. end
  647. else
  648. PadZero := TRUE;
  649. { Fill it up with the specified character }
  650. fillchar(s[length(s)+1],n-1,#0);
  651. s[0] := chr(n);
  652. end;
  653. {*************************************************************************}
  654. { Instruction utilities }
  655. {*************************************************************************}
  656. Procedure TInstruction.init;
  657. var
  658. k: integer;
  659. Begin
  660. numops := 0;
  661. labeled := FALSE;
  662. stropsize := S_NO;
  663. prefix := A_NONE;
  664. instruction := A_NONE;
  665. for k:=1 to maxoperands do
  666. begin
  667. operands[k].size := S_NO;
  668. operands[k].operandtype := OPR_NONE;
  669. { init to zeros }
  670. fillchar(operands[k].l, sizeof(operands[k].l),#0);
  671. end;
  672. end;
  673. Procedure TInstruction.addprefix(tok: tasmop);
  674. Begin
  675. if tok = A_NONE then
  676. Message(assem_e_syn_prefix_not_found);
  677. if Prefix = A_NONE then
  678. Prefix := tok
  679. else
  680. Message(assem_e_syn_try_add_more_prefix);
  681. end;
  682. Procedure TInstruction.addinstr(tok: tasmop);
  683. Begin
  684. if tok = A_NONE then
  685. Message(assem_e_syn_opcode_not_found);
  686. Instruction := tok;
  687. end;
  688. function TInstruction.getinstruction: tasmop;
  689. Begin
  690. getinstruction := Instruction;
  691. end;
  692. { get the current prefix of this instruction }
  693. function TInstruction.getprefix: tasmop;
  694. Begin
  695. getprefix := prefix;
  696. end;
  697. {*************************************************************************}
  698. { Local label utilities }
  699. {*************************************************************************}
  700. Constructor TAsmLabelList.Init;
  701. Begin
  702. First := nil;
  703. Last := nil;
  704. end;
  705. Procedure TAsmLabelList.Insert(s:string; lab: PLabel; emitted: boolean);
  706. {*********************************************************************}
  707. { Description: Insert a node at the end of the list with lab and }
  708. { and the name in s. The name is allocated on the heap. }
  709. { Duplicates are not allowed. }
  710. { Indicate in emitted if this label itself has been emitted, or is it}
  711. { a simple labeled instruction? }
  712. {*********************************************************************}
  713. Begin
  714. if search(s) = nil then
  715. Begin
  716. if First = nil then
  717. Begin
  718. New(First);
  719. Last := First;
  720. end
  721. else
  722. Begin
  723. New(Last^.Next);
  724. Last := Last^.Next;
  725. end;
  726. Last^.name := NewPasStr(s);
  727. Last^.Lab := lab;
  728. Last^.Next := nil;
  729. Last^.emitted := emitted;
  730. end;
  731. end;
  732. Function TAsmLabelList.Search(const s: string): PAsmLabel;
  733. {*********************************************************************}
  734. { Description: This routine searches for a label named s in the }
  735. { linked list, returns a pointer to the label if found, otherwise }
  736. { returns nil. }
  737. {*********************************************************************}
  738. Var
  739. asmlab: PAsmLabel;
  740. Begin
  741. asmlab := First;
  742. if First = nil then
  743. Begin
  744. Search := nil;
  745. exit;
  746. end;
  747. While (asmlab^.name^ <> s) and (asmlab^.Next <> nil) do
  748. asmlab := asmlab^.Next;
  749. if asmlab^.name^ = s then
  750. search := asmlab
  751. else
  752. search := nil;
  753. end;
  754. Destructor TAsmLabelList.Done;
  755. {*********************************************************************}
  756. { Description: This routine takes care of deallocating all nodes }
  757. { in the linked list, as well as deallocating the string pointers }
  758. { of these nodes. }
  759. { }
  760. { Remark: The PLabel field is NOT freed, the compiler takes care of }
  761. { this. }
  762. {*********************************************************************}
  763. Var
  764. temp: PAsmLabel;
  765. temp1: PAsmLabel;
  766. Begin
  767. temp := First;
  768. while temp <> nil do
  769. Begin
  770. Freemem(Temp^.name, length(Temp^.name^)+1);
  771. Temp1 := Temp^.Next;
  772. Dispose(Temp);
  773. Temp := Temp1;
  774. { The plabel could be deleted here, but let us not do }
  775. { it, FPC will do it instead. }
  776. end;
  777. end;
  778. Function TAsmLabelList.newpasstr(s: string): PString;
  779. {*********************************************************************}
  780. { FUNCTION NewPasStr(s:string): PString }
  781. { Description: This routine allocates a string on the heap and }
  782. { returns a pointer to the allocated string. }
  783. { }
  784. { Remarks: The string allocated should not be modified, since it's }
  785. { length will be less then 255. }
  786. { Remarks: It is assumed that HeapError will be called if an }
  787. { allocation fails. }
  788. {*********************************************************************}
  789. Var
  790. StrPtr: PString;
  791. Begin
  792. GetMem(StrPtr, length(s)+1);
  793. Move(s,StrPtr^,length(s)+1);
  794. newpasstr:= Strptr;
  795. end;
  796. {*************************************************************************}
  797. { Symbol table helper routines }
  798. {*************************************************************************}
  799. Procedure SwapOperands(Var instr: TInstruction);
  800. Var
  801. tempopr: TOperand;
  802. Begin
  803. if instr.numops = 2 then
  804. Begin
  805. tempopr := instr.operands[1];
  806. instr.operands[1] := instr.operands[2];
  807. instr.operands[2] := tempopr;
  808. end
  809. else
  810. if instr.numops = 3 then
  811. Begin
  812. tempopr := instr.operands[1];
  813. instr.operands[1] := instr.operands[3];
  814. instr.operands[3] := tempopr;
  815. end;
  816. end;
  817. Function SearchIConstant(const s:string; var l:longint): boolean;
  818. {**********************************************************************}
  819. { Description: Searches for a CONSTANT of name s in either the local }
  820. { symbol list, then in the global symbol list, and returns the value }
  821. { of that constant in l. Returns TRUE if successfull, if not found, }
  822. { or if the constant is not of correct type, then returns FALSE }
  823. { Remarks: Also handle TRUE and FALSE returning in those cases 1 and 0 }
  824. { respectively. }
  825. {**********************************************************************}
  826. var
  827. sym: psym;
  828. Begin
  829. SearchIConstant := FALSE;
  830. { check for TRUE or FALSE reserved words first }
  831. if s = 'TRUE' then
  832. Begin
  833. SearchIConstant := TRUE;
  834. l := 1;
  835. end
  836. else
  837. if s = 'FALSE' then
  838. Begin
  839. SearchIConstant := TRUE;
  840. l := 0;
  841. end
  842. else
  843. if assigned(aktprocsym) then
  844. Begin
  845. if assigned(aktprocsym^.definition) then
  846. Begin
  847. { Check the local constants }
  848. if assigned(aktprocsym^.definition^.localst) then
  849. sym := aktprocsym^.definition^.localst^.search(s)
  850. else
  851. sym := nil;
  852. if assigned(sym) then
  853. Begin
  854. if (sym^.typ = constsym) and (pconstsym(sym)^.consttype in
  855. [constord,constint,constchar,constbool]) then
  856. Begin
  857. l:=pconstsym(sym)^.value;
  858. SearchIConstant := TRUE;
  859. exit;
  860. end;
  861. end;
  862. end;
  863. end;
  864. { Check the global constants }
  865. getsym(s,false);
  866. if srsym <> nil then
  867. Begin
  868. if (srsym^.typ=constsym) and (pconstsym(srsym)^.consttype in
  869. [constord,constint,constchar,constbool]) then
  870. Begin
  871. l:=pconstsym(srsym)^.value;
  872. SearchIConstant := TRUE;
  873. exit;
  874. end;
  875. end;
  876. end;
  877. Procedure SetupResult(Var Instr:TInstruction; operandnum: byte);
  878. {**********************************************************************}
  879. { Description: This routine changes the correct fields and correct }
  880. { offset in the reference, so that it points to the __RESULT or }
  881. { @Result variable (depending on the inline asm). }
  882. { Resturns a reference with all correct offset correctly set up. }
  883. { The Operand should already point to a treference on entry. }
  884. {**********************************************************************}
  885. Begin
  886. { replace by correct offset. }
  887. if assigned(procinfo.retdef) and
  888. (procinfo.retdef<>pdef(voiddef)) then
  889. begin
  890. instr.operands[operandnum].ref.offset := procinfo.retoffset;
  891. instr.operands[operandnum].ref.base := procinfo.framepointer;
  892. { always assume that the result is valid. }
  893. procinfo.funcret_is_valid:=true;
  894. end
  895. else
  896. Message(assem_e_invalid_symbol_ref);
  897. end;
  898. Procedure FWaitWarning;
  899. begin
  900. if (target_info.target=target_GO32V2) and (cs_fp_emulation in aktswitches) then
  901. Message(assem_w_fwait_emu_prob);
  902. end;
  903. Function GetVarOffset(const base: string; const field: string;
  904. Var Offset: longint):boolean;
  905. { search and returns the offset of records/objects of the base }
  906. { with field name setup in field. }
  907. { returns 0 if not found. }
  908. { used when base is a variable or a typed constant name. }
  909. var
  910. sym:psym;
  911. p: psym;
  912. Begin
  913. GetVarOffset := FALSE;
  914. Offset := 0;
  915. { local list }
  916. if assigned(aktprocsym) then
  917. begin
  918. if assigned(aktprocsym^.definition^.localst) then
  919. sym:=aktprocsym^.definition^.localst^.search(base)
  920. else
  921. sym:=nil;
  922. if assigned(sym) then
  923. begin
  924. { field of local record variable. }
  925. if (sym^.typ=varsym) and (pvarsym(sym)^.definition^.deftype=recorddef) then
  926. begin
  927. p:=pvarsym(precdef(pvarsym(sym)^.definition)^.symtable^.search(field));
  928. if assigned(pvarsym(p)) then
  929. Begin
  930. Offset := pvarsym(p)^.address;
  931. GetVarOffset := TRUE;
  932. Exit;
  933. end;
  934. end;
  935. end
  936. else
  937. begin
  938. { field of local record parameter to routine. }
  939. if assigned(aktprocsym^.definition^.parast) then
  940. sym:=aktprocsym^.definition^.parast^.search(base)
  941. else
  942. sym:=nil;
  943. if assigned(sym) then
  944. begin
  945. if (sym^.typ=varsym) and (pvarsym(sym)^.definition^.deftype=recorddef)
  946. then
  947. begin
  948. p:=pvarsym(precdef(pvarsym(sym)^.definition)^.symtable^.search(field));
  949. if assigned(p) then
  950. Begin
  951. Offset := pvarsym(p)^.address;
  952. GetVarOffset := TRUE;
  953. Exit;
  954. end;
  955. end; { endif }
  956. end; {endif }
  957. end; { endif }
  958. end;
  959. { not found.. .now look for global variables. }
  960. getsym(base,false);
  961. sym:=srsym;
  962. if assigned(sym) then
  963. Begin
  964. { field of global record variable. }
  965. if (sym^.typ=varsym) and (pvarsym(sym)^.definition^.deftype=recorddef) then
  966. begin
  967. p:=pvarsym(precdef(pvarsym(sym)^.definition)^.symtable^.search(field));
  968. if assigned(p) then
  969. Begin
  970. Offset := pvarsym(p)^.address;
  971. GetVarOffset := TRUE;
  972. Exit;
  973. end;
  974. end
  975. else
  976. { field of global record type constant. }
  977. if (sym^.typ=typedconstsym) and (ptypedconstsym(sym)^.definition^.deftype=recorddef)
  978. then
  979. begin
  980. p:=pvarsym(precdef(pvarsym(sym)^.definition)^.symtable^.search(field));
  981. if assigned(p) then
  982. Begin
  983. Offset := pvarsym(p)^.address;
  984. GetVarOffset := TRUE;
  985. Exit;
  986. end;
  987. end
  988. end; { end looking for global variables .. }
  989. end;
  990. Function GetTypeOffset(const base: string; const field: string;
  991. Var Offset: longint):boolean;
  992. { search and returns the offset of records/objects of the base }
  993. { with field name setup in field. }
  994. { returns 0 if not found. }
  995. { used when base is a variable or a typed constant name. }
  996. var
  997. sym:psym;
  998. p: psym;
  999. Begin
  1000. Offset := 0;
  1001. GetTypeOffset := FALSE;
  1002. { local list }
  1003. if assigned(aktprocsym) then
  1004. begin
  1005. if assigned(aktprocsym^.definition^.localst) then
  1006. sym:=aktprocsym^.definition^.localst^.search(base)
  1007. else
  1008. sym:=nil;
  1009. if assigned(sym) then
  1010. begin
  1011. { field of local record type. }
  1012. if (sym^.typ=typesym) and (ptypesym(sym)^.definition^.deftype=recorddef) then
  1013. begin
  1014. p:=precdef(ptypesym(sym)^.definition)^.symtable^.search(field);
  1015. if assigned(p) then
  1016. Begin
  1017. Offset := pvarsym(p)^.address;
  1018. GetTypeOffset := TRUE;
  1019. Exit;
  1020. end;
  1021. end;
  1022. end
  1023. else
  1024. begin
  1025. { field of local record type to routine. }
  1026. if assigned(aktprocsym^.definition^.parast) then
  1027. sym:=aktprocsym^.definition^.parast^.search(base)
  1028. else
  1029. sym:=nil;
  1030. if assigned(sym) then
  1031. begin
  1032. if (sym^.typ=typesym) and (ptypesym(sym)^.definition^.deftype=recorddef)
  1033. then
  1034. begin
  1035. p:=precdef(ptypesym(sym)^.definition)^.symtable^.search(field);
  1036. if assigned(p) then
  1037. Begin
  1038. Offset := pvarsym(p)^.address;
  1039. GetTypeOffset := TRUE;
  1040. Exit;
  1041. end;
  1042. end; { endif }
  1043. end; {endif }
  1044. end; { endif }
  1045. end;
  1046. { not found.. .now look for global types. }
  1047. getsym(base,false);
  1048. sym:=srsym;
  1049. if assigned(sym) then
  1050. Begin
  1051. { field of global record types. }
  1052. if (sym^.typ=typesym) and (ptypesym(sym)^.definition^.deftype=recorddef) then
  1053. begin
  1054. p:=precdef(ptypesym(sym)^.definition)^.symtable^.search(field);
  1055. if assigned(p) then
  1056. Begin
  1057. Offset := pvarsym(p)^.address;
  1058. GetTypeOffset := TRUE;
  1059. Exit;
  1060. end
  1061. end
  1062. else
  1063. { public field names of objects }
  1064. if (sym^.typ=typesym) and (ptypesym(sym)^.definition^.deftype=objectdef)then
  1065. begin
  1066. if assigned(pobjectdef(ptypesym(sym)^.definition)^.publicsyms) then
  1067. Begin
  1068. p:=pobjectdef(ptypesym(sym)^.definition)^.publicsyms^.search(field);
  1069. if assigned(p) then
  1070. Begin
  1071. Offset := pvarsym(p)^.address;
  1072. GetTypeOffset := TRUE;
  1073. Exit;
  1074. end
  1075. end;
  1076. end;
  1077. end; { end looking for global variables .. }
  1078. end;
  1079. Function CreateVarInstr(var Instr: TInstruction; const hs:string;operandnum:byte): Boolean;
  1080. { search and sets up the correct fields in the Instr record }
  1081. { for the NON-constant identifier passed to the routine. }
  1082. { if not found returns FALSE. }
  1083. var
  1084. sym : psym;
  1085. l : longint;
  1086. Begin
  1087. CreateVarInstr := FALSE;
  1088. { are we in a routine ? }
  1089. if assigned(aktprocsym) then
  1090. begin
  1091. { search the local list for the name of this variable. }
  1092. if assigned(aktprocsym^.definition^.localst) then
  1093. sym:=aktprocsym^.definition^.localst^.search(hs)
  1094. else
  1095. sym:=nil;
  1096. if assigned(sym) then
  1097. begin
  1098. case sym^.typ of
  1099. typedconstsym,
  1100. varsym : begin
  1101. { we always assume in asm statements that }
  1102. { that the variable is valid. }
  1103. pvarsym(sym)^.is_valid:=1;
  1104. if pvarsym(sym)^.owner^.symtabletype=staticsymtable then
  1105. begin
  1106. if assigned(instr.operands[operandnum].ref.symbol) then
  1107. FreeMem(instr.operands[operandnum].ref.symbol,length(instr.operands[operandnum].ref.symbol^)+1);
  1108. instr.operands[operandnum].ref.symbol:=newpasstr(pvarsym(sym)^.mangledname);
  1109. end
  1110. else
  1111. begin
  1112. instr.operands[operandnum].ref.base := procinfo.framepointer;
  1113. instr.operands[operandnum].ref.offset := -(pvarsym(sym)^.address);
  1114. end;
  1115. { the current size is NOT overriden if it already }
  1116. { exists, such as in the case of a byte ptr, in }
  1117. { front of the identifier. }
  1118. if instr.operands[operandnum].size = S_NO then
  1119. Begin
  1120. case pvarsym(sym)^.getsize of
  1121. 1: instr.operands[operandnum].size := S_B;
  1122. 2: instr.operands[operandnum].size := S_W{ could be S_IS};
  1123. 4: instr.operands[operandnum].size := S_L{ could be S_IL or S_FS};
  1124. 8: instr.operands[operandnum].size := S_IQ{ could be S_D or S_FL};
  1125. extended_size: instr.operands[operandnum].size := S_FX;
  1126. else
  1127. { this is in the case where the instruction is LEA }
  1128. { or something like that, in that case size is not }
  1129. { important. }
  1130. instr.operands[operandnum].size := S_NO;
  1131. end; { end case }
  1132. end;
  1133. { ok, finished for thir variable. }
  1134. CreateVarInstr := TRUE;
  1135. Exit;
  1136. end;
  1137. procsym : begin
  1138. { free the memory before changing the symbol name. }
  1139. if assigned(instr.operands[operandnum].ref.symbol) then
  1140. FreeMem(instr.operands[operandnum].ref.symbol,length(instr.operands[operandnum].ref.symbol^)+1);
  1141. instr.operands[operandnum].operandtype:=OPR_SYMBOL;
  1142. instr.operands[operandnum].symbol:=newpasstr(pprocsym(sym)^.definition^.mangledname);
  1143. CreateVarInstr := TRUE;
  1144. Exit;
  1145. end
  1146. else
  1147. begin
  1148. Comment(V_Error,'Unsupported symbol type for operand');
  1149. exit;
  1150. end;
  1151. end;
  1152. end;
  1153. { now check for parameters passed to routine }
  1154. if assigned(aktprocsym^.definition^.parast) then
  1155. sym:=aktprocsym^.definition^.parast^.search(hs)
  1156. else
  1157. sym:=nil;
  1158. if assigned(sym) then
  1159. begin
  1160. case sym^.typ of
  1161. varsym : begin
  1162. l:=pvarsym(sym)^.address;
  1163. { set offset }
  1164. inc(l,aktprocsym^.definition^.parast^.call_offset);
  1165. pvarsym(sym)^.is_valid:=1;
  1166. instr.operands[operandnum].ref.base := procinfo.framepointer;
  1167. instr.operands[operandnum].ref.offset := l;
  1168. { the current size is NOT overriden if it already }
  1169. { exists, such as in the case of a byte ptr, in }
  1170. { front of the identifier. }
  1171. if instr.operands[operandnum].size = S_NO then
  1172. Begin
  1173. case pvarsym(sym)^.getsize of
  1174. 1: instr.operands[operandnum].size := S_B;
  1175. 2: instr.operands[operandnum].size := S_W;
  1176. 4: instr.operands[operandnum].size := S_L;
  1177. 8: instr.operands[operandnum].size := S_IQ;
  1178. extended_size: instr.operands[operandnum].size := S_FX;
  1179. else
  1180. { this is in the case where the instruction is LEA }
  1181. { or something like that, in that case size is not }
  1182. { important. }
  1183. instr.operands[operandnum].size := S_NO;
  1184. end; { end case }
  1185. end; { endif }
  1186. CreateVarInstr := TRUE;
  1187. Exit;
  1188. end;
  1189. else
  1190. begin
  1191. Comment(V_Error,'Unsupported symbol type for operand');
  1192. exit;
  1193. end;
  1194. end; { case }
  1195. end; { endif }
  1196. end;
  1197. { not found.. .now look for global variables. }
  1198. getsym(hs,false);
  1199. sym:=srsym;
  1200. if assigned(sym) then
  1201. Begin
  1202. case sym^.typ of
  1203. varsym,
  1204. typedconstsym : Begin
  1205. { free the memory before changing the symbol name. }
  1206. if assigned(instr.operands[operandnum].ref.symbol) then
  1207. FreeMem(instr.operands[operandnum].ref.symbol,
  1208. length(instr.operands[operandnum].ref.symbol^)+1);
  1209. instr.operands[operandnum].ref.symbol:=newpasstr(sym^.mangledname);
  1210. { the current size is NOT overriden if it already }
  1211. { exists, such as in the case of a byte ptr, in }
  1212. { front of the identifier. }
  1213. if (instr.operands[operandnum].size = S_NO) and (sym^.typ = varsym) then
  1214. Begin
  1215. case pvarsym(sym)^.getsize of
  1216. 1: instr.operands[operandnum].size := S_B;
  1217. 2: instr.operands[operandnum].size := S_W;
  1218. 4: instr.operands[operandnum].size := S_L;
  1219. 8: instr.operands[operandnum].size := S_IQ;
  1220. else
  1221. { this is in the case where the instruction is LEA }
  1222. { or something like that, in that case size is not }
  1223. { important. }
  1224. instr.operands[operandnum].size := S_NO;
  1225. end;
  1226. end
  1227. else
  1228. if (instr.operands[operandnum].size = S_NO) and (sym^.typ = typedconstsym) then
  1229. Begin
  1230. { only these are valid sizes, otherwise prefixes are }
  1231. { required. }
  1232. case ptypedconstsym(sym)^.definition^.size of
  1233. 1: instr.operands[operandnum].size := S_B;
  1234. 2: instr.operands[operandnum].size := S_W;
  1235. 4: instr.operands[operandnum].size := S_L;
  1236. 8: instr.operands[operandnum].size := S_IQ;
  1237. else
  1238. { this is in the case where the instruction is LEA }
  1239. { or something like that, in that case size is not }
  1240. { important. }
  1241. instr.operands[operandnum].size := S_NO;
  1242. end;
  1243. end; { endif }
  1244. CreateVarInstr := TRUE;
  1245. Exit;
  1246. end;
  1247. procsym : begin
  1248. if assigned(pprocsym(sym)^.definition^.nextoverloaded) then
  1249. Message(assem_w_calling_overload_func);
  1250. { free the memory before changing the symbol name. }
  1251. if assigned(instr.operands[operandnum].ref.symbol) then
  1252. FreeMem(instr.operands[operandnum].ref.symbol,length(instr.operands[operandnum].ref.symbol^)+1);
  1253. instr.operands[operandnum].operandtype:=OPR_SYMBOL;
  1254. instr.operands[operandnum].symbol:=newpasstr(pprocsym(sym)^.definition^.mangledname);
  1255. CreateVarInstr := TRUE;
  1256. Exit;
  1257. end;
  1258. else
  1259. begin
  1260. Comment(V_Error,'Unsupported symbol type for operand');
  1261. exit;
  1262. end;
  1263. end; {case}
  1264. end; { end looking for global variables .. }
  1265. end;
  1266. Function SearchLabel(const s: string; var hl: plabel): boolean;
  1267. {**********************************************************************}
  1268. { Description: Searches for a pascal label definition, first in the }
  1269. { local symbol list and then in the global symbol list. If found then }
  1270. { return pointer to label and return true, otherwise returns false. }
  1271. {**********************************************************************}
  1272. var
  1273. sym: psym;
  1274. Begin
  1275. SearchLabel := FALSE;
  1276. if assigned(aktprocsym) then
  1277. Begin
  1278. { Check the local constants }
  1279. if assigned(aktprocsym^.definition) then
  1280. Begin
  1281. if assigned(aktprocsym^.definition^.localst) then
  1282. sym := aktprocsym^.definition^.localst^.search(s)
  1283. else
  1284. sym := nil;
  1285. if assigned(sym) then
  1286. Begin
  1287. if (sym^.typ = labelsym) then
  1288. Begin
  1289. hl:=plabelsym(sym)^.number;
  1290. SearchLabel := TRUE;
  1291. exit;
  1292. end;
  1293. end;
  1294. end;
  1295. end;
  1296. { Check the global label symbols... }
  1297. getsym(s,false);
  1298. if srsym <> nil then
  1299. Begin
  1300. if (srsym^.typ=labelsym) then
  1301. Begin
  1302. hl:=plabelsym(srsym)^.number;
  1303. SearchLabel:= TRUE;
  1304. exit;
  1305. end;
  1306. end;
  1307. end;
  1308. {*************************************************************************}
  1309. { Instruction Generation Utilities }
  1310. {*************************************************************************}
  1311. Procedure ConcatString(p : paasmoutput;s:string);
  1312. {*********************************************************************}
  1313. { PROCEDURE ConcatString(s:string); }
  1314. { Description: This routine adds the character chain pointed to in }
  1315. { s to the instruction linked list. }
  1316. {*********************************************************************}
  1317. Var
  1318. pc: PChar;
  1319. Begin
  1320. getmem(pc,length(s)+1);
  1321. p^.concat(new(pai_string,init_length_pchar(strpcopy(pc,s),length(s))));
  1322. end;
  1323. Procedure ConcatPasString(p : paasmoutput;s:string);
  1324. {*********************************************************************}
  1325. { PROCEDURE ConcatPasString(s:string); }
  1326. { Description: This routine adds the character chain pointed to in }
  1327. { s to the instruction linked list, contrary to ConcatString it }
  1328. { uses a pascal style string, so it conserves null characters. }
  1329. {*********************************************************************}
  1330. Begin
  1331. p^.concat(new(pai_string,init(s)));
  1332. end;
  1333. Procedure ConcatDirect(p : paasmoutput;s:string);
  1334. {*********************************************************************}
  1335. { PROCEDURE ConcatDirect(s:string) }
  1336. { Description: This routine output the string directly to the asm }
  1337. { output, it is only sed when writing special labels in AT&T mode, }
  1338. { and should not be used without due consideration, since it may }
  1339. { cause problems. }
  1340. {*********************************************************************}
  1341. Var
  1342. pc: PChar;
  1343. Begin
  1344. getmem(pc,length(s)+1);
  1345. p^.concat(new(pai_direct,init(strpcopy(pc,s))));
  1346. end;
  1347. Procedure ConcatConstant(p: paasmoutput; value: longint; maxvalue: longint);
  1348. {*********************************************************************}
  1349. { PROCEDURE ConcatConstant(value: longint; maxvalue: longint); }
  1350. { Description: This routine adds the value constant to the current }
  1351. { instruction linked list. }
  1352. { maxvalue -> indicates the size of the data to initialize: }
  1353. { $ff -> create a byte node. }
  1354. { $ffff -> create a word node. }
  1355. { $ffffffff -> create a dword node. }
  1356. {*********************************************************************}
  1357. Begin
  1358. if value > maxvalue then
  1359. Begin
  1360. Message(assem_e_constant_out_of_bounds);
  1361. { assuming a value of maxvalue }
  1362. value := maxvalue;
  1363. end;
  1364. if maxvalue = $ff then
  1365. p^.concat(new(pai_const,init_8bit(byte(value))))
  1366. else
  1367. if maxvalue = $ffff then
  1368. p^.concat(new(pai_const,init_16bit(word(value))))
  1369. else
  1370. if maxvalue = $ffffffff then
  1371. p^.concat(new(pai_const,init_32bit(longint(value))));
  1372. end;
  1373. Procedure ConcatRealConstant(p : paasmoutput;value: bestreal; real_typ : tfloattype);
  1374. {***********************************************************************}
  1375. { PROCEDURE ConcatRealConstant(value: bestreal; real_typ : tfloattype); }
  1376. { Description: This routine adds the value constant to the current }
  1377. { instruction linked list. }
  1378. { real_typ -> indicates the type of the real data to initialize: }
  1379. { s32real -> create a single node. }
  1380. { s64real -> create a double node. }
  1381. { s80real -> create an extended node. }
  1382. { s64bit -> create a comp node. }
  1383. { f32bit -> create a fixed node. (not used normally) }
  1384. {***********************************************************************}
  1385. Begin
  1386. case real_typ of
  1387. s32real : p^.concat(new(pai_single,init(value)));
  1388. s64real : p^.concat(new(pai_double,init(value)));
  1389. s80real : p^.concat(new(pai_extended,init(value)));
  1390. s64bit : p^.concat(new(pai_comp,init(value)));
  1391. f32bit : p^.concat(new(pai_const,init_32bit(trunc(value*$10000))));
  1392. end;
  1393. end;
  1394. Procedure ConcatLabel(p: paasmoutput;op : tasmop;var l : plabel);
  1395. {*********************************************************************}
  1396. { PROCEDURE ConcatLabel }
  1397. { Description: This routine either emits a label or a labeled }
  1398. { instruction to the linked list of instructions. }
  1399. {*********************************************************************}
  1400. begin
  1401. if op=A_LABEL then
  1402. p^.concat(new(pai_label,init(l)))
  1403. else
  1404. p^.concat(new(pai_labeled,init(op,l)))
  1405. end;
  1406. procedure ConcatPublic(p:paasmoutput;const s : string);
  1407. {*********************************************************************}
  1408. { PROCEDURE ConcatPublic }
  1409. { Description: This routine emits an global definition to the }
  1410. { linked list of instructions.(used by AT&T styled asm) }
  1411. {*********************************************************************}
  1412. begin
  1413. p^.concat(new(pai_symbol,init_global(s)));
  1414. { concat_internal(s,EXT_NEAR); done in aasm }
  1415. end;
  1416. procedure ConcatLocal(p:paasmoutput;const s : string);
  1417. {*********************************************************************}
  1418. { PROCEDURE ConcatLocal }
  1419. { Description: This routine emits an local definition to the }
  1420. { linked list of instructions. }
  1421. {*********************************************************************}
  1422. begin
  1423. p^.concat(new(pai_symbol,init(s)));
  1424. { concat_internal(s,EXT_NEAR); done in aasm }
  1425. end;
  1426. Procedure ConcatGlobalBss(const s : string;size : longint);
  1427. {*********************************************************************}
  1428. { PROCEDURE ConcatGlobalBss }
  1429. { Description: This routine emits an global datablock to the }
  1430. { linked list of instructions. }
  1431. {*********************************************************************}
  1432. begin
  1433. bsssegment^.concat(new(pai_datablock,init_global(s,size)));
  1434. { concat_internal(s,EXT_NEAR); done in aasm }
  1435. end;
  1436. Procedure ConcatLocalBss(const s : string;size : longint);
  1437. {*********************************************************************}
  1438. { PROCEDURE ConcatLocalBss }
  1439. { Description: This routine emits a local datablcok to the }
  1440. { linked list of instructions. }
  1441. {*********************************************************************}
  1442. begin
  1443. bsssegment^.concat(new(pai_datablock,init(s,size)));
  1444. { concat_internal(s,EXT_NEAR); done in aasm }
  1445. end;
  1446. { add to list of external labels }
  1447. Procedure ConcatExternal(const s : string;typ : texternal_typ);
  1448. {*********************************************************************}
  1449. { PROCEDURE ConcatExternal }
  1450. { Description: This routine emits an external definition to the }
  1451. { linked list of instructions.(used by AT&T styled asm) }
  1452. {*********************************************************************}
  1453. { check if in internal list and remove it there }
  1454. var p : pai_external;
  1455. begin
  1456. p:=search_assembler_symbol(internals,s,typ);
  1457. if p<>nil then internals^.remove(p);
  1458. concat_external(s,typ);
  1459. end;
  1460. { add to internal list of labels }
  1461. Procedure ConcatInternal(const s : string;typ : texternal_typ);
  1462. {*********************************************************************}
  1463. { PROCEDURE ConcatInternal }
  1464. { Description: This routine emits an internal definition of a symbol }
  1465. { (used by AT&T styled asm for undefined labels) }
  1466. {*********************************************************************}
  1467. begin
  1468. concat_internal(s,typ);
  1469. end;
  1470. end.
  1471. {
  1472. $Log$
  1473. Revision 1.3 1998-05-31 14:13:30 peter
  1474. * fixed call bugs with assembler readers
  1475. + OPR_SYMBOL to hold a symbol in the asm parser
  1476. * fixed staticsymtable vars which were acessed through %ebp instead of
  1477. name
  1478. Revision 1.2 1998/04/29 10:33:43 pierre
  1479. + added some code for ansistring (not complete nor working yet)
  1480. * corrected operator overloading
  1481. * corrected nasm output
  1482. + started inline procedures
  1483. + added starstarn : use ** for exponentiation (^ gave problems)
  1484. + started UseTokenInfo cond to get accurate positions
  1485. }