?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Initial revision
[AROS-Contrib.git] / development / compilers / freepascal / compiler / cg68kcnv.pas
blobe657d96c09f53563a3a728e56f8b70f165f2da76
1 {
2 $Id$
3 Copyright (c) 1998-2000 by Florian Klaempfl
4
5 Generate m68k assembler for type converting nodes
6
7 This program is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2 of the License, or
10 (at your option) any later version.
11
12 This program is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with this program; if not, write to the Free Software
19 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
20
21 ****************************************************************************
22 }
23 {$ifdef TP}
24 {$E+,F+,N+}
25 {$endif}
26 unit cg68kcnv;
27 interface
28
29 uses
30 tree;
31
32 procedure secondtypeconv(var p : ptree);
33 procedure secondas(var p : ptree);
34 procedure secondis(var p : ptree);
35
36
37 implementation
38
39 uses
40 globtype,systems,symconst,
41 cobjects,verbose,globals,
42 symtable,aasm,types,
43 hcodegen,temp_gen,pass_2,
44 cpubase,cga68k,tgen68k;
45
46 {*****************************************************************************
47 SecondTypeConv
48 *****************************************************************************}
49
50 procedure maybe_rangechecking(p : ptree;p2,p1 : pdef);
51
52 var
53 hp : preference;
54 hregister : tregister;
55 neglabel,poslabel : pasmlabel;
56
57 begin
58 { convert from p2 to p1 }
59 { range check from enums is not made yet !!}
60 { and its probably not easy }
61 if (p1^.deftype<>orddef) or (p2^.deftype<>orddef) then
62 exit;
63 { range checking is different for u32bit }
64 { lets try to generate it allways }
65 if (cs_check_range in aktlocalswitches) and
66 { with $R+ explicit type conversations in TP aren't range checked! }
67 (not(p^.explizit) {or not(cs_tp_compatible in aktmoduleswitches)}) and
68 ((porddef(p1)^.low>porddef(p2)^.low) or
69 (porddef(p1)^.high<porddef(p2)^.high) or
70 (porddef(p1)^.typ=u32bit) or
71 (porddef(p2)^.typ=u32bit)) then
72 begin
73 porddef(p1)^.genrangecheck;
74 if porddef(p2)^.typ=u8bit then
75 begin
76 if (p^.location.loc=LOC_REGISTER) or
77 (p^.location.loc=LOC_CREGISTER) then
78 begin
79 exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_B,p^.location.register,R_D6)));
80 exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_L,$FF,R_D6)));
81 end
82 else
83 begin
84 exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_B,newreference(p^.location.reference),R_D6)));
85 exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_L,$FF,R_D6)));
86 end;
87 hregister:=R_D6;
88 end
89 else if porddef(p2)^.typ=s8bit then
90 begin
91 if (p^.location.loc=LOC_REGISTER) or
92 (p^.location.loc=LOC_CREGISTER) then
93 begin
94 exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_B,p^.location.register,R_D6)));
95 { byte to long }
96 if aktoptprocessor = MC68020 then
97 exprasmlist^.concat(new(paicpu,op_reg(A_EXTB,S_L,R_D6)))
98 else
99 begin
100 exprasmlist^.concat(new(paicpu,op_reg(A_EXT,S_W,R_D6)));
101 exprasmlist^.concat(new(paicpu,op_reg(A_EXT,S_L,R_D6)));
102 end;
103 end
104 else
105 begin
106 exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_B,newreference(p^.location.reference),R_D6)));
107 { byte to long }
108 if aktoptprocessor = MC68020 then
109 exprasmlist^.concat(new(paicpu,op_reg(A_EXTB,S_L,R_D6)))
110 else
111 begin
112 exprasmlist^.concat(new(paicpu,op_reg(A_EXT,S_W,R_D6)));
113 exprasmlist^.concat(new(paicpu,op_reg(A_EXT,S_L,R_D6)));
114 end;
115 end; { end outermost else }
116 hregister:=R_D6;
117 end
118 { rangechecking for u32bit ?? !!!!!!}
119 { lets try }
120 else if (porddef(p2)^.typ=s32bit) or (porddef(p2)^.typ=u32bit) then
121 begin
122 if (p^.location.loc=LOC_REGISTER) or
123 (p^.location.loc=LOC_CREGISTER) then
124 hregister:=p^.location.register
125 else
126 begin
127 exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(p^.location.reference),R_D6)));
128 hregister:=R_D6;
129 end;
130 end
131 { rangechecking for u32bit ?? !!!!!!}
132 else if porddef(p2)^.typ=u16bit then
133 begin
134 if (p^.location.loc=LOC_REGISTER) or
135 (p^.location.loc=LOC_CREGISTER) then
136 exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_W,p^.location.register,R_D6)))
137 else
138 exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_W,newreference(p^.location.reference),R_D6)));
139 { unisgned extend }
140 exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_L,$FFFF,R_D6)));
141 hregister:=R_D6;
142 end
143 else if porddef(p2)^.typ=s16bit then
144 begin
145 if (p^.location.loc=LOC_REGISTER) or
146 (p^.location.loc=LOC_CREGISTER) then
147 exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_W,p^.location.register,R_D6)))
148 else
149 exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_W,newreference(p^.location.reference),R_D6)));
150 { sign extend }
151 exprasmlist^.concat(new(paicpu,op_reg(A_EXT,S_L,R_D6)));
152 hregister:=R_D6;
153 end
154 else internalerror(6);
155 new(hp);
156 reset_reference(hp^);
157 hp^.symbol:=stringdup('R_'+tostr(porddef(p1)^.rangenr));
158 if porddef(p1)^.low>porddef(p1)^.high then
159 begin
160 getlabel(neglabel);
161 getlabel(poslabel);
162 exprasmlist^.concat(new(paicpu,op_reg(A_TST,S_L,hregister)));
163 emitl(A_BLT,neglabel);
164 end;
165 emit_bounds_check(hp^,hregister);
166 if porddef(p1)^.low>porddef(p1)^.high then
167 begin
168 new(hp);
169 reset_reference(hp^);
170 hp^.symbol:=stringdup('R_'+tostr(porddef(p1)^.rangenr+1));
171 emitl(A_JMP,poslabel);
172 emitl(A_LABEL,neglabel);
173 emit_bounds_check(hp^,hregister);
174 emitl(A_LABEL,poslabel);
175 end;
176 end;
177 end;
178
179
180 type
181 tsecondconvproc = procedure(p,hp : ptree;convtyp : tconverttype);
182
183 procedure second_only_rangecheck(p,hp : ptree;convtyp : tconverttype);
184
185 begin
186 maybe_rangechecking(p,hp^.resulttype,p^.resulttype);
187 end;
188
189
190 procedure second_smaller(p,hp : ptree;convtyp : tconverttype);
191
192 var
193 hregister,destregister : tregister;
194 {opsize : topsize;}
195 ref : boolean;
196 hpp : preference;
197
198 begin
199 { !!!!!!!! Rangechecking }
200 ref:=false;
201 { problems with enums !! }
202 { with $R+ explicit type conversations in TP aren't range checked! }
203 if (p^.resulttype^.deftype=orddef) and
204 (hp^.resulttype^.deftype=orddef) and
205 ((porddef(p^.resulttype)^.low>porddef(hp^.resulttype)^.low) or
206 (porddef(p^.resulttype)^.high<porddef(hp^.resulttype)^.high)) then
207 begin
208 if (cs_check_range in aktlocalswitches) and
209 (not(p^.explizit) {or not(cs_tp_compatible in aktmoduleswitches)}) then
210 porddef(p^.resulttype)^.genrangecheck;
211 if porddef(hp^.resulttype)^.typ=s32bit then
212 begin
213 if (p^.location.loc=LOC_REGISTER) or
214 (p^.location.loc=LOC_CREGISTER) then
215 hregister:=p^.location.register
216 else
217 begin
218 hregister:=getregister32;
219 exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(p^.location.reference),hregister)));
220 end;
221 end
222 { rangechecking for u32bit ?? !!!!!!}
223 else if porddef(hp^.resulttype)^.typ=u16bit then
224 begin
225 hregister:=getregister32;
226 if (p^.location.loc=LOC_REGISTER) or
227 (p^.location.loc=LOC_CREGISTER) then
228 begin
229 exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_W,p^.location.register,hregister)));
230 end
231 else
232 exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_W,newreference(p^.location.reference),hregister)));
233 { clear unused bits i.e unsigned extend}
234 exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_L, $FFFF, hregister)));
235 end
236 else if porddef(hp^.resulttype)^.typ=s16bit then
237 begin
238 hregister:=getregister32;
239 if (p^.location.loc=LOC_REGISTER) or
240 (p^.location.loc=LOC_CREGISTER) then
241 exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_W,p^.location.register,hregister)))
242 else
243 exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_W,newreference(p^.location.reference),hregister)));
244 { sign extend }
245 exprasmlist^.concat(new(paicpu,op_reg(A_EXT, S_L, hregister)));
246 end
247 else internalerror(6);
248
249 if (cs_check_range in aktlocalswitches) and
250 (not(p^.explizit) {or not(cs_tp_compatible in aktmoduleswitches)}) then
251 Begin
252 new(hpp);
253 reset_reference(hpp^);
254 hpp^.symbol:=stringdup('R_'+tostr(porddef(p^.resulttype)^.rangenr));
255
256
257 emit_bounds_check(hpp^, hregister);
258 end;
259 clear_location(p^.location);
260 p^.location.loc:=LOC_REGISTER;
261 p^.location.register:=hregister;
262 exit;
263 end
264 { -------------- endian problems once again --------------------}
265 { If RIGHT enumdef (32-bit) and we do a typecase to a smaller }
266 { type we must absolutely load it into a register first. }
267 { --------------------------------------------------------------}
268 { ------------ supposing enumdef is always 32-bit --------------}
269 { --------------------------------------------------------------}
270 else
271 if (hp^.resulttype^.deftype = enumdef) and (p^.resulttype^.deftype = orddef) then
272 begin
273 if (hp^.location.loc=LOC_REGISTER) or (hp^.location.loc=LOC_CREGISTER) then
274 hregister:=hp^.location.register
275 else
276 begin
277 hregister:=getregister32;
278 exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(hp^.location.reference),hregister)));
279 end;
280 clear_location(p^.location);
281 p^.location.loc:=LOC_REGISTER;
282 p^.location.register:=hregister;
283 exit;
284 end;
285 if (p^.left^.location.loc=LOC_REGISTER) or
286 (p^.left^.location.loc=LOC_CREGISTER) then
287 begin
288 { handled by secondpas by called routine ??? }
289 p^.location.register:=p^.left^.location.register;
290 end;
291 end;
292
293
294 procedure second_bigger(p,hp : ptree;convtyp : tconverttype);
295
296 var
297 hregister : tregister;
298 opsize : topsize;
299 op : tasmop;
300 is_register : boolean;
301
302 begin
303 {$ifdef dummy}
304 is_register:=p^.left^.location.loc=LOC_REGISTER;
305 if not(is_register) and (p^.left^.location.loc<>LOC_CREGISTER) then
306 begin
307 del_reference(p^.left^.location.reference);
308 { we can do this here as we need no temp inside second_bigger }
309 ungetiftemp(p^.left^.location.reference);
310 end;
311 { this is wrong !!!
312 gives me movl (%eax),%eax
313 for the length(string !!!
314 use only for constant values }
315 {Constanst cannot be loaded into registers using MOVZX!}
316 if (p^.left^.location.loc<>LOC_MEM) or (not p^.left^.location.reference.isintvalue) then
317 case convtyp of
318 tc_int_2_int:
319 begin
320 if is_register then
321 hregister := p^.left^.location.register
322 else
323 hregister := getregister32;
324 if is_register then
325 emit_reg_reg(A_MOVE,S_B,p^.left^.location.register, hregister)
326 else
327 begin
328 if p^.left^.location.loc = LOC_CREGISTER then
329 emit_reg_reg(A_MOVE,S_B,p^.left^.location.register,hregister)
330 else
331 exprasmlist^.concat(new(paicpu, op_ref_reg(A_MOVE,S_B,
332 newreference(P^.left^.location.reference), hregister)));
333 end;
334 case convtyp of
335 tc_u8bit_2_s32bit,
336 tc_u8bit_2_u32bit:
337 exprasmlist^.concat(new(paicpu, op_const_reg(
338 A_AND,S_L,$FF,hregister)));
339 tc_s8bit_2_u32bit,
340 tc_s8bit_2_s32bit:
341 begin
342 if aktoptprocessor = MC68020 then
343 exprasmlist^.concat(new(paicpu,op_reg
344 (A_EXTB,S_L,hregister)))
345 else { else if aktoptprocessor }
346 begin
347 { byte to word }
348 exprasmlist^.concat(new(paicpu,op_reg
349 (A_EXT,S_W,hregister)));
350 { word to long }
351 exprasmlist^.concat(new(paicpu,op_reg
352 (A_EXT,S_L,hregister)));
353 end;
354 end;
355 tc_s8bit_2_u16bit,
356 tc_u8bit_2_s16bit,
357 tc_u8bit_2_u16bit:
358 exprasmlist^.concat(new(paicpu, op_const_reg(
359 A_AND,S_W,$FF,hregister)));
360
361 tc_s8bit_2_s16bit:
362 exprasmlist^.concat(new(paicpu, op_reg(
363 A_EXT, S_W, hregister)));
364
365 end; { inner case }
366 end;
367 tc_u16bit_2_u32bit,
368 tc_u16bit_2_s32bit,
369 tc_s16bit_2_u32bit,
370 tc_s16bit_2_s32bit: begin
371 if is_register then
372 hregister := p^.left^.location.register
373 else
374 hregister := getregister32;
375 if is_register then
376 emit_reg_reg(A_MOVE,S_W,p^.left^.location.register, hregister)
377 else
378 begin
379 if p^.left^.location.loc = LOC_CREGISTER then
380 emit_reg_reg(A_MOVE,S_W,p^.left^.location.register,hregister)
381 else
382 exprasmlist^.concat(new(paicpu, op_ref_reg(A_MOVE,S_W,
383 newreference(P^.left^.location.reference), hregister)));
384 end;
385 if (convtyp = tc_u16bit_2_s32bit) or
386 (convtyp = tc_u16bit_2_u32bit) then
387 exprasmlist^.concat(new(paicpu, op_const_reg(
388 A_AND, S_L, $ffff, hregister)))
389 else { tc_s16bit_2_s32bit }
390 { tc_s16bit_2_u32bit }
391 exprasmlist^.concat(new(paicpu, op_reg(A_EXT,S_L,
392 hregister)));
393 end;
394 end { end case }
395 else
396 begin
397 case convtyp of
398 tc_u8bit_2_s32bit,
399 tc_s8bit_2_s32bit,
400 tc_u16bit_2_s32bit,
401 tc_s16bit_2_s32bit,
402 tc_u8bit_2_u32bit,
403 tc_s8bit_2_u32bit,
404 tc_u16bit_2_u32bit,
405 tc_s16bit_2_u32bit:
406
407 begin
408 hregister:=getregister32;
409 op:=A_MOVE;
410 opsize:=S_L;
411 end;
412 tc_s8bit_2_u16bit,
413 tc_s8bit_2_s16bit,
414 tc_u8bit_2_s16bit,
415 tc_u8bit_2_u16bit:
416 begin
417 hregister:=getregister32;
418 op:=A_MOVE;
419 opsize:=S_W;
420 end;
421 end;
422 if is_register then
423 begin
424 emit_reg_reg(op,opsize,p^.left^.location.register,hregister);
425 end
426 else
427 begin
428 if p^.left^.location.loc=LOC_CREGISTER then
429 emit_reg_reg(op,opsize,p^.left^.location.register,hregister)
430 else exprasmlist^.concat(new(paicpu,op_ref_reg(op,opsize,
431 newreference(p^.left^.location.reference),hregister)));
432 end;
433 end; { end elseif }
434
435 clear_location(p^.location);
436 p^.location.loc:=LOC_REGISTER;
437 p^.location.register:=hregister;
438 maybe_rangechecking(p,p^.left^.resulttype,p^.resulttype);
439 {$endif dummy}
440 end;
441
442
443 procedure second_string_string(p,hp : ptree;convtyp : tconverttype);
444
445 var
446 pushed : tpushed;
447
448 begin
449 { does anybody know a better solution than this big case statement ? }
450 { ok, a proc table would do the job }
451 case pstringdef(p)^.string_typ of
452
453 st_shortstring:
454 case pstringdef(p^.left)^.string_typ of
455 st_shortstring:
456 begin
457 stringdispose(p^.location.reference.symbol);
458 gettempofsizereference(p^.resulttype^.size,p^.location.reference);
459 del_reference(p^.left^.location.reference);
460 copystring(p^.location.reference,p^.left^.location.reference,pstringdef(p^.resulttype)^.len);
461 ungetiftemp(p^.left^.location.reference);
462 end;
463 st_longstring:
464 begin
465 {!!!!!!!}
466 internalerror(8888);
467 end;
468 st_ansistring:
469 begin
470 {!!!!!!!}
471 internalerror(8888);
472 end;
473 st_widestring:
474 begin
475 {!!!!!!!}
476 internalerror(8888);
477 end;
478 end;
479
480 st_longstring:
481 case pstringdef(p^.left)^.string_typ of
482 st_shortstring:
483 begin
484 {!!!!!!!}
485 internalerror(8888);
486 end;
487 st_ansistring:
488 begin
489 {!!!!!!!}
490 internalerror(8888);
491 end;
492 st_widestring:
493 begin
494 {!!!!!!!}
495 internalerror(8888);
496 end;
497 end;
498
499 st_ansistring:
500 case pstringdef(p^.left)^.string_typ of
501 st_shortstring:
502 begin
503 pushusedregisters(pushed,$ff);
504 push_int(p^.resulttype^.size-1);
505 gettempofsizereference(p^.resulttype^.size,p^.location.reference);
506 emitpushreferenceaddr(exprasmlist,p^.location.reference);
507 case p^.right^.location.loc of
508 LOC_REGISTER,LOC_CREGISTER:
509 begin
510 { !!!!! exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,p^.right^.location.register))); }
511 ungetregister32(p^.left^.location.register);
512 end;
513 LOC_REFERENCE,LOC_MEM:
514 begin
515 emit_push_mem(p^.left^.location.reference);
516 del_reference(p^.left^.location.reference);
517 end;
518 end;
519 emitcall('FPC_ANSI_TO_SHORTSTRING',true);
520 maybe_loada5;
521 popusedregisters(pushed);
522 end;
523 st_longstring:
524 begin
525 {!!!!!!!}
526 internalerror(8888);
527 end;
528 st_widestring:
529 begin
530 {!!!!!!!}
531 internalerror(8888);
532 end;
533 end;
534
535 st_widestring:
536 case pstringdef(p^.left)^.string_typ of
537 st_shortstring:
538 begin
539 {!!!!!!!}
540 internalerror(8888);
541 end;
542 st_longstring:
543 begin
544 {!!!!!!!}
545 internalerror(8888);
546 end;
547 st_ansistring:
548 begin
549 {!!!!!!!}
550 internalerror(8888);
551 end;
552 st_widestring:
553 begin
554 {!!!!!!!}
555 internalerror(8888);
556 end;
557 end;
558 end;
559 end;
560
561 procedure second_cstring_charpointer(p,hp : ptree;convtyp : tconverttype);
562
563 begin
564 clear_location(p^.location);
565 p^.location.loc:=LOC_REGISTER;
566 p^.location.register:=getregister32;
567 inc(p^.left^.location.reference.offset);
568 exprasmlist^.concat(new(paicpu,op_ref_reg(A_LEA,S_L,newreference(p^.left^.location.reference),
569 R_A0)));
570 emit_reg_reg(A_MOVE, S_L, R_A0, p^.location.register);
571 end;
572
573 procedure second_string_chararray(p,hp : ptree;convtyp : tconverttype);
574
575 begin
576 inc(p^.location.reference.offset);
577 end;
578
579 procedure second_array_to_pointer(p,hp : ptree;convtyp : tconverttype);
580
581 begin
582 del_reference(p^.left^.location.reference);
583 clear_location(p^.location);
584 p^.location.loc:=LOC_REGISTER;
585 p^.location.register:=getregister32;
586 exprasmlist^.concat(new(paicpu,op_ref_reg(A_LEA,S_L,newreference(p^.left^.location.reference),
587 R_A0)));
588 emit_reg_reg(A_MOVE,S_L,R_A0, P^.location.register);
589 end;
590
591 procedure second_pointer_to_array(p,hp : ptree;convtyp : tconverttype);
592 var
593 reg: tregister;
594 begin
595 clear_location(p^.location);
596 p^.location.loc:=LOC_REFERENCE;
597 clear_reference(p^.location.reference);
598 { here, after doing some arithmetic on the pointer }
599 { we put it back in an address register }
600 if p^.left^.location.loc=LOC_REGISTER then
601 begin
602 reg := getaddressreg;
603 { move the pointer in a data register back into }
604 { an address register. }
605 emit_reg_reg(A_MOVE, S_L, p^.left^.location.register,reg);
606
607 p^.location.reference.base:=reg;
608 ungetregister32(p^.left^.location.register);
609 end
610 else
611 begin
612 if p^.left^.location.loc=LOC_CREGISTER then
613 begin
614 p^.location.reference.base:=getaddressreg;
615 emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,
616 p^.location.reference.base);
617 end
618 else
619 begin
620 del_reference(p^.left^.location.reference);
621 p^.location.reference.base:=getaddressreg;
622 exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(p^.left^.location.reference),
623 p^.location.reference.base)));
624 end;
625 end;
626 end;
627
628 { generates the code for the type conversion from an array of char }
629 { to a string }
630 procedure second_chararray_to_string(p,hp : ptree;convtyp : tconverttype);
631
632 var
633 l : longint;
634
635 begin
636 { this is a type conversion which copies the data, so we can't }
637 { return a reference }
638 clear_location(p^.location);
639 p^.location.loc:=LOC_MEM;
640
641 { first get the memory for the string }
642 stringdispose(p^.location.reference.symbol);
643 gettempofsizereference(256,p^.location.reference);
644
645 { calc the length of the array }
646 l:=parraydef(p^.left^.resulttype)^.highrange-
647 parraydef(p^.left^.resulttype)^.lowrange+1;
648
649 if l>255 then
650 CGMessage(type_e_mismatch);
651
652 { write the length }
653 exprasmlist^.concat(new(paicpu,op_const_ref(A_MOVE,S_B,l,
654 newreference(p^.location.reference))));
655
656 { copy to first char of string }
657 inc(p^.location.reference.offset);
658
659 { generates the copy code }
660 { and we need the source never }
661 concatcopy(p^.left^.location.reference,p^.location.reference,l,true);
662
663 { correct the string location }
664 dec(p^.location.reference.offset);
665 end;
666
667 procedure second_char_to_string(p,hp : ptree;convtyp : tconverttype);
668
669 begin
670 stringdispose(p^.location.reference.symbol);
671 gettempofsizereference(256,p^.location.reference);
672 { call loadstring with correct left and right }
673 p^.right:=p^.left;
674 p^.left:=p;
675 loadstring(p);
676 p^.left:=nil; { reset left tree, which is empty }
677 { p^.right is not disposed for typeconv !! PM }
678 disposetree(p^.right);
679 p^.right:=nil;
680 end;
681
682 procedure second_int_real(p,hp : ptree;convtyp : tconverttype);
683
684 var
685 r : preference;
686
687 begin
688 emitloadord2reg(p^.left^.location, porddef(p^.left^.resulttype), R_D6, true);
689 ungetiftemp(p^.left^.location.reference);
690 if porddef(p^.left^.resulttype)^.typ=u32bit then
691 push_int(0);
692
693 emit_reg_reg(A_MOVE, S_L, R_D6, R_SPPUSH);
694 new(r);
695 reset_reference(r^);
696 r^.base := R_SP;
697 { no emulation }
698 { for u32bit a solution would be to push $0 and to load a
699 + comp
700 + if porddef(p^.left^.resulttype)^.typ=u32bit then
701 + exprasmlist^.concat(new(paicpu,op_ref(A_FILD,S_IQ,r)))
702 + else}
703 clear_location(p^.location);
704 p^.location.loc := LOC_FPU;
705 { get floating point register. }
706 if (cs_fp_emulation in aktmoduleswitches) then
707 begin
708 p^.location.fpureg := getregister32;
709 exprasmlist^.concat(new(paicpu, op_ref_reg(A_MOVE, S_L, r, R_D0)));
710 emitcall('FPC_LONG2SINGLE',true);
711 emit_reg_reg(A_MOVE,S_L,R_D0,p^.location.fpureg);
712 end
713 else
714 begin
715 p^.location.fpureg := getfloatreg;
716 exprasmlist^.concat(new(paicpu, op_ref_reg(A_FMOVE, S_L, r, p^.location.fpureg)))
717 end;
718 if porddef(p^.left^.resulttype)^.typ=u32bit then
719 exprasmlist^.concat(new(paicpu,op_const_reg(A_ADD,S_L,8,R_SP)))
720 else
721 { restore the stack to the previous address }
722 exprasmlist^.concat(new(paicpu, op_const_reg(A_ADDQ, S_L, 4, R_SP)));
723 end;
724
725 procedure second_real_fix(p,hp : ptree;convtyp : tconverttype);
726 var
727 rreg : tregister;
728 ref : treference;
729 begin
730 rreg:=getregister32;
731 { Are we in a LOC_FPU, if not then use scratch registers }
732 { instead of allocating reserved registers. }
733 if (p^.left^.location.loc<>LOC_FPU) then
734 begin
735 if (cs_fp_emulation in aktmoduleswitches) then
736 begin
737 exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(p^.left^.location.reference),R_D0)));
738 exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_L,65536,R_D1)));
739 emitcall('FPC_LONGMUL',true);
740 emit_reg_reg(A_MOVE,S_L,R_D0,rreg);
741 end
742 else
743 begin
744 exprasmlist^.concat(new(paicpu,op_ref_reg(A_FMOVE,S_L,newreference(p^.left^.location.reference),R_FP0)));
745 exprasmlist^.concat(new(paicpu,op_const_reg(A_FMUL,S_L,65536,R_FP0)));
746 exprasmlist^.concat(new(paicpu,op_reg_reg(A_FMOVE,S_L,R_FP0,rreg)));
747 end;
748 end
749 else
750 begin
751 if (cs_fp_emulation in aktmoduleswitches) then
752 begin
753 exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,p^.left^.location.fpureg,R_D0)));
754 exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_L,65536,R_D1)));
755 emitcall('FPC_LONGMUL',true);
756 emit_reg_reg(A_MOVE,S_L,R_D0,rreg);
757 end
758 else
759 begin
760 exprasmlist^.concat(new(paicpu,op_const_reg(A_FMUL,S_L,65536,p^.left^.location.fpureg)));
761 exprasmlist^.concat(new(paicpu,op_reg_reg(A_FMOVE,S_L,p^.left^.location.fpureg,rreg)));
762 end;
763 end;
764 clear_location(p^.location);
765 p^.location.loc:=LOC_REGISTER;
766 p^.location.register:=rreg;
767 end;
768
769
770 procedure second_float_float(p,hp : ptree;convtyp : tconverttype);
771
772 begin
773 case p^.left^.location.loc of
774 LOC_FPU : begin
775 { reload }
776 clear_location(p^.location);
777 p^.location.loc := LOC_FPU;
778 p^.location.fpureg := p^.left^.location.fpureg;
779 end;
780 LOC_MEM,
781 LOC_REFERENCE : floatload(pfloatdef(p^.left^.resulttype)^.typ,
782 p^.left^.location.reference,p^.location);
783 end;
784 { ALREADY HANDLED BY FLOATLOAD }
785 { p^.location.loc:=LOC_FPU; }
786 end;
787
788 procedure second_fix_real(p,hp : ptree;convtyp : tconverttype);
789 var
790 startreg : tregister;
791 hl : pasmlabel;
792 r : treference;
793 reg1: tregister;
794 hl1,hl2,hl3,hl4,hl5,hl6,hl7,hl8,hl9: pasmlabel;
795 begin
796 if (p^.left^.location.loc=LOC_REGISTER) or
797 (p^.left^.location.loc=LOC_CREGISTER) then
798 begin
799 startreg:=p^.left^.location.register;
800 ungetregister(startreg);
801 { move d0,d0 is removed by emit_reg_reg }
802 emit_reg_reg(A_MOVE,S_L,startreg,R_D0);
803 end
804 else
805 begin
806 exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(
807 p^.left^.location.reference),R_D0)));
808 del_reference(p^.left^.location.reference);
809 startreg:=R_NO;
810 end;
811
812 reg1 := getregister32;
813
814 { Motorola 68000 equivalent of CDQ }
815 { we choose d1:d0 pair for quad word }
816 exprasmlist^.concat(new(paicpu,op_reg(A_TST,S_L,R_D0)));
817 getlabel(hl1);
818 emitl(A_BPL,hl1);
819 { we copy all bits (-ve number) }
820 exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_L,$ffffffff,R_D1)));
821 getlabel(hl2);
822 emitl(A_BRA,hl2);
823 emitl(A_LABEL,hl1);
824 exprasmlist^.concat(new(paicpu,op_reg(A_CLR,S_L,R_D0)));
825 emitl(A_LABEL,hl2);
826 { end CDQ }
827
828 exprasmlist^.concat(new(paicpu,op_reg_reg(A_EOR,S_L,R_D1,R_D0)));
829 exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_D0,reg1)));
830 getlabel(hl3);
831 emitl(A_BEQ,hl3);
832
833 { Motorola 68000 equivalent of RCL }
834 getlabel(hl4);
835 emitl(A_BCC,hl4);
836 exprasmlist^.concat(new(paicpu,op_const_reg(A_LSL,S_L,1,reg1)));
837 exprasmlist^.concat(new(paicpu,op_const_reg(A_OR,S_L,1,reg1)));
838 getlabel(hl5);
839 emitl(A_BRA,hl5);
840 emitl(A_LABEL,hl4);
841 exprasmlist^.concat(new(paicpu,op_const_reg(A_LSL,S_L,1,reg1)));
842 emitl(A_LABEL,hl5);
843 { end RCL }
844
845 { Motorola 68000 equivalent of BSR }
846 { save register }
847 exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_D0,R_D6)));
848 exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_B,31,R_D0)));
849 getlabel(hl6);
850 emitl(A_LABEL,hl6);
851 exprasmlist^.concat(new(paicpu,op_reg_reg(A_BTST,S_L,R_D0,R_D1)));
852 getlabel(hl7);
853 emitl(A_BNE,hl7);
854 exprasmlist^.concat(new(paicpu,op_const_reg(A_SUBQ,S_B,1,R_D0)));
855 emitl(A_BPL,hl6);
856 { restore register }
857 exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_D6,R_D0)));
858 emitl(A_LABEL,hl7);
859 { end BSR }
860
861 exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_B,32,R_D6)));
862 exprasmlist^.concat(new(paicpu,op_reg_reg(A_SUB,S_B,R_D1,R_D6)));
863 exprasmlist^.concat(new(paicpu,op_reg_reg(A_LSL,S_L,R_D6,R_D0)));
864 exprasmlist^.concat(new(paicpu,op_const_reg(A_ADD,S_W,1007,R_D1)));
865 exprasmlist^.concat(new(paicpu,op_const_reg(A_LSL,S_L,5,R_D1)));
866
867 { Motorola 68000 equivalent of SHLD }
868 exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_W,11,R_D6)));
869 { save register }
870 exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_D1,R_A0)));
871 getlabel(hl8);
872 emitl(A_LABEL,hl8);
873 exprasmlist^.concat(new(paicpu,op_const_reg(A_ROXL,S_W,1,R_D1)));
874 exprasmlist^.concat(new(paicpu,op_const_reg(A_ROXL,S_W,1,reg1)));
875 exprasmlist^.concat(new(paicpu,op_const_reg(A_SUBQ,S_B,1,R_D6)));
876 emitl(A_BNE,hl8);
877 { restore register }
878 exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_A0,R_D1)));
879 { end Motorola equivalent of SHLD }
880
881 { Motorola 68000 equivalent of SHLD }
882 exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_W,20,R_D6)));
883 { save register }
884 exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_D0,R_A0)));
885 getlabel(hl9);
886 emitl(A_LABEL,hl9);
887 exprasmlist^.concat(new(paicpu,op_const_reg(A_ROXL,S_W,1,R_D0)));
888 exprasmlist^.concat(new(paicpu,op_const_reg(A_ROXL,S_W,1,reg1)));
889 exprasmlist^.concat(new(paicpu,op_const_reg(A_SUBQ,S_B,1,R_D6)));
890 emitl(A_BNE,hl9);
891 { restore register }
892 exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_A0,R_D0)));
893 { end Motorola equivalent of SHLD }
894
895 exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,S_B,20,R_D6)));
896 exprasmlist^.concat(new(paicpu,op_reg_reg(A_SUB,S_L,R_D6,R_D0)));
897 emitl(A_LABEL, hl3);
898
899 { create temp values and put on stack }
900 exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,reg1,R_SPPUSH)));
901 exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,S_L,R_D0,R_SPPUSH)));
902
903
904 reset_reference(r);
905 r.base:=R_SP;
906
907 if (cs_fp_emulation in aktmoduleswitches) then
908 begin
909 clear_location(p^.location);
910 p^.location.loc:=LOC_FPU;
911 p^.location.fpureg := getregister32;
912 exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(r),
913 p^.left^.location.fpureg)))
914 end
915 else
916 begin
917 clear_location(p^.location);
918 p^.location.loc:=LOC_FPU;
919 p^.location.fpureg := getfloatreg;
920 exprasmlist^.concat(new(paicpu,op_ref_reg(A_FMOVE,S_L,newreference(r),
921 p^.left^.location.fpureg)))
922 end;
923 { clear temporary space }
924 exprasmlist^.concat(new(paicpu,op_const_reg(A_ADDQ,S_L,8,R_SP)));
925 ungetregister32(reg1);
926 { Alreadu handled above... }
927 { p^.location.loc:=LOC_FPU; }
928 end;
929
930 procedure second_int_fix(p,hp : ptree;convtyp : tconverttype);
931
932 var
933 {hs : string;}
934 hregister : tregister;
935
936 begin
937 if (p^.left^.location.loc=LOC_REGISTER) then
938 hregister:=p^.left^.location.register
939 else if (p^.left^.location.loc=LOC_CREGISTER) then
940 hregister:=getregister32
941 else
942 begin
943 del_reference(p^.left^.location.reference);
944 hregister:=getregister32;
945 case porddef(p^.left^.resulttype)^.typ of
946 s8bit : begin
947 exprasmlist^.concat(new(paicpu, op_ref_reg(A_MOVE,S_B,
948 newreference(p^.left^.location.reference),hregister)));
949 if aktoptprocessor = MC68020 then
950 exprasmlist^.concat(new(paicpu, op_reg(A_EXTB,S_L,hregister)))
951 else
952 begin
953 exprasmlist^.concat(new(paicpu, op_reg(A_EXT,S_W,hregister)));
954 exprasmlist^.concat(new(paicpu, op_reg(A_EXT,S_L,hregister)));
955 end;
956 end;
957 u8bit : begin
958 exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_B,newreference(p^.left^.location.reference),
959 hregister)));
960 exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_L,$ff,hregister)));
961 end;
962 s16bit :begin
963 exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_W,newreference(p^.left^.location.reference),
964 hregister)));
965 exprasmlist^.concat(new(paicpu,op_reg(A_EXT,S_L,hregister)));
966 end;
967 u16bit : begin
968 exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_W,newreference(p^.left^.location.reference),
969 hregister)));
970 exprasmlist^.concat(new(paicpu,op_const_reg(A_AND,S_L,$ffff,hregister)));
971 end;
972 s32bit,u32bit : exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,newreference(p^.left^.location.reference),
973 hregister)));
974 {!!!! u32bit }
975 end;
976 end;
977 exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVEQ,S_L,16,R_D1)));
978 exprasmlist^.concat(new(paicpu,op_reg_reg(A_LSL,S_L,R_D1,hregister)));
979
980 clear_location(p^.location);
981 p^.location.loc:=LOC_REGISTER;
982 p^.location.register:=hregister;
983 end;
984
985
986 procedure second_proc_to_procvar(p,hp : ptree;convtyp : tconverttype);
987
988 begin
989 { secondpass(hp); already done in secondtypeconv PM }
990 clear_location(p^.location);
991 p^.location.loc:=LOC_REGISTER;
992 del_reference(hp^.location.reference);
993 p^.location.register:=getregister32;
994 exprasmlist^.concat(new(paicpu,op_ref_reg(A_LEA,S_L,
995 newreference(hp^.location.reference),R_A0)));
996
997 emit_reg_reg(A_MOVE, S_L, R_A0, P^.location.register);
998 end;
999
1000 procedure second_bool_to_int(p,hp : ptree;convtyp : tconverttype);
1001
1002 var
1003 oldtruelabel,oldfalselabel,hlabel : pasmlabel;
1004 hregister : tregister;
1005 newsize,
1006 opsize : topsize;
1007 op : tasmop;
1008 begin
1009 oldtruelabel:=truelabel;
1010 oldfalselabel:=falselabel;
1011 getlabel(truelabel);
1012 getlabel(falselabel);
1013 secondpass(hp);
1014 clear_location(p^.location);
1015 p^.location.loc:=LOC_REGISTER;
1016 del_reference(hp^.location.reference);
1017 hregister:=getregister32;
1018 case porddef(hp^.resulttype)^.typ of
1019 bool8bit : begin
1020 case porddef(p^.resulttype)^.typ of
1021 u8bit,s8bit,
1022 bool8bit : opsize:=S_B;
1023 u16bit,s16bit,
1024 bool16bit : opsize:=S_BW;
1025 u32bit,s32bit,
1026 bool32bit : opsize:=S_BL;
1027 end;
1028 end;
1029 bool16bit : begin
1030 case porddef(p^.resulttype)^.typ of
1031 u8bit,s8bit,
1032 bool8bit : opsize:=S_B;
1033 u16bit,s16bit,
1034 bool16bit : opsize:=S_W;
1035 u32bit,s32bit,
1036 bool32bit : opsize:=S_WL;
1037 end;
1038 end;
1039 bool32bit : begin
1040 case porddef(p^.resulttype)^.typ of
1041 u8bit,s8bit,
1042 bool8bit : opsize:=S_B;
1043 u16bit,s16bit,
1044 bool16bit : opsize:=S_W;
1045 u32bit,s32bit,
1046 bool32bit : opsize:=S_L;
1047 end;
1048 end;
1049 end;
1050 op:=A_MOVE;
1051 { if opsize in [S_B,S_W,S_L] then
1052 op:=A_MOVE
1053 else
1054 if (porddef(p^.resulttype)^.typ in [s8bit,s16bit,s32bit]) then
1055 op:=A_MOVSX
1056 else
1057 op:=A_MOVZX; }
1058 case porddef(p^.resulttype)^.typ of
1059 bool8bit,u8bit,s8bit : begin
1060 p^.location.register:=hregister;
1061 newsize:=S_B;
1062 end;
1063 bool16bit,u16bit,s16bit : begin
1064 p^.location.register:=hregister;
1065 newsize:=S_W;
1066 end;
1067 bool32bit,u32bit,s32bit : begin
1068 p^.location.register:=hregister;
1069 newsize:=S_L;
1070 end;
1071 else
1072 internalerror(10060);
1073 end;
1074
1075 case hp^.location.loc of
1076 LOC_MEM,
1077 LOC_REFERENCE : exprasmlist^.concat(new(paicpu,op_ref_reg(op,opsize,
1078 newreference(hp^.location.reference),p^.location.register)));
1079 LOC_REGISTER,
1080 LOC_CREGISTER : exprasmlist^.concat(new(paicpu,op_reg_reg(op,opsize,
1081 hp^.location.register,p^.location.register)));
1082 LOC_FLAGS : begin
1083 { hregister:=reg32toreg8(hregister); }
1084 exprasmlist^.concat(new(paicpu,op_reg(flag_2_set[hp^.location.resflags],S_B,hregister)));
1085 { !!!!!!!!
1086 case porddef(p^.resulttype)^.typ of
1087 bool16bit,
1088 u16bit,s16bit : exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVZX,S_BW,hregister,p^.location.register)));
1089 bool32bit,
1090 u32bit,s32bit : exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVZX,S_BL,hregister,p^.location.register)));
1091 end; }
1092 end;
1093 LOC_JUMP : begin
1094 getlabel(hlabel);
1095 emitl(A_LABEL,truelabel);
1096 exprasmlist^.concat(new(paicpu,op_const_reg(A_MOVE,newsize,1,hregister)));
1097 emitl(A_JMP,hlabel);
1098 emitl(A_LABEL,falselabel);
1099 exprasmlist^.concat(new(paicpu,op_reg(A_CLR,newsize,hregister)));
1100 emitl(A_LABEL,hlabel);
1101 end;
1102 else
1103 internalerror(10061);
1104 end;
1105 truelabel:=oldtruelabel;
1106 falselabel:=oldfalselabel;
1107 end;
1108
1109
1110 procedure second_int_to_bool(p,hp : ptree;convtyp : tconverttype);
1111 var
1112 hregister : tregister;
1113 begin
1114 clear_location(p^.location);
1115 p^.location.loc:=LOC_REGISTER;
1116 del_reference(hp^.location.reference);
1117 case hp^.location.loc of
1118 LOC_MEM,LOC_REFERENCE :
1119 begin
1120 hregister:=getregister32;
1121 exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,S_L,
1122 newreference(hp^.location.reference),hregister)));
1123 end;
1124 LOC_REGISTER,LOC_CREGISTER :
1125 begin
1126 hregister:=hp^.location.register;
1127 end;
1128 else
1129 internalerror(10062);
1130 end;
1131 exprasmlist^.concat(new(paicpu,op_reg_reg(A_OR,S_L,hregister,hregister)));
1132 { hregister:=reg32toreg8(hregister); }
1133 exprasmlist^.concat(new(paicpu,op_reg(flag_2_set[hp^.location.resflags],S_B,hregister)));
1134 case porddef(p^.resulttype)^.typ of
1135 bool8bit : p^.location.register:=hregister;
1136 { !!!!!!!!!!!
1137
1138 bool16bit : begin
1139 p^.location.register:=reg8toreg16(hregister);
1140 exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVZX,S_BW,hregister,p^.location.register)));
1141 end;
1142 bool32bit : begin
1143 p^.location.register:=reg16toreg32(hregister);
1144 exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVZX,S_BL,hregister,p^.location.register)));
1145 end; }
1146 else
1147 internalerror(10064);
1148 end;
1149 end;
1150
1151 procedure second_load_smallset(p,hp : ptree;convtyp : tconverttype);
1152 var
1153 href : treference;
1154 pushedregs : tpushed;
1155 begin
1156 href.symbol:=nil;
1157 pushusedregisters(pushedregs,$ff);
1158 gettempofsizereference(32,href);
1159 emitpushreferenceaddr(exprasmlist,p^.left^.location.reference);
1160 emitpushreferenceaddr(exprasmlist,href);
1161 emitcall('FPC_SET_LOAD_SMALL',true);
1162 maybe_loada5;
1163 popusedregisters(pushedregs);
1164 clear_location(p^.location);
1165 p^.location.loc:=LOC_MEM;
1166 stringdispose(p^.location.reference.symbol);
1167 p^.location.reference:=href;
1168 end;
1169
1170 procedure second_ansistring_to_pchar(p,hp : ptree;convtyp : tconverttype);
1171
1172 var
1173 l1,l2 : pasmlabel;
1174 hr : preference;
1175
1176 begin
1177 InternalError(342132);
1178 {!!!!!!!!!!!
1179
1180 clear_location(p^.location);
1181 p^.location.loc:=LOC_REGISTER;
1182 getlabel(l1);
1183 getlabel(l2);
1184 case hp^.location.loc of
1185 LOC_CREGISTER,LOC_REGISTER:
1186 exprasmlist^.concat(new(paicpu,op_const_reg(A_CMP,S_L,0,
1187 hp^.location.register)));
1188 LOC_MEM,LOC_REFERENCE:
1189 begin
1190 exprasmlist^.concat(new(paicpu,op_const_ref(A_CMP,S_L,0,
1191 newreference(hp^.location.reference))));
1192 del_reference(hp^.location.reference);
1193 p^.location.register:=getregister32;
1194 end;
1195 end;
1196 emitl(A_JZ,l1);
1197 if hp^.location.loc in [LOC_MEM,LOC_REFERENCE] then
1198 exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOV,S_L,newreference(
1199 hp^.location.reference),
1200 p^.location.register)));
1201 emitl(A_JMP,l2);
1202 emitl(A_LABEL,l1);
1203 new(hr);
1204 reset_reference(hr^);
1205 hr^.symbol:=stringdup('FPC_EMPTYCHAR');
1206 exprasmlist^.concat(new(paicpu,op_ref_reg(A_LEA,S_L,hr,
1207 p^.location.register)));
1208 emitl(A_LABEL,l2); }
1209 end;
1210
1211 procedure second_pchar_to_string(p,hp : ptree;convtyp : tconverttype);
1212 begin
1213 internalerror(12121);
1214 end;
1215
1216 procedure second_nothing(p,hp : ptree;convtyp : tconverttype);
1217 begin
1218 end;
1219
1220 {****************************************************************************
1221 SecondTypeConv
1222 ****************************************************************************}
1223
1224 procedure secondtypeconv(var p : ptree);
1225 const
1226 secondconvert : array[tconverttype] of
1227 tsecondconvproc = (second_nothing,second_nothing,
1228 second_bigger,second_only_rangecheck,
1229 second_bigger,second_bigger,second_bigger,
1230 second_smaller,second_smaller,
1231 second_smaller,second_string_string,
1232 second_cstring_charpointer,second_string_chararray,
1233 second_array_to_pointer,second_pointer_to_array,
1234 second_char_to_string,second_bigger,
1235 second_bigger,second_bigger,
1236 second_smaller,second_smaller,
1237 second_smaller,second_smaller,
1238 second_bigger);
1239
1240 {$ifdef dummy}
1241 ,second_smaller,
1242 second_only_rangecheck,second_bigger,
1243 second_bigger,second_bigger,
1244 second_bigger,second_only_rangecheck,
1245 second_smaller,second_smaller,
1246 second_smaller,second_smaller,
1247 second_bool_to_int,second_int_to_bool,
1248 second_int_real,second_real_fix,
1249 second_fix_real,second_int_fix,second_float_float,
1250 second_chararray_to_string,
1251 second_proc_to_procvar,
1252 { is constant char to pchar, is done by firstpass }
1253 second_nothing,
1254 second_load_smallset,
1255 second_ansistring_to_pchar,
1256 second_pchar_to_string,
1257 second_nothing);
1258 {$endif dummy}
1259
1260 begin
1261 { this isn't good coding, I think tc_bool_2_int, shouldn't be }
1262 { type conversion (FK) }
1263
1264 { this is necessary, because second_bool_byte, have to change }
1265 { true- and false label before calling secondpass }
1266 if p^.convtyp<>tc_bool_2_int then
1267 begin
1268 secondpass(p^.left);
1269 set_location(p^.location,p^.left^.location);
1270 if codegenerror then
1271 exit;
1272 end;
1273
1274 if not(p^.convtyp in [tc_equal,tc_not_possible]) then
1275 {the second argument only is for maybe_range_checking !}
1276 secondconvert[p^.convtyp](p,p^.left,p^.convtyp)
1277 end;
1278
1279
1280 {*****************************************************************************
1281 SecondIs
1282 *****************************************************************************}
1283
1284 procedure secondis(var p : ptree);
1285
1286 var
1287 pushed : tpushed;
1288
1289 begin
1290 { save all used registers }
1291 pushusedregisters(pushed,$ffff);
1292 secondpass(p^.left);
1293 clear_location(p^.location);
1294 p^.location.loc:=LOC_FLAGS;
1295 p^.location.resflags:=F_NE;
1296
1297 { push instance to check: }
1298 case p^.left^.location.loc of
1299 LOC_REGISTER,LOC_CREGISTER:
1300 begin
1301 exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,
1302 S_L,p^.left^.location.register,R_SPPUSH)));
1303 ungetregister32(p^.left^.location.register);
1304 end;
1305 LOC_MEM,LOC_REFERENCE:
1306 begin
1307 exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,
1308 S_L,newreference(p^.left^.location.reference),R_SPPUSH)));
1309 del_reference(p^.left^.location.reference);
1310 end;
1311 else internalerror(100);
1312 end;
1313
1314 { generate type checking }
1315 secondpass(p^.right);
1316 case p^.right^.location.loc of
1317 LOC_REGISTER,LOC_CREGISTER:
1318 begin
1319 exprasmlist^.concat(new(paicpu,op_reg_reg(A_MOVE,
1320 S_L,p^.right^.location.register,R_SPPUSH)));
1321 ungetregister32(p^.right^.location.register);
1322 end;
1323 LOC_MEM,LOC_REFERENCE:
1324 begin
1325 exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOVE,
1326 S_L,newreference(p^.right^.location.reference),R_SPPUSH)));
1327 del_reference(p^.right^.location.reference);
1328 end;
1329 else internalerror(100);
1330 end;
1331 emitcall('FPC_DO_IS',true);
1332 exprasmlist^.concat(new(paicpu,op_reg(A_TST,S_B,R_D0)));
1333 popusedregisters(pushed);
1334 end;
1335
1336
1337 {*****************************************************************************
1338 SecondAs
1339 *****************************************************************************}
1340
1341 procedure secondas(var p : ptree);
1342
1343 var
1344 pushed : tpushed;
1345
1346 begin
1347 set_location(p^.location,p^.left^.location);
1348 { save all used registers }
1349 pushusedregisters(pushed,$ffff);
1350 { push the vmt of the class }
1351 exprasmlist^.concat(new(paicpu,op_csymbol_reg(A_MOVE,
1352 S_L,newcsymbol(pobjectdef(p^.right^.resulttype)^.vmt_mangledname,0),R_SPPUSH)));
1353 emitpushreferenceaddr(exprasmlist,p^.location.reference);
1354 emitcall('FPC_DO_AS',true);
1355 popusedregisters(pushed);
1356 end;
1357
1358
1359 end.
1360 {
1361 $Log$
1362 Revision 1.1 2002/02/19 08:21:46 sasu
1363 Initial revision
1364
1365 Revision 1.1 2000/07/13 06:29:46 michael
1366 + Initial import
1367
1368 Revision 1.17 2000/02/09 13:22:48 peter
1369 * log truncated
1370
1371 Revision 1.16 2000/01/07 01:14:21 peter
1372 * updated copyright to 2000
1373
1374 Revision 1.15 1999/12/22 01:01:47 peter
1375 - removed freelabel()
1376 * added undefined label detection in internal assembler, this prevents
1377 a lot of ld crashes and wrong .o files
1378 * .o files aren't written anymore if errors have occured
1379 * inlining of assembler labels is now correct
1380
1381 Revision 1.14 1999/09/16 23:05:51 florian
1382 * m68k compiler is again compilable (only gas writer, no assembler reader)
1383
1384 Revision 1.13 1999/08/25 11:59:48 jonas
1385 * changed pai386, paippc and paiapha (same for tai*) to paicpu (taicpu)
1386
1387 }
Mirror of AROS' Contrib svn.