← Back to branch summary

~ubuntu-branches/ubuntu/dapper/fpc/dapper

« back to all changes in this revision

Viewing changes to rtl/m68k/m68k.inc

  • Committer: Bazaar Package Importer
  • Author(s): Carlos Laviola
  • Date: 2004-08-12 16:29:37 UTC
  • mfrom: (1.2.1 upstream) (2.1.1 warty)
  • Revision ID: james.westby@ubuntu.com-20040812162937-moo8ulvysp1ln771
Tags: 1.9.4-5
http://bugs.debian.org/265265
fp-compiler: needs ld, adding dependency on binutils.  (Closes: #265265)

Show diffs side-by-side

added added

removed removed

Lines of Context:
rtl/m68k/m68k.inc
1
1
{
2
 
    $Id: m68k.inc,v 1.1 2000/07/13 06:30:56 michael Exp $
 
2
    $Id: m68k.inc,v 1.5 2004/05/23 12:42:42 florian Exp $
3
3
    This file is part of the Free Pascal run time library.
4
4
    Copyright (c) 1999-2000 by Carl-Eric Codere,
5
5
    member of the Free Pascal development team.
30
30
{****************************************************************************}
31
31
 
32
32
 
33
 
    { Don't call the following routines directly. }
34
 
 Procedure Hlt;[public,alias: 'FPC_HALT_ERROR'];
35
 
 { called by code generator on run-time errors. }
36
 
 { on entry contains d0 = error code.           }
37
 
 var
38
 
  b:byte; { only byte is used... }
39
 
 begin
40
 
  asm
41
 
     move.b d0,b
42
 
  end;
43
 
     HandleError(b);
44
 
 end;
45
 
 
46
 
 
47
 
 
48
 
 
49
 
   Procedure FillChar(var x;count:longint;value:byte);[public,alias: 'FPC_FILL_OBJECT'];
50
 
   begin
51
 
     asm
52
 
      move.l 8(a6), a0      { destination                   }
53
 
      move.l 12(a6), d1     { number of bytes to fill       }
54
 
      move.b 16(a6),d0      { fill data                     }
55
 
      cmpi.l #65535, d1     { check, if this is a word move }
56
 
      ble    @LMEMSET3      { use fast dbra mode            }
57
 
      bra @LMEMSET2
58
 
    @LMEMSET1:
59
 
      move.b d0,(a0)+
60
 
    @LMEMSET2:
61
 
      subq.l #1,d1
62
 
      cmp.l #-1,d1
63
 
      bne  @LMEMSET1
64
 
      bra @LMEMSET5        { finished slow mode , exit     }
65
 
 
66
 
    @LMEMSET4:             { fast loop mode section 68010+ }
67
 
      move.b d0,(a0)+
68
 
    @LMEMSET3:
69
 
      dbra d1,@LMEMSET4
70
 
 
71
 
    @LMEMSET5:
72
 
     end ['d0','d1','a0'];
73
 
   end;
74
 
 
75
 
   Procedure FillObject(var x; count: longint; value: byte);
76
 
   begin
77
 
     asm
78
 
      move.l 8(a6), a0      { destination                   }
79
 
      move.l 12(a6), d1     { number of bytes to fill       }
80
 
      move.w 16(a6),d0      { fill data                     }
81
 
      cmp.l  #65535, d1     { check, if this is a word move }
82
 
      ble    @LMEMSET3      { use fast dbra mode            }
83
 
      bra @LMEMSET2
84
 
    @LMEMSET1:
85
 
      move.b d0,(a0)+
86
 
    @LMEMSET2:
87
 
      subq.l #1,d1
88
 
      cmp.l #-1,d1
89
 
      bne  @LMEMSET1
90
 
      bra @LMEMSET5        { finished slow mode , exit     }
91
 
 
92
 
    @LMEMSET4:             { fast loop mode section 68010+ }
93
 
      move.b d0,(a0)+
94
 
    @LMEMSET3:
95
 
      dbra d1,@LMEMSET4
96
 
 
97
 
    @LMEMSET5:
98
 
     end ['d0','d1','a0'];
99
 
   end;
100
 
 
101
 
    procedure int_help_constructor;[public,alias:'FPC_HELP_CONSTRUCTOR'];
102
 
 
103
 
      begin
104
 
         asm
105
 
            { Entry without preamble, since we need the ESP of the
106
 
              constructor }
107
 
            { Stack (relative to %ebp):
108
 
                12 Self
109
 
                8 VMT-Address
110
 
                4 main programm-Addr
111
 
                0 %ebp
112
 
            }
113
 
            { do we have to initialize self  }
114
 
            { we just need to check for zero }
115
 
            move.l    a5,d0
116
 
            tst.l     d0      { set flags }
117
 
            bne       @LHC_4
118
 
 
119
 
            { get memory, but save register first }
120
 
            { temporary variable }
121
 
            subq.l #4,sp
122
 
            move.l sp,a5
123
 
            { Save Registers }
124
 
            movem.l d0-a7,-(sp)
125
 
            { Memory size }
126
 
            move.l 8(a6),a0
127
 
            move.l (a0),-(sp)
128
 
            { push method pointer }
129
 
            move.l a5,-(sp)
130
 
            jsr FPC_GETMEM
131
 
            { Restore all registers in the correct order }
132
 
            movem.l (sp)+,d0-a7
133
 
            { Memory position to a5 }
134
 
            move.l (a5),a5
135
 
            addq.l  #4,sp
136
 
            { If no memory available : fail() }
137
 
            move.l a5,d0
138
 
            tst.l  d0         { set flags for a5 }
139
 
            beq    @LHC_5
140
 
            { init self for the constructor }
141
 
            move.l a5,12(a6)
142
 
         @LHC_4:
143
 
            { is there a VMT address ? }
144
 
            move.l 8(a6),d0
145
 
            or.l   d0,d0
146
 
            bne @LHC_7
147
 
            { In case the constructor doesn't do anything, the Zero-Flag }
148
 
            { can't be put, because this calls Fail() }
149
 
            add.l  #1,d0
150
 
            rts
151
 
         @LHC_7:
152
 
            { set zero inside the object }
153
 
            { Save Registers }
154
 
            movem.l d0-a7,-(sp)
155
 
            move.w  #0,-(sp)
156
 
 
157
 
            move.l  8(a6),a0
158
 
            move.l  (a0),-(sp)
159
 
            move.l  a5,-(sp)
160
 
            {                }
161
 
            jsr  FPC_FILLOBJECT
162
 
            { Restore all registers in the correct order }
163
 
            movem.l (sp)+,d0-a7
164
 
            { set the VMT address for the new created object }
165
 
{$ifdef OBJECTVMTOFFSET}
166
 
      { the offset is in %edi since the calling and has not been changed !! }
167
 
            move.l 8(a6),d1
168
 
            move.l d1,(a5,d0.l)
169
 
{$else OBJECTVMTOFFSET}
170
 
            move.l 8(a6),d0
171
 
            move.l d0,(a5)
172
 
{$endif OBJECTVMTOFFSET}
173
 
            or.l d0,d0
174
 
         @LHC_5:
175
 
            rts
176
 
         end;
177
 
      end;
178
 
 
179
 
    procedure help_fail;
180
 
 
181
 
      begin
182
 
         asm
183
 
         end;
184
 
      end;
185
 
 
186
 
    procedure int_help_destructor;[public,alias:'FPC_HELP_DESTRUCTOR'];
187
 
 
188
 
      begin
189
 
         asm
190
 
            { Stack (relative to %ebp):
191
 
                12 Self
192
 
                8 VMT-Address
193
 
                4 Main program-Addr
194
 
                0 %ebp
195
 
                d0 contains vmt_offset
196
 
            }
197
 
            { temporary Variable }
198
 
            subq.l #4,sp
199
 
            move.l sp,d6
200
 
            { Save Registers }
201
 
            movem.l d0-a7,-(sp)
202
 
 
203
 
            move.l 8(a6),d1         { Get the address of the vmt }
204
 
            or.l   d1,d1            { Check if there is a vmt    }
205
 
            beq    @LHD_3
206
 
            { Yes, get size from SELF! }
207
 
            move.l 12(a6),a0
208
 
            { get VMT-pointer (from Self) to %ebx }
209
 
{$ifdef OBJECTVMTOFFSET}
210
 
      { the offset is in d0 since the calling and has not been changed !! }
211
 
            move.l (a0,d0.l),a1
212
 
{$else OBJECTVMTOFFSET}
213
 
            move.l (a0),a1
214
 
{$endif OBJECTVMTOFFSET}
215
 
            { And put size on the Stack }
216
 
            move.l (a1),-(sp)
217
 
            { SELF }
218
 
            { I think for precaution }
219
 
            { that we should clear the VMT here }
220
 
            clr.l (a0)
221
 
            { get address of local variable into  }
222
 
            { address register                    }
223
 
            move.l d6,a1
224
 
            move.l a0,(a1)
225
 
            move.l a1,-(sp)
226
 
            jsr    FPC_FREEMEM
227
 
         @LHD_3:
228
 
            { Restore all registers in the correct order }
229
 
            movem.l (sp)+,d0-a7
230
 
            add.l #4,sp
231
 
            rts
232
 
         end;
233
 
      end;
234
 
 
235
 
  procedure new_class;assembler;[public,alias:'FPC_NEW_CLASS'];
236
 
 
237
 
  asm
238
 
     { create class ? }
239
 
     move.l 8(a6), d0
240
 
     tst.l  d0
241
 
     { check for nil... }
242
 
     beq    @NEW_CLASS1
243
 
 
244
 
     { a5 contains vmt }
245
 
     move.l a5,-(sp)
246
 
     { call newinstance (class method!) }
247
 
     jsr 16(a5)
248
 
     { new instance returns a pointer to the new created }
249
 
     { instance in d0                                    }
250
 
     { load a5  and insert self                          }
251
 
     move.l d0,8(a6)
252
 
     move.l d0,a5
253
 
     bra    @end
254
 
  @NEW_CLASS1:
255
 
     move.l a5,8(a6)
256
 
  @end:
257
 
  end;
258
 
 
259
 
 
260
 
 
261
 
  procedure dispose_class;assembler;[public,alias:'FPC_DISPOSE_CLASS'];
262
 
 
263
 
  asm
264
 
     { destroy class ? }
265
 
     move.l 8(a6),d0
266
 
     { save self }
267
 
     move.l a5,8(a6)
268
 
     tst.l  d0
269
 
     beq    @DISPOSE_CLASS
270
 
     { no inherited call }
271
 
     move.l (a5),d0
272
 
     { push self }
273
 
     move.l a5,-(sp)
274
 
     { call freeinstance }
275
 
     move.l d0,a0
276
 
     jsr    20(a0)
277
 
  @DISPOSE_CLASS:
278
 
     { load self }
279
 
     move.l 8(a6),a5
280
 
  end;
281
 
 
282
 
  { checks for a correct vmt pointer }
283
 
  procedure int_check_object;assembler;[public,alias:'FPC_CHECK_OBJECT'];
284
 
  { ON ENTRY: a0 -> Pointer to the VMT                  }
285
 
  {   Nota: All registers must be preserved including   }
286
 
  {   A0 itself!                                        }
287
 
  asm
288
 
     move.l   d0,-(sp)
289
 
     tst.l    a0
290
 
     { z flag set if zero }
291
 
     beq      @co_re
292
 
 
293
 
     move.l   (a0),d0
294
 
     add.l    4(a0),d0
295
 
     bne      @co_re
296
 
     bra      @end
297
 
@co_re:
298
 
     move.l   (sp)+,d0
299
 
     move.b   #210,d0
300
 
     jsr      FPC_HALT_ERROR
301
 
@end:
302
 
     move.l   (sp)+,d0
303
 
  end;
304
 
 
305
 
 
306
 
    function get_frame : longint; assembler;
307
 
      asm
308
 
              move.l a6,d0
309
 
      end;
310
 
 
311
 
 
312
 
    function get_caller_addr(framebp:longint):longint;
313
 
      begin
314
 
         asm
315
 
            move.l FRAMEBP,a0
316
 
            cmp.l #0,a0
317
 
            beq @Lnul_address
318
 
            move.l 4(a0),a0
319
 
         @Lnul_address:
320
 
            move.l a0,@RESULT
321
 
         end ['a0'];
322
 
      end;
323
 
 
324
 
    function get_caller_frame(framebp:longint):longint;
325
 
 
326
 
      begin
327
 
         asm
328
 
            move.l FRAMEBP,a0
329
 
            cmp.l  #0,a0
330
 
            beq    @Lnul_frame
331
 
            move.l (a0),a0
332
 
         @Lnul_frame:
333
 
            move.l a0,@RESULT
334
 
         end ['a0'];
335
 
      end;
336
 
 
 
33
procedure fpc_cpuinit;
 
34
  begin
 
35
  end;
 
36
 
 
37
{$define FPC_SYSTEM_HAS_GET_FRAME}
 
38
function get_frame : pointer; assembler;
 
39
  asm
 
40
    move.l a6,d0
 
41
  end;
 
42
 
 
43
 
 
44
{$define FPC_SYSTEM_HAS_GET_CALLER_ADDR}
 
45
function get_caller_addr(framebp : pointer) : pointer;
 
46
  begin
 
47
     asm
 
48
        move.l FRAMEBP,a0
 
49
        cmp.l #0,a0
 
50
        beq @Lnul_address
 
51
        move.l 4(a0),a0
 
52
     @Lnul_address:
 
53
        move.l a0,@RESULT
 
54
     end ['a0'];
 
55
  end;
 
56
 
 
57
 
 
58
{$define FPC_SYSTEM_HAS_GET_CALLER_FRAME}
 
59
function get_caller_frame(framebp : pointer) : pointer;
 
60
  begin
 
61
     asm
 
62
        move.l FRAMEBP,a0
 
63
        cmp.l  #0,a0
 
64
        beq    @Lnul_frame
 
65
        move.l (a0),a0
 
66
     @Lnul_frame:
 
67
        move.l a0,@RESULT
 
68
     end ['a0'];
 
69
  end;
 
70
 
 
71
 
 
72
{$define FPC_SYSTEM_HAS_SPTR}
 
73
function Sptr : Longint;
 
74
  begin
 
75
    asm
 
76
      move.l sp,d0
 
77
      add.l  #8,d0
 
78
      move.l d0,@RESULT
 
79
    end ['d0'];
 
80
  end;
 
81
 
 
82
 
 
83
{$define FPC_SYSTEM_HAS_FILLCHAR}
 
84
procedure FillChar(var x;count:longint;value:byte);[public,alias: 'FPC_FILL_OBJECT'];
 
85
  begin
 
86
    asm
 
87
     move.l 8(a6), a0      { destination                   }
 
88
     move.l 12(a6), d1     { number of bytes to fill       }
 
89
     move.b 16(a6),d0      { fill data                     }
 
90
     cmpi.l #65535, d1     { check, if this is a word move }
 
91
     ble    @LMEMSET3      { use fast dbra mode            }
 
92
     bra @LMEMSET2
 
93
   @LMEMSET1:
 
94
     move.b d0,(a0)+
 
95
   @LMEMSET2:
 
96
     subq.l #1,d1
 
97
     cmp.l #-1,d1
 
98
     bne  @LMEMSET1
 
99
     bra @LMEMSET5        { finished slow mode , exit     }
 
100
 
 
101
   @LMEMSET4:             { fast loop mode section 68010+ }
 
102
     move.b d0,(a0)+
 
103
   @LMEMSET3:
 
104
     dbra d1,@LMEMSET4
 
105
 
 
106
   @LMEMSET5:
 
107
    end ['d0','d1','a0'];
 
108
  end;
 
109
 
 
110
 
 
111
{$ifdef dummy}
337
112
{    procedure strcopy(dstr,sstr : pointer;len : longint);[public,alias: 'STRCOPY'];}
338
 
     procedure strcopy; assembler;[public,alias: 'FPC_STRCOPY'];
339
 
    {---------------------------------------------------}
340
 
    { Low-level routine to copy a string to another     }
341
 
    { string with maximum length. Never call directly!  }
342
 
    { On Entry:                                         }
343
 
    {     a1.l = string to copy to                      }
344
 
    {     a0.l = source string                          }
345
 
    {     d0.l = maximum length of copy                 }
346
 
    { registers destroyed: a0,a1,d0,d1                  }
347
 
    {---------------------------------------------------}
348
 
         asm
 
113
procedure strcopy; assembler;[public,alias: 'FPC_STRCOPY'];
 
114
{---------------------------------------------------}
 
115
{ Low-level routine to copy a string to another     }
 
116
{ string with maximum length. Never call directly!  }
 
117
{ On Entry:                                         }
 
118
{     a1.l = string to copy to                      }
 
119
{     a0.l = source string                          }
 
120
{     d0.l = maximum length of copy                 }
 
121
{ registers destroyed: a0,a1,d0,d1                  }
 
122
{---------------------------------------------------}
 
123
asm
349
124
{            move.l 12(a6),a0
350
 
            move.l 16(a6),a1
351
 
            move.l 8(a6),d1 }
352
 
            move.l d0,d1
353
 
 
354
 
            move.b (a0)+,d0     { Get source length }
355
 
            and.w  #$ff,d0
356
 
            cmp.w  d1,d0        { This is a signed comparison! }
357
 
            ble    @LM4
358
 
            move.b d1,d0        { If longer than maximum size of target, cut
359
 
                                  source length }
360
 
         @LM4:
361
 
            andi.l #$ff,d0     { zero extend d0-byte }
362
 
            move.l d0,d1       { save length to copy }
363
 
            move.b d0,(a1)+    { save new length     }
364
 
            { Check if copying length is zero - if so then }
365
 
            { exit without copying anything.               }
366
 
            tst.b  d1
367
 
            beq    @Lend
368
 
            bra    @LMSTRCOPY55
369
 
         @LMSTRCOPY56:         { 68010 Fast loop mode }
370
 
            move.b (a0)+,(a1)+
371
 
         @LMSTRCOPY55:
372
 
            dbra  d1,@LMSTRCOPY56
373
 
         @Lend:
374
 
      end;
375
 
 
376
 
    { Concatenate Strings }
377
 
    { PARAMETERS ARE REVERSED COMPARED TO NORMAL! }
378
 
    { therefore online assembler may not parse the params as normal }
379
 
    procedure strconcat(s1,s2 : pointer);[public,alias: 'STRCONCAT'];
380
 
 
381
 
      begin
382
 
         asm
383
 
          move.b  #255,d0
384
 
          move.l  s1,a0                { a0 = destination }
385
 
          move.l  s2,a1                { a1 = source      }
386
 
          sub.b   (a0),d0              {  copyl:= 255 -length(s1)    }
387
 
          move.b  (a1),d6
388
 
          and.w   #$ff,d0              { Sign flags are checked!     }
389
 
          and.w   #$ff,d6
390
 
          cmp.w   d6,d0                { if copyl > length(s2) then  }
391
 
          ble     @Lcontinue
392
 
          move.b  (a1),d0              {  copyl:=length(s2)          }
393
 
    @Lcontinue:
394
 
          move.b  (a0),d6
395
 
          and.l   #$ff,d6
396
 
          lea     1(a0,d6),a0          { s1[length(s1)+1]            }
397
 
          add.l   #1,a1                { s2[1]                       }
398
 
          move.b  d0,d6
399
 
          { Check if copying length is zero - if so then }
400
 
          { exit without copying anything.               }
401
 
          tst.b  d6
402
 
          beq    @Lend
403
 
          bra    @ALoop
404
 
    @Loop:
405
 
          move.b  (a1)+,(a0)+          { s1[i] := s2[i];             }
406
 
    @ALoop:
407
 
          dbra    d6,@Loop
408
 
          move.l  s1,a0
409
 
          add.b   d0,(a0)              { change to new string length }
410
 
    @Lend:
411
 
         end ['d0','d1','a0','a1','d6'];
412
 
      end;
413
 
 
414
 
    { Compares strings }
415
 
    { DO NOT CALL directly.                                 }
416
 
    {   a0 = pointer to first string to compare             }
417
 
    {   a1 = pointer to second string to compare            }
418
 
    {   ALL FLAGS are set appropriately.                    }
419
 
    {    ZF = strings are equal                             }
420
 
    { REGISTERS DESTROYED: a0, a1, d0, d1, d6               }
421
 
    procedure strcmp; assembler;[public,alias:'FPC_STRCMP'];
422
 
     asm
423
 
            move.b (a0)+,d0     { Get length of first string  }
424
 
            move.b (a1)+,d6     { Get length of 2nd string    }
425
 
 
426
 
            move.b  d6,d1      { Save length of string for final compare   }
427
 
 
428
 
            cmp.b  d0,d6        { Get shortest string length   }
429
 
            ble    @LSTRCONCAT1
430
 
            move.b d0,d6       { Set length to shortest string }
431
 
 
432
 
         @LSTRCONCAT1:
433
 
            tst.b  d6          { Both strings have a length of zero, exit }
434
 
            beq    @LSTRCONCAT2
435
 
 
436
 
            andi.l  #$ff,d6
437
 
 
438
 
 
439
 
            subq.l  #1,d6      { subtract first attempt                    }
440
 
            { if value is -1 then don't loop and just compare lengths of   }
441
 
            { both strings before exiting.                                 }
442
 
            bmi     @LSTRCONCAT2
443
 
            or.l    d0,d0      { Make sure to set Zerfo flag to 0          }
444
 
         @LSTRCONCAT5:
445
 
            { Workaroung for GAS v.134 bug }
446
 
            {  old: cmp.b (a1)+,(a0)+      }
447
 
            cmpm.b  (a1)+,(a0)+
448
 
         @LSTRCONCAT4:
449
 
            dbne    d6,@LSTRCONCAT5   { Repeat until not equal }
450
 
            bne     @LSTRCONCAT3
451
 
          @LSTRCONCAT2:
452
 
            { If length of both string are equal }
453
 
            { Then set zero flag                 }
454
 
            cmp.b   d1,d0   { Compare length - set flag if equal length strings }
455
 
         @LSTRCONCAT3:
456
 
     end;
457
 
 
458
 
 
459
 
  Function strpas(p: pchar): string;
460
 
  { only 255 first characters are actually copied. }
461
 
   var
462
 
    counter : byte;
463
 
    str: string;
464
 
  Begin
465
 
     counter := 0;
466
 
     str := '';
467
 
     while (ord(p[counter]) <> 0) and (counter < 255) do
468
 
     begin
469
 
        counter:=counter+1;
470
 
        str[counter] := char(p[counter-1]);
471
 
     end;
472
 
     str[0] := char(counter);
473
 
     strpas := str;
474
 
  end;
475
 
 
476
 
  function strlen(p : pchar) : longint;
477
 
  var
478
 
     counter : longint;
479
 
  Begin
480
 
       counter := 0;
481
 
       repeat
482
 
          counter:=counter+1;
483
 
       until ord(p[counter]) = 0;
484
 
       strlen := counter;
485
 
  end;
486
 
 
487
 
 
488
 
   procedure move(var source;var dest;count : longint);
489
 
   { base pointer+8 = source                  }
490
 
   { base pointer+12 = destination            }
491
 
   { base pointer+16 = number of bytes to move}
492
 
   begin
493
 
     asm
494
 
      clr.l      d0
495
 
      move.l   16(a6),d0   {  number of bytes }
496
 
    @LMOVE0:
497
 
      move.l   12(a6),a1   {  destination          }
498
 
      move.l   8(a6),a0      {  source               }
499
 
 
500
 
      cmpi.l #65535, d0     { check, if this is a word move }
501
 
      ble    @LMEMSET00     { use fast dbra mode 68010+     }
502
 
 
503
 
      cmp.l      a0,a1         {  check copy direction }
504
 
      bls      @LMOVE4
505
 
      add.l      d0,a0         { move pointers to end  }
506
 
      add.l      d0,a1
507
 
      bra     @LMOVE2
508
 
    @LMOVE1:
509
 
      move.b   -(a0),-(a1)   {  (s < d) copy loop }
510
 
    @LMOVE2:
511
 
      subq.l    #1,d0
512
 
      cmpi.l    #-1,d0
513
 
      bne       @LMOVE1
514
 
      bra       @LMOVE5
515
 
    @LMOVE3:
516
 
      move.b  (a0)+,(a1)+  { (s >= d) copy loop }
517
 
    @LMOVE4:
518
 
      subq.l    #1,d0
519
 
      cmpi.l    #-1,d0
520
 
      bne       @LMOVE3
521
 
      bra       @LMOVE5
522
 
 
523
 
    @LMEMSET00:            { use fast loop mode 68010+ }
524
 
      cmp.l      a0,a1         {  check copy direction }
525
 
      bls      @LMOVE04
526
 
      add.l      d0,a0         { move pointers to end  }
527
 
      add.l      d0,a1
528
 
      bra     @LMOVE02
529
 
    @LMOVE01:
530
 
      move.b   -(a0),-(a1)   {  (s < d) copy loop }
531
 
    @LMOVE02:
532
 
      dbra      d0,@LMOVE01
533
 
      bra       @LMOVE5
534
 
    @LMOVE03:
535
 
      move.b  (a0)+,(a1)+  { (s >= d) copy loop }
536
 
    @LMOVE04:
537
 
      dbra      d0,@LMOVE03
538
 
    { end fast loop mode }
539
 
    @LMOVE5:
540
 
    end ['d0','a0','a1'];
541
 
   end;
542
 
 
543
 
 
544
 
    procedure fillword(var x;count : longint;value : word);
545
 
 
546
 
      begin
547
 
     asm
548
 
      move.l 8(a6), a0      { destination             }
549
 
      move.l 12(a6), d1     { number of bytes to fill }
550
 
      move.w 16(a6),d0      { fill data               }
551
 
      bra @LMEMSET21
552
 
    @LMEMSET11:
553
 
      move.w d0,(a0)+
554
 
    @LMEMSET21:
555
 
      subq.l #1,d1
556
 
      cmp.b #-1,d1
557
 
      bne  @LMEMSET11
558
 
     end ['d0','d1','a0'];
559
 
   end;
560
 
 
561
 
 
562
 
    function abs(l : longint) : longint;
563
 
 
564
 
      begin
565
 
         asm
566
 
            move.l 8(a6),d0
567
 
            tst.l  d0
568
 
            bpl @LMABS1
569
 
            neg.l d0
570
 
         @LMABS1:
571
 
            move.l d0,@RESULT
572
 
         end ['d0'];
573
 
      end;
574
 
 
575
 
    function odd(l : longint) : boolean;
576
 
 
577
 
      begin
578
 
        if (l and $01) = $01 then
579
 
          odd := TRUE
580
 
        else
581
 
          odd := FALSE;
582
 
      end;
583
 
 
584
 
    function sqr(l : longint) : longint;
585
 
 
586
 
      begin
587
 
         sqr := l*l;
588
 
      end;
589
 
 
590
 
    procedure int_str(l : longint;var s : string);
591
 
 
592
 
      var
593
 
        value: longint;
594
 
        negative: boolean;
595
 
 
596
 
      begin
597
 
         negative := false;
598
 
         s:='';
599
 
         { Workaround: }
600
 
         if l=$80000000 then
601
 
           begin
602
 
              s:='-2147483648';
603
 
              exit;
604
 
           end;
605
 
        { handle case where l = 0 }
606
 
         if l = 0 then
607
 
         begin
608
 
           s:='0';
609
 
           exit;
610
 
         end;
611
 
         If l < 0 then
612
 
         begin
613
 
             negative := true;
614
 
             value:=abs(l);
615
 
         end
616
 
         else
617
 
             value:=l;
618
 
       { handle non-zero case }
619
 
       while value>0 do
620
 
         begin
621
 
            s:=char((value mod 10)+ord('0'))+s;
622
 
            value := value div 10;
623
 
         end;
624
 
         if negative then
625
 
           s := '-' + s;
626
 
      end;
627
 
 
628
 
 
629
 
Function Sptr : Longint;
630
 
begin
631
 
  asm
632
 
    move.l sp,d0
633
 
    add.l  #8,d0
634
 
    move.l d0,@RESULT
635
 
  end ['d0'];
636
 
end;
637
 
 
638
 
 
639
 
 
640
 
 
641
 
 Procedure BoundsCheck;assembler;[public,alias:'FPC_RE_BOUNDS_CHECK'];
642
 
 { called by code generator with R+ state to    }
643
 
 { determine if a range check occured.          }
644
 
 { Only in 68000 mode, in 68020 mode this is    }
645
 
 { inline.                                      }
646
 
 { On Entry:                                    }
647
 
 {   A1 = address contaning min and max indexes }
648
 
 {   D0 = value of current index to check.      }
649
 
 asm
650
 
  cmp.l   (A1),D0        { lower bound ...    }
651
 
  bmi     @rebounderr    { is index lower ... }
652
 
  add.l   #4,A1
653
 
  cmp.l   (A1),D0
654
 
  bmi     @reboundend
655
 
  beq     @reboundend
656
 
@rebounderr:
657
 
  move.l  #201,d0
658
 
  jsr     FPC_HALT_ERROR
659
 
@reboundend:
660
 
 end;
661
 
 
662
 
{****************************************************************************
663
 
                                 IoCheck
664
 
****************************************************************************}
665
 
 
666
 
procedure int_iocheck(addr : longint);[public,alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'IOCHECK'];
667
 
var
668
 
  l : longint;
669
 
begin
670
 
  asm
671
 
        movem.l d0-a7,-(sp)
672
 
  end;
673
 
  if InOutRes<>0 then
674
 
   begin
675
 
     l:=InOutRes;
676
 
     InOutRes:=0;
677
 
     If ErrorProc<>Nil then
678
 
       TErrorProc(Errorproc)(l,pointer(addr));
679
 
{$ifndef RTLLITE}
680
 
     writeln('IO-Error ',l,' at 0x',HexStr(addr,8));
681
 
{$endif}
682
 
     Halt(byte(l));
683
 
   end;
684
 
  asm
685
 
        movem.l (sp)+,d0-a7
686
 
  end;
687
 
end;
 
125
   move.l 16(a6),a1
 
126
   move.l 8(a6),d1 }
 
127
   move.l d0,d1
 
128
 
 
129
   move.b (a0)+,d0     { Get source length }
 
130
   and.w  #$ff,d0
 
131
   cmp.w  d1,d0        { This is a signed comparison! }
 
132
   ble    @LM4
 
133
   move.b d1,d0        { If longer than maximum size of target, cut
 
134
                         source length }
 
135
@LM4:
 
136
   andi.l #$ff,d0     { zero extend d0-byte }
 
137
   move.l d0,d1       { save length to copy }
 
138
   move.b d0,(a1)+    { save new length     }
 
139
   { Check if copying length is zero - if so then }
 
140
   { exit without copying anything.               }
 
141
   tst.b  d1
 
142
   beq    @Lend
 
143
   bra    @LMSTRCOPY55
 
144
@LMSTRCOPY56:         { 68010 Fast loop mode }
 
145
   move.b (a0)+,(a1)+
 
146
@LMSTRCOPY55:
 
147
   dbra  d1,@LMSTRCOPY56
 
148
@Lend:
 
149
end;
 
150
 
 
151
 
 
152
{ Concatenate Strings }
 
153
{ PARAMETERS ARE REVERSED COMPARED TO NORMAL! }
 
154
{ therefore online assembler may not parse the params as normal }
 
155
procedure strconcat(s1,s2 : pointer);[public,alias: 'STRCONCAT'];
 
156
  begin
 
157
     asm
 
158
      move.b  #255,d0
 
159
      move.l  s1,a0                { a0 = destination }
 
160
      move.l  s2,a1                { a1 = source      }
 
161
      sub.b   (a0),d0              {  copyl:= 255 -length(s1)    }
 
162
      move.b  (a1),d6
 
163
      and.w   #$ff,d0              { Sign flags are checked!     }
 
164
      and.w   #$ff,d6
 
165
      cmp.w   d6,d0                { if copyl > length(s2) then  }
 
166
      ble     @Lcontinue
 
167
      move.b  (a1),d0              {  copyl:=length(s2)          }
 
168
@Lcontinue:
 
169
      move.b  (a0),d6
 
170
      and.l   #$ff,d6
 
171
      lea     1(a0,d6),a0          { s1[length(s1)+1]            }
 
172
      add.l   #1,a1                { s2[1]                       }
 
173
      move.b  d0,d6
 
174
      { Check if copying length is zero - if so then }
 
175
      { exit without copying anything.               }
 
176
      tst.b  d6
 
177
      beq    @Lend
 
178
      bra    @ALoop
 
179
@Loop:
 
180
      move.b  (a1)+,(a0)+          { s1[i] := s2[i];             }
 
181
@ALoop:
 
182
      dbra    d6,@Loop
 
183
      move.l  s1,a0
 
184
      add.b   d0,(a0)              { change to new string length }
 
185
@Lend:
 
186
     end ['d0','d1','a0','a1','d6'];
 
187
  end;
 
188
 
 
189
{ Compares strings }
 
190
{ DO NOT CALL directly.                                 }
 
191
{   a0 = pointer to first string to compare             }
 
192
{   a1 = pointer to second string to compare            }
 
193
{   ALL FLAGS are set appropriately.                    }
 
194
{    ZF = strings are equal                             }
 
195
{ REGISTERS DESTROYED: a0, a1, d0, d1, d6               }
 
196
procedure strcmp; assembler;[public,alias:'FPC_STRCMP'];
 
197
asm
 
198
       move.b (a0)+,d0     { Get length of first string  }
 
199
       move.b (a1)+,d6     { Get length of 2nd string    }
 
200
 
 
201
       move.b  d6,d1      { Save length of string for final compare   }
 
202
 
 
203
       cmp.b  d0,d6        { Get shortest string length   }
 
204
       ble    @LSTRCONCAT1
 
205
       move.b d0,d6       { Set length to shortest string }
 
206
 
 
207
    @LSTRCONCAT1:
 
208
       tst.b  d6          { Both strings have a length of zero, exit }
 
209
       beq    @LSTRCONCAT2
 
210
 
 
211
       andi.l  #$ff,d6
 
212
 
 
213
 
 
214
       subq.l  #1,d6      { subtract first attempt                    }
 
215
       { if value is -1 then don't loop and just compare lengths of   }
 
216
       { both strings before exiting.                                 }
 
217
       bmi     @LSTRCONCAT2
 
218
       or.l    d0,d0      { Make sure to set Zerfo flag to 0          }
 
219
    @LSTRCONCAT5:
 
220
       { Workaroung for GAS v.134 bug }
 
221
       {  old: cmp.b (a1)+,(a0)+      }
 
222
       cmpm.b  (a1)+,(a0)+
 
223
    @LSTRCONCAT4:
 
224
       dbne    d6,@LSTRCONCAT5   { Repeat until not equal }
 
225
       bne     @LSTRCONCAT3
 
226
     @LSTRCONCAT2:
 
227
       { If length of both string are equal }
 
228
       { Then set zero flag                 }
 
229
       cmp.b   d1,d0   { Compare length - set flag if equal length strings }
 
230
    @LSTRCONCAT3:
 
231
end;
 
232
{$endif dummy}
 
233
 
 
234
 
 
235
{$define FPC_SYSTEM_HAS_MOVE}
 
236
procedure move(var source;var dest;count : longint);
 
237
{ base pointer+8 = source                  }
 
238
{ base pointer+12 = destination            }
 
239
{ base pointer+16 = number of bytes to move}
 
240
begin
 
241
  asm
 
242
    clr.l      d0
 
243
    move.l   16(a6),d0   {  number of bytes }
 
244
  @LMOVE0:
 
245
    move.l   12(a6),a1   {  destination          }
 
246
    move.l   8(a6),a0      {  source               }
 
247
 
 
248
    cmpi.l #65535, d0     { check, if this is a word move }
 
249
    ble    @LMEMSET00     { use fast dbra mode 68010+     }
 
250
 
 
251
    cmp.l      a0,a1         {  check copy direction }
 
252
    bls      @LMOVE4
 
253
    add.l      d0,a0         { move pointers to end  }
 
254
    add.l      d0,a1
 
255
    bra     @LMOVE2
 
256
  @LMOVE1:
 
257
    move.b   -(a0),-(a1)   {  (s < d) copy loop }
 
258
  @LMOVE2:
 
259
    subq.l    #1,d0
 
260
    cmpi.l    #-1,d0
 
261
    bne       @LMOVE1
 
262
    bra       @LMOVE5
 
263
  @LMOVE3:
 
264
    move.b  (a0)+,(a1)+  { (s >= d) copy loop }
 
265
  @LMOVE4:
 
266
    subq.l    #1,d0
 
267
    cmpi.l    #-1,d0
 
268
    bne       @LMOVE3
 
269
    bra       @LMOVE5
 
270
 
 
271
  @LMEMSET00:            { use fast loop mode 68010+ }
 
272
    cmp.l      a0,a1         {  check copy direction }
 
273
    bls      @LMOVE04
 
274
    add.l      d0,a0         { move pointers to end  }
 
275
    add.l      d0,a1
 
276
    bra     @LMOVE02
 
277
  @LMOVE01:
 
278
    move.b   -(a0),-(a1)   {  (s < d) copy loop }
 
279
  @LMOVE02:
 
280
    dbra      d0,@LMOVE01
 
281
    bra       @LMOVE5
 
282
  @LMOVE03:
 
283
    move.b  (a0)+,(a1)+  { (s >= d) copy loop }
 
284
  @LMOVE04:
 
285
    dbra      d0,@LMOVE03
 
286
  { end fast loop mode }
 
287
  @LMOVE5:
 
288
  end ['d0','a0','a1'];
 
289
end;
 
290
 
 
291
 
 
292
{$define FPC_SYSTEM_HAS_FILLWORD}
 
293
procedure fillword(var x;count : longint;value : word);
 
294
  begin
 
295
    asm
 
296
     move.l 8(a6), a0      { destination             }
 
297
     move.l 12(a6), d1     { number of bytes to fill }
 
298
     move.w 16(a6),d0      { fill data               }
 
299
     bra @LMEMSET21
 
300
   @LMEMSET11:
 
301
     move.w d0,(a0)+
 
302
   @LMEMSET21:
 
303
     subq.l #1,d1
 
304
     cmp.b #-1,d1
 
305
     bne  @LMEMSET11
 
306
    end ['d0','d1','a0'];
 
307
  end;
 
308
 
 
309
 
 
310
{$define FPC_SYSTEM_HAS_ABS_LONGINT}
 
311
function abs(l : longint) : longint;
 
312
  begin
 
313
     asm
 
314
        move.l 8(a6),d0
 
315
        tst.l  d0
 
316
        bpl @LMABS1
 
317
        neg.l d0
 
318
     @LMABS1:
 
319
        move.l d0,@RESULT
 
320
     end ['d0'];
 
321
  end;
 
322
 
688
323
 
689
324
{
690
325
  $Log: m68k.inc,v $
691
 
  Revision 1.1  2000/07/13 06:30:56  michael
692
 
  + Initial import
693
 
 
694
 
  Revision 1.17  2000/01/07 16:41:42  daniel
695
 
    * copyright 2000
696
 
 
697
 
  Revision 1.16  2000/01/07 16:32:29  daniel
698
 
    * copyright 2000 added
699
 
 
700
 
  Revision 1.15  1998/10/17 14:34:37  carl
701
 
   * FillChar and FillObject bugfix, count was compared with byte
702
 
 
703
 
  Revision 1.14  1998/10/16 13:37:45  pierre
704
 
    * added code for vmt_offset in destructors
705
 
 
706
 
  Revision 1.13  1998/10/15 11:35:03  pierre
707
 
   + first step of variable vmt offset
708
 
     offset is stored in R_EDI (R_D0)
709
 
     if objectvmtoffset is defined
710
 
 
711
 
  Revision 1.12  1998/10/13 08:00:06  pierre
712
 
    * some bugs related to FPC_ prefix fixed
713
 
    * problems with pbyte sometimes defined and sometimes not for rttip.inc solved
714
 
 
715
 
  Revision 1.11  1998/09/14 10:48:29  peter
716
 
    * FPC_ names
717
 
    * Heap manager is now system independent
718
 
 
719
 
  Revision 1.10  1998/08/17 12:26:04  carl
720
 
    + simple cleanup of comments
721
 
 
722
 
  Revision 1.9  1998/07/30 13:26:14  michael
723
 
  + Added support for ErrorProc variable. All internal functions are required
724
 
    to call HandleError instead of runerror from now on.
725
 
    This is necessary for exception support.
726
 
 
727
 
  Revision 1.8  1998/07/10 11:02:41  peter
728
 
    * support_fixed, becuase fixed is not 100% yet for the m68k
729
 
 
730
 
  Revision 1.7  1998/07/02 12:20:58  carl
731
 
    + Io-Error and overflow print erroraddr in hex now
732
 
 
733
 
  Revision 1.6  1998/07/01 14:25:57  carl
734
 
    * strconcat was copying one byte too much
735
 
    * strcopy bugfix was using signed comparison
736
 
    + STRCOPY uses register calling conventions
737
 
    * FillChar bugfix was loading a word instead of a byte
 
326
  Revision 1.5  2004/05/23 12:42:42  florian
 
327
    + added currency and widestring support to TWriter and TReader
 
328
 
 
329
  Revision 1.4  2004/01/02 17:22:14  jonas
 
330
    + fpc_cpuinit procedure to allow cpu/fpu initialisation before any unit
 
331
      initialises
 
332
    + fpu exceptions for invalid operations and division by zero enabled for
 
333
      ppc
 
334
 
 
335
  Revision 1.3  2002/09/07 16:01:20  peter
 
336
    * old logs removed and tabs fixed
738
337
}