ack/lang/a68s/liba68s/float.p

49 lines
1.9 KiB
OpenEdge ABL
Raw Normal View History

1988-10-04 13:41:01 +00:00
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*)