system.pp 12 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416
  1. {
  2. This file is part of the Free Pascal run time library.
  3. Copyright (c) 2006 by Florian Klaempfl
  4. member of the Free Pascal development team.
  5. System unit for embedded systems
  6. See the file COPYING.FPC, included in this distribution,
  7. for details about the copyright.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  11. **********************************************************************}
  12. Unit system;
  13. {*****************************************************************************}
  14. interface
  15. {*****************************************************************************}
  16. {$define FPC_IS_SYSTEM}
  17. {$I-,Q-,H-,R-,V-}
  18. {$implicitexceptions off}
  19. {$mode objfpc}
  20. Type
  21. { The compiler has all integer types defined internally. Here
  22. we define only aliases }
  23. DWord = LongWord;
  24. Cardinal = LongWord;
  25. Integer = SmallInt;
  26. UInt64 = QWord;
  27. ValReal = Double;
  28. { map comp to int64, }
  29. Comp = Int64;
  30. HResult = type longint;
  31. { Java primitive types }
  32. jboolean = boolean;
  33. jbyte = shortint;
  34. jshort = smallint;
  35. jint = longint;
  36. jlong = int64;
  37. jchar = widechar;
  38. jfloat = single;
  39. jdouble = double;
  40. const
  41. { max. values for longint and int}
  42. maxLongint = $7fffffff;
  43. maxSmallint = 32767;
  44. maxint = maxsmallint;
  45. type
  46. { Java base class type }
  47. TObject = class external 'java.lang' name 'Object'
  48. protected
  49. function clone: TObject;
  50. public
  51. constructor create;
  52. function equals(obj: TObject): boolean;
  53. function hashcode: longint;
  54. end;
  55. TJLObject = TObject;
  56. TJISerializable = interface external 'java.lang' name 'Serializable'
  57. end;
  58. TJLThrowable = class external 'java.lang' name 'Throwable' (TObject,TJISerializable)
  59. constructor create;
  60. end;
  61. { Java Float class type }
  62. TJFloat = class external 'java.lang' name 'Float'
  63. constructor create(f: jfloat);
  64. class function floatToRawIntBits(f: jfloat): jint; static;
  65. class function intBitsToFloat(j: jint): jfloat; static;
  66. end;
  67. { Java Dloat class type }
  68. TJDouble = class external 'java.lang' name 'Double'
  69. constructor create(d: jdouble);
  70. class function doubleToRawLongBits(d: jdouble): jlong; static;
  71. class function longBitsToDouble(l: jlong): jdouble; static;
  72. end;
  73. {$i innr.inc}
  74. {$i jmathh.inc}
  75. {$i jdynarrh.inc}
  76. {*****************************************************************************}
  77. implementation
  78. {*****************************************************************************}
  79. {i jdynarr.inc}
  80. {
  81. This file is part of the Free Pascal run time library.
  82. Copyright (c) 2011 by Jonas Maebe
  83. member of the Free Pascal development team.
  84. This file implements the helper routines for dyn. Arrays in FPC
  85. See the file COPYING.FPC, included in this distribution,
  86. for details about the copyright.
  87. This program is distributed in the hope that it will be useful,
  88. but WITHOUT ANY WARRANTY; without even the implied warranty of
  89. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  90. **********************************************************************
  91. }
  92. function min(a,b : longint) : longint;
  93. begin
  94. if a<=b then
  95. min:=a
  96. else
  97. min:=b;
  98. end;
  99. { copying helpers }
  100. { also for booleans }
  101. procedure copy_jbyte_array(src, dst: TJByteArray);
  102. var
  103. i: longint;
  104. begin
  105. for i:=0 to min(high(src),high(dst)) do
  106. dst[i]:=src[i];
  107. end;
  108. procedure copy_jshort_array(src, dst: TJShortArray);
  109. var
  110. i: longint;
  111. begin
  112. for i:=0 to min(high(src),high(dst)) do
  113. dst[i]:=src[i];
  114. end;
  115. procedure copy_jint_array(src, dst: TJIntArray);
  116. var
  117. i: longint;
  118. begin
  119. for i:=0 to min(high(src),high(dst)) do
  120. dst[i]:=src[i];
  121. end;
  122. procedure copy_jlong_array(src, dst: TJLongArray);
  123. var
  124. i: longint;
  125. begin
  126. for i:=0 to min(high(src),high(dst)) do
  127. dst[i]:=src[i];
  128. end;
  129. procedure copy_jchar_array(src, dst: TJCharArray);
  130. var
  131. i: longint;
  132. begin
  133. for i:=0 to min(high(src),high(dst)) do
  134. dst[i]:=src[i];
  135. end;
  136. procedure copy_jfloat_array(src, dst: TJFloatArray);
  137. var
  138. i: longint;
  139. begin
  140. for i:=0 to min(high(src),high(dst)) do
  141. dst[i]:=src[i];
  142. end;
  143. procedure copy_jdouble_array(src, dst: TJDoubleArray);
  144. var
  145. i: longint;
  146. begin
  147. for i:=0 to min(high(src),high(dst)) do
  148. dst[i]:=src[i];
  149. end;
  150. procedure copy_jobject_array(src, dst: TJObjectArray);
  151. var
  152. i: longint;
  153. begin
  154. for i:=0 to min(high(src),high(dst)) do
  155. dst[i]:=src[i];
  156. end;
  157. { 1-dimensional setlength routines }
  158. function fpc_setlength_dynarr_jbyte(aorg, anew: TJByteArray; deepcopy: boolean): TJByteArray;
  159. begin
  160. if deepcopy or
  161. (length(aorg)<>length(anew)) then
  162. begin
  163. copy_jbyte_array(aorg,anew);
  164. result:=anew
  165. end
  166. else
  167. result:=aorg;
  168. end;
  169. function fpc_setlength_dynarr_jshort(aorg, anew: TJShortArray; deepcopy: boolean): TJShortArray;
  170. begin
  171. if deepcopy or
  172. (length(aorg)<>length(anew)) then
  173. begin
  174. copy_jshort_array(aorg,anew);
  175. result:=anew
  176. end
  177. else
  178. result:=aorg;
  179. end;
  180. function fpc_setlength_dynarr_jint(aorg, anew: TJIntArray; deepcopy: boolean): TJIntArray;
  181. begin
  182. if deepcopy or
  183. (length(aorg)<>length(anew)) then
  184. begin
  185. copy_jint_array(aorg,anew);
  186. result:=anew
  187. end
  188. else
  189. result:=aorg;
  190. end;
  191. function fpc_setlength_dynarr_jlong(aorg, anew: TJLongArray; deepcopy: boolean): TJLongArray;
  192. begin
  193. if deepcopy or
  194. (length(aorg)<>length(anew)) then
  195. begin
  196. copy_jlong_array(aorg,anew);
  197. result:=anew
  198. end
  199. else
  200. result:=aorg;
  201. end;
  202. function fpc_setlength_dynarr_jchar(aorg, anew: TJCharArray; deepcopy: boolean): TJCharArray;
  203. begin
  204. if deepcopy or
  205. (length(aorg)<>length(anew)) then
  206. begin
  207. copy_jchar_array(aorg,anew);
  208. result:=anew
  209. end
  210. else
  211. result:=aorg;
  212. end;
  213. function fpc_setlength_dynarr_jfloat(aorg, anew: TJFloatArray; deepcopy: boolean): TJFloatArray;
  214. begin
  215. if deepcopy or
  216. (length(aorg)<>length(anew)) then
  217. begin
  218. copy_jfloat_array(aorg,anew);
  219. result:=anew
  220. end
  221. else
  222. result:=aorg;
  223. end;
  224. function fpc_setlength_dynarr_jdouble(aorg, anew: TJDoubleArray; deepcopy: boolean): TJDoubleArray;
  225. begin
  226. if deepcopy or
  227. (length(aorg)<>length(anew)) then
  228. begin
  229. copy_jdouble_array(aorg,anew);
  230. result:=anew
  231. end
  232. else
  233. result:=aorg;
  234. end;
  235. function fpc_setlength_dynarr_jobject(aorg, anew: TJObjectArray; deepcopy: boolean; docopy : boolean = true): TJObjectArray;
  236. begin
  237. if deepcopy or
  238. (length(aorg)<>length(anew)) then
  239. begin
  240. if docopy then
  241. copy_jobject_array(aorg,anew);
  242. result:=anew
  243. end
  244. else
  245. result:=aorg;
  246. end;
  247. { multi-dimensional setlength routine }
  248. function fpc_setlength_dynarr_multidim(aorg, anew: TJObjectArray; deepcopy: boolean; ndim: longint; eletype: jchar): TJObjectArray;
  249. var
  250. partdone,
  251. i: longint;
  252. begin
  253. { resize the current dimension; no need to copy the subarrays of the old
  254. array, as the subarrays will be (re-)initialised immediately below }
  255. result:=fpc_setlength_dynarr_jobject(aorg,anew,deepcopy,false);
  256. { if aorg was empty, there's nothing else to do since result will now
  257. contain anew, of which all other dimensions are already initialised
  258. correctly since there are no aorg elements to copy }
  259. if not assigned(aorg) and
  260. not deepcopy then
  261. exit;
  262. partdone:=min(high(result),high(aorg));
  263. { ndim must be >=2 when this routine is called, since it has to return
  264. an array of java.lang.Object! (arrays are also objects, but primitive
  265. types are not) }
  266. if ndim=2 then
  267. begin
  268. { final dimension -> copy the primitive arrays }
  269. case eletype of
  270. FPCJDynArrTypeJByte:
  271. begin
  272. for i:=low(result) to partdone do
  273. result[i]:=TObject(fpc_setlength_dynarr_jbyte(TJByteArray(aorg[i]),TJByteArray(anew[i]),deepcopy));
  274. for i:=succ(partdone) to high(result) do
  275. result[i]:=TObject(fpc_setlength_dynarr_jbyte(nil,TJByteArray(anew[i]),deepcopy));
  276. end;
  277. FPCJDynArrTypeJShort:
  278. begin
  279. for i:=low(result) to partdone do
  280. result[i]:=TObject(fpc_setlength_dynarr_jshort(TJShortArray(aorg[i]),TJShortArray(anew[i]),deepcopy));
  281. for i:=succ(partdone) to high(result) do
  282. result[i]:=TObject(fpc_setlength_dynarr_jshort(nil,TJShortArray(anew[i]),deepcopy));
  283. end;
  284. FPCJDynArrTypeJInt:
  285. begin
  286. for i:=low(result) to partdone do
  287. result[i]:=TObject(fpc_setlength_dynarr_jint(TJIntArray(aorg[i]),TJIntArray(anew[i]),deepcopy));
  288. for i:=succ(partdone) to high(result) do
  289. result[i]:=TObject(fpc_setlength_dynarr_jint(nil,TJIntArray(anew[i]),deepcopy));
  290. end;
  291. FPCJDynArrTypeJLong:
  292. begin
  293. for i:=low(result) to partdone do
  294. result[i]:=TObject(fpc_setlength_dynarr_jlong(TJLongArray(aorg[i]),TJLongArray(anew[i]),deepcopy));
  295. for i:=succ(partdone) to high(result) do
  296. result[i]:=TObject(fpc_setlength_dynarr_jlong(nil,TJLongArray(anew[i]),deepcopy));
  297. end;
  298. FPCJDynArrTypeJChar:
  299. begin
  300. for i:=low(result) to partdone do
  301. result[i]:=TObject(fpc_setlength_dynarr_jchar(TJCharArray(aorg[i]),TJCharArray(anew[i]),deepcopy));
  302. for i:=succ(partdone) to high(result) do
  303. result[i]:=TObject(fpc_setlength_dynarr_jchar(nil,TJCharArray(anew[i]),deepcopy));
  304. end;
  305. FPCJDynArrTypeJFloat:
  306. begin
  307. for i:=low(result) to partdone do
  308. result[i]:=TObject(fpc_setlength_dynarr_jfloat(TJFloatArray(aorg[i]),TJFloatArray(anew[i]),deepcopy));
  309. for i:=succ(partdone) to high(result) do
  310. result[i]:=TObject(fpc_setlength_dynarr_jfloat(nil,TJFloatArray(anew[i]),deepcopy));
  311. end;
  312. FPCJDynArrTypeJDouble:
  313. begin
  314. for i:=low(result) to partdone do
  315. result[i]:=TObject(fpc_setlength_dynarr_jdouble(TJDoubleArray(aorg[i]),TJDoubleArray(anew[i]),deepcopy));
  316. for i:=succ(partdone) to high(result) do
  317. result[i]:=TObject(fpc_setlength_dynarr_jdouble(nil,TJDoubleArray(anew[i]),deepcopy));
  318. end;
  319. FPCJDynArrTypeJObject:
  320. begin
  321. for i:=low(result) to partdone do
  322. result[i]:=TObject(fpc_setlength_dynarr_jobject(TJObjectArray(aorg[i]),TJObjectArray(anew[i]),deepcopy,true));
  323. for i:=succ(partdone) to high(result) do
  324. result[i]:=TObject(fpc_setlength_dynarr_jobject(nil,TJObjectArray(anew[i]),deepcopy,true));
  325. end;
  326. end;
  327. end
  328. else
  329. begin
  330. { recursively handle the next dimension }
  331. for i:=low(result) to partdone do
  332. result[i]:=TObject(fpc_setlength_dynarr_multidim(TJObjectArray(aorg[i]),TJObjectArray(anew[i]),deepcopy,pred(ndim),eletype));
  333. for i:=succ(partdone) to high(result) do
  334. result[i]:=TObject(fpc_setlength_dynarr_multidim(nil,TJObjectArray(anew[i]),deepcopy,pred(ndim),eletype));
  335. end;
  336. end;
  337. {i jdynarr.inc end}
  338. {*****************************************************************************
  339. Misc. System Dependent Functions
  340. *****************************************************************************}
  341. {*****************************************************************************
  342. SystemUnit Initialization
  343. *****************************************************************************}
  344. end.