Add source files from Michael

1 files changed, 378 insertions, 0 deletions

diff --git a/system/base/unknown/src/real b/system/base/unknown/src/real
new file mode 100644
index 0000000..a2ab9c3
--- /dev/null
+++ b/system/base/unknown/src/real
@@ -0,0 +1,378 @@
+ 

+PACKET real DEFINES                            (* Autor: J.Liedtke *) 

+                                               (* Stand: 30.04.80  *) 

+   text , 

+   int ,

+   real ,

+   round ,

+   floor , 

+   frac ,

+   INCR ,

+   DECR ,

+   abs , 

+   ABS , 

+   sign ,

+   SIGN ,

+   MOD ,

+   min ,

+   max ,

+   put , 

+   get , 

+   max real ,

+   small real :

+

+LET mantissa length = 13 ;

+

+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 ;

+  set exp (decimal exponent (result) - digits, result) .

+

+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 : 

+  result CAT subtext (short mantissa, 1, exponent+1) ; 

+  result CAT (exponent+1 - LENGTH short mantissa) * "0" ; 

+  result CAT "." ; 

+  IF exponent < 0 

+    THEN result + (-exponent-1) * "0" + short mantissa 

+    ELSE result + subtext (short mantissa, exponent+2) 

+  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 ;

+

+PROC put (REAL CONST real) : 

+ 

+  put (text (real) ) 

+ 

+ENDPROC put ; 

+ 

+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 ; 

+  check correct conversion ;

+  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 := 0.0 ; 

+  INT VAR exponent pos := 0 ;

+  WHILE pos <= LENGTH text REP 

+    TEXT VAR digit := text SUB pos ; 

+    IF digit <= "9" AND digit >= "0" 

+      THEN value := value * 10.0 + real digit (code (digit) - 47) ;

+           pos INCR 1 

+    ELIF digit = "." 

+      THEN pos INCR 1 ;

+           exponent pos := pos

+    ELSE LEAVE mantissa part 

+    FI 

+  END REP . 

+ 

+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)) 

+  FI . 

+ 

+check correct conversion :

+  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 ; 

+ 

+TEXT VAR word ;

+ 

+PROC get (REAL VAR value) : 

+ 

+  get (word) ; 

+  value := real (word) 

+ 

+ENDPROC get ; 

+ 

+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 left < 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) :

+ 

+  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 ;

+ 

+  IF value < 0.0

+    THEN - result

+    ELSE   result

+  FI

+ 

+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 ;