ARM.Builtins.Mod 18 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688
  1. MODULE Builtins;
  2. IMPORT SYSTEM, FPE64;
  3. CONST
  4. B = 127;
  5. C = 800000H;
  6. E = 100H;
  7. S = LONGINT(80000000H); (* used by VFP unit emulation *)
  8. MAXFLOAT32 = LONGINT(7F7FFFFFH);
  9. TYPE
  10. ULONGINT = LONGINT; (* alias to make distinction between signed and unsigned more clear *)
  11. UHUGEINT = HUGEINT;
  12. FLOAT32 = LONGINT; (* alias to make clear that the integer actually contains a IEEE 32 bit float *)
  13. FLOAT64= HUGEINT;
  14. DoubleWord = RECORD
  15. low*: UNSIGNED32; high*: SIGNED32;
  16. END;
  17. PROCEDURE DivS8*(left, right: SHORTINT): SHORTINT;
  18. VAR result, dummy: LONGINT;
  19. BEGIN DivModS32(left, right, result, dummy); RETURN SHORTINT(result)
  20. END DivS8;
  21. PROCEDURE DivS16*(left, right: INTEGER): INTEGER;
  22. VAR result, dummy: LONGINT;
  23. BEGIN DivModS32(left, right, result, dummy); RETURN INTEGER(result)
  24. END DivS16;
  25. PROCEDURE DivS32*(left, right: LONGINT): LONGINT;
  26. VAR result, dummy: LONGINT;
  27. BEGIN DivModS32(left, right, result, dummy); RETURN result
  28. END DivS32;
  29. PROCEDURE DivU32*(left, right: ULONGINT): ULONGINT;
  30. VAR result, dummy: LONGINT;
  31. BEGIN DivModU32(left, right, result, dummy); RETURN result
  32. END DivU32;
  33. PROCEDURE DivS64*(left, right: HUGEINT): HUGEINT;
  34. VAR result, dummy: HUGEINT;
  35. BEGIN
  36. DivModS64(left, right, result, dummy); RETURN result
  37. END DivS64;
  38. PROCEDURE ModS8*(left, right: SHORTINT): SHORTINT;
  39. VAR result, dummy: LONGINT;
  40. BEGIN DivModS32(left, right, dummy, result); RETURN SHORTINT(result)
  41. END ModS8;
  42. PROCEDURE ModS16*(left, right: INTEGER): INTEGER;
  43. VAR result, dummy: LONGINT;
  44. BEGIN DivModS32(left, right, dummy, result); RETURN INTEGER(result)
  45. END ModS16;
  46. PROCEDURE ModS32*(left, right: LONGINT): LONGINT;
  47. VAR result, dummy: LONGINT;
  48. BEGIN DivModS32(left, right, dummy, result); RETURN result
  49. END ModS32;
  50. PROCEDURE ModU32*(left, right: ULONGINT): ULONGINT;
  51. VAR result, dummy: LONGINT;
  52. BEGIN DivModU32(left, right, dummy, result); RETURN result
  53. END ModU32;
  54. PROCEDURE ModS64*(left, right: HUGEINT): HUGEINT;
  55. VAR result, dummy: HUGEINT;
  56. BEGIN
  57. DivModS64(left, right, dummy, result); RETURN result
  58. END ModS64;
  59. PROCEDURE RolS64*(source: HUGEINT; amount: ULONGINT): HUGEINT;
  60. CODE
  61. LDR R2, [FP, #+8] ; R2 := amount
  62. LDR R3, [FP, #+12] ; R3 := source[Low]
  63. LDR R4, [FP, #+16] ; R4 := source[High]
  64. ; source = R4:R3
  65. AND R2, R2, #3FH ; R2 := R2 MOD 64
  66. CMP R2, #32
  67. ; IF R2 < 32:
  68. MOVLT R0, R3, LSL R2
  69. MOVLT R1, R4, LSL R2
  70. RSBLT R2, R2, #32 ; R2 := 32 - R2
  71. ORRLT R0, R0, R4, LSR R2
  72. ORRLT R1, R1, R3, LSR R2
  73. ; IF R2 >= 32:
  74. SUBGE R2, R2, #32 ; R2 := R2 - 32
  75. MOVGE R0, R4, LSL R2
  76. MOVGE R1, R3, LSL R2
  77. RSBGE R2, R2, #32 ; R2 := 32 - R2
  78. ORRGE R0, R0, R3, LSR R2
  79. ORRGE R1, R1, R4, LSR R2
  80. ; result = R1:R0
  81. END RolS64;
  82. PROCEDURE RolU64*(source: HUGEINT; amount: ULONGINT): HUGEINT;
  83. BEGIN RETURN RolS64(source, amount)
  84. END RolU64;
  85. PROCEDURE RorS64*(source: HUGEINT; amount: ULONGINT): HUGEINT;
  86. BEGIN RETURN RolS64(source, 64 - (amount MOD 64))
  87. END RorS64;
  88. PROCEDURE RorU64*(source: HUGEINT; amount: ULONGINT): HUGEINT;
  89. BEGIN RETURN RolS64(source, 64 - (amount MOD 64))
  90. END RorU64;
  91. (* signed division and modulus
  92. - note: this implements the mathematical definition of DIV and MOD in contrast to the symmetric one
  93. *)
  94. PROCEDURE DivModS32(dividend, divisor: LONGINT; VAR quotient, remainder: LONGINT);
  95. BEGIN
  96. ASSERT(divisor > 0);
  97. IF dividend >= 0 THEN
  98. DivModU32(dividend, divisor, quotient, remainder)
  99. ELSE
  100. dividend := -dividend;
  101. DivModU32(dividend, divisor, quotient, remainder);
  102. quotient := -quotient;
  103. IF remainder # 0 THEN
  104. DEC(quotient);
  105. remainder := divisor - remainder
  106. END
  107. END
  108. END DivModS32;
  109. (*
  110. Fast 32-bit unsigned integer division/modulo (author Alexey Morozov)
  111. *)
  112. PROCEDURE DivModU32*(dividend, divisor: ULONGINT; VAR quotient, remainder: ULONGINT);
  113. CODE
  114. MOV R2, #0 ; quotient will be stored in R2
  115. LDR R0, [FP,#dividend] ; R0 := dividend
  116. LDR R1, [FP,#divisor] ; R1 := divisor
  117. ; check for the case dividend < divisor
  118. CMP R0, R1
  119. BEQ Equal
  120. BLS Exit ; nothing to do than setting quotient to 0 and remainder to dividend (R0)
  121. CLZ R3, R0 ; R3 := clz(dividend)
  122. CLZ R4, R1 ; R4 := clz(divisor)
  123. SUB R3, R4, R3 ; R2 := clz(divisor) - clz(dividend) , R2 >= 0
  124. LSL R1, R1, R3 ; scale divisor: divisor := LSH(divisor,clz(divisor)-clz(dividend))
  125. Loop:
  126. CMP R0, R1
  127. ADC R2, R2, R2
  128. SUBCS R0, R0, R1
  129. LSR R1, R1, #1
  130. SUBS R3, R3, #1
  131. BPL Loop
  132. ; R0 holds the remainder
  133. B Exit
  134. Equal:
  135. MOV R2, #1
  136. MOV R0, #0
  137. Exit:
  138. LDR R1, [FP,#quotient] ; R1 := address of quotient
  139. LDR R3, [FP,#remainder] ; R3 := address of remainder
  140. STR R2, [R1,#0] ; quotient := R2
  141. STR R0, [R3,#0] ; remainder := R0
  142. END DivModU32;
  143. (**
  144. Signed 64-bit multiplication. Adapted version based on the original code
  145. from "Runtime ABI for the ARM Cortex-M0" (https://github.com/bobbl/libaeabi-cortexm0/blob/master/lmul.S)
  146. /* Runtime ABI for the ARM Cortex-M0
  147. * lmul.S: 64 bit multiplication
  148. *
  149. * Copyright (c) 2013 Jörg Mische <bobbl@gmx.de>
  150. *
  151. * Permission to use, copy, modify, and/or distribute this software for any
  152. * purpose with or without fee is hereby granted, provided that the above
  153. * copyright notice and this permission notice appear in all copies.
  154. *
  155. * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
  156. * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
  157. * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
  158. * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
  159. * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
  160. * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT
  161. * OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  162. */
  163. Multiply r1:r0 and r3:r2 and return the product in r1:r0
  164. Can also be used for unsigned long product
  165. *)
  166. PROCEDURE MulS64*(x, y: HUGEINT): HUGEINT;
  167. CODE
  168. ldr r0, [FP,#x]
  169. ldr r1, [FP,#x+4]
  170. ldr r2, [FP,#y]
  171. ldr r3, [FP,#y+4]
  172. muls r1, r1, r2
  173. muls r3, r3, r0
  174. adds r1, r1, r3
  175. lsrs r3, r0, #16
  176. lsrs r4, r2, #16
  177. muls r3, r3, r4
  178. adds r1, r1, r3
  179. lsrs r3, r0, #16
  180. uxth r0, r0
  181. uxth r2, r2
  182. muls r3, r3, r2
  183. muls r4, r4, r0
  184. muls r0, r0, r2
  185. movs r2, #0
  186. adds r3, r3, r4
  187. adcs r2, r2, r2
  188. lsls r2, r2, #16
  189. adds r1, r1, r2
  190. lsls r2, r3, #16
  191. lsrs r3, r3, #16
  192. adds r0, r0, r2
  193. adcs r1, r1, r3
  194. END MulS64;
  195. PROCEDURE MulU64*(x, y: UHUGEINT): UHUGEINT;
  196. CODE
  197. ldr r0, [FP,#x]
  198. ldr r1, [FP,#x+4]
  199. ldr r2, [FP,#y]
  200. ldr r3, [FP,#y+4]
  201. mul r3, r0, r3 ; r3 := xlo * yhi
  202. mla r3, r1, r2, r3 ; r3 := r3 + xhi * ylo
  203. umull r0, r1, r0, r2 ; r0 := lo(xlo * ylo); r1 := hi(xlo * ylo)
  204. add r1, r1, r3 ; r1 := r1 + r3
  205. END MulU64;
  206. (* signed division and modulus
  207. - note: this implements the mathematical definition of DIV and MOD in contrast to the symmetric one
  208. *)
  209. PROCEDURE DivModS64*(dividend, divisor: HUGEINT; VAR quotient, remainder: HUGEINT);
  210. BEGIN
  211. ASSERT(divisor > 0);
  212. IF dividend >= 0 THEN
  213. DivModU64(dividend, divisor, quotient, remainder)
  214. ELSE
  215. dividend := -dividend;
  216. DivModU64(dividend, divisor, quotient, remainder);
  217. quotient := -quotient;
  218. IF remainder # 0 THEN
  219. DEC(quotient);
  220. remainder := divisor - remainder
  221. END
  222. END
  223. END DivModS64;
  224. (* Count leading zeros in a binary representation of a given 64-bit integer number *)
  225. PROCEDURE Clz64*(x: UHUGEINT): LONGINT;
  226. CODE
  227. ; high-half
  228. LDR R1, [FP,#x+4]
  229. CMP R1, #0 ; if high-half is zero count leading zeros of the low-half
  230. BEQ LowHalf
  231. CLZ R0, R1
  232. B Exit
  233. ; low-half
  234. LowHalf:
  235. LDR R1, [FP,#x]
  236. CLZ R0, R1
  237. ADD R0, R0, #32 ; add 32 zeros from the high-half
  238. Exit:
  239. END Clz64;
  240. (*
  241. Fast 64-bit unsigned integer division/modulo (Alexey Morozov)
  242. *)
  243. PROCEDURE DivModU64*(dividend, divisor: UHUGEINT; VAR quotient, remainder: UHUGEINT);
  244. VAR m: LONGINT;
  245. BEGIN
  246. quotient := 0;
  247. IF dividend = 0 THEN remainder := 0; RETURN; END;
  248. IF dividend < divisor THEN remainder := dividend; RETURN; END;
  249. m := Clz64(divisor) - Clz64(dividend);
  250. ASSERT(m >= 0);
  251. divisor := LSH(divisor,m);
  252. WHILE m >= 0 DO
  253. quotient := LSH(quotient,1);
  254. IF dividend >= divisor THEN
  255. INC(quotient);
  256. DEC(dividend,divisor);
  257. END;
  258. divisor := LSH(divisor,-1);
  259. DEC(m);
  260. END;
  261. remainder := dividend;
  262. (*
  263. CODE
  264. ldr r0, [FP,#dividend]
  265. ldr r1, [FP,#dividend+4]
  266. ldr r2, [FP,#divisor]
  267. ldr r3, [FP,#divisor+4]
  268. ldr r5, [FP,#quotient]
  269. ldr r6, [FP,#remainder]
  270. str r0, [r5,#0]
  271. str r1, [r5,#4]
  272. str r2, [r6,#0]
  273. str r3, [r6,#4]
  274. *)
  275. END DivModU64;
  276. (* only called when no FPU64 is available *)
  277. PROCEDURE NegF32*(float: FLOAT32): FLOAT32;
  278. CODE
  279. LDR R0, [FP, #+float] ; R0 := float
  280. EOR R0, R0, #S ; invert only the sign bit
  281. END NegF32;
  282. (* only called when no FPU64 is available *)
  283. PROCEDURE AbsF32*(float: FLOAT32): FLOAT32;
  284. CODE
  285. LDR R0, [FP, #+float] ; R0 := float
  286. BIC R0, R0, #S ; clear the sign bit
  287. END AbsF32;
  288. (* only called when no FPU32 is available *)
  289. PROCEDURE AddF32*(x, y: FLOAT32): FLOAT32;
  290. VAR xe, ye, s: LONGINT;
  291. BEGIN
  292. IF SYSTEM.NULL(x) = TRUE THEN x := y
  293. ELSIF SYSTEM.NULL(y) = FALSE THEN
  294. xe := x DIV C MOD E; (* exponent with bias *)
  295. IF x >= 0 THEN x := (x MOD C + C)*2 ELSE x := -(x MOD C + C)*2 END ;
  296. ye := y DIV C MOD E; (* exponent with bias *)
  297. IF y >= 0 THEN y := (y MOD C + C)*2 ELSE y := -(y MOD C + C)*2 END ;
  298. IF xe < ye THEN
  299. ye := ye - xe; xe := xe + ye; (*denorm x*)
  300. IF ye <= 25 THEN x := ASH(x, -ye) ELSE x := 0 END
  301. ELSIF ye < xe THEN
  302. ye := xe - ye; (*denorm y*)
  303. IF ye <= 25 THEN y := ASH(y, -ye) ELSE y := 0 END
  304. END ;
  305. s := x + y; x := ABS(s);
  306. s := SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, s)*{31});
  307. IF x # 0 THEN
  308. IF x >= 4*C THEN x := (x+2) DIV 4; INC(xe)
  309. ELSIF x >= 2*C THEN x := (x+1) DIV 2
  310. ELSE DEC(xe);
  311. WHILE x < C DO x := 2*x; DEC(xe) END
  312. END ;
  313. IF xe < 0 THEN x := 0 (*underflow*)
  314. ELSIF xe > 0FEH THEN x := MAXFLOAT32 + s; (* overflow *)
  315. ELSE x := xe*C + (x - C) + s;
  316. END;
  317. END
  318. END ;
  319. RETURN x
  320. END AddF32;
  321. (* only called when no FPU64 is available *)
  322. PROCEDURE AddF64*(x,y: FLOAT64): FLOAT64;
  323. VAR z: FLOAT64;
  324. BEGIN FPE64.Add(SYSTEM.VAL(FPE64.Float64,x),SYSTEM.VAL(FPE64.Float64,y),SYSTEM.VAL(FPE64.Float64,z)); RETURN z
  325. END AddF64;
  326. (* only called when no FPU64 is available *)
  327. PROCEDURE MulF64*(x,y: FLOAT64): FLOAT64;
  328. VAR z: FLOAT64;
  329. BEGIN FPE64.Mul(SYSTEM.VAL(FPE64.Float64,x),SYSTEM.VAL(FPE64.Float64,y),SYSTEM.VAL(FPE64.Float64,z)); RETURN z
  330. END MulF64;
  331. (* only called when no FPU64 is available *)
  332. PROCEDURE DivF64*(x,y: FLOAT64): FLOAT64;
  333. VAR z: FLOAT64;
  334. BEGIN FPE64.Div(SYSTEM.VAL(FPE64.Float64,x),SYSTEM.VAL(FPE64.Float64,y),SYSTEM.VAL(FPE64.Float64,z)); RETURN z
  335. END DivF64;
  336. (* only called when no FPU64 is available *)
  337. PROCEDURE SubF64*(x,y: FLOAT64): FLOAT64;
  338. VAR z: FLOAT64;
  339. BEGIN FPE64.Sub(SYSTEM.VAL(FPE64.Float64,x),SYSTEM.VAL(FPE64.Float64,y),SYSTEM.VAL(FPE64.Float64,z)); RETURN z
  340. END SubF64;
  341. (* only called when no FPU64 is available *)
  342. PROCEDURE AbsF64*(x: FLOAT64): FLOAT64;
  343. VAR z: FLOAT64;
  344. BEGIN FPE64.Abs(SYSTEM.VAL(FPE64.Float64,x),SYSTEM.VAL(FPE64.Float64,z)); RETURN z
  345. END AbsF64;
  346. (* only called when no FPU64 is available *)
  347. PROCEDURE NegF64*(x: FLOAT64): FLOAT64;
  348. VAR z: FLOAT64;
  349. BEGIN FPE64.Neg(SYSTEM.VAL(FPE64.Float64,x),SYSTEM.VAL(FPE64.Float64,z)); RETURN z
  350. END NegF64;
  351. PROCEDURE ConvS32F64*(x: FLOAT64): LONGINT;
  352. BEGIN RETURN FPE64.Fix(SYSTEM.VAL(FPE64.Float64,x))
  353. END ConvS32F64;
  354. PROCEDURE ConvS64F64*(x: FLOAT64): HUGEINT;
  355. BEGIN RETURN FPE64.FixInt64(SYSTEM.VAL(FPE64.Float64,x))
  356. END ConvS64F64;
  357. PROCEDURE ConvS64F32*(x: FLOAT32): HUGEINT;
  358. VAR d: FPE64.Float64;
  359. BEGIN
  360. FPE64.Double(x, d);
  361. RETURN FPE64.FixInt64(d)
  362. END ConvS64F32;
  363. (* only called when no FPU32 is available *)
  364. PROCEDURE ConvF32F64*(x: FLOAT64): FLOAT32;
  365. BEGIN RETURN FPE64.Single(SYSTEM.VAL(FPE64.Float64,x))
  366. END ConvF32F64;
  367. (* if an FPU32 is available, the result must be made available via FPU register *)
  368. PROCEDURE ConvF32F64F*(x: FLOAT64): REAL;
  369. VAR r: FLOAT32;
  370. BEGIN
  371. r := FPE64.Single(SYSTEM.VAL(FPE64.Float64,x));
  372. RETURN SYSTEM.VAL(REAL, r);
  373. END ConvF32F64F;
  374. (* only called when no FPU64 is available *)
  375. PROCEDURE ConvF64F32*(x: FLOAT32): FLOAT64;
  376. VAR z: FLOAT64;
  377. BEGIN FPE64.Double(x,SYSTEM.VAL(FPE64.Float64,z)); RETURN z
  378. END ConvF64F32;
  379. (* only called when no FPU64 is available *)
  380. PROCEDURE ConvF64S64*(x: HUGEINT): FLOAT64;
  381. VAR flt: FLOAT64;
  382. BEGIN
  383. FPE64.FloatInt64(x, SYSTEM.VAL(FPE64.Float64, flt)); RETURN flt
  384. END ConvF64S64;
  385. (* stub in order to make the runtime itself compile, cf next procedure. This module needs to be compiled with FPU support on *)
  386. PROCEDURE ConvF64U32*(x: UNSIGNED32): FLOAT64;
  387. BEGIN
  388. HALT(100);
  389. END ConvF64U32;
  390. (* if an FPU64 is available, the result must be made available via FPU register *)
  391. PROCEDURE ConvF64S64F*(x: DoubleWord): LONGREAL;
  392. VAR l,h:LONGREAL;
  393. BEGIN
  394. l := x.low;
  395. h := x.high;
  396. RETURN h * 100000000H + l;
  397. END ConvF64S64F;
  398. (* only called when no FPU64 is available *)
  399. PROCEDURE ConvF64S32*(x: LONGINT): FLOAT64;
  400. VAR flt: FLOAT64;
  401. BEGIN FPE64.Float(x, SYSTEM.VAL(FPE64.Float64,flt)); RETURN flt
  402. END ConvF64S32;
  403. (* only called when no FPU64 is available *)
  404. PROCEDURE ConvF64S16*(x: INTEGER): FLOAT64;
  405. VAR flt: FLOAT64;
  406. BEGIN FPE64.Float(x, SYSTEM.VAL(FPE64.Float64,flt)); RETURN flt
  407. END ConvF64S16;
  408. (* only called when no FPU32 is available *)
  409. PROCEDURE ConvF32S16*(x: INTEGER): FLOAT32;
  410. BEGIN
  411. RETURN ConvF32S32(LONGINT(x))
  412. END ConvF32S16;
  413. (* only called when no FPU32 is available *)
  414. PROCEDURE ConvF32S8*(x: SHORTINT): FLOAT32;
  415. BEGIN
  416. RETURN ConvF32S16(INTEGER(x))
  417. END ConvF32S8;
  418. (* only called when no FPU64 is available *)
  419. PROCEDURE ConvF64S8*(x: SHORTINT): FLOAT64;
  420. BEGIN
  421. RETURN ConvF64S16(INTEGER(x))
  422. END ConvF64S8;
  423. (* only called when no FPU32 is available *)
  424. PROCEDURE SubF32*(left, right: FLOAT32): FLOAT32;
  425. BEGIN RETURN AddF32(left, NegF32(right))
  426. END SubF32;
  427. (* only called when no FPU32 is available *)
  428. PROCEDURE MulF32*(x, y: FLOAT32): FLOAT32;
  429. VAR xe, zh, ye, s: LONGINT; (*zh, ye in this order; ye used as zh in MULD*)
  430. BEGIN
  431. IF SYSTEM.NULL(y) = TRUE THEN x := 0
  432. ELSIF SYSTEM.NULL(y) = FALSE THEN
  433. s := SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, SYSTEM.XOR(x, y))*{31});
  434. xe := x DIV C MOD E; (* exponent with bias *)
  435. ye := y DIV C MOD E; (* exponent with bias *)
  436. x := (x MOD C + C) * 20H;
  437. y := (y MOD C + C) * 20H;
  438. xe := xe + ye - B; (* exponent with bias *)
  439. SYSTEM.MULD(ye, x, y); (* note that this implicitly changes zh *)
  440. IF zh >= 4*C THEN
  441. x := (zh+2) DIV 4;
  442. INC(xe);
  443. ELSE
  444. x := (zh+1) DIV 2;
  445. END;
  446. IF xe < 0 THEN (* underflow *)
  447. x := 0;
  448. ELSIF xe > 0FEH THEN (* overflow *)
  449. x := MAXFLOAT32 + s;
  450. ELSE
  451. x := xe*C + (x-C) + s;
  452. END;
  453. END ;
  454. RETURN x
  455. END MulF32;
  456. (* only called when no FPU32 is available *)
  457. PROCEDURE DivF32*(x, y: FLOAT32): FLOAT32;
  458. VAR xe, ye, q, s: LONGINT;
  459. BEGIN
  460. s := SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, SYSTEM.XOR(x, y))*{31});
  461. IF SYSTEM.NULL(y) = TRUE THEN
  462. x := MAXFLOAT32 + s;
  463. ELSIF SYSTEM.NULL(x) = FALSE THEN
  464. xe := x DIV C MOD E; (* exponent with bias *)
  465. ye := y DIV C MOD E; (* exponent with bias *)
  466. x := x MOD C + C;
  467. y := y MOD C + C;
  468. xe := xe - ye + B; (* exponent with bias *)
  469. IF x < y THEN
  470. x := x*2; DEC(xe);
  471. END ;
  472. IF xe < 0 THEN (* underflow *)
  473. x := 0;
  474. ELSIF xe > 0FEH THEN (* overflow *)
  475. x := MAXFLOAT32 + s;
  476. ELSE (* divide *)
  477. q := 0;
  478. WHILE q < LONGINT(1000000H) DO (* 2*C *)
  479. q := 2*q;
  480. IF x >= y THEN
  481. x := x - y;
  482. INC(q);
  483. END;
  484. x := 2*x;
  485. END;
  486. q := (q+1) DIV 2; (*round*)
  487. x := xe*C + (q-C) + s;
  488. END;
  489. END;
  490. RETURN x
  491. END DivF32;
  492. (** converts a float into an integer, ignores the fractional part
  493. - corresponds to ENTIER(x) **)
  494. PROCEDURE ConvS32F32*(x: FLOAT32): LONGINT;
  495. VAR xe, s: LONGINT;
  496. BEGIN
  497. IF SYSTEM.NULL(x) = TRUE THEN
  498. x := 0
  499. ELSE
  500. s := x; xe := x DIV C MOD E - B; x := x MOD C + C;
  501. IF s < 0 THEN x := -x END ;
  502. IF xe < 24 THEN x := ASH(x, xe - 23)
  503. ELSIF xe < 31 THEN x := LSH(x, xe - 23)
  504. ELSIF s < 0 THEN x := LONGINT(80000000H);
  505. ELSE x := LONGINT(7FFFFFFFH);
  506. END;
  507. END ;
  508. RETURN x
  509. END ConvS32F32;
  510. (** converts an integer into a float, ignores the non-integer part
  511. - corresponds to REAL(int)
  512. - note that no rounding occurs
  513. only called when no FPU32 is available
  514. **)
  515. PROCEDURE ConvF32S32*(x: LONGINT): FLOAT32;
  516. VAR xe, s: LONGINT;
  517. BEGIN
  518. IF x = LONGINT(80000000H) THEN (* ABS cannot handle the most negative LONGINT number! *)
  519. x := LONGINT(0CF000000H);
  520. ELSIF x # 0 THEN
  521. s := x;
  522. x := ABS(x); xe := 23;
  523. WHILE x >= 2*C DO
  524. x := x DIV 2; INC(xe);
  525. END;
  526. WHILE x < C DO
  527. x := 2*x; DEC(xe);
  528. END;
  529. x := (xe + B)*C - C + x;
  530. IF s < 0 THEN x := x+S END
  531. END ;
  532. RETURN x
  533. END ConvF32S32;
  534. (* only called when no FPU32 is available *)
  535. PROCEDURE ConvF32S64*(x: HUGEINT): FLOAT32;
  536. BEGIN
  537. RETURN ConvF32F64(ConvF64S64(x))
  538. END ConvF32S64;
  539. (* stub in order to make the runtime itself compile, cf next procedure. This module needs to be compiled with FPU support on *)
  540. PROCEDURE ConvF32U32*(x: UNSIGNED32): FLOAT32;
  541. BEGIN
  542. HALT(100);
  543. END ConvF32U32;
  544. (* if an FPU32 is available, the result must be made available via FPU register *)
  545. PROCEDURE ConvF32S64F*(x: DoubleWord): REAL;
  546. VAR l,h:REAL;
  547. BEGIN
  548. l := x.low;
  549. h := x.high;
  550. RETURN h * 100000000H + l;
  551. END ConvF32S64F;
  552. (* ---- STRING OPERATIONS ---- *)
  553. (** compare two strings
  554. - returns 0 if both strings are lexicographically equal
  555. - returns +1 if 'left' is lexicographically greater than 'right'
  556. - returns -1 if 'left' is lexicographically less than 'right'
  557. **)
  558. PROCEDURE CompareString*(CONST left, right: ARRAY OF CHAR): SHORTINT;
  559. VAR
  560. result: SHORTINT;
  561. i: LONGINT;
  562. leftChar, rightChar: CHAR;
  563. BEGIN
  564. result := 0;
  565. i := 0;
  566. REPEAT
  567. leftChar := left[i]; rightChar := right[i];
  568. IF leftChar < rightChar THEN result := -1
  569. ELSIF leftChar > rightChar THEN result := +1
  570. END;
  571. INC(i)
  572. UNTIL (result # 0) OR (leftChar = 0X) OR (rightChar = 0X);
  573. RETURN result
  574. END CompareString;
  575. (** copy a string from 'source' to 'destination'
  576. - note that PACO semantics are used **)
  577. PROCEDURE CopyString*(VAR destination: ARRAY OF CHAR; CONST source: ARRAY OF CHAR);
  578. VAR
  579. sourceLength, destinationLength: LONGINT;
  580. BEGIN
  581. destinationLength := LEN(destination);
  582. sourceLength := LEN(source);
  583. IF destinationLength < sourceLength THEN sourceLength := destinationLength END;
  584. SYSTEM.MOVE(ADDRESSOF(source[0]), ADDRESSOF(destination[0]), sourceLength)
  585. END CopyString;
  586. END Builtins.