From 04e68443040c7abad84d66477e98f93bed701760 Mon Sep 17 00:00:00 2001 From: Lars-Dominik Braun Date: Mon, 4 Feb 2019 13:09:03 +0100 Subject: Initial import --- system/base/1.7.5/src/real | 442 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 442 insertions(+) create mode 100644 system/base/1.7.5/src/real (limited to 'system/base/1.7.5/src/real') diff --git a/system/base/1.7.5/src/real b/system/base/1.7.5/src/real new file mode 100644 index 0000000..3e3c651 --- /dev/null +++ b/system/base/1.7.5/src/real @@ -0,0 +1,442 @@ +(* ------------------- VERSION 6 05.05.86 ------------------- *) +PACKET real DEFINES (* Autor: J.Liedtke *) + + text , + int , + real , + round , + floor , + frac , + decimal exponent , + set exp , + INCR , + DECR , + abs , + ABS , + sign , + SIGN , + MOD , + min , + max , + max real , + small real : + +LET mantissa length = 13 , + digit zero index = 1 , + digit nine index = 10 ; +INT CONST + decimal point index := -1 ; + +TEXT VAR mantissa ; + +ROW 10 REAL VAR real digit ; + +INT VAR i ; REAL VAR d := 0.0 ; +FOR i FROM 1 UPTO 10 REP + real digit (i) := d ; + d := d + 1.0 +PER ; + +REAL PROC max real : 9.999999999999e126 ENDPROC max real ; + +REAL PROC small real : 1.0e-12 ENDPROC small real ; + +PROC sld (INT CONST in, REAL VAR real, INT VAR out) : + EXTERNAL 96 +ENDPROC sld ; + +INT PROC decimal exponent (REAL CONST mantissa) : + EXTERNAL 97 +ENDPROC decimal exponent ; + +PROC set exp (INT CONST exponent, REAL VAR number) : + EXTERNAL 98 +ENDPROC set exp ; + +REAL PROC tenpower (INT CONST exponent) : + REAL VAR result := 1.0 ; + set exp (exponent, result) ; + result +ENDPROC tenpower ; + +REAL PROC floor (REAL CONST real) : + EXTERNAL 99 +ENDPROC floor ; + +REAL PROC round (REAL CONST real, INT CONST digits) : + + REAL VAR result := real ; + IF (real <> 0.0) CAND (decimal exponent (real) + digits < mantissa length) + THEN round result ; + FI ; + result . + +round result : + set exp (decimal exponent (result) + digits, result) ; + IF result >= 0.0 + THEN result := floor (result + 0.5) + ELSE result := floor (result - 0.5) + FI ; + IF result <> 0.0 + THEN set exp (decimal exponent (result) - digits, result) + FI . + +ENDPROC round ; + +TEXT VAR result ; + +TEXT PROC text (REAL CONST real) : + + REAL VAR value := rounded to seven digits ; + IF value = 0.0 + THEN "0.0" + ELSE + process sign ; + get mantissa (value) ; + INT CONST exponent := decimal exponent (value) ; + get short mantissa ; + IF exponent > 7 OR exponent < LENGTH short mantissa - 7 + THEN scientific notation + ELSE short notation + FI + FI . + +rounded to seven digits : + round ( real * tenpower( -decimal exponent(real) ) , 6 ) + * tenpower ( decimal exponent(real) ) . + +process sign : + IF value < 0.0 + THEN result := "-" ; + value := - value + ELSE result := "" + FI . + +get short mantissa : + INT VAR i := 7 ; + WHILE (mantissa SUB i) = "0" REP + i DECR 1 + UNTIL i=1 END REP ; + TEXT CONST short mantissa := subtext (mantissa, 1, i) . + +scientific notation : + result CAT (mantissa SUB 1) ; + result CAT "." ; + result CAT subtext (mantissa, 2, 7) ; + result + "e" + text (exponent) . + +short notation : + IF exponent < 0 + THEN result + "0." + (-exponent - 1) * "0" + short mantissa + ELSE result CAT subtext (short mantissa, 1, exponent+1) ; + result CAT (exponent+1 - LENGTH short mantissa) * "0" ; + result CAT "." ; + result CAT subtext (short mantissa, exponent+2) ; + IF LENGTH short mantissa < exponent + 2 + THEN result + "0" + ELSE result + FI + FI . + +ENDPROC text ; + +PROC get mantissa (REAL CONST number) : + + REAL VAR real mantissa := number ; + mantissa := "" ; + INT VAR i , digit ; + FOR i FROM 1 UPTO mantissa length REP + sld (0, real mantissa, digit) ; + mantissa CAT code (digit + 48) + PER ; + +ENDPROC get mantissa ; + +TEXT PROC text (REAL CONST real, INT CONST length) : + + INT CONST mantissa length := min (length - 7, 13) ; + IF mantissa length > 0 + THEN construct scientific notation + ELSE result := length * "*" + FI ; + result . + +construct scientific notation : + REAL VAR value := rounded real ; + IF value = 0.0 + THEN result := subtext (" 0.0 ", 1, length) + ELSE process sign ; + process mantissa ; + process exponent + FI . + +rounded real : + round (real * tenpower ( -decimal exponent (real)) , mantissa length - 1) + * tenpower (decimal exponent (real)) . + +process sign : + IF value < 0.0 + THEN result := "-" + ELSE result := "+" + FI . + +process mantissa : + get mantissa (value) ; + result CAT (mantissa SUB 1) ; + result CAT "." ; + result CAT subtext (mantissa, 2, mantissa length) . + +process exponent : + IF decimal exponent (value) >= 0 + THEN result CAT "e+" + ELSE result CAT "e-" + FI ; + result CAT text (ABS decimal exponent (value), 3) ; + change all (result, " ", "0") . + +ENDPROC text ; + +TEXT PROC text (REAL CONST real, INT CONST length, fracs) : + + REAL VAR value := round (real, fracs) ; + INT VAR exponent := decimal exponent (value) ; + IF value = 0.0 THEN exponent := 0 FI ; + INT VAR floors := exponent + 1 , + floor length := length - fracs - 1 ; + IF value < 0.0 THEN floor length DECR 1 FI ; + + IF value too big + THEN length * "*" + ELSE transformed value + FI . + +transformed value : + process leading blanks and sign ; + get mantissa (value) ; + result CAT subtext (mantissa, 1, floors) ; + IF LENGTH mantissa < floors + THEN result CAT (floors - LENGTH mantissa) * "0" + FI ; + result CAT "." ; + IF exponent < 0 + THEN result CAT (-floors) * "0" ; + result CAT subtext (mantissa, 1, length - LENGTH result) + ELSE result CAT subtext (mantissa, floors+1, floors + fracs) + FI ; + IF LENGTH result < length + THEN result CAT (length - LENGTH result) * "0" + FI ; + result . + +process leading blanks and sign : + result := (floor length - max(floors,0)) * " " ; + IF value < 0.0 + THEN result CAT "-" ; + value := - value + FI . + +value too big : + floors > floor length . + +ENDPROC text ; + +REAL PROC real (TEXT CONST text) : + + skip leading blanks ; + sign ; + mantissa part ; + exponent ; + result . + +skip leading blanks : + INT VAR pos := 1 ; + skip blanks . + +skip blanks : + WHILE (text SUB pos) = " " REP + pos INCR 1 + PER . + +sign : + BOOL VAR negative ; + IF (text SUB pos) = "-" + THEN negative := TRUE ; + pos INCR 1 + ELIF (text SUB pos) = "+" + THEN negative := FALSE ; + pos INCR 1 + ELSE negative := FALSE + FI . + +mantissa part: + REAL VAR value ; + INT VAR exponent pos := 0 ; + get first digit ; + WHILE pos <= LENGTH text REP + digit := code (text SUB pos) - 47 ; + IF digit >= digit zero index AND digit <= digit nine index + THEN value := value * 10.0 + real digit (digit) ; + pos INCR 1 + ELIF digit = decimal point index AND exponent pos = 0 + THEN pos INCR 1 ; + exponent pos := pos + ELSE LEAVE mantissa part + FI + END REP . + +get first digit : + INT VAR digit := code (text SUB pos) - 47 ; + IF digit = decimal point index + THEN pos INCR 1 ; + exponent pos := pos ; + digit := code (text SUB pos) - 47 + FI ; + IF digit >= digit zero index AND digit <= digit nine index + THEN value := real digit (digit) ; + pos INCR 1 + ELSE set conversion (FALSE) ; + LEAVE real WITH 0.0 + FI . + +exponent : + INT VAR exp ; + IF exponent pos > 0 + THEN exp := exponent pos - pos + ELSE exp := 0 + FI ; + IF (text SUB pos) = "e" + THEN exp INCR int (subtext(text,pos+1)) + ELSE no more nonblank chars permitted + FI . + +no more nonblank chars permitted : + skip blanks ; + IF pos > LENGTH text + THEN set conversion (TRUE) + ELSE set conversion (FALSE) + FI . + +result : + value := value * tenpower (exp) ; + IF negative + THEN - value + ELSE value + FI . + +ENDPROC real ; + + +REAL PROC abs (REAL CONST value) : + + IF value >= 0.0 + THEN value + ELSE -value + FI + +ENDPROC abs ; + +REAL OP ABS (REAL CONST value) : + + abs (value) + +ENDOP ABS ; + +INT PROC sign (REAL CONST value) : + + IF value < 0.0 THEN -1 + ELIF value = 0.0 THEN 0 + ELSE 1 + FI + +ENDPROC sign ; + +INT OP SIGN (REAL CONST value) : + + sign (value) + +ENDOP SIGN ; + +REAL OP MOD (REAL CONST left, right) : + + REAL VAR result := left - floor (left/right) * right ; + IF result < 0.0 + THEN result + abs (right) + ELSE result + FI + +ENDOP MOD ; + +REAL PROC frac (REAL CONST value) : + + value - floor (value) + +ENDPROC frac ; + +REAL PROC max (REAL CONST a, b) : + + IF a > b THEN a ELSE b FI + +ENDPROC max ; + +REAL PROC min (REAL CONST a, b) : + + IF a < b THEN a ELSE b FI + +ENDPROC min ; + +OP INCR (REAL VAR dest, REAL CONST increment) : + + dest := dest + increment + +ENDOP INCR ; + +OP DECR (REAL VAR dest, REAL CONST decrement) : + + dest := dest - decrement + +ENDOP DECR ; + +INT PROC int (REAL CONST value) : + + IF value = minint value + THEN minint + ELSE compute int result ; + IF value < 0.0 + THEN - result + ELSE result + FI + FI . + +compute int result : + INT VAR result := 0, digit ,i ; + REAL VAR mantissa := value ; + + FOR i FROM 0 UPTO decimal exponent (value) REP + sld (0, mantissa, digit) ; + result := result * 10 + digit + PER . + +minint value : - 32768.0 . +minint : - 32767 - 1 . + +ENDPROC int ; + +REAL PROC real (INT CONST value) : + + IF value < 0 + THEN - real (-value) + ELIF value < 10 + THEN real digit (value+1) + ELSE split value into head and last digit ; + real (head) * 10.0 + real digit (last digit+1) + FI . + +split value into head and last digit : + INT CONST + head := value DIV 10 , + last digit := value - head * 10 . + +ENDPROC real ; + +ENDPACKET real ; + -- cgit v1.2.3