← Back to branch summary

~ubuntu-branches/debian/lenny/fpc/lenny

« back to all changes in this revision

Viewing changes to fpcsrc/utils/simulator/simlib.pas

  • Committer: Bazaar Package Importer
  • Author(s): Mazen Neifer, Torsten Werner, Mazen Neifer
  • Date: 2008-05-17 17:12:11 UTC
  • mfrom: (3.1.9 intrepid)
  • Revision ID: james.westby@ubuntu.com-20080517171211-9qi33xhd9evfa0kg
Tags: 2.2.0-dfsg1-9
http://bugs.debian.org/477743
[ Torsten Werner ]
* Add Mazen Neifer to Uploaders field.

[ Mazen Neifer ]
* Moved FPC sources into a version dependent directory from /usr/share/fpcsrc
  to /usr/share/fpcsrc/${FPCVERSION}. This allow installing more than on FPC
  release.
* Fixed far call issue in compiler preventing building huge binearies.
  (closes: #477743)
* Updated building dependencies, recomennded and suggested packages.
* Moved fppkg to fp-utils as it is just a helper tool and is not required by
  compiler.

Show diffs side-by-side

added added

removed removed

Lines of Context:
fpcsrc/utils/simulator/simlib.pas
 
1
{
 
2
    This file is part of the Free Pascal simulator environment
 
3
    Copyright (c) 1999-2000 by Florian Klaempfl
 
4
 
 
5
    This unit implemements routines for data types which aren't
 
6
    support by commonly used compilers
 
7
 
 
8
    See the file COPYING.FPC, included in this distribution,
 
9
    for details about the copyright.
 
10
 
 
11
    This program is distributed in the hope that it will be useful,
 
12
    but WITHOUT ANY WARRANTY; without even the implied warranty of
 
13
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 
14
 
 
15
 **********************************************************************}
 
16
{$N+}
 
17
{ we do some strange things here }
 
18
{$O-}
 
19
{$R-}
 
20
unit simlib;
 
21
 
 
22
  interface
 
23
 
 
24
    uses
 
25
       simbase;
 
26
 
 
27
    procedure byte_zap(q : qword;b : byte;var r : qword);
 
28
 
 
29
    { shifts q b bytes left }
 
30
    procedure shift_left_q(q : qword;b : byte;var r : qword);
 
31
 
 
32
    { shifts q b bytes right }
 
33
    procedure shift_right_q(q : qword;b : byte;var r : qword);
 
34
 
 
35
    { returns true if i1<i2 assuming that c1 and c2 are unsigned !}
 
36
    function ltu(c1,c2 : qword) : boolean;
 
37
 
 
38
    { returns true if i1=<i2 assuming that c1 and c2 are unsigned !}
 
39
    function leu(c1,c2 : qword) : boolean;
 
40
 
 
41
    { adds to owords, returns true if an overflow occurs }
 
42
    function addoword(o1,o2 : oword;var r : oword) : boolean;
 
43
 
 
44
    { adds two words, returns true if an overflow occurs }
 
45
    function addword(w1,w2 : word;var r : word) : boolean;
 
46
 
 
47
    { sets an oword to zero }
 
48
    procedure zerooword(var o : oword);
 
49
 
 
50
    { multiplies two qwords into a full oword }
 
51
    procedure mulqword(q1,q2 : qword;var r : oword);
 
52
 
 
53
  implementation
 
54
 
 
55
    procedure byte_zap(q : qword;b : byte;var r : qword);
 
56
 
 
57
      var
 
58
         i : tindex;
 
59
 
 
60
      begin
 
61
         for i:=0 to 7 do
 
62
           if ((1 shl i) and b)=0 then
 
63
             tqwordrec(r).bytes[i]:=tqwordrec(q).bytes[i]
 
64
           else
 
65
             tqwordrec(r).bytes[i]:=0;
 
66
      end;
 
67
 
 
68
    { shifts q b bytes left }
 
69
    procedure shift_left_q(q : qword;b : byte;var r : qword);
 
70
 
 
71
      var
 
72
         i : tindex;
 
73
 
 
74
      begin
 
75
         r:=0;
 
76
         if b>63 then
 
77
         else if b>31 then
 
78
           tqwordrec(r).high32:=tqwordrec(q).low32 shl (b-32)
 
79
         else
 
80
           begin
 
81
              { bad solution! A qword shift would be nice! }
 
82
              r:=q;
 
83
              for i:=1 to b do
 
84
                begin
 
85
                   tqwordrec(r).high32:=tqwordrec(r).high32 shl 1;
 
86
                   if (tqwordrec(r).low32 and $80000000)<>0 then
 
87
                     tqwordrec(r).high32:=tqwordrec(r).high32 or 1;
 
88
                   tqwordrec(r).low32:=tqwordrec(r).low32 shl 1;
 
89
                end;
 
90
           end;
 
91
      end;
 
92
 
 
93
    { shifts q b bytes right }
 
94
    procedure shift_right_q(q : qword;b : byte;var r : qword);
 
95
 
 
96
      var
 
97
         i : tindex;
 
98
 
 
99
      begin
 
100
         r:=0;
 
101
         if b>63 then
 
102
         else if b>31 then
 
103
           tqwordrec(r).low32:=tqwordrec(q).high32 shr (b-32)
 
104
         else
 
105
           begin
 
106
              { bad solution! A qword shift would be nice! }
 
107
              r:=q;
 
108
              for i:=1 to b do
 
109
                begin
 
110
                   tqwordrec(r).low32:=tqwordrec(r).low32 shr 1;
 
111
                   if (tqwordrec(r).high32 and 1)<>0 then
 
112
                     tqwordrec(r).low32:=tqwordrec(r).low32 or
 
113
                       $80000000;
 
114
                   tqwordrec(r).high32:=tqwordrec(r).high32 shr 1;
 
115
                end;
 
116
           end;
 
117
      end;
 
118
 
 
119
    { returns true if i1<i2 assuming that c1 and c2 are unsigned !}
 
120
    function ltu(c1,c2 : qword) : boolean;
 
121
 
 
122
      begin
 
123
         if (c1>=0) and (c2>=0) then
 
124
           ltu:=c1<c2
 
125
         else if (c1<0) and (c2>=0) then
 
126
           ltu:=false
 
127
         else if (c1>=0) and (c2<0) then
 
128
           ltu:=true
 
129
         else
 
130
           ltu:=c1<c2
 
131
      end;
 
132
 
 
133
    { returns true if i1=<i2 assuming that c1 and c2 are unsigned !}
 
134
    function leu(c1,c2 : qword) : boolean;
 
135
 
 
136
      begin
 
137
         if (c1>=0) and (c2>=0) then
 
138
           leu:=c1<=c2
 
139
         else if (c1<0) and (c2>=0) then
 
140
           leu:=false
 
141
         else if (c1>=0) and (c2<0) then
 
142
           leu:=true
 
143
         else
 
144
           leu:=c1<=c2
 
145
      end;
 
146
 
 
147
    { "ands" two qwords }
 
148
    procedure andqword(w1,w2 : qword;var r : qword);
 
149
 
 
150
      begin
 
151
         tqwordrec(r).low32:=tqwordrec(w1).low32 and tqwordrec(w2).low32;
 
152
         tqwordrec(r).high32:=tqwordrec(w1).high32 and tqwordrec(w2).high32;
 
153
      end;
 
154
 
 
155
    { adds two words, returns true if an overflow occurs }
 
156
    function addword(w1,w2 : word;var r : word) : boolean;
 
157
 
 
158
      var
 
159
         l : longint;
 
160
 
 
161
      begin
 
162
         l:=w1+w2;
 
163
         addword:=(l and $10000)<>0;
 
164
         r:=l and $ffff;
 
165
      end;
 
166
 
 
167
    { adds two owords, returns true if an overflow occurs }
 
168
    function addoword(o1,o2 : oword;var r : oword) : boolean;
 
169
 
 
170
      var
 
171
         i : tindex;
 
172
         carry : word;
 
173
 
 
174
      begin
 
175
         carry:=0;
 
176
         for i:=0 to 7 do
 
177
           begin
 
178
              r[i]:=o1[i]+o2[i]+carry;
 
179
              { an overflow has occured, if the r is less
 
180
                than one of the summands
 
181
              }
 
182
              if (r[i]<o1[i]) or (r[i]<o2[i]) then
 
183
                carry:=1
 
184
              else
 
185
                carry:=0;
 
186
           end;
 
187
         addoword:=carry=1;
 
188
      end;
 
189
 
 
190
    { sets an oword to zero }
 
191
    procedure zerooword(var o : oword);
 
192
 
 
193
      begin
 
194
         fillchar(o,sizeof(o),0);
 
195
      end;
 
196
 
 
197
    { multiplies two qwords into a full oword }
 
198
    procedure mulqword(q1,q2 : qword;var r : oword);
 
199
 
 
200
      var
 
201
         i : tindex;
 
202
         h,bitpos : qword;
 
203
         ho1 : oword;
 
204
 
 
205
      begin
 
206
         { r is zero }
 
207
         zerooword(ho1);
 
208
         r:=ho1;
 
209
         towordrec(ho1).low64:=q1;
 
210
 
 
211
         bitpos:=1;
 
212
 
 
213
         for i:=0 to 63 do
 
214
           begin
 
215
              andqword(q2,bitpos,h);
 
216
              if h<>0 then
 
217
                addoword(r,ho1,r);
 
218
 
 
219
              { ho1:=2*ho1 }
 
220
              addoword(ho1,ho1,ho1);
 
221
              shift_left_q(bitpos,1,bitpos);
 
222
           end;
 
223
      end;
 
224
 
 
225
end.