295 lines
9.3 KiB
OpenEdge ABL
295 lines
9.3 KiB
OpenEdge ABL
|
22300 #include "rundecs.h"
|
||
|
|
22310 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
|
||
|
|
22320 (**)
|
||
|
|
22330 PROCEDURE ERRORR(N: INTEGER);EXTERN;
|
||
|
|
22340 PROCEDURE GARBAGE(ANOBJECT: OBJECTP);EXTERN;
|
||
|
|
22350 FUNCTION SAFEACCESS(LOCATION: OBJECTP): UNDRESSP; EXTERN;
|
||
|
|
22360 (**)
|
||
|
|
22370 (**)
|
||
|
|
22380 FUNCTION CRCOMPLEX(REPART,IMAGPART: REAL): OBJECTP;
|
||
|
|
22390 VAR NEWCOMPLEX: OBJECTP;
|
||
|
|
22400 BEGIN
|
||
|
|
22410 ENEW(NEWCOMPLEX, STRUCTCONST+2*SZREAL);
|
||
|
|
22420 WITH NEWCOMPLEX^ DO
|
||
|
|
22430 BEGIN
|
||
|
|
22440 (*-02() FIRSTWORD := SORTSHIFT * ORD(STRUCT); ()-02*)
|
||
|
|
22450 (*+02() PCOUNT:=0; SORT:=STRUCT; ()+02*)
|
||
|
|
22460 LENGTH := STRUCTCONST+2*SZREAL;
|
||
|
|
22470 DBLOCK := COMPLEX;
|
||
|
|
22480 RE := REPART;
|
||
|
|
22490 IM := IMAGPART
|
||
|
|
22500 END;
|
||
|
|
22510 CRCOMPLEX := NEWCOMPLEX
|
||
|
|
22520 END;
|
||
|
|
22530 (**)
|
||
|
|
22540 (**)
|
||
|
|
22550 FUNCTION WIDREAL(REA: REAL): OBJECTP;
|
||
|
|
22560 (*PWIDEN+2*)
|
||
|
|
22570 BEGIN
|
||
|
|
22580 WIDREAL := CRCOMPLEX(REA,0.0)
|
||
|
|
22590 END;
|
||
|
|
22600 (**)
|
||
|
|
22610 (**)
|
||
|
|
22620 FUNCTION CPLUS(LEFT,RIGHT: OBJECTP): OBJECTP;
|
||
|
|
22630 VAR NEWOBJ: OBJECTP;
|
||
|
|
22640 BEGIN
|
||
|
|
22650 IF FPTST(LEFT^) THEN NEWOBJ := LEFT
|
||
|
|
22660 ELSE IF FPTST(RIGHT^) THEN NEWOBJ := RIGHT
|
||
|
|
22670 ELSE NEWOBJ := CRCOMPLEX(0.0,0.0);
|
||
|
|
22680 WITH NEWOBJ^ DO
|
||
|
|
22690 BEGIN
|
||
|
|
22700 RE := LEFT^.RE+RIGHT^.RE;
|
||
|
|
22710 IM := LEFT^.IM+RIGHT^.IM
|
||
|
|
22720 END;
|
||
|
|
22730 IF (FPTST(LEFT^)) AND (FPTST(RIGHT^)) THEN GARBAGE(RIGHT);
|
||
|
|
22740 CPLUS := NEWOBJ
|
||
|
|
22750 END;
|
||
|
|
22760 (**)
|
||
|
|
22770 (**)
|
||
|
|
22780 FUNCTION CMINUS(LEFT,RIGHT: OBJECTP): OBJECTP;
|
||
|
|
22790 VAR NEWOBJ: OBJECTP;
|
||
|
|
22800 BEGIN
|
||
|
|
22810 IF FPTST(LEFT^) THEN NEWOBJ := LEFT
|
||
|
|
22820 ELSE IF FPTST(RIGHT^) THEN NEWOBJ := RIGHT
|
||
|
|
22830 ELSE NEWOBJ := CRCOMPLEX(0.0,0.0);
|
||
|
|
22840 WITH NEWOBJ^ DO
|
||
|
|
22850 BEGIN
|
||
|
|
22860 RE := LEFT^.RE-RIGHT^.RE;
|
||
|
|
22870 IM := LEFT^.IM-RIGHT^.IM
|
||
|
|
22880 END;
|
||
|
|
22890 IF (FPTST(LEFT^)) AND (FPTST(RIGHT^)) THEN GARBAGE(RIGHT);
|
||
|
|
22900 CMINUS := NEWOBJ
|
||
|
|
22910 END;
|
||
|
|
22920 (**)
|
||
|
|
22930 (**)
|
||
|
|
22940 FUNCTION CTIMS(LEFT,RIGHT: OBJECTP): OBJECTP;
|
||
|
|
22950 VAR NEWOBJ: OBJECTP;
|
||
|
|
22960 TEMPREAL: REAL;
|
||
|
|
22970 BEGIN
|
||
|
|
22980 IF FPTST(LEFT^) THEN NEWOBJ := LEFT
|
||
|
|
22990 ELSE IF FPTST(RIGHT^) THEN NEWOBJ := RIGHT
|
||
|
|
23000 ELSE NEWOBJ := CRCOMPLEX(0.0,0.0);
|
||
|
|
23010 TEMPREAL := LEFT^.RE*RIGHT^.RE-LEFT^.IM*RIGHT^.IM;
|
||
|
|
23020 WITH NEWOBJ^ DO
|
||
|
|
23030 BEGIN
|
||
|
|
23040 IM := LEFT^.RE*RIGHT^.IM+LEFT^.IM*RIGHT^.RE;
|
||
|
|
23050 RE := TEMPREAL
|
||
|
|
23060 END;
|
||
|
|
23070 IF (FPTST(LEFT^)) AND (FPTST(RIGHT^)) THEN GARBAGE(RIGHT);
|
||
|
|
23080 CTIMS := NEWOBJ
|
||
|
|
23090 END;
|
||
|
|
23100 (**)
|
||
|
|
23110 (**)
|
||
|
|
23120 FUNCTION CDIV(LEFT,RIGHT: OBJECTP): OBJECTP;
|
||
|
|
23130 VAR NEWOBJ: OBJECTP;
|
||
|
|
23140 TEMPREAL,RIGHTSQR: REAL;
|
||
|
|
23150 BEGIN
|
||
|
|
23160 IF FPTST(LEFT^) THEN NEWOBJ := LEFT
|
||
|
|
23170 ELSE IF FPTST(RIGHT^) THEN NEWOBJ := RIGHT
|
||
|
|
23180 ELSE NEWOBJ := CRCOMPLEX(0.0,0.0);
|
||
|
|
23190 RIGHTSQR := SQR(RIGHT^.RE)+SQR(RIGHT^.IM);
|
||
|
|
23200 TEMPREAL := (LEFT^.RE*RIGHT^.RE+LEFT^.IM*RIGHT^.IM)/RIGHTSQR;
|
||
|
|
23210 WITH NEWOBJ^ DO
|
||
|
|
23220 BEGIN
|
||
|
|
23230 IM := (LEFT^.IM*RIGHT^.RE-LEFT^.RE*RIGHT^.IM)/RIGHTSQR;
|
||
|
|
23240 RE := TEMPREAL
|
||
|
|
23250 END;
|
||
|
|
23260 IF (FPTST(LEFT^)) AND (FPTST(RIGHT^)) THEN GARBAGE(RIGHT);
|
||
|
|
23270 CDIV := NEWOBJ
|
||
|
|
23280 END;
|
||
|
|
23290 (**)
|
||
|
|
23300 (**)
|
||
|
|
23310 FUNCTION CNEGI(CNUMB: OBJECTP): OBJECTP;
|
||
|
|
23320 VAR NEWOBJ: OBJECTP;
|
||
|
|
23330 BEGIN
|
||
|
|
23340 IF FPTST(CNUMB^) THEN NEWOBJ := CNUMB
|
||
|
|
23350 ELSE NEWOBJ := CRCOMPLEX(0.0,0.0);
|
||
|
|
23360 WITH NEWOBJ^ DO
|
||
|
|
23370 BEGIN
|
||
|
|
23380 RE := -CNUMB^.RE;
|
||
|
|
23390 IM := -CNUMB^.IM
|
||
|
|
23400 END;
|
||
|
|
23410 CNEGI := NEWOBJ
|
||
|
|
23420 END;
|
||
|
|
23430 (**)
|
||
|
|
23440 (**)
|
||
|
|
23450 FUNCTION CCONJ(CNUMB: OBJECTP): OBJECTP;
|
||
|
|
23460 VAR NEWOBJ: OBJECTP;
|
||
|
|
23470 BEGIN
|
||
|
|
23480 IF FPTST(CNUMB^) THEN NEWOBJ := CNUMB
|
||
|
|
23490 ELSE NEWOBJ := CRCOMPLEX(0.0,0.0);
|
||
|
|
23500 WITH NEWOBJ^ DO
|
||
|
|
23510 BEGIN
|
||
|
|
23520 RE := CNUMB^.RE;
|
||
|
|
23530 IM := -CNUMB^.IM
|
||
|
|
23540 END;
|
||
|
|
23550 CCONJ := NEWOBJ
|
||
|
|
23560 END;
|
||
|
|
23570 (**)
|
||
|
|
23580 (**)
|
||
|
|
23590 FUNCTION CRE(CNUMB: OBJECTP): REAL;
|
||
|
|
23600 BEGIN
|
||
|
|
23610 CRE := CNUMB^.RE;
|
||
|
|
23620 IF FPTST(CNUMB^) THEN GARBAGE(CNUMB)
|
||
|
|
23630 END;
|
||
|
|
23640 (**)
|
||
|
|
23650 (**)
|
||
|
|
23660 FUNCTION CIM(CNUMB: OBJECTP): REAL;
|
||
|
|
23670 BEGIN
|
||
|
|
23680 CIM := CNUMB^.IM;
|
||
|
|
23690 IF FPTST(CNUMB^) THEN GARBAGE(CNUMB)
|
||
|
|
23700 END;
|
||
|
|
23710 (**)
|
||
|
|
23720 (**)
|
||
|
|
23730 FUNCTION CABSI(CNUMB: OBJECTP): REAL;
|
||
|
|
23740 BEGIN
|
||
|
|
23750 WITH CNUMB^ DO
|
||
|
|
23760 CABSI := SQRT(SQR(RE)+SQR(IM));
|
||
|
|
23770 IF FPTST(CNUMB^) THEN GARBAGE(CNUMB)
|
||
|
|
23780 END;
|
||
|
|
23790 (**)
|
||
|
|
23800 (**)
|
||
|
|
23810 FUNCTION ARG(CNUMB: OBJECTP): REAL;
|
||
|
|
23820 VAR RESULT: REAL;
|
||
|
|
23830 BEGIN
|
||
|
|
23840 WITH CNUMB^ DO
|
||
|
|
23850 IF (RE<>0.0) OR (IM<>0.0) THEN
|
||
|
|
23860 IF ABS(RE)>ABS(IM) THEN
|
||
|
|
23870 RESULT := ARCTAN(IM/RE)+HALFPI.ACTUALPI*(1-ORD(RE>0.0))*2*(1-2*ORD(IM<0.0))
|
||
|
|
23880 ELSE RESULT := -ARCTAN(RE/IM)+HALFPI.ACTUALPI*(ORD(IM>0.0)-ORD(IM<0.0))
|
||
|
|
23890 ELSE ERRORR(RARG);
|
||
|
|
23900 ARG := RESULT
|
||
|
|
23910 END;
|
||
|
|
23920 (**)
|
||
|
|
23930 (**)
|
||
|
|
23940 FUNCTION CARG(CNUMB: OBJECTP): REAL;
|
||
|
|
23950 BEGIN
|
||
|
|
23960 CARG := ARG(CNUMB);
|
||
|
|
23970 IF FPTST(CNUMB^) THEN GARBAGE(CNUMB)
|
||
|
|
23980 END;
|
||
|
|
23990 (**)
|
||
|
|
24000 (**)
|
||
|
|
24010 FUNCTION CPOW(CNUMB: OBJECTP;POW: INTEGER): OBJECTP;
|
||
|
|
24020 VAR NEWOBJ: OBJECTP;
|
||
|
|
24030 CMOD,CMODPOW,NTHETA: REAL;
|
||
|
|
24040 NEGPOW: BOOLEAN;
|
||
|
|
24050 BEGIN
|
||
|
|
24060 IF FPTST(CNUMB^) THEN NEWOBJ := CNUMB
|
||
|
|
24070 ELSE NEWOBJ := CRCOMPLEX(0.0,0.0);
|
||
|
|
24080 WITH CNUMB^ DO
|
||
|
|
24090 CMOD := SQRT(SQR(RE)+SQR(IM));
|
||
|
|
24100 IF CMOD<>0.0 THEN
|
||
|
|
24110 BEGIN
|
||
|
|
24120 NEGPOW := POW<0;
|
||
|
|
24130 POW := ABS(POW);
|
||
|
|
24140 NTHETA := POW*ARG(CNUMB);
|
||
|
|
24150 CMODPOW := 1;
|
||
|
|
24160 WHILE POW<>0 DO
|
||
|
|
24170 BEGIN
|
||
|
|
24180 IF POW MOD 2=1 THEN CMODPOW := CMODPOW*CMOD;
|
||
|
|
24190 CMOD := SQR(CMOD);
|
||
|
|
24200 POW := POW DIV 2
|
||
|
|
24210 END;
|
||
|
|
24220 WITH NEWOBJ^ DO
|
||
|
|
24230 BEGIN
|
||
|
|
24240 RE := COS(NTHETA)*CMODPOW;
|
||
|
|
24250 IM := SIN(NTHETA)*CMODPOW;
|
||
|
|
24260 IF NEGPOW THEN
|
||
|
|
24270 BEGIN
|
||
|
|
24280 CMOD := SQR(RE)+SQR(IM);
|
||
|
|
24290 RE := RE/CMOD;
|
||
|
|
24300 IM := -IM/CMOD
|
||
|
|
24310 END
|
||
|
|
24320 END
|
||
|
|
24330 END
|
||
|
|
24340 ELSE WITH NEWOBJ^ DO
|
||
|
|
24350 BEGIN
|
||
|
|
24360 RE := 0.0;
|
||
|
|
24370 IM := 0.0
|
||
|
|
24380 END;
|
||
|
|
24390 CPOW := NEWOBJ;
|
||
|
|
24400 END;
|
||
|
|
24410 (**)
|
||
|
|
24420 (**)
|
||
|
|
24430 FUNCTION CEQ(LEFT,RIGHT: OBJECTP): INTEGER;
|
||
|
|
24440 VAR EQUALS: BOOLEAN;
|
||
|
|
24450 BEGIN
|
||
|
|
24460 EQUALS := (LEFT^.RE=RIGHT^.RE) AND (LEFT^.IM=RIGHT^.IM);
|
||
|
|
24470 IF FPTST(LEFT^) THEN GARBAGE(LEFT);
|
||
|
|
24480 IF FPTST(RIGHT^) THEN GARBAGE(RIGHT);
|
||
|
|
24490 IF EQUALS THEN CEQ := TRUEVAL ELSE CEQ := 0
|
||
|
|
24500 END;
|
||
|
|
24510 (**)
|
||
|
|
24520 (**)
|
||
|
|
24530 FUNCTION CNE(LEFT,RIGHT: OBJECTP): INTEGER;
|
||
|
|
24540 VAR NOTEQUAL: BOOLEAN;
|
||
|
|
24550 BEGIN
|
||
|
|
24560 NOTEQUAL := (LEFT^.RE<>RIGHT^.RE) OR (LEFT^.IM<>RIGHT^.IM);
|
||
|
|
24570 IF FPTST(LEFT^) THEN GARBAGE(LEFT);
|
||
|
|
24580 IF FPTST(RIGHT^) THEN GARBAGE(RIGHT);
|
||
|
|
24590 IF NOTEQUAL THEN CNE := TRUEVAL ELSE CNE := 0
|
||
|
|
24600 END;
|
||
|
|
24610 (**)
|
||
|
|
24620 (**)
|
||
|
|
24630 FUNCTION CPLUSAB(DESTINATION,INCREMENT: OBJECTP): OBJECTP;
|
||
|
|
24640 VAR REALPTR: UNDRESSP;
|
||
|
|
24650 BEGIN
|
||
|
|
24660 REALPTR := SAFEACCESS(DESTINATION);
|
||
|
|
24670 REALPTR^.FIRSTREAL := REALPTR^.FIRSTREAL+INCREMENT^.RE;
|
||
|
|
24680 REALPTR := INCPTR(REALPTR,SZREAL);
|
||
|
|
24690 REALPTR^.FIRSTREAL := REALPTR^.FIRSTREAL+INCREMENT^.IM;
|
||
|
|
24700 IF FPTST(INCREMENT^) THEN GARBAGE(INCREMENT);
|
||
|
|
24710 CPLUSAB := DESTINATION
|
||
|
|
24720 END;
|
||
|
|
24730 (**)
|
||
|
|
24740 (**)
|
||
|
|
24750 FUNCTION CMINAB(DESTINATION,DECREMENT: OBJECTP): OBJECTP;
|
||
|
|
24760 VAR REALPTR: UNDRESSP;
|
||
|
|
24770 BEGIN
|
||
|
|
24780 REALPTR := SAFEACCESS(DESTINATION);
|
||
|
|
24790 REALPTR^.FIRSTREAL := REALPTR^.FIRSTREAL-DECREMENT^.RE;
|
||
|
|
24800 REALPTR := INCPTR(REALPTR,SZREAL);
|
||
|
|
24810 REALPTR^.FIRSTREAL := REALPTR^.FIRSTREAL-DECREMENT^.IM;
|
||
|
|
24820 IF FPTST(DECREMENT^) THEN GARBAGE(DECREMENT);
|
||
|
|
24830 CMINAB := DESTINATION
|
||
|
|
24840 END;
|
||
|
|
24850 (**)
|
||
|
|
24860 (**)
|
||
|
|
24870 FUNCTION CTIMSAB(DESTINATION,FACTOR: OBJECTP): OBJECTP;
|
||
|
|
24880 VAR REALPTR,IMAGPTR: UNDRESSP;
|
||
|
|
24890 TEMPREAL: REAL;
|
||
|
|
24900 BEGIN
|
||
|
|
24910 REALPTR := SAFEACCESS(DESTINATION);
|
||
|
|
24920 IMAGPTR := INCPTR(REALPTR,SZREAL);
|
||
|
|
24930 TEMPREAL := REALPTR^.FIRSTREAL*FACTOR^.RE-IMAGPTR^.FIRSTREAL*FACTOR^.IM;
|
||
|
|
24940 IMAGPTR^.FIRSTREAL := REALPTR^.FIRSTREAL*FACTOR^.IM+IMAGPTR^.FIRSTREAL*FACTOR^.RE;
|
||
|
|
24950 REALPTR^.FIRSTREAL := TEMPREAL;
|
||
|
|
24960 IF FPTST(FACTOR^) THEN GARBAGE(FACTOR);
|
||
|
|
24970 CTIMSAB := DESTINATION
|
||
|
|
24980 END;
|
||
|
|
24990 (**)
|
||
|
|
25000 (**)
|
||
|
|
25010 FUNCTION CDIVAB(DESTINATION,DIVISOR: OBJECTP): OBJECTP;
|
||
|
|
25020 VAR REALPTR,IMAGPTR: UNDRESSP;
|
||
|
|
25030 TEMPREAL,DIVISORSQR: REAL;
|
||
|
|
25040 BEGIN
|
||
|
|
25050 REALPTR := SAFEACCESS(DESTINATION);
|
||
|
|
25060 IMAGPTR := INCPTR(REALPTR,SZREAL);
|
||
|
|
25070 DIVISORSQR := SQR(DIVISOR^.RE)+SQR(DIVISOR^.IM);
|
||
|
|
25080 TEMPREAL := (REALPTR^.FIRSTREAL*DIVISOR^.RE+IMAGPTR^.FIRSTREAL*DIVISOR^.IM)/DIVISORSQR;
|
||
|
|
25090 IMAGPTR^.FIRSTREAL := (IMAGPTR^.FIRSTREAL*DIVISOR^.RE-REALPTR^.FIRSTREAL*DIVISOR^.IM)/DIVISORSQR;
|
||
|
|
25100 REALPTR^.FIRSTREAL := TEMPREAL;
|
||
|
|
25110 IF FPTST(DIVISOR^) THEN GARBAGE(DIVISOR);
|
||
|
|
25120 CDIVAB := DESTINATION
|
||
|
|
25130 END;
|
||
|
|
25140 (**)
|
||
|
|
25150 (**)
|
||
|
|
25160 (*-02()
|
||
|
|
25170 BEGIN (* OF A68 *)
|
||
|
|
25180 END (* OF A68 *);
|
||
|
|
25190 ()-02*)
|
||
|
|
25200 (*+01()
|
||
|
|
25210 BEGIN (* OF MAIN PROGRAM *)
|
||
|
|
25220 END (* OF MAIN PROGRAM *).
|
||
|
|
25230 ()+01*)
|