49 lines
1.9 KiB
OpenEdge ABL
49 lines
1.9 KiB
OpenEdge ABL
74700 #include "rundecs.h"
|
|
74710 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
|
|
74720 (**)
|
|
74730 (**)
|
|
74740 FUNCTION CRSTRING(LENGTH: OFFSETRANGE): OBJECTP; EXTERN ;
|
|
74750 FUNCTION SUBFIXED(SIGN, BEFORE, POINT, AFTER : INTEGER; VAR EXP: INTEGER; EXPNEEDED: BOOLEAN;
|
|
74760 X: REALTEGER; R: BOOLEAN; VAR S: OBJECTP; START: INTEGER): BOOLEAN; EXTERN;
|
|
74770 PROCEDURE ERRORFILL(VAR S: OBJECTP; LENGTH: INTEGER); EXTERN;
|
|
74780 (**)
|
|
74790 (**)
|
|
74800 FUNCTION FLOAT(XMODE: INTEGER; VAL: REALTEGER; WIDTH, AFTER, EXP: INTEGER): OBJECTP;
|
|
74810 VAR E: REALTEGER;
|
|
74820 S: OBJECTP;
|
|
74830 ABSWIDTH, BEFORE, POINT, ABSEXP, EXPSIGN: INTEGER;
|
|
74840 OK, OK1: BOOLEAN;
|
|
74850 BEGIN
|
|
74860 ABSWIDTH := ABS(WIDTH)+ORD(WIDTH=0);
|
|
74870 ABSEXP := ABS(EXP)+ORD(EXP=0);
|
|
74880 S := CRSTRING(ABSWIDTH);
|
|
74890 REPEAT
|
|
74900 POINT := ORD(AFTER>0);
|
|
74910 BEFORE := ABSWIDTH-1-POINT-AFTER-1-ABSEXP;
|
|
74920 IF BEFORE<0 THEN AFTER := -1; (*WILL CAUSE SUBFIXED TO FAIL*)
|
|
74930 OK := SUBFIXED(ORD((WIDTH>0) OR (VAL.INT<0))-ORD((WIDTH<0) AND (VAL.INT>=0)),
|
|
74940 BEFORE, POINT, AFTER, E.INT, TRUE, VAL, XMODE=2, S, 1)
|
|
74950 AND (BEFORE+AFTER>0);
|
|
74960 S^.CHARVEC[1+BEFORE+POINT+AFTER+1] := 'E';
|
|
74970 EXPSIGN := ORD((EXP>0) OR (E.INT<0));
|
|
74980 OK1 := SUBFIXED(EXPSIGN, ABSEXP-EXPSIGN, 0, 0, E.INT, FALSE, E, FALSE,
|
|
74990 S, 1+BEFORE+POINT+AFTER+2);
|
|
75000 AFTER := AFTER-ORD(AFTER<>0); ABSEXP := ABSEXP+1
|
|
75010 UNTIL NOT OK OR OK1;
|
|
75020 IF NOT OK THEN ERRORFILL(S, ABSWIDTH);
|
|
75030 FLOAT := S;
|
|
75040 END;
|
|
75050 (**)
|
|
75060 (**)
|
|
75070 (*+01() (*$X4*) ()+01*)
|
|
75080 (**)
|
|
75090 (**)
|
|
75100 (*-02()
|
|
75110 BEGIN (*OF A68*)
|
|
75120 END; (*OF A68*)
|
|
75130 ()-02*)
|
|
75140 (*+01()
|
|
75150 BEGIN (*OF MAIN PROGRAM*)
|
|
75160 END (* OF EVERYTHING *).
|
|
75170 ()+01*)
|