asmutils.pas 58 KB

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