Trailing-Edge
-
PDP-10 Archives
-
AP-D608C-SB
-
alglib.mac
There are 11 other files named alglib.mac in the archive. Click here to see a list.
;
;
;
;
;
;
; COPYRIGHT (C) 1975,1976,1977,1978
; DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
;
;
; THIS SOFTWARE IS FURNISHED UNDER A LICENSE FOR USE ONLY ON A
; SINGLE COMPUTER SYSTEM AND MAY BE COPIED ONLY WITH THE INCLUSION
; OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE, OR ANY OTHER
; COPIES THEREOF, MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE
; TO ANY OTHER PERSON EXCEPT FOR USE ON SUCH SYSTEM AND TO ONE WHO
; AGREES TO THESE LICENSE TERMS. TITLE TO AND OWNERSHIP OF THE
; SOFTWARE SHALL AT ALL TIMES REMAIN IN DEC.
;
; THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT
; NOTICE AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL
; EQUIPMENT CORPORATION.
;
; DEC ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
; SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DEC.
;
; SUBTTL GLOBAL DECLARATIONS
; COPYRIGHT 1971,1972,1973,1974 DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
SEARCH ALGPRM,ALGSYS ; SEARCH PARAMETER FILES
SALL
%TITLE(ALGLIB,ALGOL LIBRARY)
IF2, <
IFE PROC-KA10, <PRINTX KA10 VERSION>
IFE PROC-KI10, <PRINTX KI10 VERSION>>
EXTERNAL %ENTRY,%ALGDR
ENTRY %ALGDA
%ALGDA:
LIT
PRGEND
SUBTTL SHARABLE ALGOTS ENTRY
ENTRY %SHARE
INTERNAL %ENTRY,%ALGDR,%START,%REN
EXTERNAL %BEGIN,%OWN,%HEAP,%ALGDA,%JBVER,%JBEDT,%FLAGS,%TRACE
SEARCH ALGPRM,ALGSYS ; SEARCH PARAMETER FILES
SALL
%TITLE(ALGOBJ,ALGOL LIBRARY)
INTERNAL .JBREN,.JBOPS,.JBHDA
%ENTRY=0
%SHARE=0
%ALGDR=400000+.JBHDA
LOC .JBREN
XWD 0,%REN ; INITIAL REENTER
RELOC
%START: TDZA AX,AX ; START ENTRY POINT
%REN: HRLZI AX,REEN ; REENTER ENTRY POINT
MOVEM AX,.JBOPS ; SAVE START/REENTER FLAG DURING GETSEG
MOVEM A7,IFDAT ; SAVE LOAD-FILE INFO FOR OVRLAY
MOVEM A0,IFDAT+1
MOVEM A11,IFDAT+2
HRLZI A1,%JBEDT
LSH A1,^D9
MOVEI A2,3
HRLZI A5,(SIXBIT/ALG/)
MOVE A3,[
POINT 6,A5,17]
MOVE A4,[
POINT 7,SEGMES+6,6]
GET2: SETZ A0,
LSHC A0,3
ADDI A0,20 ; TO SIXBIT
IDPB A0,A3
ADDI A0,40 ; TO ASCII
IDPB A0,A4 ; TO ERROR-MESSAGE
SOJG A2,GET2
MOVEM A5,HSEG+1
MOVEM A5,HSEG1+1
GETSYS: MOVEI A0,HSEG
GETSEG A0, ; TRY TO GET SHARABLE ALGOTS
JRST NOSYS ; NOT FOUND
GET1: MOVE AX,.JBOPS ; RESTORE START/REENTER FLAG
HRRI AX,OBJDAT
JRST INITIA ; ENTER TO INITIALIZE
NOSYS: MOVEI A0,HSEG1
GETSEG A0, ; TRY ON DSK INSTEAD
JRST NOSEG ; NOT THERE EITHER
JRST GET1 ; FOUND ON DSK
NOSEG: TTCALL 3,SEGMES ; COMPLAIN ON TTY
EXIT 1, ; AND RETIRE
JRST GETSYS ; TRY AGAIN IF CONTINUE
HSEG: SIXBIT /SYS/
0 0
0
0
0
HSEG1: SIXBIT /DSK/
0 0
0
0
0
OBJDAT: XWD 0,%BEGIN ; DATA-BLOCK FOR OTS
XWD 0,%ALGDA
XWD 0,%OWN
XWD %FLAGS,%HEAP
XWD %JBVER,%JBEDT
IFDAT: BLOCK 3 ; INITIAL-FILE DATA FOR OVRLAY
XWD 0,%TRACE ; TRACE BUFFER-LENGTH
SEGMES: ASCIZ /
?ALGOL object time system ALGNNN.SHR not found
/
ENTRY FUNCT.
FUNCT.: JRST FUNCT ; OVERLAY-HANDLER SUB-ROUTINE ENTRY
LIT
PRGEND %START ; ENTRY POINT
SUBTTL NON-SHARABLE ALGOTS ENTRY
ENTRY %ENTRY
INTERNAL %START,%REN
EXTERNAL %BEGIN,%ALGDR,%OWN,%HEAP,%ALGDA,%JBVER,%JBEDT,%FLAGS,%TRACE
SEARCH ALGPRM,ALGSYS ; SEARCH PARAMETER FILES
SALL
%TITLE(ALGOBJ,ALGOL LIBRARY)
INTERNAL .JBREN
%ENTRY=0
LOC .JBREN
XWD 0,%REN ; INITIAL RENTER
RELOC
%START: TDZA AX,AX ; START ENTRY POINT
%REN: HRLZI AX,REEN ; REENTER ENTRY POINT
HRRI AX,[
XWD 0,%BEGIN
XWD 0,%ALGDA
XWD 0,%OWN
XWD %FLAGS,%HEAP
XWD %JBVER,%JBEDT
EXP 0,0,0
XWD 0,%TRACE] ;
JRST INITIA ; ENTER TO INITIALIZE
ENTRY FUNCT. ; DUMMY OVERLAY-HANDLER ENTRY-POINT
FUNCT.: TTCALL 3,[ASCIZ/?ALGNSO Sharable programs may not be overlaid.
/]
EXIT ; FATAL. ONE DAY GO TO DEBUGGER.
LIT
PRGEND %START ; ENTRY POINT
TITLE POWER1/POWER2 - INTEGER/REAL TO INTEGER EXPONENTIATION ROUTINE
; POWER1:
; ON ENTRY:
; THE BASE AND EXPONENT ARE ON THE STACK
; A1=0 IF RESULT MUST BE INTEGRAL (COMPILER SAYS SO)
; A1=1 IF RESULT IS TO BE REAL
; THE LINK IS IN AX
; ON EXIT, THE RESULT IS IN A0
; POWER2:
; ON ENTRY:
; THE BASE AND EXPONENT ARE ON THE STACK
; THE LINK IS IN AX
; ON EXIT, THE RESULT IS IN A0
SEARCH ALGPRM,ALGSYS
%ENTER<1,2>
SALL
%SUBTTL(ALGLIB,ALGOL LIBRARY)
MLON
LABEL(2): MOVEI A1,2
LABEL(1): POP SP,A2 ; RECOVER EXPONENT
POP SP,A0 ; RECOVER BASE
JUMPN A2,POW101 ; EXPONENT = 0?
EDIT(050); 0^0 is undefined, so generate error message
JUMPE A0,POW110 ; [E050] ERROR IF BASE = 0
XCT [
MOVEI A0,1
MOVSI A0,(1.0)
MOVSI A0,(1.0)](A1) ; YES - I^0 IS 1 OR 1.0
JRST (AX)
POW101: JUMPN A1,POW103 ; POWER1?
JUMPE A0,(AX) ; YES - QUICK EXIT FOR ZERO BASE
MOVE A1,A0 ; NO - COPY BASE
MOVEI A0,1 ; AND PREPARE FOR MULTIPLICATION
POW102: TRZE A2,000001 ; BIT SET IN EXPONENT?
IMUL A0,A1 ; YES - MULTIPLY
JOV POW109 ; CHECK OVERFLOW
JUMPE A2,(AX) ; EXIT IF FINISHED
IMUL A1,A1 ; OTHERWISE SQUARE MULTIPLIER
JOV POW109 ; CHECK OVERFLOW
LSH A2,-1 ; SHIFT ROUND EXPONENT
JRST POW102 ; AND CARRY ON
POW103: JUMPE A0,POW107 ; POWER2 - BASE = 0?
SOJN A1,POW104 ; NO - BASE IN REAL MODE?
IFE PROC-KA10, <
IDIVI A0,400000
JUMPE A0,.+2
TLC A0,254000
TLC A1,233000
FADR A0,A1>
IFE PROC-KI10, <
FLTR A0,A0> ; NO - CONVERT TO REAL
POW104: MOVE A1,A0 ; TRANSFER BASE TO A1
JUMPG A2,POW105 ; EXPONENT POSITIVE?
MOVN A2,A2 ; NO - NEGATE IT
JOV POW109 ; CHECK OVERFLOW
TDZA A3,A3 ; AND CLEAR POSITIVE FLAG
POW105: MOVEI A3,1 ; SET POSITIVE FLAG
MOVSI A0,(1.0) ; PREPARE FOR MULTIPLICATION/DIVISION
POW106: TRZN A2,000001 ; BIT SET IN EXPONENT?
JRST .+3 ; NO
XCT [
FDVR A0,A1
FMPR A0,A1](A3) ; YES - MULTIPLY/DIVIDE
JFOV POW108 ; CHECK OVERFLOW
JUMPE A2,(AX) ; EXIT IF FINISHED
FMPR A1,A1 ; OTHERWISE SQUARE MULTIPLIER
JFOV POW108 ; CHECK OVERFLOW
LSH A2,-1 ; SHIFT AROUND EXPONENT
JRST POW106 ; AND CARRY ON
POW107: JUMPG A2,(AX) ; BASE = 0 - EXIT IF EXPONENT > 0
POW108: SYSER2 2,(AX) ; OTHERWISE GIVE OVERFLOW
POW109: SYSER2 3,(AX) ; FIXED POINT OVERFLOW
POW110: LIBERR 1,(AX) ; [E050] BASE & EXPONENT BOTH ZERO
LIT
PRGEND
TITLE POWER3 - LONG REAL TO INTEGER EXPONENTIATION ROUTINE
; ON ENTRY:
; THE BASE AND EXPONENT ARE ON THE STACK
; THE LINK IS IN AX
; ON EXIT, THE RESULT (TYPE LONG REAL) IS IN A0,A1
SEARCH ALGPRM,ALGSYS
%ENTER<3>
SALL
%SUBTTL(ALGLIB,ALGOL LIBRARY)
IFE PROC-KA10, <
EXTLAB<21,22,27>>
LABEL(3): POP SP,A7 ; RECOVER EXPONENT
POP SP,A4
EXCH AX,(SP) ; RECOVER BASE
MOVE A3,AX ; AND SAVE LINK
JUMPN A7,POW302 ; EXPONENT = 0?
EDIT(050); 0^0 is undefined, so generate error message
JUMPE A3,POW308 ; [E050] ERROR IF BASE = 0.0&&0
MOVSI A0,(1.0)
MOVEI A1,0 ; YES - L^0 IS ALWAYS 1.0&&0
POW301: POPJ SP,0
POW302: JUMPE A3,POW305 ; BASE = 0?
JUMPGE A7,POW303 ; NO - EXPONENT POSITIVE?
MOVN A7,A7 ; NO - NEGATE IT
JOV POW307 ; CHECK OVERFLOW
TDZA A10,A10 ; AND CLEAR POSITIVE FLAG
POW303: MOVEI A10,1 ; SET POSITIVE FLAG
MOVSI A0,(1.0)
MOVEI A1,0 ; PREPARE FOR MULTIPLICATION/DIVISION
POW304: TRZN A7,000001 ; BIT SET IN EXPONENT?
JRST .+3 ; NO
IFE PROC-KA10, <
MOVEI AX,A3
PUSHJ SP,@[
XWD 0,LABEL(22)
XWD 0,LABEL(21)](A10)>
IFE PROC-KI10, <
XCT [
DFDV A0,A3
DFMP A0,A3](A10)
JFOV POW306> ; YES - MULTIPLY/DIVIDE
JUMPE A7,POW301 ; EXIT IF FINISHED
IFE PROC-KA10, <
MOVEI AX,A3
PUSHJ SP,LABEL(27)>
IFE PROC-KI10, <
DFMP A3,A3> ; OTHERWISE SQUARE MULTIPLIER
LSH A7,-1 ; SHIFT AROUND EXPONENT
JRST POW304 ; AND CARRY ON
POW305: SETZB A0,A1 ; BASE = 0
JUMPG A7,POW301 ; EXIT IF EXPONENT > 0
POW306: SYSER2 2,@(SP) ; OTHERWISE GIVE OVERFLOW
POW307: SYSER2 3,@(SP) ; FIXED POINT OVERFLOW
POW308: LIBERR 1,@(SP) ; [E050] BASE & EXPONENT BOTH ZERO
LIT
PRGEND
TITLE POWER4 - INTEGER/REAL TO REAL EXPONENTIATION ROUTINE
; ON ENTRY:
; THE BASE AND EXPONENT ARE ON THE STACK
; A1 = 0 IF BASE IS INTEGER
; A1 = 1 IF BASE IS REAL
; THE LINK IS IN AX
; ON EXIT, THE RESULT (TYPE REAL) IS IN A0
SEARCH ALGPRM,ALGSYS
%ENTER<4>
EXTLAB<7,104,105>
SALL
%SUBTTL(ALGLIB,ALGOL LIBRARY)
LABEL(4): POP SP,A2 ; RECOVER EXPONENT
EXCH AX,(SP) ; RECOVER BASE
MOVE A0,AX ; AND SAVE LINK
JUMPN A2,POW401 ; EXPONENT = 0?
EDIT(050); 0^0 is undefined, so generate error message
JUMPN A0,POW405 ; [E050] O.K. IF BASE NON-ZERO
POW403: LIBERR 1,@(SP) ; NO - COMPLAIN
POW401: JUMPN A1,.+2
JSP AX,LABEL(7) ; CONVERT BASE TO REAL IF NECESSARY
JUMPLE A0,POW402 ; BASE <= 0?
PUSH SP,A2 ; NO - SAVE EXPONENT
PUSHJ SP,LABEL(105) ; AND TAKE LOGARITHM OF BASE
POP SP,A1 ; RESTORE EXPONENT
JUMPE A0,POW405 ; QUICK EXIT IF RESULT ZERO
FMPR A0,A1 ; OTHERWISE MULTIPLY BY EXPONENT
JRST LABEL(104) ; AND TAKE EXPONENTIAL
POW402: JUMPN A0,POW403 ; BASE = 0?
POW404: JUMPL A2,POW403 ; YES - EXPONENT < 0?
TDZA A0,A0 ; NO - RESULT IS 0.0
POW405: MOVSI A0,(1.0) ; RESULT IS 1.0
POPJ SP,0
LIT
PRGEND
TITLE POWER5 - INTEGER/REAL TO LONG REAL, LONG REAL TO REAL/LONG REAL EXPONENTIATION ROUTINE
; ON ENTRY:
; THE BASE AND EXPONENT ARE ON THE STACK
; A1 = 0 IF INTEGER TO LONG REAL
; A1 = 1 IF REAL TO LONG REAL
; A1 = 2 IF LONG REAL TO REAL
; A1 = 3 IF LONG REAL TO LONG REAL
; THE LINK IS IN AX
; ON EXIT, THE RESULT (TYPE LONG REAL) IS IN A0,A1
SEARCH ALGPRM,ALGSYS
%ENTER<5>
EXTLAB<10,13,21,120,121>
SALL
%SUBTTL(ALGLIB,ALGOL LIBRARY)
LABEL(5): JRST @POW501(A1) ; USE APPROPRIATE SEQUENCE
POW501: XWD 0,POW502 ; I^LR
XWD 0,POW503 ; R^LR
XWD 0,POW504 ; LR^R
XWD 0,POW505 ; LR^LR
POW502: POP SP,A4
POP SP,A3 ; RECOVER EXPONENT
EXCH AX,(SP) ; RECOVER BASE
MOVE A0,AX ; AND SAVE LINK
JSP AX,LABEL(10) ; CONVERT BASE TO LONG REAL
JRST POW506
POW503: POP SP,A4
POP SP,A3 ; RECOVER EXPONENT
EXCH AX,(SP) ; RECOVER BASE
MOVE A0,AX ; AND SAVE LINK
JSP AX,LABEL(13) ; CONVERT BASE TO LONG REAL
JRST POW506
POW504: POP SP,A0 ; RECOVER EXPONENT
POP SP,A4
EXCH AX,(SP) ; RECOVER BASE
MOVE A3,AX ; AND SAVE LINK
JSP AX,LABEL(13) ; CONVERT EXPONENT TO LONG REAL
EXCH A0,A3
EXCH A1,A4 ; GET THINGS IN RIGHT ACCUMULATORS
JRST POW506
POW505: POP SP,A4
POP SP,A3 ; RECOVER EXPONENT
POP SP,A1
EXCH AX,(SP) ; RECOVER BASE
MOVE A0,AX ; AND SAVE LINK
POW506: JUMPN A3,POW507 ; EXPONENT = 0?
EDIT(050); 0^0 is undefined, so generate error message
JUMPE A0,POW509 ; [E050] ERROR IF BASE ALSO ZERO
MOVSI A0,(1.0)
MOVEI A1,0
POPJ SP,0 ; YES - RESULT IS 1.0&&0
POW507: JUMPLE A0,POW508 ; BASE <= 0?
PUSH SP,A3
PUSH SP,A4 ; NO - SAVE EXPONENT
PUSHJ SP,LABEL(121) ; AND TAKE LOGARITHM OF BASE
POP SP,A4
POP SP,A3 ; RESTORE EXPONENT
JUMPE A0,LABEL(120) ; QUICK EXIT IF RESULT ZERO
MOVEI AX,A3
PUSHJ SP,LABEL(21) ; OTHERWISE MULTIPLY BY EXPONENT
JRST LABEL(120) ; AND TAKE EXPONENTIAL
POW508: JUMPE A0,POW510 ; BASE = 0?
POW509: LIBERR 1,@(SP) ; NO - COMPLAIN
POW510: JUMPL A3,POW509 ; YES - EXPONENT < 0?
SETZB A0,A1 ; NO - RESULT IS 0.0&&0
POW511: POPJ SP,0
LIT
PRGEND
TITLE DSIGN - DUMMY BODY FOR SIGN
; INTEGER PROCEDURE SIGN(I); VALUE I; INTEGER I;
; INTEGER PROCEDURE SIGN(X); VALUE X; REAL X;
; INTEGER PROCEDURE SIGN(D); VALUE D; LONG REAL D;
.EXIT=1
.IXD=3
SEARCH ALGPRM,ALGSYS
%ENTER<223>
EXTERNAL %ALGDR
SALL
%SUBTTL(ALGLIB,ALGOL LIBRARY)
EXTLAB<6>
LABEL(223): JSP AX,PARAM
Z ; ZERO POINTER. ROUTINE ITSELF CALLS TRACE
XWD 0,4
XWD $PRO!$I!$SIM,2
XWD $VAR!$WA!$FOV,.IXD
MOVE A0,.IXD(DL) ; GET ARGUMENT
JSP AX,LABEL(6) ; AND ITS SIGN
MOVEM A0,.EXIT+1(DL)
JRST .EXIT(DL)
LIT
PRGEND
TITLE SIGN - SIGN ROUTINE
; ON ENTRY:
; THE ARGUMENT (INTEGER, REAL OR THE HIGH ORDER WORD OF LONG REAL) IS IN A0
; THE LINK IS IN AX
; ON EXIT:
; THE RESULT: -1 IF ARGUMENT < 0
; 0 IF ARGUMENT = 0
; 1 IF ARGUMENT > 0
; IS IN A0
SEARCH ALGPRM,ALGSYS
STDENT(6,SIGN)
JUMPE A0,(AX) ; EXIT IF ZERO ARGUMENT
JUMPL A0,SIGN1 ; ARGUMENT < 0?
MOVEI A0,1 ; NO - RESULT IS 1
JRST (AX)
SIGN1: MOVNI A0,1 ; YES - RESULT IS -1
JRST (AX)
LIT
PRGEND
TITLE DABS - DUMMY BODY FOR ABS
; INTEGER PROCEDURE ABS(I); VALUE I; INTEGER I;
; REAL PROCEDURE ABS(X); VALUE X; REAL X;
; LONG REAL PROCEDURE ABS(D); VALUE D; LONG REAL D;
.EXIT=1
.IX=3
.D=4
SEARCH ALGPRM,ALGSYS
%ENTER<222>
EXTERNAL %ALGDR
SALL
%SUBTTL(ALGLIB,ALGOL LIBRARY)
ABS:
LABEL(222): MOVE A1,(SP) ; GET PROGRAM LINK
HRRZ A0,(A1) ; NUMBER OF PARAMETERS+1
CAIE A0,2 ; TWO?
SYSER1 10,0 ; NO - COMPLAIN
HLRZ A0,1(A1)
ANDI A0,$TYPE ; GET TYPE
CAIN A0,$I
JRST DABS2 ; INTEGER I
CAIN A0,$R
JRST DABS3 ; REAL
CAIE A0,$LR ; LONG REAL?
SYSER1 7,0 ; NO - COMPLAIN
JSP AX,PARAM ; (D)
EXP PMB
XWD 0,5
XWD $PRO!$LR!$SIM,2
XWD $VAR!$LR!$FOV,.D
LRLOAD A0,.D(DL)
JUMPGE A0,DABS1
IFN PROC-KI10, <
LRNEG A0,A1>
IFE PROC-KI10, <
DMOVN A0,A0>
DABS1: LRSTOR A0,.EXIT+1(DL)
JRST .EXIT(DL)
DABS2: JSP AX,PARAM ; (I)
XWD 0,3
XWD $PRO!$I!$SIM,2
XWD $VAR!$I!$FOV,.IX
JRST DABS4
DABS3: JSP AX,PARAM ; (R)
XWD 0,3
XWD $PRO!$R!$SIM,2
XWD $VAR!$R!$FOV,.IX
DABS4: MOVM A0,.IX(DL) ; GET MAGNITUDE
MOVEM A0,.EXIT+1(DL)
JRST .EXIT(DL)
PMB:
PMB: 0 ; PROFILE WORD
1,,3
SIXBIT/ABS/
LIT
PRGEND
TITLE DENTIER - DUMMY BODY FOR ENTIER
; INTEGER PROCEDURE ENTIER(X); VALUE X; REAL X;
; INTEGER PROCEDURE ENTIER(D); VALUE D; LONG REAL D;
.EXIT=1
.XD=3
SEARCH ALGPRM,ALGSYS
%ENTER<224>
EXTERNAL %ALGDR
SALL
%SUBTTL(ALGLIB,ALGOL LIBRARY)
EXTLAB<11,14>
LABEL(224): JSP AX,PARAM
Z
XWD 0,4
XWD $PRO!$I!$SIM,2
XWD $VAR!$WF!$FOV,.XD
MOVE A1,PRGLNK(DL) ; GET PROGRAM LINK
HLRZ A2,-1(A1)
ANDI A2,$TYPE ; GET TYPE OF PARAMETER
MOVEI AX,DENT1 ; SET RETURN LINK
MOVE A0,.XD(DL) ; AND LOAD FIRST ARGUMENT WORD
CAIN A2,$R ; REAL?
JRST LABEL(11) ; YES - USE ENTIER
MOVE A1,.XD+1(DL) ; NO - LOAD SECOND WORD OF ARGUMENT
JRST LABEL(14) ; AND USE ENTIEL
DENT1: MOVEM A0,.EXIT+1(DL) ; RESULT
JRST .EXIT(DL)
LIT
PRGEND
TITLE DINT - DUMMY BODY FOR INT
; INTEGER PROCEDURE INT(B); VALUE B; BOOLEAN B;
.EXIT=1
.B=2
SEARCH ALGPRM,ALGSYS
LIBENT(225,INT)
XWD 0,2
XWD $PRO!$I!$SIM,2
XWD $VAR!$B!$FOV,.B
JRST .EXIT(DL) ; RESULT TRANSFERRED AUTOMATICALLY!
LIT
PRGEND
TITLE DBOOL - DUMMY BODY FOR BOOL
; BOOLEAN PROCEDURE BOOL(I); VALUE I; INTEGER I;
.EXIT=1
.I=2
SEARCH ALGPRM,ALGSYS
LIBENT(226,BOOL)
XWD 0,2
XWD $PRO!$B!$SIM,2
XWD $VAR!$I!$FOV,.I
JRST .EXIT(DL) ; RESULT TRANSFERRED AUTOMATICALLY!
LIT
PRGEND
TITLE IR - INTEGER TO REAL CONVERSION ROUTINE
; ON ENTRY:
; THE ARGUMENT IS IN A0
; THE LINK IS IN AX
; ON EXIT, THE RESULT IS IN A0
SEARCH ALGPRM,ALGSYS
%ENTER<7>
SALL
%SUBTTL(ALGLIB,ALGOL LIBRARY)
LABEL(7): IFE PROC-KA10, <
IDIVI A0,400 ; SEPARATE HIGH AND LOW HALVES
JUMPE A0,.+2 ; ONLY 18 BITS?
TLC A0,243000 ; NO - SET UP HIGH HALF EXPONENT
TLC A1,233000 ; SET UP LOW HALF EXPONENT
FADR A0,A1 ; AND ADD BITS TOGETHER>
IFE PROC-KI10, <
FLTR A0,A0>
JRST (AX)
LIT
PRGEND
TITLE ILR - INTEGER TO LONG REAL CONVERSION ROUTINE
; ON ENTRY:
; THE ARGUMENT IS IN A0
; THE LINK IS IN AX
; ON EXIT, THE RESULT IS IN A0,A1
SEARCH ALGPRM,ALGSYS
%ENTER<10>
SALL
%SUBTTL(ALGLIB,ALGOL LIBRARY)
LABEL(10): IDIVI A0,400 ; SEPARATE HIGH AND LOW HALVES
JUMPE A0,.+2 ; ONLY 18 BITS?
TLC A0,243000 ; NO - SET UP HIGH HALF EXPONENT
TLC A1,233000 ; SET UP LOW HALF EXPONENT
FADL A0,A1 ; AND ADD BITS TOGETHER
IFE PROC-KI10, <
TLZ A1,777000 ; IF KI10, WIPE OUT LOW WORD EXPONENT
LSH A1,10 ; AND SHIFT UP MANTISSA>
JRST (AX)
LIT
PRGEND
TITLE ENTIER/RI - ENTIER/REAL TO INTEGER CONVERSION ROUTINE
; ON ENTRY:
; THE ARGUMENT IS IN A0
; THE LINK IS IN AX
; ON EXIT, THE RESULT IS IN A0
SEARCH ALGPRM,ALGSYS
SALL
%ENTER<12>
%SUBTTL(ALGLIB,ALGOL LIBRARY)
STDENT(11,ENTIER)
ENT1: MULI A0,400 ; ENTIER - SEPARATE EXPONENT AND MANTISSA
EXCH A0,A1
TSC A1,A1 ; FIX UP EXPONENT
ASH A0,-243(A1) ; AND SHIFT MANTISSA TO FORM INTEGER
JRST (AX)
IFE PROC-KA10, <
LABEL(12):FAD A0,[EXP 0.5] ; [E005] UNROUNDED ADD
JRST ENT1>
IFE PROC-KI10, <
LABEL(12):FIXR A0,A0 ; RI - CONVERT TO NEAREST INTEGER
JRST (AX)>
LIT
PRGEND
TITLE RLR - REAL TO LONG REAL CONVERSION ROUTINE
; ON ENTRY:
; THE ARGUMENT IS IN A0
; THE LINK IS IN AX
; ON EXIT, THE RESULT IS IN A0,A1
SEARCH ALGPRM,ALGSYS
%ENTER<13>
SALL
%SUBTTL(ALGLIB,ALGOL LIBRARY)
LABEL(13): MOVEI A1,0 ; ZERO LOW ORDER WORD
JRST (AX)
LIT
PRGEND
TITLE ENTIEL/LRI - ENTIEL/LONG REAL TO INTEGER CONVERSION ROUTINE
; ON ENTRY:
; THE ARGUMENT IS IN A0,A1
; THE LINK IS IN AX
; ON EXIT, THE RESULT IS IN A0
SEARCH ALGPRM,ALGSYS
%ENTER<15>
SALL
%SUBTTL(ALGLIB,ALGOL LIBRARY)
IFE PROC-KA10, <
LABEL(15): MOVE A2,A1 ; LI - ADD 0.5
FADL A0,[0.5]
UFA A1,A2
FADL A0,A2>
IFE PROC-KI10, <
LABEL(15): DFAD A0,[
EXP 0.5,0.0] ; LI - ADD 0.5>
JRST LRI1
STDENT(14,ENTIER)
LRI1: HLRZ A2,A0 ; ENTIEL
LSH A2,-11
ANDI A2,000377 ; EXTRACT HIGH ORDER EXPONENT
TLZ A0,377000 ; AND CLEAR IT OUT
JUMPGE A0,.+3 ; NUMBER POSITIVE?
TRC A2,000377 ; NO - COMPLEMENT EXTRACTED EXPONENT
TLO A0,377000 ; AND SET ALL ONES
IFE PROC-KA10, <
LSH A1,10 ; IF KA10, SHIFT UP LOW ORDER MANTISSA>
ASHC A0,-233(A2) ; SHIFT MANTISSA TO INTEGER
JRST (AX)
LIT
PRGEND
TITLE LRR - LONG REAL TO REAL CONVERSION ROUTINE
; ON ENTRY:
; THE ARGUMENT IS IN A0,A1
; THE LINK IS IN AX
; ON EXIT, THE RESULT IS IN A0
SEARCH ALGPRM,ALGSYS
%ENTER<16>
SALL
%SUBTTL(ALGLIB,ALGOL LIBRARY)
MLON
LABEL(16): IFE PROC-KA10, <
FADR A0,A1 ; ADD HIGH AND LOW PARTS
JRST (AX)>
IFE PROC-KI10, <
JUMPGE A0,.+3 ; ARGUMENT POSITIVE?
DMOVN A0,A0 ; NO - NEGATE IT
TLZA A1,400000 ; AND CLEAR BIT 0 FLAG
TLO A1,400000 ; YES - SET BIT 0 FLAG
TLNN A1,200000 ; ROUNDING REQUIRED?
JRST LR1 ; NO
CAMN A0,[
XWD 377777,777777] ; NUMBER TOO LARGE?
SYSER2 2,0 ; YES - REPORT OVERFLOW
ADDI A0,1 ; NO
TLO A0,400 ; CARRY
LR1: JUMPL A1,(AX) ; EXIT IF POSITIVE
MOVN A0,A0 ; OTHEWISE NEGATE
JRST (AX)>
LIT
PRGEND
TITLE DSINE - DUMMY BODY FOR SINE
; REAL PROCEDURE SIN(X); VALUE X; REAL X;
.EXIT=1
.X=3
SEARCH ALGPRM,ALGSYS
%ENTER<200>
SALL
EXTERNAL %ALGDR
%SUBTTL(ALGLIB,ALGOL LIBRARY)
EXTLAB<100>
LABEL(200): JSP AX,PARAM
Z
XWD 0,3
XWD $PRO!$R!$SIM,2
XWD $VAR!$R!$FOV,.X
MOVE A0,.X(DL) ; GET ARGUMENT
PUSHJ SP,LABEL(100) ; CALL SINE
MOVEM A0,.EXIT+1(DL) ; STORE RESULT
JRST .EXIT(DL)
LIT
PRGEND
TITLE DCOSINE - DUMMY BODY FOR COSINE
; REAL PROCEDURE COS(X); VALUE X; REAL X;
.EXIT=1
.X=3
SEARCH ALGPRM,ALGSYS
%ENTER<201>
SALL
EXTERNAL %ALGDR
%SUBTTL(ALGLIB,ALGOL LIBRARY)
EXTLAB<101>
LABEL(201): JSP AX,PARAM
Z
XWD 0,3
XWD $PRO!$R!$SIM,2
XWD $VAR!$R!$FOV,.X
MOVE A0,.X(DL) ; GET ARGUMENT
PUSHJ SP,LABEL(101) ; CALL COSINE
MOVEM A0,.EXIT+1(DL) ; STORE RESULT
JRST .EXIT(DL)
LIT
PRGEND
TITLE SINE/COSINE - SINGLE PRECISION SINE/COSINE ROUTINES
; TRANSCRIBED FROM LIB40 V.22/EY/KK
; METHOD: TAYLOR SERIES WITH FIVE TERMS
; ON ENTRY:
; THE ARGUMENT (X) IS IN A0
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A0
SEARCH ALGPRM,ALGSYS
STDENT(101,COSINE)
MOVE A1,A0 ; COSINE
FADR A1,SIN4 ; ADD PI/2
MOVM A1,A1 ; AND TAKE MAGNITUDE
CAMGE A1,SIN6 ; VERY SMALL?
MOVN A0,A0 ; YES - CALCULATE COS(-X)
FADR A0,SIN4
MOVM A1,A0
JRST COS2
STDENT(100,SINE)
FADRI A0,0 ; ENSURE NORMALISED
MOVM A1,A0 ; SINE - GET MAGNITUDE OF X
CAMGE A1,SIN6 ; VERY SMALL?
POPJ SP,0 ; YES - QUICK EXIT: SIN(X) = X
COS2: FMPR A1,[
XWD 200505,746034] ; Y = ABS(X)/(PI/2)
CAMGE A1,[
XWD 201400,000000] ; Y < 1.0?
JRST SIN1 ; YES
MULI A1,400 ; NO - SEPARATE EXPONENT AND MANTISSA
LSH A2,-202(A1)
TLZ A2,400000 ; SHIFT OUT INTEGER PART OF NUMBER
MOVEI A1,200 ; PREPARE NEW EXPONENT
ROT A2,3 ; SAVE QUADRANT BITS
LSHC A1,33 ; AND BRING INTO RANGE (0,1)
FADRI A1,000000 ; NORMALIZE
JUMPE A2,SIN1 ; OK IF IN FIRST QUADRANT
TLCE A2,001000 ; SECOND OR FOURTH QUADRANT
FSBRI A1,201400 ; YES - SUBTRACT 1.0
TLCE A2,003000 ; SECOND QUADRANT
TLNN A2,003000 ; OR THIRD QUADRANT?
MOVN A1,A1 ; YES - NEGATE
SIN1: JUMPGE A0,SIN2 ; X < 0?
MOVN A1,A1 ; YES - NEGATE Y
SIN2: MOVE A2,A1 ; SAVE Y
FMPR A1,A1 ; AND FORM Y^2
MOVEI A3,3
MOVE A0,SIN5
SIN3: FMPR A0,A1
FADR A0,SIN4(A3)
SOJGE A3,SIN3
FMPR A0,A2 ; FORM POLYNOMIAL IN Y
POPJ SP,0
SIN4: XWD 201622,077325 ; PI/2
XWD 577265,210372 ; -(PI/2)^3/3!
XWD 175506,321276 ; (PI/2)^5/5!
XWD 606315,546346 ; -(PI/2)^7/7!
SIN5: XWD 164475,536722 ; (PI/2)^9/9!
SIN6: XWD 162400,000000 ; 2&-15
LIT
PRGEND
TITLE DARCSIN - DUMMY BODY FOR ARCSINE
; REAL PROCEDURE ARCSIN(X); VALUE X; REAL X;
.EXIT=1
.X=3
SEARCH ALGPRM,ALGSYS
%ENTER<207>
SALL
EXTERNAL %ALGDR
%SUBTTL(ALGLIB,ALGOL LIBRARY)
EXTLAB<107>
LABEL(207): JSP AX,PARAM
Z
XWD 0,3
XWD $PRO!$R!$SIM,2
XWD $VAR!$R!$FOV,.X
MOVE A0,.X(DL) ; GET ARGUMENT
PUSHJ SP,LABEL(107) ; CALL ARCSINE
MOVEM A0,.EXIT+1(DL) ; STORE RESULT
JRST .EXIT(DL)
LIT
PRGEND
TITLE ARCSIN - SINGLE PRECISION INVERSE SINE ROUTINE
; REWRITE OF LIB40 V.27/EY/KK/DMN
; METHOD:
;
; IF X < -1.0 OR X > 1.0 AN ERROR RESULTS
;
; IF -1 <= X <= 1, ARCSIN(X) = ARCTAN(X/SQRT(1 - X^2))
; ON ENTRY:
; THE ARGUMENT (X) IS IN A0
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A0
SEARCH ALGPRM,ALGSYS
EXTLAB<102,103>
STDENT(107,ARCSIN)
MOVM A1,A0 ; MAGNITUDE OF ARGUMENT
CAML A1,[
XWD 201400,000000] ; STRICTLY IN RANGE?
JRST ARCS1 ; NO
MOVE A4,A0 ; TAKE SAFE COPY OF X
MOVN A1,A0
FMPR A0,A1
FADRI A0,201400 ; FORM 1 - X^2
PUSHJ SP,LABEL(103) ; AND TAKE SQRT
FDVRM A4,A0 ; FORM X/SQRT(1 - X^2)
JRST LABEL(102) ; AND LET ARCTAN FINISH OFF
ARCS1: CAME A1,[
XWD 201400,000000] ; X = -1.0 OR 1.0?
LIBERR 3,@(SP) ; NO
FMPR A0,[
XWD 201622,077325] ; YES - RETURN -PI/2 OR PI/2
POPJ SP,0
LIT
PRGEND
TITLE DARCCOS - DUMMY BODY FOR ARCCOS
; REAL PROCEDURE ARCCOS(X); VALUE X; REAL X;
.EXIT=1
.X=3
SEARCH ALGPRM,ALGSYS
%ENTER<210>
SALL
EXTERNAL %ALGDR
%SUBTTL(ALGLIB,ALGOL LIBRARY)
EXTLAB<110>
LABEL(210): JSP AX,PARAM
Z
XWD 0,3
XWD $PRO!$R!$SIM,2
XWD $VAR!$R!$FOV,.X
MOVE A0,.X(DL) ; GET ARGUMENT
PUSHJ SP,LABEL(110) ; CALL ARCCOS
MOVEM A0,.EXIT+1(DL) ; STORE RESULT
JRST .EXIT(DL)
LIT
PRGEND
TITLE ARCCOS - SINGLE PRECISION INVERSE COSINE ROUTINE
; REWRITE OF LIB40 V.27/KK/DMN
; METHOD:
;
; IF X < -1.0 OR X > 1.0 AN ERROR RESULTS
; IF X = -1.0, ARCCOS(X) = PI
; IF -1.0 < X < 0, ARCCOS(X) = PI + ARCTAN(SQRT(1 - X^2)/X)
; IF X = 0, ARCCOS(X) = PI/2
; IF 0 < X < 1.0, ARCCOS(X) = ARCTAN(SQRT(1 - X^2)/X)
; IF X = 1.0, ARCCOS(X) = 0
; ON ENTRY:
; THE ARGUMENT (X) IS IN A0
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A0
SEARCH ALGPRM,ALGSYS
EXTLAB<102,103>
STDENT(110,ARCCOS)
MOVM A1,A0 ; MAGNITUDE OF ARGUMENT
CAML A1,[
XWD 201400,000000] ; STRICTLY IN RANGE?
JRST ARCC1 ; NO
JUMPE A0,ARCC2 ; SPECIAL CASE X = 0?
MOVE A4,A0 ; SAFE COPY OF ARGUMENT
MOVN A1,A0
FMPR A0,A1
FADRI A0,201400 ; FORM 1 - X^2
PUSHJ SP,LABEL(103) ; AND TAKE SQRT
FDVR A0,A4 ; AND DIVIDE BY X
JUMPG A4,LABEL(102) ; LET ARCTAN PROCEDE IF X > 0
PUSHJ SP,LABEL(102) ; OTHERWISE CALL ARCTAN
FADR A0,[
XWD 202622,077325] ; AND ADD PI
POPJ SP,0
ARCC1: CAME A1,[
XWD 201400,000000] ; X = -1.0 OR 1.0
LIBERR 3,@(SP) ; NO - COMPLAIN
JUMPL A0,.+2 ; X = 1.0?
TDZA A0,A0 ; YES - RESULT IS 0
MOVE A0,[
202622,,077325] ; NO - RESULT IS PI.
POPJ SP,0
ARCC2: MOVE A0,[
XWD 201622,077325] ; X = 0, RESULT IS PI/2
POPJ SP,0
LIT
PRGEND
TITLE DARCTAN - DUMMY BODY FOR ARCTAN
; REAL PROCEDURE ARCTAN(X); VALUE X; REAL X;
.EXIT=1
.X=3
SEARCH ALGPRM,ALGSYS
%ENTER<202>
SALL
EXTERNAL %ALGDR
%SUBTTL(ALGLIB,ALGOL LIBRARY)
EXTLAB<102>
LABEL(202): JSP AX,PARAM
Z
XWD 0,3
XWD $PRO!$R!$SIM,2
XWD $VAR!$R!$FOV,.X
MOVE A0,.X(DL) ; GET ARGUMENT
PUSHJ SP,LABEL(102) ; CALL ARCTAN
MOVEM A0,.EXIT+1(DL) ; STORE RESULT
JRST .EXIT(DL)
LIT
PRGEND
TITLE ARCTAN - SINGLE PRECISION INVERSE TANGENT ROUTINE
; TRANSCRIBED FROM LIB40 V.22/EY/KK
; METHOD:
;
; IF X < 0, ARCTAN(X) = -ARCTAN(-X)
;
; IF 0 <= X < 2^(-27), ARCTAN(X) = X
;
; IF 2^(-27) <= X <= 1.0:
;
; ARCTAN(X) = X*(B0 + A1/(X^2 + B1 + A2/(X^2 + B2 + A3/(X^2 + B3))))
;
; IF 1.0 < X < 2^27, ARCTAN(X) = PI/2 - ARCTAN(1/X)
;
; IF X >= 2^27, ARCTAN(X) = PI/2
; ON ENTRY:
; THE ARGUMENT IS IN A0
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A0
SEARCH ALGPRM,ALGSYS
STDENT(102,ARCTAN)
MOVM A1,A0 ; GET ABS(X)
CAMGE A1,[
XWD 145400,000000] ; ABS(X) < 2^(-27)?
JRST ARCT3 ; YES - ARCTAN(X) = X
CAMGE A1,[
XWD 233400,000000] ; ABS(X) >= 2^27?
JRST ARCT1 ; NO
JUMPL A0,.+2 ; YES: X < 0?
SKIPA A1,ARCT4 ; NO - RESULT IS PI/2
MOVN A1,ARCT4 ; YES - RESULT IS -PI/2
MOVE A0,A1
POPJ SP,0
ARCT1: HRRI A0,0 ; CLEAR RANGE FLAG
MOVSI A2,201400
CAMG A1,A2 ; ABS(X) > 1.0?
JRST ARCT2 ; NO
FDVRM A2,A1 ; YES - FORM 1/ABS(X)
SETCA A0,0 ; SET RANGE FLAG AND INVERT SIGN
ARCT2: MOVE A2,A1
FMPR A2,A2 ; FORM X^2
MOVE A3,ARCT8
FADR A3,A2 ; X^2 + B3
MOVE A4,ARCT11
FDVR A4,A3
FADR A4,ARCT7
FADR A4,A2 ; X^2 + B2 + A3/(X^2 + B3)
MOVE A3,ARCT10
FDVR A3,A4
FADR A3,ARCT6
FADR A3,A2 ; X^2 + B1 + A2/(X^2 + B2 + A3/(X^2 + B3))
MOVE A4,ARCT9
FDVR A4,A3
FADR A4,ARCT5 ; B0 + A1/(X^2 + B1 + A2/(X^2 + B2 + A3/(X^2 + B3)))
FMPR A1,A4 ; MULTIPLY BY ABS(X) TO GIVE ARCTAN(X)
TRNE A0,-1 ; RANGE FLAG SET?
FSBR A1,ARCT4 ; YES - SUBTRACT PI/2
EXCH A0,A1 ; LOAD UP RESULT
JUMPGE A1,ARCT3 ; SHOULD IT BE NEGATIVE?
MOVN A0,A0 ; YES- NEGATE IT
ARCT3: POPJ SP,0
ARCT4: XWD 201622,077325 ; PI/2
ARCT5: XWD 176545,543401 ; B0
ARCT6: XWD 203660,615617 ; B1
ARCT7: XWD 202650,373270 ; B2
ARCT8: XWD 201562,663021 ; B3
ARCT9: XWD 202732,621643 ; A1
ARCT10: XWD 574071,125540 ; A2
ARCT11: XWD 600360,700773 ; A3
LIT
PRGEND
TITLE DSQRT - DUMMY BODY FOR SQRT
; REAL PROCEDURE SQRT(X); VALUE X; REAL X;
.EXIT=1
.X=3
SEARCH ALGPRM,ALGSYS
%ENTER<203>
SALL
EXTERNAL %ALGDR
%SUBTTL(ALGLIB,ALGOL LIBRARY)
EXTLAB<103>
LABEL(203): JSP AX,PARAM
Z
XWD 0,3
XWD $PRO!$R!$SIM,2
XWD $VAR!$R!$FOV,.X
MOVE A0,.X(DL) ; GET ARGUMENT
PUSHJ SP,LABEL(103) ; CALL SQRT
MOVEM A0,.EXIT+1(DL) ; STORE RESULT
JRST .EXIT(DL)
LIT
PRGEND
TITLE SQRT - SINGLE PRECISION SQUARE ROOT ROUTINE
; TRANSCRIBED FROM LIB40 V.27I/TL/TWE
; METHOD: LINEAR APPROXIMATION WITH TWO NEWTON-RAPHESON ITERATIONS
; ON ENTRY:
; THE ARGUMENT (X) IS IN A0
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A0
SEARCH ALGPRM,ALGSYS
STDENT(103,SQRT)
JUMPGE A0,SQRT1 ; ENSURE POSITIVE ARGUMENT
LIBERR 0,@(SP) ; NO - COMPLAIN
SQRT1: JUMPE A0,SQRT4 ; QUICK EXIT FOR ZERO ARGUMENT
MOVEI A1,0
ROTC A0,11 ; GET EXPONENT IN A1
LSH A0,-11 ; AND CLEAR IT OUT OF ARGUMENT
SUBI A1,201 ; TRUE EXPONENT - 1
ROT A1,-1 ; HALVE AND SAVE ODD/EVEN BIT IN A1
JUMPL A1,SQRT2 ; 0.25 <= FRACTION < 0.5?
TLO A0,177000 ; YES - FIX UP EXPONENT TO FORM Y
MOVE A2,A0
FMPRI A2,200640 ; R1 = LINEAR APPROXIMATION TO SQRT(Y)
FADRI A2,177465 ; = (832*Y + 309)/1024
JRST SQRT3
SQRT2: TLO A0,200000 ; NO - FIX UP EXPONENT TO FORM Y
MOVE A2,A0
FMPRI A2,200450 ; R1 = LINEAR APPROXIMATION TO SQRT(Y)
FADRI A2,177660 ; = (37*Y + 27)/64
SQRT3: MOVE A3,A0
FDVR A3,A2
FADR A3,A2 ; FIRST NEWTON-RAPHESON ITERATION:
FSC A3,-1 ; R2 = (Y/R1 + R1)/2
FDVR A0,A3 ; SECOND NEWTON-RAPHESON ITERATION:
FADR A0,A3 ; R3 = (Y/R2 + R2)/2
FSC A0,(A1) ; SCALE BACK TO SIZE (INCLUDES HALVING TO R3)
SQRT4: POPJ SP,0
LIT
PRGEND
TITLE DLN - DUMMY BODY FOR LN
; REAL PROCEDURE LN(X); VALUE X; REAL X;
.EXIT=1
.X=3
SEARCH ALGPRM,ALGSYS
%ENTER<205>
SALL
EXTERNAL %ALGDR
%SUBTTL(ALGLIB,ALGOL LIBRARY)
EXTLAB<105>
LABEL(205): JSP AX,PARAM
Z
XWD 0,3
XWD $PRO!$R!$SIM,2
XWD $VAR!$R!$FOV,.X
MOVE A0,.X(DL) ; GET ARGUMENT
PUSHJ SP,LABEL(105) ; CALL LN
MOVEM A0,.EXIT+1(DL) ; STORE RESULT
JRST .EXIT(DL)
LIT
PRGEND
TITLE LN - SINGLE PRECISION LOGARITHM ROUTINE
; REWRITE OF LIB40 V.22/KK/DMN
; METHOD:
;
; X = F*2^I, WHERE 0.5 <= F < 1
;
; LN(X) = LN(2)*(I + LOG2(F))
;
; LOG2(F) = C1*Z + C3*Z^3 + C5*Z^5 - 0.5
;
; WHERE Z = (F - SQRT(0.5))/(F + SQRT(0.5))
; ON ENTRY:
; THE ARGUMENT (X) IS IN A0
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A0
SEARCH ALGPRM,ALGSYS
STDENT(105,LN)
JUMPG A0,.+2 ; ARGUMENT POSITIVE?
LIBERR 1,@(SP) ; NO - COMPLAIN
CAMN A0,[
XWD 201400,000000] ; X = 1.0?
JRST LN1 ; YES - QUICK EXIT
ASHC A0,-33 ; SEPARATE EXPONENT AND MANTISSA
HRLI A0,233000
FSBRI A0,210401 ; FORM I - 0.5, FLOATING POINT
ASH A1,-10
TLO A1,200000 ; FIX UP F
MOVE A2,A1
FSBR A1,LN2
FADR A2,LN2
FDVRB A1,A2 ; Z = (F - SQRT(0.5))/(F + SQRT(0.5))
FMPR A1,A1 ; FORM Z^2
MOVE A3,LN5
FMPR A3,A1
FADR A3,LN4
FMPR A3,A1
FADR A3,LN3
FMPR A2,A3 ; C1*Z + C3*Z^3 + C5*Z^5
FADR A0,A2 ; ADD I - 0.5
FMPR A0,[
XWD 200542,710300] ; AND MULTIPLY BY LN(2)
POPJ SP,0
LN1: MOVEI A0,0
POPJ SP,0
LN2: XWD 200552,023632 ; SQRT(0.5)
LN3: XWD 202561,251002 ; C1
LN4: XWD 200754,213604 ; C3
LN5: XWD 200462,432521 ; C5
LIT
PRGEND
TITLE DTAN - DUMMY BODY FOR TAN
; REAL PROCEDURE TAN(X); VALUE X; REAL X;
.EXIT=1
.X=3
SEARCH ALGPRM,ALGSYS
%ENTER<206>
SALL
EXTERNAL %ALGDR
%SUBTTL(ALGLIB,ALGOL LIBRARY)
EXTLAB<106>
LABEL(206): JSP AX,PARAM
Z
XWD 0,3
XWD $PRO!$R!$SIM,2
XWD $VAR!$R!$FOV,.X
MOVE A0,.X(DL) ; GET ARGUMENT
PUSHJ SP,LABEL(106) ; CALL TAN
MOVEM A0,.EXIT+1(DL) ; STORE RESULT
JRST .EXIT(DL)
LIT
PRGEND
TITLE TAN - SINGLE PRECISION TANGENT ROUTINE
; REWRITE OF ATLAS EXTRACODE 1735
; METHOD:
;
; X = (N+Y)*PI/2, WHERE N IS AN INTEGER, AND -0.5 <= Y < 0.5
;
; IF N IS EVEN, TAN(X) = P(Y)/(1 - Y^2)
;
; IF N IS ODD, TAN(X) = -(1 - Y^2)/P(Y)
;
; WHERE P(Y) IS AN ODD POLYNOMIAL IN Y
; ON ENTRY:
; THE ARGUMENT (X) IS IN A0
; THE LINK IS ON THE STACK
; ON EXIT, THE REULT IS IN A0
SEARCH ALGPRM,ALGSYS
STDENT(106,TAN)
JUMPE A0,TAN4 ; QUICK EXIT FOR ZERO
FMPR A0,[
XWD 200505,746034] ; MULTIPLY BY 2/PI
MOVM A2,A0 ; ABS(X)/(PI/2)
MOVEI A1,1 ; SET FLAG FOR EVEN N
CAMGE A2,[
XWD 200400,000000] ; LESS THAN 0.5?
JRST TAN1 ; YES - TAKE SHORT CUT
FSBRI A2,200400 ; NO - SUBTRACT 0.5
MULI A2,400 ; SEPARATE EXPONENT AND MANTISSA
EXCH A2,A3 ; THINGS ARE NOW THE WRONG WAY ROUND
MOVEI A1,0
CAIL A3,233 ; WILL SHIFT CAUSE LOSS OF MANTISSA?
TDZA A2,A2 ; YES - SAVE A LOT OF WORK
ASHC A1,-200(A3) ; SHIFT OUT INTEGER PART
ANDI A1,1 ; SET ODD/EVEN FLAG FOR N
LSH A2,-10
TLO A2,200000 ; AND FIX UP NEW EXPONENT
FSBRI A2,200400 ; SUBTRACT 0.5 TO GET Y
TAN1: MOVE A3,A2 ; SAVE Y
FMPR A2,A2 ; SAVE Y^2
MOVEI A5,3
MOVE A4,TAN7
TAN2: FMPR A4,A2
FADR A4,TAN6(A5)
SOJGE A5,TAN2
FMPR A4,A3 ; FORM -P(Y)
MOVN A2,A2
FADRI A2,201400 ; FORM 1 - Y^2
JUMPN A1,TAN3 ; N ODD?
EXCH A4,A2 ; YES - EXCHANGE OPERANDS
MOVN A0,A0 ; AND INVERT ARGUMENT SIGN
TAN3: FDVR A4,A2 ; FORM FINAL RESULT
JFOV TAN5 ; OVERFLOW IS FATAL
EXCH A0,A4 ; LOAD UP RESULT
JUMPGE A4,TAN4 ; SHOULD IT BE NEGATIVE?
MOVN A0,A0 ; YES - NEGATE IT
TAN4: POPJ SP,0
TAN5: LIBERR 4,@(SP)
TAN6: XWD 201622,077325 ; PI/2
XWD 600342,340621 ; PI/2*((PI/2)^2/3 - 1)
XWD 604353,774024 ; (PI/2)^3*((PI/2)^2*2/15 - 1/3)
XWD 610120,631722 ; (PI/2)^5*((PI/2)^2*17/315 - 2/15)
TAN7: XWD 613217,113617 ; (PI/2)^7*((PI/2)^2*62/2835 - 17/315)
LIT
PRGEND
TITLE DSINH - DUMMY BODY FOR SINH
; REAL PROCEDURE SINH(X); VALUE X; REAL X;
.EXIT=1
.X=3
SEARCH ALGPRM,ALGSYS
%ENTER<211>
SALL
EXTERNAL %ALGDR
%SUBTTL(ALGLIB,ALGOL ALIAS)
EXTLAB<111>
LABEL(211): JSP AX,PARAM
Z
XWD 0,3
XWD $PRO!$R!$SIM,2
XWD $VAR!$R!$FOV,.X
MOVE A0,.X(DL) ; GET ARGUMENT
PUSHJ SP,LABEL(111) ; CALL SINH
MOVEM A0,.EXIT+1(DL) ; STORE RESULT
JRST .EXIT(DL)
LIT
PRGEND
TITLE SINH - SINGLE PRECISION SINH ROUTINE
; TRANSCRIBED FROM LIB40 V.27/KK/DMN
; METHOD:
;
; IF ABS(X) < 0.1, SINH(X) = X + X^3/6 + X^5/120
;
; IF 0.1 <= ABS(X) < 88.029, SINH(X) = (EXP(X) - EXP(-X))/2
;
; IF ABS(X) >= 88.029, SINH(X) = SIGN(X)*EXP(ABS(X) - LN(2))
;
; EXP(-X) IS 1/EXP(X)
; ON ENTRY:
; THE ARGUMENT (X) IS IN A0
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A0
SEARCH ALGPRM,ALGSYS
EXTLAB<104>
STDENT(111,SINH)
MOVM A1,A0 ; SAVE ABS(X)
CAML A1,[
XWD 175631,463146] ; < 0.1?
JRST SINH1 ; NO
FMPR A1,A1 ; YES - FORM X^2
MOVE A2,A1 ; AND SAVE IT
FDVRI A1,207740
FADR A1,[
XWD 176525,252525]
FMPR A1,A2
FADRI A1,201400
FMPR A0,A1 ; FORM X + X^3/6 + X^5/120
POPJ SP,0
SINH1: CAML A1,[
XWD 207540,074636] ; < 88.029?
JRST SINH2 ; NO
PUSHJ SP,LABEL(104) ; YES - CALCULATE EXP(X)
MOVSI A1,576400
FDVR A1,A0 ; CALCULATE -EXP(-X)
FADR A0,A1
FSC A0,-1 ; FORM SINH(X)
POPJ SP,0
SINH2: PUSH SP,A0 ; SAVE X
MOVE A0,A1
FSBR A0,[
XWD 200542,710300] ; FORM ABS(X) - LN(2)
PUSHJ SP,LABEL(104) ; AND CALL EXP
POP SP,A1 ; RESTORE X
JUMPGE A1,SINH3 ; POSITIVE?
MOVN A0,A0 ; NO - NEGATE RESULT
SINH3: POPJ SP,0
LIT
PRGEND
TITLE DCOSH - DUMMY BODY FOR COSH
; REAL PROCEDURE COSH(X); VALUE X; REAL X;
.EXIT=1
.X=3
SEARCH ALGPRM,ALGSYS
%ENTER<212>
SALL
EXTERNAL %ALGDR
%SUBTTL(ALGLIB,ALGOL LIBRARY)
EXTLAB<112>
LABEL(212): JSP AX,PARAM
Z
XWD 0,3
XWD $PRO!$R!$SIM,2
XWD $VAR!$R!$FOV,.X
MOVE A0,.X(DL) ; GET ARGUMENT
PUSHJ SP,LABEL(112) ; CALL COSH
MOVEM A0,.EXIT+1(DL) ; STORE RESULT
JRST .EXIT(DL)
LIT
PRGEND
TITLE COSH - SINGLE PRECISION COSH ROUTINE
; TRANSCRIBED FROM LIB40 V27/EY/KK/DMN
; METHOD:
;
; IF ABS(X) < 88.029, COSH(X) = (EXP(X) + EXP(-X))/2
;
; IF 88.029 <= ABS(X) < 88.029 + LN(2), COSH(X) = EXP(ABS(X) + LN(2))
;
; EXP(-X) IS 1/EXP(X)
; ON ENTRY:
; THE ARGUMENT (X) IS IN A0
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A0
SEARCH ALGPRM,ALGSYS
EXTLAB<104>
STDENT(112,COSH)
MOVM A0,A0 ; FORM ABS(X)
CAML A0,COSH2 ; < 88.029?
JRST COSH1 ; NO
PUSHJ SP,LABEL(104) ; YES - CALCULATE EXP(X)
MOVSI A1,201400
FDVR A1,A0 ; CALCULATE EXP(-X)
FADR A0,A1
FSC A0,-1 ; FORM COSH(X)
POPJ SP,0
COSH1: FSBR A0,[
XWD 200542,710300]
CAML A0,COSH2 ; < 88.029 + LN(2)?
LIBERR 4,@(SP) ; NO - COMPLAIN
JRST LABEL(104) ; YES - LET EXP DO THE WORK
COSH2: XWD 207540,074635 ; 88.029
LIT
PRGEND
TITLE DTANH - DUMMY BODY FOR TANH
; REAL PROCEDURE TANH(X); VALUE X; REAL X;
.EXIT=1
.X=3
SEARCH ALGPRM,ALGSYS
%ENTER<213>
SALL
EXTERNAL %ALGDR
%SUBTTL(ALGLIB,ALGOL LIBRARY)
EXTLAB<113>
LABEL(213): JSP AX,PARAM
Z
XWD 0,3
XWD $PRO!$R!$SIM,2
XWD $VAR!$R!$FOV,.X
MOVE A0,.X(DL) ; GET ARGUMENT
PUSHJ SP,LABEL(113) ; CALL TANH
MOVEM A0,.EXIT+1(DL) ; STORE RESULT
JRST .EXIT(DL)
LIT
PRGEND
TITLE TANH - SINGLE PRECISION TANH ROUTINE
; TRANSCRIBED FROM LIB40 V.21/EY/KK
; METHOD:
;
; IF ABS(X) < 0.00034, TANH(X) = X
;
; IF 0.00034 <= ABS(X) < 0.17, TANH(X) = F/(K1 + F^2*(K2 + K3
;
; /(K4 + F^2)))
;
; WHERE F = 4*LOG2(E)*X
;
; IF 0.17 <= ABS(X) < 12.0, TANH(X) = (1 - 2/(1 + EXP(2*X))*SIGN(X)
;
; IF X >= 12.0, TANH(X) = SIGN(X)
; ON ENTRY:
; THE ARGUMENT (X) IS IN A0
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A0
SEARCH ALGPRM,ALGSYS
EXTLAB<104>
STDENT(113,TANH)
MOVM A5,A0 ; MAGNITUDE OF ARGUMENT
CAMGE A5,[
XWD 165544,410070] ; < 0.00034?
JRST TANH1 ; YES - TANH(X) = X
CAML A5,[
XWD 204600,000000] ; ABS(X) >= 12.0?
JRST TANH3 ; YES - TANH(X) = SIGN(X)
CAMGE A5,[
XWD 176534,121727] ; ABS(X) >= 0.17?
JRST TANH2 ; NO
FSC A0,1
PUSHJ SP,LABEL(104) ; CALCULATE EXP(2*X)
FADRI A0,201400
MOVSI A1,575400
FDVRM A1,A0
FADRI A0,201400 ; 1 - 2/(1 + EXP(2*ABS(X)))
TANH1: POPJ SP,0
TANH2: FMPR A0,TANH4 ; F = 4*LOG2(E)*X
MOVE A1,A0
FMPR A1,A1
MOVE A2,A1 ; FORM AND TAKE COPY OF F^2
FADR A1,TANH7 ; ADD K4
MOVE A5,TANH6
FDVR A5,A1 ; K3/(K4 + F^2)
FADR A5,TANH5 ; + K2
FMPR A5,A2 ; *F^2
FADR A5,TANH4 ; + K1
TANH3: FDVR A0,A5
POPJ SP,0
TANH4: XWD 203561,250731 ; K1 = 4*LOG2(E)
TANH5: XWD 173433,723376 ; K2 = 1.73286795&-1
TANH6: XWD 204704,333567 ; K3 = 1.41384514
TANH7: XWD 211535,527022 ; K4 = 3.49669988&2
LIT
PRGEND
TITLE DEXP - DUMMY BODY FOR EXP
; REAL PROCEDURE EXP(X); VALUE X; REAL X;
.EXIT=1
.X=3
SEARCH ALGPRM,ALGSYS
%ENTER<204>
SALL
EXTERNAL %ALGDR
%SUBTTL(ALGLIB,ALGOL LIBRARY)
EXTLAB<104>
LABEL(204): JSP AX,PARAM
Z
XWD 0,3
XWD $PRO!$R!$SIM,2
XWD $VAR!$R!$FOV,.X
MOVE A0,.X(DL) ; GET ARGUMENT
PUSHJ SP,LABEL(104) ; CALL EXP
MOVEM A0,.EXIT+1(DL) ; STORE RESULT
JRST .EXIT(DL)
LIT
PRGEND
TITLE EXP - SINGLE PRECISION EXPONENTIATION ROUTINE
; REWRITE OF LIB40 V.21/EY/KK/DMN
; METHOD:
;
; IF X < -89.416, EXP(X) = 0
;
; IF -89.416 <= X < 88.029:
;
; X = (N+Y)*LN(2), WHERE N IS AN INTEGER, AND 0 <= Y < 1
;
; EXP(X) = 2^(N+Y) = 2^N*2^Y
;
; WHERE 2^Y = 2*(0.5 + Y/(K1 - Y + K2*Y^2 + K3/(K4 + Y^2))
;
; IS DERIVED FROM THE PADE (4,4) APPROXIMATION
; ON ENTRY:
; THE ARGUMENT (X) IS IN A0
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A0
SEARCH ALGPRM,ALGSYS
STDENT(104,EXP)
CAMGE A0,[
XWD 570232,254037] ; X < -89.416?
JRST EXP1 ; YES - QUICK EXIT
CAML A0,[
XWD 207540,074636] ; X >= 88.029?
LIBERR 2,@(SP) ; YES - COMPLAIN
MULI A0,400 ; SEPARATE EXPONENT FROM MANTISSA
MOVE 3,A0
TSC A3,A3 ; GET POSITIVE EXPONENT
MUL A1,[
XWD 270524,354513] ; MULTIPLY MANTISSA BY LOG2(E)
ASHC A1,-242(A3) ; SEPARATE INTEGER PART
JUMPGE A1,.+2
ADDI A1,1 ; ADJUST IF NEGATIVE FRACTION
JUMPG A2,EXP6
TRNE A2,000377 ; IF NECESSARY ...
ADDI A2,200 ; DO A LITTLE ROUNDING
EXP6: ASH A2,-10
TLC A2,200000 ; FORM Y
FADRI A2,000000 ; NORMALIZE
MOVE A0,A2 ; SAVE A COPY
FMPR A2,A2 ; AND FORM Y^2
MOVE A3,A2
FADR A3,EXP5 ; K4 + Y^2
MOVE A4,EXP4
FDVR A4,A3 ; K3/(K4 + Y^2)
FMPR A2,EXP3
FADR A2,A4
FADR A2,EXP2
FSBR A2,A0 ; K1 - Y + K2*Y^2 + K3/(K4 + Y^2)
FDVR A0,A2
FADRI A0,200400 ; 0.5 + Y/(K1 - Y + K2*Y^2 + K3/(K4 + Y^2))
FSC A0,1(A1) ; MULTIPLY BY 2^(N+1)
POPJ SP,0
EXP1: MOVEI A0,0
POPJ SP,0
EXP2: XWD 204476,430062 ; K1 = 9.95459578
EXP3: XWD 174433,723400 ; K2 = 3.46573590&-2
EXP4: XWD 565313,007063 ; K3 = -6.17972270&2
EXP5: XWD 207535,527022 ; K4 = 8.74174972&1
LIT
PRGEND
TITLE DLSIN - DUMMY BODY FOR LSIN
; LONG REAL PROCEDURE LSIN(D); VALUE D; LONG REAL D;
.EXIT=1
.D=4
SEARCH ALGPRM,ALGSYS
%ENTER<214>
SALL
EXTERNAL %ALGDR
%SUBTTL(ALGLIB,ALGOL LIBRARY)
EXTLAB<114>
LABEL(214): JSP AX,PARAM
Z
XWD 0,5
XWD $PRO!$LR!$SIM,2
XWD $VAR!$LR!$FOV,.D
LRLOAD A0,.D(DL) ; GET ARGUMENT
PUSHJ SP,LABEL(114) ; CALL LSIN
LRSTOR A0,.EXIT+1(DL) ; STORE RESULT
JRST .EXIT(DL)
LIT
PRGEND
TITLE DLCOS - DUMMY BODY FOR LCOS
; LONG REAL PROCEDURE LCOS(D); VALUE D; LONG REAL D;
.EXIT=1
.D=4
SEARCH ALGPRM,ALGSYS
%ENTER<215>
SALL
EXTERNAL %ALGDR
%SUBTTL(ALGLIB,ALGOL LIBRARY)
EXTLAB<115>
LABEL(215): JSP AX,PARAM
Z
XWD 0,5
XWD $PRO!$LR!$SIM,2
XWD $VAR!$LR!$FOV,.D
LRLOAD A0,.D(DL) ; GET ARGUMENT
PUSHJ SP,LABEL(115) ; CALL LCOS
LRSTOR A0,.EXIT+1(DL) ; STORE RESULT
JRST .EXIT(DL)
LIT
PRGEND
TITLE LSIN /LCOS - DOUBLE PRECISION SINE/COSINE ROUTINES
; TRANSCRIBED FROM LIB40 V.022/.020/.005/KK/TWE
; METHOD: SEE SCIENCE LIBRARY AND FORTRAN UTILITY SUBPROGRAMS
; MANUAL
; ON ENTRY:
; THE ARGUMENT (X) IS IN A0,A1
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A0,A1
SEARCH ALGPRM,ALGSYS
STDENT(115,LCOS)
DFAD0 LSIN22 ; COS(X)=SIN(PI/2+X), LEAVE RESULT IN A0
JRST LSIN0
STDENT(114,LSIN)
LSIN0: JUMPE A0,LSIN8 ; ARGUMENT OF ZERO?
SETZB A6,A12 ; SET FLAG FOR POSITIVE ARGUMENT
JUMPGE A0,LSIN1 ; IS ARGUMENT POSITIVE?
MOVNI A12,1 ; NO, CHANGE FLAG
LRNEG A0,A1 ; NEGATE THE ARGUMENT
LSIN1: LRLOAD A7,A0
DFDV0 LSIN22 ; CALCULATE X/(PI/2)
CAML A0,LSIN21 ; X < PI/2?
JRST LSIN10 ; NO, REDUCE IT
CAML A0,[
XWD 200400,000000] ; X >= PI/4
MOVEI A6,1 ; YES, 2ND OCTANT
LSIN2: LRLOAD A0,A7
LSIN3: TRNE A6,4 ; QUADRANTS 3 OR 4?
SETCA A12,0 ; YES, SINE IS NEGATIVE
JUMPE A6,LSIN5 ; X < PI/4
TRNE A6,1 ; NO, GET INDEX INTO QUADRANT TABLE
ADDI A6,1 ; ...
DFAD0 LSIN20-2(A6) ; MAKE -PI/4 <= X < PI/4
JUMPGE A0,LSIN4
LRNEG A0,A1 ; TAKE ABSOLUTE VALUE
LSIN4: LRLOAD A7,A0
LSIN5: TRZ A6,777775 ; LEAVE ONLY OCTANT BIT
HRRZ A11,A6 ; 0 FOR SINE SERIES, 2 FOR COSINE
CAMG A0,[
XWD 147471,421605] ; X < SQRT(6)*2^(-27)?
JRST LSIN9 ; YES, THEN SIN(X)=X
DFMP0 A7 ; CALCULATE X^2
LRLOAD A3,LSIN11(A6) ; INITIALIZE PARTIAL SUM
MOVEI A6,LSIN12(A6) ; TURN OCTANT POINTER INTO TABLE ADDRESS
LSIN6: DFMP3 A0 ; MULTIPLY PARTIAL SUM BY X^2
DFAD3 0(A6) ; ADD NEXT CONSTANT TO PARTIAL SUM
ADDI A6,4 ; MOVE POINTER TO NEXT CONSTANT
CAIG A6,LSIN19 ; DONE?
JRST LSIN6 ; NO, LOOP BACK FOR MORE OF SERIES
DFMP0 A3 ; YES, ONE MORE MULTIPLY
DFAD0 LSIN21 ; ADD 1.0 INTO SUM
JUMPN A11,LSIN7 ; IS THIS COSINE SERIES?
DFMP0 A7 ; NO, MULTIPLY BY X, THIS IS SIN
LSIN7: JUMPE A12,LSIN8 ; NEGATE RESULT?
LRNEG A0,A1 ; YES
LSIN8: POPJ SP,0 ; EXIT
LSIN9: JUMPE A6,LSIN7 ; CALCULATING COSINE?
LRLOAD A0,LSIN21 ; YES, COS(X)=1.0
JRST LSIN7
LSIN10: MOVE A3,A0 ; SAVE QUADRANT NUMBER
LDB A6,[
POINT 8,A0,8] ; GET EXPONENT
IFE PROC-KA10,<
LSH A1,11 ; WIPE OUT LOW EXPONENT>
IFE PROC-KI10, <
LSH A1,1 ; FOR KI10>
TLZ A0,777000 ; DITTO HIGH EXPONENT
LSHC A0,-202(A6) ; MAKE ARGUMENT MODULO 2 PI
LDB A6,[
POINT 3,A0,11] ; GET QUADRANT AND OCTANT BITS
CAMGE A3,[
XWD 203400,000000] ; IS NON-REDUCED ARGUMENT OK?
JRST LSIN2 ; YES, SAVE THE DFMP INACCURACIES
TLZ A0,777000 ; MAKE WAY FOR EXPONENT
IFE PROC-KA10, <
FSC A0,202 ; PUT EXP IN HIGH WORD
LSH A1,-11 ; MAKE WAY FOR LOW EXPONENT
FSC A1,202-^D27 ; PUT IN LOW EXPONENT
FADL A0,A1 ; UNNORMALIZE LOW WORD>
IFE PROC-KI10, <
TLO A0,202000
LSH A1,-1
DFAD A0,[EXP 0,0]>
DFMP0 LSIN22 ; CHANGE MAKE TO RADIANS (MOD 2 PI)
LRLOAD A7,A0 ; TEMPORARY X
JRST LSIN3 ; GO CHANGE ARGUMENT TO 1ST OCTANT
LSIN11: DOUBLE 120625130734,014126512326 ; 1/17!=.28114572543455207632&&-14
DOUBLE 124656376371,314734037043 ; 1/16!=.47794773323873852974&&-13
LSIN12: DOUBLE 647121401406,463043740735 ; -1/15!=-.76471637318198164759&&-12
DOUBLE 643154321325,717701542677 ; -1/14! =-.11470745597729724714&&-10
LSIN13: DOUBLE 140541110604,352066411370 ; 1/13!=.16059043836821614599&&-9
DOUBLE 144436733073,376154227552 ; 1/12!=.20876756987868098979&&-8
LSIN14: DOUBLE 630121467246,402535434340 ; -1/11!=-.25052108385441718775&&-7
DOUBLE 624330066022,441660243433 ; -1/10!=-.27557319223985890653&&-6
LSIN15: DOUBLE 156561674351,125543463437 ; 1/9!=.27557319223985890653&&-5
DOUBLE 161640064006,200320032003 ; 1/8!=.24801587301587301587&&-4
LSIN16: DOUBLE 613137713771,577457745775 ; -1/7!=-.19841269841269841270&&-3
DOUBLE 610223722372,517511751175 ; -1/6!=-.1388888888888888889&&-2
LSIN17: DOUBLE 172421042104,104210421042 ; 1/5!=.00833333333333333333333
DOUBLE 174525252525,125252525253 ; 1/4!=.041666666666666666667
LSIN18: DOUBLE 601252525252,652525252526 ; -1/3!=-0.16666666666666666667
LSIN19: DOUBLE 577400000000,000000000000 ; -1/2!=-0.50000000000000000000
PIOTLO=021026430215 ; LOW HALF OF PI/2 FOR KI10
LSIN20: DOUBLE 576155700452,-PIOTLO ; -PI/2
DOUBLE 575155700452,-PIOTLO ; -PI
574322320340 ; -3*PI/2
IFE PROC-KA10,< 150146336134>
IFE PROC-KI10,< 463157055627>
DOUBLE 574155700452,-PIOTLO ; -2*PI
LSIN21: DOUBLE 201400000000,000000000000 ; 1.0
LSIN22: DOUBLE 201622077325,PIOTLO ; PI/2
LIT
PRGEND
TITLE DLARCTAN - DUMMY BODY FOR LARCTAN
; LONG REAL PROCEDURE LARCTAN(D); VALUE D; LONG REAL D;
.EXIT=1
.D=4
SEARCH ALGPRM,ALGSYS
%ENTER<216>
SALL
EXTERNAL %ALGDR
%SUBTTL(ALGLIB,ALGOL LIBRARY)
EXTLAB<116>
LABEL(216): JSP AX,PARAM
Z
XWD 0,5
XWD $PRO!$LR!$SIM,2
XWD $VAR!$LR!$FOV,.D
LRLOAD A0,.D(DL) ; GET ARGUMENT
PUSHJ SP,LABEL(116) ; CALL LARCTAN
LRSTOR A0,.EXIT+1(DL) ; STORE RESULT
JRST .EXIT(DL)
LIT
PRGEND
TITLE LARCTAN - DOUBLE PRECISION ARCTANGENT ROUTINE
; TRANSCRIBED FROM LIB40 V.022/.020/.005/KK/TWE
; METHOD:
; THIS ROUTINE CALCULATES THE ACTANGENT OF A DOUBLE PRECISION
; ARGUMENT ACCORDING TO THE ALGORITHM
; ARCTAN(X) = LAMBDA*X/(Z+LTN11+LTN12/(Z+LTN13+LTN14/(Z+LTN15+LTN16/(Z+LTN17))))
; FOR X > 1.0, THE IDENTITY
; ARCTAN(X) = PI/2 - ARCTAN(1/X)
; IS USED. FOR 0.5 < X < 1.0, THE IDENTITY
; ARCTAN(X) = ARCTAN(1/2) + ARCTAN(2X-1/X+2)
; IS USED.
; FOR X < SQRT(3)*2^(-27), ARCTAN(X) = X IS USED
; ON ENTRY:
; THE ARGUMENT (X) IS IN A0,A1
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A0,A1
SEARCH ALGPRM,ALGSYS
STDENT(116,LARCTAN)
JUMPE A0,LTN9 ; ARGUMENT = 0?
HLLZ A6,A0 ; LH(A6)=SGN(A0), RH(A6) = 0
JUMPGE A0,LTN1 ; IS THE ARGUMENT POSITIVE?
LRNEG A0,A1 ; NO, NEGATE IT
LTN1: MOVSI A3,201400 ; GET DOUBLE PRECISION 1.0
MOVEI A4,0 ; 0 LOW PART
CAMN A0,A3 ; IS HIGH ORDER EQUAL TO 1.0?
JUMPE A1,LTN2 ; YES, IS LOW ORDER ZERO?
CAMGE A0,A3 ; NO, IS ARGUMENT > 1.0?
JRST LTN2 ; NO
TLC A6,400000 ; COMPLEMENT FINAL SIGN BIT, GET 1/X
IORI A6,2 ; ADD -PI/2 TO FINAL ANSWER
DFDV3 A0
LRLOAD A0,A3
LTN2: LRLOAD A10,A0
CAMGE A0,[0.236] ; IS ARGUMENT >= SQRT(5)-2 ?
JRST LTN3 ; NO, PROCEED WITH ALGORITHM
; CALCULATE X+2
DFAD0 LTN21
EXCH A0,A10 ; GET X, SAVE X+2
EXCH A1,A11 ; ...
FSC A0,1 ; CALCULATE 2X
IFE PROC-KA10, <
FSC A1,1 ; ...
FADL A0,A1 ; ...>
; CALCULATE 2X-1
DFAD0 LTN20
; (2X-1)/(X+2) WITH RESULTS IN A0,A1
DFDV0 A10
LRLOAD A10,A0
IORI A6,1 ; SET FLAG TO LATER ADD ARCTAN(1/2)
LTN3: MOVM A3,A0
CAMGE A3,LTN23 ; CAN ATAN(X)=X?
JRST LTN6 ; YES
DFMP0 A10 ; CALCULATE X^2
LRLOAD A12,A0
LRLOAD A0,LTN17 ; INITIALIZE CONTINUED FRACTION
; COMPARISON WITH LTN17
MOVEI A7,LTN17 ; INITIALIZE POINTER TO NUMBER TABLE
JRST LTN5 ; ENTER LOOP
LTN4: DFAD0 0(A7) ; ADD LTN13
LTN5: DFAD0 A12 ; ADD X^2
LRLOAD A3,-2(A7) ; GET LTN16 (OR LTN12)
DFDV3 A0
DFAD3 -4(A7) ; ADD LTN15 (OR LTN11)
DFAD3 A12 ; ADD X^2
LRLOAD A0,-6(A7) ; GET LTN14 (OR LAMBDA)
DFDV0 A3
SUBI A7,10 ; DECREMENT TABLE POINTER
CAILE A7,LTN10 ; FINISHED?
JRST LTN4 ; NO, DO IT LAST TIME
DFMP0 A10 ; MULTIPLY BY X
LTN6: IFE PROC-KA10, <
TRNN A6,1 ; ADD ARCTAN(1/2)?
JRST LTN7 ; NO
DFAD0 LTN18
LTN7: TRNN A6,2 ; ADD -PI/2?
JRST LTN8 ; NO
DFAD0 LTN22
LTN8:>
IFE PROC-KI10, <
TRNE A6,1 ;
DFAD0 LTN18
TRNE A6,2
DFAD0 LTN22>
JUMPGE A6,LTN9 ; NEGATE RESULT?
LRNEG A0,A1 ; YES
LTN9: POPJ SP,0 ; EXIT
LTN10: DOUBLE 204613772770,017027645561 ; 12.37469 38775 51020 40816
LTN11: DOUBLE 205644272446,121335250615 ; 26.27277 52490 26980 67155
LTN12: DOUBLE 570276502107,437176661671 ; -80.34270 56102 16599 70467
LTN13: DOUBLE 203627237361,165414142742 ; 6.36424 16870 04411 34492
LTN14: DOUBLE 576316772502,512470127251 ; -1.19144 72238 50426 48905
LTN15: DOUBLE 202415301602,015271031674 ; 2.10451 89515 40978 95180
LTN16: DOUBLE 602277106546,717167531241 ; -0.07833 54278 56532 11777
LTN17: DOUBLE 201502125320,370207664057 ; 1.25846 41124 27629 031727
LTN18: DOUBLE 177732614701,130335517321 ; ATAN(1/2)
LTN19: XWD 200400,000000 ; 0.5
LTN20: DOUBLE 576400000000,000000000000 ; -1.0
LTN21: DOUBLE 202400000000,000000000000 ; EXP 2.0
LTN22: DOUBLE 576155700452,756751347563 ; -PI/2
LTN23: XWD 146673,317272 ; SQRT(3)*2^(-27)
LIT
PRGEND
TITLE DLSQRT - DUMMY BODY FOR LSQRT
; LONG REAL PROCEDURE LSQRT(D); VALUE D; LONG REAL D;
.EXIT=1
.D=4
SEARCH ALGPRM,ALGSYS
%ENTER<217>
SALL
EXTERNAL %ALGDR
%SUBTTL(ALGLIB,ALGOL LIBRARY)
EXTLAB<117>
LABEL(217): JSP AX,PARAM
Z
XWD 0,5
XWD $PRO!$LR!$SIM,2
XWD $VAR!$LR!$FOV,.D
LRLOAD A0,.D(DL) ; GET ARGUMENT
PUSHJ SP,LABEL(117) ; CALL SQRT
LRSTOR A0,.EXIT+1(DL) ; STORE RESULT
JRST .EXIT(DL)
LIT
PRGEND
TITLE LSQRT - DOUBLE PRECISION SQUARE ROOT ROUTINE
; TRANSCRIBED FROM LIB40 V.022/.020/.005/KK/TWE
; METHOD:
; THIS ROUTINE CALCULATES THE SQUARE ROOT OF A DOUBLE PRECISION
; ARGUMENT BY DOING A LINEAR SINGLE PRECISION APPROXIMATION ON
; THE HIGH ORDER WORD, THEN TWO DOUBLE PRECISION ITERATIONS OF
; NEWTONS METHOD. THIS SHOULD GENERATE A RESULT ACCURATE TO
; 20 SIGNIFICANT DECIMAL DIGITS. THE ALGORITHM IS AS FOLLOWS
; X = (2^(2N))*F, WHERE 1/2 < F < 1
; HENCE SQRT(X) = 2^N*SQRT(F)
; THE LINEAR APPROXIMATION IS OF THE FORM
; SQRT(F) = LSQ3 - LSQ4/(LSQ5+F-LSQ6/(LSQ7+F))
; WHERE THE CONSTANTS LSQ3,LSQ4,LSQ5,LSQ6, AND LSQ7 HAVE THE FOLLOWING
; VALUES
; CONSTANT VALUE WHEN 0.25<F<0.50 VALUE WHEN 0.50<F<1.0
; LSQ3 (5/14)*SQRT(70) (5/7)*SQRT(35)
; LSQ4 (50/49)*SQRT(70) (200/49)*SQRT(35)
; LSQ5 47/14 47/7
; LSQ6 4/49 16/49
; LSQ7 3/14 3/7
; ON ENTRY:
; THE ARGUMENT (X) IS IN A0,A1
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A0,A1
SEARCH ALGPRM,ALGSYS
STDENT(117,LSQRT)
JUMPE A0,LSQ2 ; ARGUMENT OF ZERO?
JUMPGE A0,.+2 ; IS ARGUMENT POSITIVE?
LIBERR 0,@(SP) ; NO, COMPLAIN
MOVE A5,A0 ; GET SPARE COPY OF HIGH ORDER
LSH A5,-33 ; GET RID OF FRACTION BITS
SUBI A5,201 ; GET RID OF THE BASE 200 PART OF
; EXPONENT. EXTRA 1 IS A FUDGE.
ROT A5,-1 ; CUT EXPONENT IN HALF, SAVE EXTRA
; BIT FOR LATER USE AS INDEX REG.
HRRZ A11,A5 ; SAVE REDUCED EXPONENT FOR SCALING
LSH A5,-43 ; BRING BIT BACK - IF 0, THEN
; 1/4<A5<1/2,OTHERWISE 1/2<A5<1.
TLZ A0,777000 ; WIPE OUT EXPONENT BITS IN ARG.
FSC A0,177(A5) ; RESET IT TO EITHER 177 OR 200
IFE PROC-KA10, <
TLZ A1,777000 ; WIPE OUT EXPONENT BITS IN LOW ARGUMENT
FSC A1,177-^D27(A5) ; SET IT TO 27 LESS THAN HIGH PART
FADL A0,A1 ; UNNORMALIZE LOW PART>
MOVE A3,A0 ; PICK UP ANOTHER COPY OF NEW FRAC.
FADR A3,LSQ7(A5) ; FORM LSQ7+F
MOVN A2,LSQ6(A5) ; PICK UP -LSQ6
FDVR A2,A3 ; CALCULATE -LSQ6/(LSQ7+F)
FADR A2,LSQ5(A5) ; GET LSQ5-LSQ6/(LSQ7+F)
FADR A2,A0 ; CALCULATE F+LSQ5-LSQ6/(LSQ7+F)
MOVN A3,LSQ4(A5) ; PICK UP -LSQ4
FDVR A3,A2 ; GET -LSQ4/(F+LSQ5-LSQ6/(LSQ7+F))
FADR A3,LSQ3(A5) ; GET FINAL FIRST APPROXIMATION
MOVEI A4,0 ; LOW HALF OF 1ST APPROX. IS 0
LRLOAD A7,A0 ; SAVE LSQRT ARGUMENT
DFDV0 A3 ; GET N/X0
DFAD0 A3 ; X0+N/X0
FSC A0,-1 ; X1=.5*(X0+N/X0)
IFE PROC-KA10, <
FSC A1,-1 ; ...
FADL A0,A1 ; UNNORMALIZE LOW WORD>
EXCH A0,A7 ; GET ARGUMENT INTO AC, SAVE X1
EXCH A1,A10 ; ...
; N/X1
DFDV0 A7
; X1+N/X1
DFAD0 A7
LSQ1: FSC A0,(A11) ; SCALE RESULTS FOR ANSWER
IFE PROC-KA10, <
FSC A1,(A11) ; ...
FADL A0,A1>
LSQ2: POPJ SP,0 ; EXIT
LSQ3: XWD 202576,362203 ; 2.98807152
XWD 203416,346045 ; 4.225771271
LSQ4: XWD 204421,143713 ; 8.537347194
XWD 205602,266310 ; 24.14726441
LSQ5: XWD 202655,555556 ; 3.357142857
XWD 203655,555556 ; 6.7142857143
LSQ6: XWD 175516,274052 ; 0.0816326531
XWD 177516,274052 ; 0.326530612
LSQ7: XWD 176666,666667 ; 0.2142857143
XWD 177666,666667 ; 0.4285714286
LIT
PRGEND
TITLE DLEXP - DUMMY BODY FOR LEXP
; LONG REAL PROCEDURE LEXP(D); VALUE D; LONG REAL D;
.EXIT=1
.D=4
SEARCH ALGPRM,ALGSYS
%ENTER<220>
SALL
EXTERNAL %ALGDR
%SUBTTL(ALGLIB,ALGOL LIBRARY)
EXTLAB<120>
LABEL(220): JSP AX,PARAM
Z
XWD 0,5
XWD $PRO!$LR!$SIM,2
XWD $VAR!$LR!$FOV,.D
LRLOAD A0,.D(DL) ; GET ARGUMENT
PUSHJ SP,LABEL(120) ; CALL LEXP
LRSTOR A0,.EXIT+1(DL) ; STORE RESULT
JRST .EXIT(DL)
LIT
PRGEND
TITLE LEXP - DOUBLE PRECISION EXPONENTIAL FUNCTION
; TRANSCRIBED FROM LIB40 V.022/.020/.005/KK/TWE
; METHOD:
; THE ROUTINE USES THE FOLLOWING ALGORITHM:
; EXP(X) = 2^(X*LOG2(E))
; = 2^(M+F) WHERE M IS AN INTEGER AND 0 < F < 1
; = 2^(M+N+R) WHERE 0 < R < 1/8 AND M+N+R = X*LOG2(E)
; = 2^(M+N)*EXP(R*LN(2))
; 2^M IS CALCULATED EASILY WITH THE FLOATING SCALE INSTRUCTION.
; 2^N IS CALCULATED BY DETERMINING THE CORRECT INTERVAL OF N AND
; USING A TABLE OF POWERS OF TWO FROM 2^1/8 TO 2^7/8.
; FINALLY, EXP(R*LN(2)) IS CALCULATED BY A CONTINUED FRACTION
; TAKEN FROM RALSTON AND WILF, "METHODS FOR DIGITAL COMPUTERS" :
; EXP(R*LN(2)) = 1+E/((LEXP9/R) - C4 + LEXP11*R + LEXP12/(R + LEXP9/R))
; ON ENTRY:
; THE ARGUMENT (X) IS IN A0,A1
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A0,A1
SEARCH ALGPRM,ALGSYS
STDENT(120,LEXP)
JUMPE A0,[
MOVSI A0,(1.0) ; RETURN 1.0 FOR ARGUMENT OF ZERO
JRST LEXP3] ; EXIT
MOVM A2,A0 ; GET MAGNITUDE OF ARGUMENT
CAML A2,LEXP4 ; IN RANGE?
JRST [
MOVE A3,A0 ; TAKE COPY OF HIGH ORDER WORD
SETZB A0,A1
JUMPL A3,LEXP3 ; ARGUMENT < 0?
LIBERR 2,@(SP)]
DFMP0 LEXP5
HLRE A4,A0 ; EXTRACT EXPONENT
ASH A4,-11 ; ...
TSC A4,A4 ; TAKE 1'S COMPLEMENT IF NUM < 0
IFE PROC-KA10, <
LSH A1,10 ; REMOVE LOW ORDER EXPONENT>
JUMPGE A0,.+2 ; CHANGE EXPONENT BITS TO SIGN BITS
TLOA A0,377000 ; NUMBER NEGATIVE, SET BITS
TLZ A0,377000 ; NUMBER POSITIVE, CLEAR BITS
ASHC A0,10 ; LEFT JUSTIFY ARGUMENT FRACTION BITS
; GET ANOTHER COPY OF FRACTION
LRLOAD A2,A0
ASHC A0,-243(A4) ; SIMULATE THREE-WORD SHIFT WITH...
; TWO LONG SHIFTS. THIS LEAVES INTEGER
; IN A0, FRACTION IN A1 AND C.
LSH A3,1 ; SQUEEZE OUT SIGN BIT
LSHC A2,43-200(A4) ; THEN DO 2ND LONG SHIFT, (THE LSHC HERE
; PREVENTS OVERFLOW GOING LEFT)
TLZ A1,400000 ; CLEAR SIGN BIT. IF FRACTION WAS < 0,
; THIS GIVES 1-FRACTION AND PROPER EXPONENT
HRRZ A7,A0 ; SAVE EXPONENT FOR FUTURE SCALING
MOVEI A6,7 ; GET INDEX REGISTER POINTER TO TABLE
EDIT(123); Fix divide-by-zero errors
TRZ A2,377 ; [E123] CLEAR JUNK FROM BOTTOM OF A2
LEXP1: CAMN A1,LEXP6(A6) ; DOES ARGUMENT MATCH TABLE ENTRY?
JUMPE A2,[
LSH A6,1 ; YES, IF LOW HALF = 0. CHANGE INDEX TO POINTER
LRLOAD A0,LEXP7(A6) ; PICK UP DOUBLE WORD ANSWER
JRST LEXP2] ; SCALE RESULTS AND EXIT
CAMGE A1,LEXP6(A6) ; IS ARGUMENT GREATER THAN ENTRY?
SOJA A6,LEXP1 ; NO, TRY NEXT LOWER ENTRY
SUB A1,LEXP6(A6) ; YES, ALL DONE -REDUCE ARGUMENT
LSH A6,1 ; SAVE INDEX AS A0 POINTER
ASHC A1,-10 ; MAKE ROOM FOR EXPONENT
IFE PROC-KA10, <
MOVE A0,A1 ; SET UP ARG. FOR NORMALIZING
ASH A2,-10 ; MAKE ROOM FOR LOW ORDER EXPONENT
FSC A0,200 ; SET EXP TO 200
FSC A2,200-^D27 ; SET EXP 27 LOWER
FADL A0,A2 ; MAKE STANDARD NUMBER>
IFE PROC-KI10, <
TLO A1,200000
DFAD A1,[EXP 0,0]
LRLOAD A0,A1>
LRLOAD A3,LEXP9 ; GET LEXP9/F
DFDV3 A0
LRLOAD A10,A3 ; SAVE LEXP9/F
DFAD3 A0 ; GET F+LEXP9/F
LRLOAD A12,A3 ; GET LEXP12/(F+LEXP9/F)
LRLOAD A3,LEXP12
DFDV3 A12
DFMP0 LEXP11 ; GET LEXP11*F
DFAD3 A0 ; GET (LEXP9/F)-C4+LEXP11*F+(LEXP12/(F+LEXP9/F))
DFAD3 LEXP10
DFAD3 A10
LRLOAD A0,LEXP8 ; GET 1.0+E/REST
DFDV0 A3
DFAD0 LEXP7
JUMPE A6,LEXP2 ; MULTIPLY BY POWER OF TWO?
DFMP0 LEXP7(A6)
LEXP2: FSC A0,(A7) ; SCALE RESULTS
IFE PROC-KA10, <
FSC A1,(A7)
JFCL 17,.+1 ; IGNORE UNDERFLOW
FADL A0,A1 ; MAKE STANDARD NUMBER>
LEXP3: POPJ SP,0 ; EXIT
LEXP4: XWD 207540,071260 ; 88.028
LEXP5: DOUBLE 201561250731,112701376057 ; LOG2(E) = 1.44269 50408 88963 40740
LEXP6: XWD 000000,000000
XWD 040000,000000 ; 1/8
XWD 100000,000000 ; 2/8
XWD 140000,000000 ; 3/8
XWD 200000,000000 ; 4/8
XWD 240000,000000 ; 5/8
XWD 300000,000000 ; 6/8
XWD 340000,000000 ; 7/8
LEXP7: DOUBLE 201400000000,000000000000 ; 2^0 = 1.0
DOUBLE 201427127017,037250572672 ; 2^1/8 = 1.09050 77326 65257 65919
DOUBLE 201460337602,214333425134 ; 2^2/8 = 1.18920 71150 02721 06671
DOUBLE 201513773265,115425047073 ; 2^3/8 = 1.29683 95546 51009 66590
DOUBLE 201552023631,237635714441 ; 2^4/8 = 1.41421 35623 73095 04878
DOUBLE 201612634520,212520333270 ; 2^5/8 = 1.54221 08254 07940 824
DOUBLE 201656423746,126551655275 ; 2^(6/8) = 1.68179 28305 07429 086
DOUBLE 201725403067,076722207113 ; 2^(7/8) = 1.83400 80864 09342 463
LEXP8: DOUBLE 206744575555,062215755376 ; LEXP8 = 60.59319 17173 36463 11080
LEXP9: DOUBLE 207535527021,213670572221 ; LEXP9 = 87.41749 72022 35527 474
LEXP10: DOUBLE 572033202222,715562022402 ; LEXP10 = -C4 = -30.29659 58586 68231 555
LEXP11: DOUBLE 201414631463,063146314632 ; LEXP11 = 1.05
LEXP12: DOUBLE 210654261010,261565402456 ; LEXP12 = 214.17286 81454 77042 3113
LIT
PRGEND
TITLE DLLN - DUMMY BODY FOR LLN
; LONG REAL PROCEDURE LLN(D); VALUE D; LONG REAL D;
.EXIT=1
.D=4
SEARCH ALGPRM,ALGSYS
%ENTER<221>
SALL
EXTERNAL %ALGDR
%SUBTTL(ALGLIB,ALGOL LIBRARY)
EXTLAB<121>
LABEL(221): JSP AX,PARAM
Z
XWD 0,5
XWD $PRO!$LR!$SIM,2
XWD $VAR!$LR!$FOV,.D
LRLOAD A0,.D(DL) ; GET ARGUMENT
PUSHJ SP,LABEL(121) ; CALL LLN
LRSTOR A0,.EXIT+1(DL) ; STORE RESULT
JRST .EXIT(DL)
LIT
PRGEND
TITLE LLN - DOUBLE PRECISION LOGARITHM FUNCTION
; TRANSCRIBED FROM LIB40 V.022/.020/.005/KK/TWE
; METHOD:
; THIS PROGRAM CALCULATES THE LOGARITHM OF A DOUBLE PRECISION
; ARGUMENT. THE ALGORITHM USED IS DESCRIBED ON PAGES 29-30 OF
; RALSTON AND WILF, "MATHEMATICAL METHODS FOR DIGITAL COMPUTERS".
; THE ARGUMENT X IS WRITTEN AS
; X = (2^N)*F WHERE 1/2 < F < 1
; THEN LN(X) = (N*LN(2)) + LN(F)
; F IS REDUCED BY FIXED POINT MULTIPLICATION BY NOT MORE THAN
; THREE CONSTANTS. THIS YIELDS
; 0 < T = K1*K2*K3*F - 1.0 < (2^(-7))/5
; NOTE THAT NOT ALL THE K1,K2,K3 NEED BE INCLUDED IN THE PRODUCT.
; FINALLY,
; LN(F) = LN(1+T) - LN(K1) - LN(K2) - LN(K3)
; LN(1+T) IS CALCULATED AS A TAYLOR SERIES IN T.
SEARCH ALGPRM,ALGSYS
; ON ENTRY:
; THE ARGUMENT (X) IS IN A0,A1
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A0,A1
STDENT(121,LLN)
JUMPG A0,.+2 ; ARGUMENT <= 0?
LIBERR 1,@(SP) ; YES, COMPLAIN
CAMN A0,LLN17 ; X PRECISELY 1.0?
JUMPE A1,[
MOVEI A0,0
JRST LLN5] ; YES, RETURN ZERO
LLN1: LDB A3,[
POINT 8,A0,8] ; NO, PICK UP EXPONENT FROM HIGH ORDER
SUBI A3,200 ; GET EXPONENT EXCESS 200
FSC A3,233 ; MAKE FLOATING POINT NUMBER
MOVEI A4,0 ; SET UP LOW HALF
; CALCULATE N*LN(2)
DFMP3 LLN8
LRLOAD A7,A3
; IFE PROC-KI10<
IFE PROC-KA10< ;
LSH A1,10 ; GET RID OF LOW ORDER EXPONENT>
TLZ A0,777000 ; MASK OUT EXPONENT
ASHC A0,10 ; NORMALIZE FRACTION TO BIT 1
SETZB A3,A4 ; INITIALIZE REDUCTION CONSTANT TO 0
LLN2: LDB A6,[
POINT 3,A0,4] ; GET HIGH 3 BITS BELOW 1/2
MUL A1,LLN7(A6) ; FIXED POINT MULTIPLY FOR LOW HALF
MOVE A2,A1 ; SAVE HIGH HALF OF LOW PRODUCT
; (LOW HALF IS ALL 0'S, THROW IT AWAY)
MUL A0,LLN7(A6) ; MULTIPLY HIGH ORDER, TOO
TLO A1,400000 ; SET BIT 0, TO AVOID OVERFLOW
ADD A1,A2 ; COMBINE RESULTS OF MULTIPLY
TLZN A1,400000 ; CLEAR BIT 0, WAS THERE OVERFLOW?
ADDI A0,1 ; YES, PROPOGATE CARRY
ASH A6,1 ; TURN BITS INTO D.P. POINTER
DFAD3 LLN6(A6)
TLZE A0,200000 ; IS THE PRODUCT >= 1.0?
JRST LLN3 ; YES
ASHC A0,1 ; NO, GET RID OF EXTRANEOUS ZERO
JRST LLN2 ; TRY ANOTHER MULTIPLICATION
LLN3: ASHC A0,-7 ; MAKE ROOM FOR THE EXPONENT
IFE PROC-KA10<
FSC A0,200 ; SET EXPONENT TO 200
ASH A1,-10 ; MAKE ROOM FOR LOW EXPONENT
FSC A1,200-^D27 ; INSERT LOW EXPONENT
FADL A0,A1 ; MAKE NORMAL DOUBLE PRECISION NUMBER>
IFE PROC-KI10 <
TLC A0,200000 ; INSERT EXPONENT
DFAD0 LLN18 ; NORMALIZE>
LRNEG A3,A4 ; NEGATE LOG OF MAGIC NUMBERS
; AND ADD INTO FINAL SUMMATION
DFAD3 A7
LRLOAD A7,A3
LRLOAD A3,LLN9 ; PICK UP CONSTANT TO START
MOVEI A6,LLN10 ; INITIALIZE TABLE POINTER AT LLN10
LLN4: DFMP3 A0 ; MULTIPLY ACCUMULATED SUM BY X
DFAD3 0(A6) ; ADD NEXT CONSTANT INTO PARTIAL SUM
ADDI A6,2 ; UPDATE POINTER TO NEXT CONSTANT
CAIG A6,LLN17 ; ARE WE DONE YET?
JRST LLN4 ; NO, LOOP BACK FOR MORE TAYLOR SERIES
DFMP0 A3 ; YES, ONE LAST MULTIPLICATION
DFAD0 A7 ; AND ADD SERIES SUM INTO FINAL ANSWER
LLN5: POPJ SP,0 ; EXIT
LLN6: DOUBLE 200471174064,325425031470 ; 0.61180 15411 05992 8976
DOUBLE 200402252251,151350376610 ; 0.50455 60107 52395 2859
DOUBLE 177637144373,057714113734 ; 0.40546 51081 08164 3810
DOUBLE 177506061360,207057302360 ; 0.31845 37311 18534 6147
DOUBLE 176710776761,346515041520 ; 0.22314 35513 14209 7553
DOUBLE 176537746034,051711723600 ; 0.17185 02569 26659 2214
DOUBLE 175557032242,271265512760 ; 0.08961 21586 89687 12374
DOUBLE 173770123303,236031377700 ; 0.03077 16586 66753 68689
LLN7: XWD 354000,000000 ; 1.11011 BINARY
XWD 324000,000000 ; 1.10101 BINARY
XWD 300000,000000 ; 1.10000 BINARY
XWD 260000,000000 ; 1.01100 BINARY
XWD 240000,000000 ; 1.01000 BINARY
XWD 230000,000000 ; 1.00110 BINARY
XWD 214000,000000 ; 1.00011 BINARY
XWD 204000,000000 ; 1.00001 BINARY
LLN8: DOUBLE 200542710277,276434757143 ; 0.69314 71805 59945 30941 72321
LLN9: DOUBLE 175707070707,0343434344 ; 1/9
LLN10: DOUBLE 601400000000,000000000000 ; -1/8
LLN11: DOUBLE 176444444444,222222222222 ; 1/7
LLN12: DOUBLE 601252525252,652525252526 ; -1/6
LLN13: DOUBLE 176631463146,146314631463 ; 1/5
LLN14: DOUBLE 600400000000,000000000000 ; -1/4
LLN15: DOUBLE 177525252525,125252525253 ; 1/3
LLN16: DOUBLE 577400000000,000000000000 ; -1/2
LLN17: XWD 201400,000000 ; 1.0
LLN18: XWD 000000,000000 ; FOR KI10 DOUBLE-LENGTH ZERO
IFE PROC-KI10 <
XWD 000000,000000>
LIT
PRGEND
TITLE DFAD0 - KA10/KI10 DOUBLE PRECISION ADD (A0,A1)
; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A0,A1
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A0,A1
SEARCH ALGPRM,ALGSYS
%ENTER<17>
SALL
%SUBTTL(ALGLIB,ALGOL LIBRARY)
LABEL(17):
IFE PROC-KA10,<
UFA A1,1(AX) ; ADD LOW ORDER PARTS IN A2
FADL A0,(AX) ; ADD HIGH ORDER PARTS IN A0,A1
UFA A1,A2 ; ADD LOW PART OF HIGH SUM TO A2
FADL A0,A2 ; ADD LOW SUM TO HIGH SUM
POPJ SP,0>
IFE PROC-KI10,<
DFAD A0,(AX)
POPJ SP,0>
LIT
PRGEND
TITLE DFSB0 - KA10/KI10 DOUBLE PRECISION SUBTRACT (A0,A1)
; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A0,A1
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A0,A1
SEARCH ALGPRM,ALGSYS
%ENTER<20>
SALL
%SUBTTL(ALGLIB,ALGOL LIBRARY)
LABEL(20):
IFE PROC-KA10,<
LRNEG A0,A1 ; NEGATE LEFT HAND OPERAND
UFA A1,1(AX)
FADL A0,(AX)
UFA A1,A2
FADL A0,A2 ; ADD RIGHT HAND OPERAND
LRNEG A0,A1 ; AND NEGATE RESULT
POPJ SP,0>
IFE PROC-KI10,<
DFSB A0,(AX)
POPJ SP,0>
LIT
PRGEND
TITLE DFMP0 - KA10/KI10 DOUBLE PRECISION MULTIPLY (A0,A1)
; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A0,A1
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A0,A1
SEARCH ALGPRM,ALGSYS
%ENTER<21>
SALL
%SUBTTL(ALGLIB,ALGOL LIBRARY)
LABEL(21):
IFE PROC-KA10,<
MOVE A2,A0 ; COPY HIGH WORD OF LEFT HAND OPERAND
FMPR A2,1(AX) ; FORM ONE CROSS PRODUCT IN A2
JFOVO DFMP01 ; SPECIAL UNDERFLOW HANDLING
FMPR A1,(AX) ; FORM OTHER CROSS PRODUCT IN A1
JFOVO DFMP01 ; SPECIAL UNDERFLOW HANDLING
UFA A1,A2 ; ADD CROSS PRODUCTS IN A2
FMPL A0,(AX) ; FORM HIGH ORDER PRODUCT IN A0,A1
UFA A1,A2 ; ADD CROSS PRODUCTS SUM TO LOW PART
FADL A0,A2 ; ADD TOGETHER LOW AND HIGH PARTS OF RESULT
POPJ SP,0
DFMP01: SYSER2 2,0> ; OVERFLOW
IFE PROC-KI10,<
DFMP A0,(AX)
POPJ SP,0>
LIT
PRGEND
TITLE DFDV0 - KA10/KI10 DOUBLE PRECISION DIVIDE (A0,A1)
; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A0,A1
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A0,A1
SEARCH ALGPRM,ALGSYS
%ENTER<22>
SALL
%SUBTTL(ALGLIB,ALGOL LIBRARY)
LABEL(22):
IFE PROC-KA10,<
FDVL A0,(AX) ; GET HIGH PART OF QUOTIENT
MOVN A2,A0 ; AND NEGATE IT
FMPR A2,1(AX) ; MULTIPLY BY LOW PART OF DIVISOR
JFOVO DFDV01 ; SPECIAL UNDERFLOW HANDLING
UFA A1,A2 ; ADD REMAINDER
FDVR A2,(AX) ; DIVIDE SUM BY HIGH PART OF DIVISOR
FADL A0,A2 ; ADD RESULT TO ORIGINAL QUOTIENT
POPJ SP,0
DFDV01: SYSER2 2,0> ; OVERFLOW
IFE PROC-KI10,<
DFDV A0,(AX)
POPJ SP,0>
LIT
PRGEND
TITLE RDFSB0 - KA10/KI10 DOUBLE PRECISION REVERSE SUBTRACT (A0,A1)
; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A0,A1
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A0,A1
SEARCH ALGPRM,ALGSYS
%ENTER<23>
SALL
%SUBTTL(ALGLIB,ALGOL LIBRARY)
LABEL(23): IFE PROC-KA10, <
LRNEG A0,A1 ; NEGATE LEFT HAND OPERAND
UFA A1,1(AX)
FADL A0,(AX)
UFA A1,A2
FADL A0,A2 ; ADD RIGHT HAND OPERAND
POPJ SP,0>
IFE PROC-KI10, <
DMOVN A0,A0 ; NEGATE LEFT HAND OPERAND
DFAD A0,(AX) ; ADD RIGHT HAND OPERAND
POPJ SP,0>
LIT
PRGEND
TITLE RDFDV0 - KA10/KI10 DOUBLE PRECISION REVERSE DIVIDE (A0,A1)
; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A0,A1
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A0,A1
SEARCH ALGPRM,ALGSYS
%ENTER<24>
SALL
%SUBTTL(ALGLIB,ALGOL LIBRARY)
LABEL(24): IFE PROC-KA10, <
LRSTOR A0,%SYS12(DB) ; SAVE LEFT HAND OPERAND
LRLOAD A0,(AX) ; AND LOAD RIGHT HAND OPERAND
FDVL A0,%SYS12(DB)
MOVN A2,A0
FMPR A2,%SYS13(DB)
JFOVO DFDV02
UFA A1,A2
FDVR A2,%SYS12(DB)
FADL A0,A2 ; AND DIVIDE BY LEFT HAND OPERAND
POPJ SP,0
DFDV02: SYSER2 2,0 ; OVERFLOW>
IFE PROC-KI10, <
LRSTOR A0,%SYS12(DB) ; SAVE LEFT HAND OPERAND
LRLOAD A0,(AX) ; LOAD RIGHT HAND OPERAND INTO A0,A1
DFDV A0,%SYS12(DB) ; AND DIVIDE BY LEFT HAND OPERAND
POPJ SP,0>
LIT
PRGEND
TITLE DFAD3 - KA10/KI10 DOUBLE PRECISION ADD (A3,A4)
; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A3,A4
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A3,A4
SEARCH ALGPRM,ALGSYS
%ENTER<25>
SALL
%SUBTTL(ALGLIB,ALGOL LIBRARY)
LABEL(25):
IFE PROC-KA10,<
UFA A4,1(AX) ; ADD LOW ORDER PARTS IN A5
FADL A3,(AX) ; ADD HIGH ORDER PARTS IN A3,A4
UFA A4,A5 ; ADD LOW PART OF HIGH SUM TO A5
FADL A3,A5 ; ADD LOW SUM TO HIGH SUM
POPJ SP,0>
IFE PROC-KI10,<
DFAD A3,(AX)
POPJ SP,0>
LIT
PRGEND
TITLE DFSB3 - KA10/KI10 DOUBLE PRECISION SUBTRACT (A3,A4)
; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A3,A4
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A3,A4
SEARCH ALGPRM,ALGSYS
%ENTER<26>
SALL
%SUBTTL(ALGLIB,ALGOL LIBRARY)
LABEL(26):
IFE PROC-KA10,<
LRNEG A3,A4 ; NEGATE LEFT HAND OPERAND
UFA A4,1(AX)
FADL A3,(AX)
UFA A4,A5
FADL A3,A5 ; ADD RIGHT HAND OPERAND
LRNEG A3,A4 ; AND NEGATE RESULT
POPJ SP,0>
IFE PROC-KI10,<
DFSB A3,(AX)
POPJ SP,0>
LIT
PRGEND
TITLE DFMP3 - KA10/KI10 DOUBLE PRECISION MULTIPLY (A3,A4)
; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A3,A4
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A3,A4
SEARCH ALGPRM,ALGSYS
%ENTER<27>
SALL
%SUBTTL(ALGLIB,ALGOL LIBRARY)
LABEL(27):
IFE PROC-KA10,<
MOVE A5,A3 ; COPY HIGH WORD OF LEFT HAND OPERAND
FMPR A5,1(AX) ; FORM ONE CROSS PRODUCT IN A5
JFOVO DFMP31 ; SPECIAL UNDERFLOW HANDLING
FMPR A4,(AX) ; FORM OTHER CROSS PRODUCT IN A4
JFOVO DFMP31 ; SPECIAL UNDERFLOW HANDLING
UFA A4,A5 ; ADD CROSS PRODUCTS IN A5
FMPL A3,(AX) ; FORM HIGH ORDER PRODUCT IN A3,A4
UFA A4,A5 ; ADD CROSS PRODUCTS SUM TO LOW PART
FADL A3,A5 ; ADD TOGETHER LOW AND HIGH PARTS OF RESULT
POPJ SP,0
DFMP31: SYSER2 2,0> ; OVERFLOW
IFE PROC-KI10,<
DFMP A3,(AX)
POPJ SP,0>
LIT
PRGEND
TITLE DFDV3 - KA10/KI10 DOUBLE PRECISION DIVIDE (A3,A4)
; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A3,A4
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A3,A4
SEARCH ALGPRM,ALGSYS
%ENTER<30>
SALL
%SUBTTL(ALGLIB,ALGOL LIBRARY)
LABEL(30):
IFE PROC-KA10,<
FDVL A3,(AX) ; GET HIGH PART OF QUOTIENT
MOVN A5,A3 ; AND NEGATE IT
FMPR A5,1(AX) ; MULTIPLY BY LOW PART OF DIVISOR
JFOVO DFDV31 ; SPECIAL UNDERFLOW HANDLING
UFA A4,A5 ; ADD REMAINDER
FDVR A5,(AX) ; DIVIDE SUM BY HIGH PART OF DIVISOR
FADL A3,A5 ; ADD RESULT TO ORIGINAL QUOTIENT
POPJ SP,0
DFDV31: SYSER2 2,0> ; OVERFLOW
IFE PROC-KI10,<
DFDV A3,(AX)
POPJ SP,0>
LIT
PRGEND
TITLE RDFSB3 - KA10/KI10 DOUBLE PRECISION REVERSE SUBTRACT (A3,A4)
; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A3,A4
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A3,A4
SEARCH ALGPRM,ALGSYS
%ENTER<31>
SALL
%SUBTTL(ALGLIB,ALGOL LIBRARY)
LABEL(31): IFE PROC-KA10, <
LRNEG A3,A4 ; NEGATE LEFT HAND OPERAND
UFA A4,1(AX)
FADL A3,(AX)
UFA A4,A5
FADL A3,A5 ; ADD RIGHT HAND OPERAND
POPJ SP,0>
IFE PROC-KI10, <
DMOVN A3,A3 ; NEGATE LEFT HAND OPERAND
DFAD A3,(AX) ; ADD RIGHT HAND OPERAND
POPJ SP,0>
LIT
PRGEND
TITLE RDFDV3 - KA10/KI10 DOUBLE PRECISION REVERSE DIVIDE (A3,A4)
; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A3,A4
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A3,A4
SEARCH ALGPRM,ALGSYS
%ENTER<32>
SALL
%SUBTTL(ALGLIB,ALGOL LIBRARY)
LABEL(32): IFE PROC-KA10, <
LRSTOR A3,%SYS12(DB) ; SAVE LEFT HAND OPERAND
LRLOAD A3,(AX) ; AND LOAD RIGHT HAND OPERAND
FDVL A3,%SYS12(DB)
MOVN A5,A3
FMPR A5,%SYS13(DB)
JFOVO DFDV32
UFA A4,A5
FDVR A5,%SYS12(DB)
FADL A3,A5 ; AND DIVIDE BY LEFT HAND OPERAND
POPJ SP,0
DFDV32: SYSER2 2,0 ; OVERFLOW>
IFE PROC-KI10, <
LRSTOR A3,%SYS12(DB) ; SAVE LEFT HAND OPERAND
LRLOAD A3,(AX) ; LOAD RIGHT HAND OPERAND INTO A3,A4
DFDV A3,%SYS12(DB) ; AND DIVIDE BY LEFT HAND OPERAND
POPJ SP,0>
LIT
PRGEND
TITLE DFAD6 - KA10/KI10 DOUBLE PRECISION ADD (A6,A7)
; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A6,A7
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A6,A7
SEARCH ALGPRM,ALGSYS
%ENTER<33>
SALL
%SUBTTL(ALGLIB,ALGOL LIBRARY)
LABEL(33):
IFE PROC-KA10,<
UFA A7,1(AX) ; ADD LOW ORDER PARTS IN A10
FADL A6,(AX) ; ADD HIGH ORDER PARTS IN A6,A7
UFA A7,A10 ; ADD LOW PART OF HIGH SUM TO A10
FADL A6,A10 ; ADD LOW SUM TO HIGH SUM
POPJ SP,0>
IFE PROC-KI10,<
DFAD A6,(AX)
POPJ SP,0>
LIT
PRGEND
TITLE DFSB6 - KA10/KI10 DOUBLE PRECISION SUBTRACT (A6,A7)
; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A6,A7
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A6,A7
SEARCH ALGPRM,ALGSYS
%ENTER<34>
SALL
%SUBTTL(ALGLIB,ALGOL LIBRARY)
LABEL(34):
IFE PROC-KA10,<
LRNEG A6,A7 ; NEGATE LEFT HAND OPERAND
UFA A7,1(AX)
FADL A6,(AX)
UFA A7,A10
FADL A6,A10 ; ADD RIGHT HAND OPERAND
LRNEG A6,A7 ; AND NEGATE RESULT
POPJ SP,0>
IFE PROC-KI10,<
DFSB A6,(AX)
POPJ SP,0>
LIT
PRGEND
TITLE DFMP6 - KA10/KI10 DOUBLE PRECISION MULTIPLY (A6,A7)
; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A6,A7
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A6,A7
SEARCH ALGPRM,ALGSYS
%ENTER<35>
SALL
%SUBTTL(ALGLIB,ALGOL LIBRARY)
LABEL(35):
IFE PROC-KA10,<
MOVE A10,A6 ; COPY HIGH WORD OF LEFT HAND OPERAND
FMPR A10,1(AX) ; FORM ONE CROSS PRODUCT IN A10
JFOVO DFMP61 ; SPECIAL UNDERFLOW HANDLING
FMPR A7,(AX) ; FORM OTHER CROSS PRODUCT IN A7
JFOVO DFMP61 ; SPECIAL UNDERFLOW HANDLING
UFA A7,A10 ; ADD CROSS PRODUCTS IN A10
FMPL A6,(AX) ; FORM HIGH ORDER PRODUCT IN A6,A7
UFA A7,A10 ; ADD CROSS PRODUCTS SUM TO LOW PART
FADL A6,A10 ; ADD TOGETHER LOW AND HIGH PARTS OF RESULT
POPJ SP,0
DFMP61: SYSER2 2,0> ; OVERFLOW
IFE PROC-KI10,<
DFMP A6,(AX)
POPJ SP,0>
LIT
PRGEND
TITLE DFDV6 - KA10/KI10 DOUBLE PRECISION DIVIDE (A6,A7)
; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A6,A7
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A6,A7
SEARCH ALGPRM,ALGSYS
%ENTER<36>
SALL
%SUBTTL(ALGLIB,ALGOL LIBRARY)
LABEL(36):
IFE PROC-KA10,<
FDVL A6,(AX) ; GET HIGH PART OF QUOTIENT
MOVN A10,A6 ; AND NEGATE IT
FMPR A10,1(AX) ; MULTIPLY BY LOW PART OF DIVISOR
JFOVO DFDV61 ; SPECIAL UNDERFLOW HANDLING
UFA A7,A10 ; ADD REMAINDER
FDVR A10,(AX) ; DIVIDE SUM BY HIGH PART OF DIVISOR
FADL A6,A10 ; ADD RESULT TO ORIGINAL QUOTIENT
POPJ SP,0
DFDV61: SYSER2 2,0> ; OVERFLOW
IFE PROC-KI10,<
DFDV A6,(AX)
POPJ SP,0>
LIT
PRGEND
TITLE RDFSB6 - KA10/KI10 DOUBLE PRECISION REVERSE SUBTRACT (A6,A7)
; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A6,A7
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A6,A7
SEARCH ALGPRM,ALGSYS
%ENTER<37>
SALL
%SUBTTL(ALGLIB,ALGOL LIBRARY)
LABEL(37): IFE PROC-KA10, <
LRNEG A6,A7 ; NEGATE LEFT HAND OPERAND
UFA A7,1(AX)
FADL A6,(AX)
UFA A7,A10
FADL A6,A10 ; ADD RIGHT HAND OPERAND
POPJ SP,0>
IFE PROC-KI10, <
DMOVN A6,A6 ; NEGATE LEFT HAND OPERAND
DFAD A6,(AX) ; ADD RIGHT HAND OPERAND
POPJ SP,0>
LIT
PRGEND
TITLE RDFDV6 - KA10/KI10 DOUBLE PRECISION REVERSE DIVIDE (A6,A7)
; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A6,A7
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A6,A7
SEARCH ALGPRM,ALGSYS
%ENTER<40>
SALL
%SUBTTL(ALGLIB,ALGOL LIBRARY)
LABEL(40): IFE PROC-KA10, <
LRSTOR A6,%SYS12(DB) ; SAVE LEFT HAND OPERAND
LRLOAD A6,(AX) ; AND LOAD RIGHT HAND OPERAND
FDVL A6,%SYS12(DB)
MOVN A10,A6
FMPR A10,%SYS13(DB)
JFOVO DFDV62
UFA A7,A10
FDVR A10,%SYS12(DB)
FADL A6,A10 ; AND DIVIDE BY LEFT HAND OPERAND
POPJ SP,0
DFDV62: SYSER2 2,0 ; OVERFLOW>
IFE PROC-KI10, <
LRSTOR A6,%SYS12(DB) ; SAVE LEFT HAND OPERAND
LRLOAD A6,(AX) ; LOAD RIGHT HAND OPERAND INTO A6,A7
DFDV A6,%SYS12(DB) ; AND DIVIDE BY LEFT HAND OPERAND
POPJ SP,0>
LIT
PRGEND
TITLE DFAD9 - KA10/KI10 DOUBLE PRECISION ADD (A11,A12)
; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A11,A12
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A11,A12
SEARCH ALGPRM,ALGSYS
%ENTER<41>
SALL
%SUBTTL(ALGLIB,ALGOL LIBRARY)
LABEL(41):
IFE PROC-KA10,<
UFA A12,1(AX) ; ADD LOW ORDER PARTS IN A13
FADL A11,(AX) ; ADD HIGH ORDER PARTS IN A11,A12
UFA A12,A13 ; ADD LOW PART OF HIGH SUM TO A13
FADL A11,A13 ; ADD LOW SUM TO HIGH SUM
POPJ SP,0>
IFE PROC-KI10,<
DFAD A11,(AX)
POPJ SP,0>
LIT
PRGEND
TITLE DFSB9 - KA10/KI10 DOUBLE PRECISION SUBTRACT (A11,A12)
; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A11,A12
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A11,A12
SEARCH ALGPRM,ALGSYS
%ENTER<42>
SALL
%SUBTTL(ALGLIB,ALGOL LIBRARY)
LABEL(42):
IFE PROC-KA10,<
LRNEG A11,A12 ; NEGATE LEFT HAND OPERAND
UFA A12,1(AX)
FADL A11,(AX)
UFA A12,A13
FADL A11,A13 ; ADD RIGHT HAND OPERAND
LRNEG A11,A12 ; AND NEGATE RESULT
POPJ SP,0>
IFE PROC-KI10,<
DFSB A11,(AX)
POPJ SP,0>
LIT
PRGEND
TITLE DFMP9 - KA10/KI10 DOUBLE PRECISION MULTIPLY (A11,A12)
; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A11,A12
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A11,A12
SEARCH ALGPRM,ALGSYS
%ENTER<43>
SALL
%SUBTTL(ALGLIB,ALGOL LIBRARY)
LABEL(43):
IFE PROC-KA10,<
MOVE A13,A11 ; COPY HIGH WORD OF LEFT HAND OPERAND
FMPR A13,1(AX) ; FORM ONE CROSS PRODUCT IN A13
JFOVO DFMP91 ; SPECIAL UNDERFLOW HANDLING
FMPR A12,(AX) ; FORM OTHER CROSS PRODUCT IN A12
JFOVO DFMP91 ; SPECIAL UNDERFLOW HANDLING
UFA A12,A13 ; ADD CROSS PRODUCTS IN A13
FMPL A11,(AX) ; FORM HIGH ORDER PRODUCT IN A11,A12
UFA A12,A13 ; ADD CROSS PRODUCTS SUM TO LOW PART
FADL A11,A13 ; ADD TOGETHER LOW AND HIGH PARTS OF RESULT
POPJ SP,0
DFMP91: SYSER2 2,0> ; OVERFLOW
IFE PROC-KI10,<
DFMP A11,(AX)
POPJ SP,0>
LIT
PRGEND
TITLE DFDV9 - KA10/KI10 DOUBLE PRECISION DIVIDE (A11,A12)
; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A11,A12
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A11,A12
SEARCH ALGPRM,ALGSYS
%ENTER<44>
SALL
%SUBTTL(ALGLIB,ALGOL LIBRARY)
LABEL(44):
IFE PROC-KA10,<
FDVL A11,(AX) ; GET HIGH PART OF QUOTIENT
MOVN A13,A11 ; AND NEGATE IT
FMPR A13,1(AX) ; MULTIPLY BY LOW PART OF DIVISOR
JFOVO DFDV91 ; SPECIAL UNDERFLOW HANDLING
UFA A12,A13 ; ADD REMAINDER
FDVR A13,(AX) ; DIVIDE SUM BY HIGH PART OF DIVISOR
FADL A11,A13 ; ADD RESULT TO ORIGINAL QUOTIENT
POPJ SP,0
DFDV91: SYSER2 2,0> ; OVERFLOW
IFE PROC-KI10,<
DFDV A11,(AX)
POPJ SP,0>
LIT
PRGEND
TITLE RDFSB9 - KA10/KI10 DOUBLE PRECISION REVERSE SUBTRACT (A11,A12)
; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A11,A12
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A11,A12
SEARCH ALGPRM,ALGSYS
%ENTER<45>
SALL
%SUBTTL(ALGLIB,ALGOL LIBRARY)
LABEL(45): IFE PROC-KA10, <
LRNEG A11,A12 ; NEGATE LEFT HAND OPERAND
UFA A12,1(AX)
FADL A11,(AX)
UFA A12,A13
FADL A11,A13 ; ADD RIGHT HAND OPERAND
POPJ SP,0>
IFE PROC-KI10, <
DMOVN A11,A11 ; NEGATE LEFT HAND OPERAND
DFAD A11,(AX) ; ADD RIGHT HAND OPERAND
POPJ SP,0>
LIT
PRGEND
TITLE RDFDV9 - KA10/KI10 DOUBLE PRECISION REVERSE DIVIDE (A11,A12)
; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A11,A12
; THE RIGHT HAND OPERAND IS ADDRESSED BY AX
; THE LINK IS ON THE STACK
; ON EXIT, THE RESULT IS IN A11,A12
SEARCH ALGPRM,ALGSYS
%ENTER<46>
SALL
%SUBTTL(ALGLIB,ALGOL LIBRARY)
LABEL(46): IFE PROC-KA10, <
LRSTOR A11,%SYS12(DB) ; SAVE LEFT HAND OPERAND
LRLOAD A11,(AX) ; AND LOAD RIGHT HAND OPERAND
FDVL A11,%SYS12(DB)
MOVN A13,A11
FMPR A13,%SYS13(DB)
JFOVO DFDV92
UFA A12,A13
FDVR A13,%SYS12(DB)
FADL A11,A13 ; AND DIVIDE BY LEFT HAND OPERAND
POPJ SP,0
DFDV92: SYSER2 2,0 ; OVERFLOW>
IFE PROC-KI10, <
LRSTOR A11,%SYS12(DB) ; SAVE LEFT HAND OPERAND
LRLOAD A11,(AX) ; LOAD RIGHT HAND OPERAND INTO A11,A12
DFDV A11,%SYS12(DB) ; AND DIVIDE BY LEFT HAND OPERAND
POPJ SP,0>
LIT
PRGEND
TITLE DIM - ARRAY DIMENSION ROUTINE
; INTEGER PROCEDURE DIM(A); (INTEGER/REAL/LONG REAL/BOOLEAN/STRING) ARRAY A;
.EXIT=1
.A=3
SEARCH ALGPRM,ALGSYS
LIBENT(300,DIM)
XWD 0,4
XWD $PRO!$I!$SIM,2
XWD $ARR!$WV!$FON,.A
HLRE A0,.A+1(DL)
MOVNM A0,.EXIT+1(DL) ; GET NUMBER OF DIMENSIONS
JRST .EXIT(DL)
LIT
PRGEND
TITLE LB/UB - ARRAY BOUND ROUTINE
; INTEGER PROCEDURE LB(A,N); VALUE N; (INTEGER/REAL/LONG REAL/BOOLEAN/STRING) ARRAY; INTEGER N;
; INTEGER PROCEDURE UB(A,N); VALUE N; (INTEGER/REAL/LONG REAL/BOOLEAN/STRING) ARRAY; INTEGER N;
.EXIT=1
.LU=3
.A=4
.N=6
SEARCH ALGPRM,ALGSYS
LIBENT(301,LB)
XWD 0,6
XWD $PRO!$I!$SIM,3
XWD $ARR!$WV!$FON,.A
XWD $VAR!$I!$FOV,.N
SETZM .LU(DL) ; FLAG AS LB ENTRY
JRST LB1
LIBENT(302,UB)
XWD 0,6
XWD $PRO!$I!$SIM,3
XWD $ARR!$WV!$FON,.A
XWD $VAR!$I!$FOV,.N
MOVEI A0,1
MOVEM A0,.LU(DL) ; FLAG AS UB ENTRY
LB1: MOVE A0,.N(DL) ; GET SUBSCRIPT NUMBER
JUMPLE A0,LBUB1 ; ANY GOOD?
HLRE A1,.A+1(DL)
MOVN A1,A1 ; GET NUMBER OF SUBSCRIPTES
CAMGE A1,A0 ; ENOUGH
JRST LBUB1 ; NO
HRRZ A1,.A+1(DL) ; GET DOPE VECTOR ADDRESS
LSH A0,1 ; DOUBLE SUBSCRIPT NUMBER
ADD A1,A0
ADD A1,.LU(DL) ; AND ALLOW FOR LB/UB
SKIPA A1,-2(A1) ; GET RELEVANT BOUND
LBUB1: MOVEI A1,0 ; OUT OF RANGE
MOVEM A1,.EXIT+1(DL)
JRST .EXIT(DL)
LIT
PRGEND
TITLE IMIN/IMAX - INTEGER MINIMUM/MAXIMUM ROUTINES
; INTEGER PROCEDURE IMIN(I); VALUE I; INTEGER I;
; INTEGER PROCEDURE IMAX(I); VALUE I; INTEGER I;
SEARCH ALGPRM,ALGSYS
DEFINE REP(M,A,I)
<Q=0
R=A-I
REPEAT PRMMAX, <
IF2,
<Q=Q+1
R=R+I>
M \Q,\R>>
DEFINE DECL(A,B)
<IF2, <.I'A=B>>
DEFINE PAR(A,B)
<IF1, <Z>
IF2, <XWD $VAR!$I!$FOV,.I'A>>
.EXIT=1
.MM=3
.V=4
REP DECL,5,1
LIBENT(303,IMIN,.V)
XWD 0,PRMMAX+4
XWD $PRO!$I!$SIM,PRMMAX+1
REP PAR,5,1
MOVEI A2,0 ; IMIN FLAG
JRST IM1
LIBENT(304,IMAX,.V)
XWD 0,PRMMAX+4
XWD $PRO!$I!$SIM,PRMMAX+1
REP PAR,5,1
MOVEI A2,1 ; IMAX FLAG
IM1: MOVN A1,.V(DL) ; NUMBER OF PARAMETERS+1
AOJE A1,IM5 ; NO PARAMETERS?
HRLZ A1,A1
HRRI A1,.I1(DL) ; SET UP COUNTER POINTER
SKIPE A2 ; MIN OR MAX
JRST IM3
HRLOI A0,377777 ; MIN
IM2: CAMLE A0,(A1)
MOVE A0,(A1)
AOBJN A1,IM2
JRST IM6
IM3: HRLZI A0,400000 ; MAX
IM4: CAMGE A0,(A1)
MOVE A0,(A1)
AOBJN A1,IM4
JRST IM6
IM5: MOVEI A0,0 ; NO PARAMETER CASE
IM6: MOVEM A0,.EXIT+1(DL) ; RESULT
JRST .EXIT(DL)
LIT
PRGEND
TITLE RMIN/RMAX - REAL MINIMUM/MAXIMUM ROUTINES
; REAL PROCEDURE RMIN(X); VALUE X; REAL X;
; REAL PROCEDURE RMAX(X); VALUE X; REAL X;
SEARCH ALGPRM,ALGSYS
DEFINE REP(M,A,I)
<Q=0
R=A-I
REPEAT PRMMAX, <
IF2,
<Q=Q+1
R=R+I>
M \Q,\R>>
DEFINE DECL(A,B)
<IF2, <.X'A=B>>
DEFINE PAR(A,B)
<IF1, <Z>
IF2, <XWD $VAR!$R!$FOV,.X'A>>
.EXIT=1
.MM=3
.V=4
REP DECL,5,1
LIBENT(305,RMIN,.V)
XWD 0,PRMMAX+4
XWD $PRO!$R!$SIM,PRMMAX+1
REP PAR,5,1
MOVEI A2,0 ; RMIN FLAG
JRST RM1
LIBENT(306,RMAX,.V)
XWD 0,PRMMAX+4
XWD $PRO!$R!$SIM,PRMMAX+1
REP PAR,5,1
MOVEI A2,1 ; RMAX FLAG
RM1: MOVN A1,.V(DL) ; NUMBER OF PARAMETERS+1
AOJE A1,RM5 ; NO PARAMETERS?
HRLZ A1,A1
HRRI A1,.X1(DL) ; SET UP COUNTER POINTER
SKIPE A2 ; MIN OR MAX
JRST RM3
HRLOI A0,377777 ; MIN
RM2: CAMLE A0,(A1)
MOVE A0,(A1)
AOBJN A1,RM2
JRST RM6
RM3: MOVE A0,[
XWD 400000,000001]
RM4: CAMGE A0,(A1)
MOVE A0,(A1)
AOBJN A1,RM4
JRST RM6
RM5: MOVEI A0,0 ; NO PARAMETER CASE
RM6: MOVEM A0,.EXIT+1(DL) ; RESULT
JRST .EXIT(DL)
LIT
PRGEND
TITLE LMIN/LMAX - LONG REAL MINIMUM/MAXIMUM ROUTINES
; LONG REAL PROCEDURE LMIN(D); VALUE D; LONG REAL D;
; LONG REAL PROCEDURE LMAX(D); VALUE D; LONG REAL D;
SEARCH ALGPRM,ALGSYS
DEFINE REP(M,A,I)
<Q=0
R=A-I
REPEAT PRMMAX, <
IF2,
<Q=Q+1
R=R+I>
M \Q,\R>>
DEFINE DECL(A,B)
<IF2, <.D'A=B>>
DEFINE PAR(A,B)
<IF1, <Z>
IF2, <XWD $VAR!$LR!$FOV,.D'A>>
.EXIT=1
.MM=4
.V=5
REP DECL,6,2
LIBENT(307,LMIN,.V)
XWD 0,2*PRMMAX+5
XWD $PRO!$LR!$SIM,PRMMAX+1
REP PAR,6,2
MOVEI A0,0 ; FLAG AS LMIN
JRST LM1
LIBENT(310,LMAX,.V)
XWD 0,2*PRMMAX+5
XWD $PRO!$LR!$SIM,PRMMAX+1
REP PAR,6,2
MOVEI A0,1 ; FLAG AS LMAX
LM1: MOVN A2,.V(DL) ; NUMBER OF PARAMETERS+1
AOJE A2,LM7 ; NO PARAMETERS?
HRLZ A2,A2
HRRI A2,.D1(DL) ; SET UP COUNTER POINTER
SKIPE A0 ; MIN OR MAX?
JRST LM4
HRLOI A0,377777 ; MIN
HRLOI A1,344777
LM2: CAMN A0,(A2)
CAMLE A1,1(A2)
CAMGE A0,(A2)
AOJA A2,LM3
LRLOAD A0,(A2)
ADDI A2,1
LM3: AOBJN A2,LM2
JRST LM8
LM4: HRLZI A0,400000 ; MAX
MOVE A1,[
XWD 344000,000001]
LM5: CAMN A0,(A2)
CAMGE A1,1(A2)
CAMLE A0,(A2)
AOJA A2,LM6
LRLOAD A0,(A2)
ADDI A2,1
LM6: AOBJN A2,LM5
JRST LM8
LM7: SETZB A0,A1 ; NO PARAMETER CASE
LM8: LRSTOR A0,.EXIT+1(DL) ; RESULT
JRST .EXIT(DL)
LIT
PRGEND
TITLE GFIELD/SFIELD - FIELD ACCESS ROUTINES
; INTEGER PROCEDURE GFIELD(A,I,J); VALUE A,I,J;
; (INTEGER/REAL/LONG REAL/BOOLEAN/STRING) A; INTEGER I,J;
; PROCEDURE SFIELD(A,I,J,N); VALUE I,J,N;
; (INTEGER/REAL/LONG REAL/BOOLEAN/STRING) A; INTEGER I,J,N;
.EXIT=1
.A=3
.I=6
.J=7
.N=10
SEARCH ALGPRM,ALGSYS
LIBENT(312,SFIELD)
XWD 0,10
XWD $PRO!$N!$SIM,5
XWD $VAR!$WV!$FON,.A
XWD $VAR!$I!$FOV,.I
XWD $VAR!$I!$FOV,.J
XWD $VAR!$I!$FOV,.N
MOVEI A1,1 ; SET SFIELD FLAG
JRST GSF1
LIBENT(311,GFIELD)
XWD 0,10
XWD $PRO!$I!$SIM,4
XWD $VAR!$WV!$FOV,.A
XWD $VAR!$I!$FOV,.I
XWD $VAR!$I!$FOV,.J
MOVEI A1,0 ; CLEAR SFIELD FLAG
GSF1: MOVE A2,PRGLNK(DL) ; GET PROGRAM LINK
SUBI A2,3(A1) ; GET ADDRESS OF AP FOR A
HLRZ A0,(A2)
ANDI A0,$TYPE ; GET TYPE OF A
CAIE A0,$LR
CAIN A0,$S
HRLI A1,400000 ; SET LONG FLAG IF DOUBLE WORD
SKIPL A2,.I(DL) ; GET I
SKIPG A3,.J(DL) ; AND J
GSF2: SYSER1 15,0 ; BAD VALUES
TLZE A1,400000
JRST GSF5 ; LONG CASE?
MOVEI A4,^D36 ; NO
SUB A4,A2
SUB A4,A3 ; FORM 36-I-J
JUMPL A4,GSF2 ; FAIL UNLESS I+J <= 36
GSF3: LSH A4,6
ADDI A4,(A3) ; FORM 64*P + S
ROT A4,-14 ; FUDGE BYTE POINTER
JUMPN A1,GSF4 ; GFIELD?
ADDI A4,.A(DL) ; YES - ADD ADDRESS TO BYTE POINTER
LDB A0,A4
MOVEM A0,.EXIT+1(DL) ; GET RESULT
JRST .EXIT(DL)
GSF4: PUSH SP,A4 ; SFIELD - SAVE BYTE POINTER
XCT .A(DL) ; LOAD A
MOVE A4,(SP) ; RESTORE BYTE POINTER
MOVE A5,.N(DL)
DPB A5,A4 ; DEPOSIT BYTE (IN A0 OR A1)
MOVEM A0,(SP)
PUSH SP,A1 ; SAVE VALUE(S)
XCTA .A(DL) ; GET ADDRESS OF A
POP SP,A1
POP SP,A0 ; RESTORE VALUE(S)
XCT .A+1(DL) ; AND WRITE IT IN A
JRST .EXIT(DL)
GSF5: MOVEI A5,^D72 ; LONG CASE
SUB A5,A2
SUB A5,A3 ; FORM 72-I-J
JUMPL A5,GSF2 ; FAIL UNLESS I+J <= 72
HRREI A4,-^D36(A5) ; TEST FOR SIMPLE CASE
JUMPGE A4,GSF3 ; OF I+J <= 36
CAIGE A2,^D36 ; I >= 36?
JRST GSF6 ; NO
MOVEI A4,100*A1(A5) ; YES - FUDGE BYTE POINTER FOR A1
JRST GSF3
GSF6: CAILE A3,^D36 ; FRAGMENTED CASE
JRST GSF2 ; LOSES IF J > 36
MOVN A4,A4 ; S2 = I+J-36
MOVEI A2,(A4) ; SAVE SHIFT
SUBI A3,(A4) ; S1 = 36-I
ROT A3,-14 ; FORM FIRST BYTE POINTER
LSH A5,6
ADDI A4,(A5)
ROT A4,-14
ADDI A4,A1 ; FORM SECOND BYTE POINTER
JUMPN A1,GSF7 ; GBYTE?
LRLOAD A0,.A(DL) ; YES - LOAD A
LDB A0,A3 ; GET FIRST BYTE
LDB A1,A4 ; GET SECOND BYTE
LSH A0,(A2)
ADD A0,A1 ; ASSEMBLE RESULT
MOVEM A0,.EXIT+1(DL)
JRST .EXIT(DL)
GSF7: PUSH SP,A2
PUSH SP,A3
PUSH SP,A4 ; SAVE A2-A4
XCT .A(DL) ; GET VALUE OF A
POP SP,A4
MOVE A3,(SP) ; RESTORE BYTE POINTERS
MOVN A2,-1(SP) ; AND SHIFT
MOVE A5,.N(DL) ; GET BYTE VALUE FROM N
DPB A5,A4 ; DEPOSIT SECOND BYTE
LSH A5,(A2) ; SHIFT DOWN BYTE
DPB A5,A3 ; DEPOSIT FIRST BYTE
LRSTOR A0,-1(SP) ; SAVE NEW VALUE
XCTA .A(DL) ; GET ADDRESS OF A
POP SP,A1
POP SP,A0 ; RESTORE NEW VALUE
XCT .A+1(DL) ; AND STORE IT
JRST .EXIT(DL)
LIT
PRGEND
TITLE COPY - COPY STRING ROUTINE
; STRING PROCEDURE COPY(S,M,N); VALUE M,N; STRING S; INTEGER M,N;
.EXIT=1
.S=4
.M=7
.N=10
.V=11
SEARCH ALGPRM,ALGSYS
LIBENT(314,COPY,.V)
XWD 0,11
XWD $PRO!$S!$SIM,4
XWD $VAR!$S!$FON,.S
XWD $VAR!$I!$FOV,.M
XWD $VAR!$I!$FOV,.N
SOSN .V(DL) ; ANY PARAMETERS?
SYSER1 10,0 ; NO - COMPLAIN
XCT .S(DL) ; GET ADDRESS OF STRING
EDIT(023); SAVE STRING HEADER ADDRESS DELOCATED
MOVEM A2,%SYS11(DB) ; [E023]
MOVEI A2,@A2
LDB A0,[
POINT 24,STR2(A2),35] ; AND ITS LENGTH
MOVEI A7,1
MOVE A10,A0 ; SET UP DEFAULT PARAMETERS
SOSN A1,.V(DL)
JRST COPY1 ; ONLY ONE PARAMETER
CAMLE A10,.M(DL)
MOVE A10,.M(DL) ; MIN(M,LENGTH(S))
SOJE A1,COPY1 ; IF TWO PARAMETERS
MOVE A7,A10
CAIGE A7,1
MOVEI A7,1 ; MAX(M,1)
MOVE A10,.N(DL)
CAMLE A10,A0
MOVE A10,A0 ; MIN(N,LENGTH(S))
COPY1: SUB A10,A7
AOJG A10,.+3 ; NUMBER OF BYTES TO BE COPIED
MOVEI A10,0
JRST COPY2 ; MAYBE NONE AT ALL
LDB A0,[
POINT 6,STR1(A2),11] ; GET BYTE SIZE
MOVEI A1,^D36
IDIV A1,A0 ; CALCULATE NUMBER OF BYTES PER WORD
MOVE A0,A10
IDIVI A0,(A1)
JUMPE A1,.+2
ADDI A0,1 ; NUMBER OF WORDS IN BYTE STRING
LRSTOR A7,%SYS12(DB) ; SAVE A7,A10
PUSHJ SP,GETCLR ; ASK FOR SPACE FOR STRING (ZEROED)
LRLOAD A7,%SYS12(DB) ; RESTORE A7,A10
COPY2: MOVEI A2,.EXIT+1(DL) ; ADDRESS OF NEW STRING
MOVEI A4,(A1) ; ADDRESS OF NEW BYTE STRING
MOVEI A3,@%SYS11(DB) ; [E023] ADDRESS OF OLD HEADER
LRLOAD A0,(A3) ; LOAD UP VALUE OF OLD STRING
JSP AX,CPYSTR ; AND COPY STRING
JRST .EXIT(DL)
LIT
PRGEND
TITLE TRAP - TRAP ERROR ROUTINE
; PROCEDURE TRAP(N,L); VALUE N,L; INTEGER N; LABEL L;
.EXIT=1
.N=2
.L=3
.V=6
SEARCH ALGPRM,ALGSYS
LIBENT(315,TRAP,.V)
XWD 0,6
XWD $PRO!$N!$SIM,3
XWD $VAR!$I!$FOV,.N
XWD $VAR!$L!$FOV,.L
SOSN .V(DL) ; HOW MANY ACTUAL PARAMETERS?
SYSER1 10,0 ; NONE - COMPLAIN
SKIPL A2,.N(DL) ; GET TRAP NUMBER
CAIL A2,100
JRST .EXIT(DL) ; OUT OF RANGE
MOVEI A0,0
ADDI A2,(DB)
HRRZ A1,%TRAPS(A2)
JUMPE A1,TRAP0
PUSHJ SP,GETOWN ; YES - RELEASE IT
TRAP0: MOVEI A1,0
SOSN .V(DL)
JRST TRAP1 ; TRAP TO BE UNSET
XCT .L(DL) ; GET LABEL ADDRESS
JUMPE A2,TRAP0 ; EXIT IF SWITCH OUT OF RANGE
HLRZ A3,A2 ; GET F[0]
ADDI A3,(DB)
HLRZ A4,2(A3) ; SAVE ITS DL
HRRZ A3,1(A3) ; AND GET THE ACTUAL LABEL ADDRESS
HRRZ A0,1(A3) ; PROCEDURE LEVEL OF LABEL
ADDI A0,2
PUSH SP,A3 ; SAVE LABEL ADDRESS
PUSH SP,A4 ; AND RELEVANT DL
PUSHJ SP,GETOWN ; GET DUMP AREA
POP SP,A2 ; RESTORE RELEVANT DL
POP SP,(A1) ; STORE LABEL ADDRESS
HLRZ A0,-1(A1) ; LABEL
SUBI A0,2 ; PROCEDURE LEVEL+1
HRLM A0,(A1) ;
ADDI A2,(DB) ; RELOCATE RELEVANT DL
HRLZI A2,(A2)
HRRI A2,1(A1) ; SET UP BLT POINTER
ADDI A0,(A1)
BLT A2,@A0 ; AND MAKE COPY OF DISPLAY
TRAP1: MOVE A3,.N(DL)
ADDI A3,(DB)
MOVEM A1,%TRAPS(A3) ; SET UP TRAP ENTRY
JRST .EXIT(DL)
LIT
PRGEND
TITLE FCALLS - FORTRAN INTERFACE ROUTINES
SEARCH ALGPRM,ALGSYS
%ENTER<434,435,436,437,440>
%ENTER<450,451,452,453,454>
EXTERNAL %ALGDR
SALL
%SUBTTL(ALGLIB,ALGOL LIBRARY)
.EXIT=1
.SUBR=4
LABEL(450): ; F10CALL
LABEL(451): ; F10ICALL
LABEL(452): ; F10RCALL
LABEL(453): ; F10DCALL
LABEL(454): ; F10LCALL
TDZA A0,A0 ; F10 - SET A0 TO 0
LABEL(434): ; CALL
LABEL(435): ; ICALL
LABEL(436): ; RCALL
LABEL(437): ; DCALL
LABEL(440): ; LCALL
MOVEI A0,1 ; F40 - SET A0 TO 1
SKIPE A13,A0 ; SKIP IF F10 & CLEAR A13
MOVSI A13,(JUMP) ; F40 - SET NOOP CODE
HRRZS A2,(SP) ; GET RETURN LINK
HRRZ A1,(A2) ; GET NUMBER OF PARAMETERS (+1)
HRLI A2,-1(A1) ; GET ACTUAL NUMBER OF PARAMETERS
TLC A2,-1 ; GET -(N+1) IN L.H. OF A2
AOBJN A2,.+2 ; ARE THERE ANY PARAMETERS ?
SYSER1 10,0 ; NO - FATAL ERROR
MOVEI A3,(SP) ; SAVE STACK POINTER
PUSH SP,A0 ; STACK F10/F40 INDICATOR
PUSH SP,A0 ; RESERVE WORD FOR ARRAY COUNT
PUSH SP,[JSP AX,PARAM]; STACK CALL TO PARAM
SKIPN A0 ; WHAT TYPE OF FORTRAN ?
TROA A0,F10PMB ; F10 - A0 := F10 PMB ADDRESS
MOVEI A0,F40PMB ; F40 - A0 := F40 PMB ADDRESS
PUSH SP,A0 ; STACK PMB ADDRESS
PUSH SP,[EXP 3] ; STACK INITIAL PL,,L
IMULM A1,(SP) ; (3 WORDS/PARAMETER + 3)
PUSH SP,A1 ; STACK FTYPE,,M+1
MOVE A1,(A2) ; GET DESCRIPTOR FOR FIRST ARGUMENT
TLC A1,<$PRO!$EXT> ; PREPARE FOR TESTS
TLCN A1,$PRO ; IS IT A PROCEDURE ?
TLNE A1,$STAT ; YES - IS IT EXTERNAL ?
CALL01: SYSER1 7,0 ; NO TO EITHER - FATAL ERROR
HLLM A1,(SP) ; SET TYPE BITS OF RESULT FOR PARAM
HRRI A1,.SUBR ; GET OFFSET WITHIN FIXED STACK
SETZ A4, ; CLEAR COUNT OF ARRAYS FOUND
JRST CALL03 ; AND GO SET TYPE FIELD
CALL02: HRRZI A1,3(A1) ; GET NEXT OFFSET WITHIN FIXED STACK
HLL A1,(A2) ; GET KIND,TYPE,STATUS OF NEXT ACTUAL
TLNN A1,$ARR ; VARIABLE OR EXPRESSION ?
JRST CALL04 ; YES
TLNN A1,$EXP ; NO - ARRAY ?
AOJA A4,CALL04 ; YES (COUNT IT IN A4)
TLC A1,$EXT ; NO - MUST BE A PROCEDURE !
TLNE A1,$STAT ; WAS IT EXTERNAL ?
SYSER1 7,0 ; NO - FATAL ERROR
CALL03: TLZA A1,$TYPE ; [PRO] CLEAR TYPE FIELD
CALL04: TLZA A1,<$EXP!$TYPE!$STAT>; [VAR] SET KIND TO $VAR OR $ARR
TLOA A1,$ABN ; [PRO] SET TYPE TO WILD ARITH/BOOL/NON
TLO A1,<$AB!$FON> ; [VAR] SET WILD ARITHMETIC/BOOLEAN BY NAME
PUSH SP,A1 ; STACK FORMAL PARAMETER DESCRIPTOR
AOBJN A2,CALL02 ; REPEAT IF MORE PARAMETERS
PUSH SP,[JRST CALL05]; STACK RETURN JUMP
PUSH SP,A13 ; SAVE OPCODE FOR DESCRIPTORS
PUSH SP,A3 ; SAVE POINTER TO START
PUSH SP,(A3) ; STACK PROGRAM LINK
MOVEM A4,2(A3) ; SAVE COUNT OF ARRAYS
JRST 3(A3) ; **** ENTER PARAM INTERLUDE ****
CALL05: MOVE A3,LINKDL-1(DL) ; PICK UP TOP-OF-STACK ON ENTRY TO FCALL
HRRZ A1,BLKPTR(DL) ; GET CURRENT TOP-OF-STACK (DELOCATED)
HRLI A1,DB ; SET DB INTO INDEX FIELD
EXCH A1,2(A3) ; SWAP WITH COUNT OF ARRAYS
JUMPE A1,.+3 ; ARE THERE ANY ARRAYS ?
PUSH SP,A1 ; IF SO, RESERVE ONE WORD ON
SOJG A1,.-1 ; THE STACK FOR EACH ONE
MOVEI A2,CALL20 ; GET INTERMEDIATE RETURN ADDRESS
EXCH A2,PRGLNK(DL) ; SWAP WITH (POSSIBLY DELOCATED) LINK
EXCH A2,(A3) ; SWAP THIS WITH ORIGINAL LINK
SUBI A2,@(A3) ; GET DIFFERENCE (-(N+1))
AOS A1,A2 ; ADD 1 (STEP OVER COUNT OF PARAMETERS)
ADD A2,(A3) ; AND GET (DELOCATED?) ADDR OF DESCRIPTORS
HRRZ A0,.SUBR+1(DL) ; GET ADDRESS OF FORTRAN ROUTINE
ADDM A0,1(A3) ; SAVE IT (+1 IF F40 CALL)
SUBI A3,-2(DB) ; DELOCATE ADDRESS
HRLI A3,DB ; SET DB INTO INDEX FIELD
MOVEM A3,LINKDL-1(DL) ; AND SAVE IT
HRLZI A3,1(A1) ; SET A3 TO ARG-COUNT WORD FOR F10
PUSH SP,A3 ; PUSH IT ONTO PARAMETER BLOCK
MOVE A3,[Z .SUBR(DL)]; GET DELOCATED POINTER INTO A3
AOJGE A1,CALL07 ; JUMP IF NO PARAMETERS TO FORTRAN
CALL06: HRRI A2,1(A2) ; STEP TO NEXT DESCRIPTOR WORD
HRRI A3,3(A3) ; AND NEXT 3-WORD AREA ON LOCAL STACK
MOVE A4,@A2 ; GET DESCRIPTOR WORD
TLNN A4,$ARR ; DECODE TYPE
SKIPA A13,[ARGVAR,,ARGEXP]; TYPE 0 (VAR) OR TYPE 1 (EXP)
MOVE A13,[ARGARR,,ARGPRO]; TYPE 2 (ARR) OR TYPE 3 (PRO)
TLNN A4,$EXP ; DECIDE WHICH HALF WE NEED
MOVS A13,A13 ; LEFT HALF - SWAP HALVES
PUSHJ SP,(A13) ; EVALUATE ADDRESS INTO A13
TLNN A4,<$TYPE-$B> ; IS TYPE BOOLEAN ?
TLO A13,(Z 01,0) ; YES - FORTRAN TYPE CODE = 1
TLNN A4,<$TYPE-$I> ; IS TYPE INTEGER ?
TLO A13,(Z 02,0) ; YES - FORTRAN TYPE CODE = 2
TLNN A4,<$TYPE-$R> ; IS TYPE REAL ?
TLO A13,(Z 04,0) ; YES - FORTRAN TYPE CODE = 4
TLNN A4,<$TYPE-$LR> ; IS TYPE LONG REAL ?
TLO A13,(Z 10,0) ; YES - FORTRAN TYPE CODE = 8
IOR A13,LINKDL-2(DL); SET NOOP IF F40
PUSH SP,A13 ; PUSH PARAMETER WORD ONTO STACK
AOJL A1,CALL06 ; REPEAT FOR EACH PARAMETER
CALL07: PUSH SP,[POPJ SP,] ; PUSH RETURN INSTRUCTION (FOR F40)
PUSH SP,DB ; SAVE ENVIRONMENT
PUSH SP,DL ; ..
MOVEI A1,@LINKDL-1(DL); GET ADDRESS OF ARRAY-WORD POINTER
AOS A2,(A1) ; GET DELOCATED ADDRESS OF COUNT WORD
MOVEI A2,@A2 ; CONVERT TO ABSOLUTE ADDRESS
AOS AX,A2 ; POINT AX TO FORTRAN ARG BLOCK
HLL A2,-1(A2) ; GET AOBJN WORD OVER ARG BLOCK
JUMPGE A2,CALL09 ; JUMP IF NO PARAMETERS TO FORTRAN
CALL08: MOVE A3,(A2) ; GET A FORTRAN DESCRIPTOR WORD
HRRI A3,@A3 ; CONVERT TO ABSOLUTE ADDRESS
TLZE A3,17 ; MAKE SURE INDEX FIELD IS ZERO
MOVEM A3,(A2) ; UPDATE ADDRESS IF DYNAMIC
AOBJN A2,CALL08 ; REPEAT FOR EACH PARAMETER
CALL09: MOVEI A2,(SP) ; GET ADDRESS OF TOP-OF-STACK
PUSH SP,A2 ; AND REMEMBER IT
PUSHJ SP,@-1(A1) ; **** CALL FORTRAN ROUTINE ****
POP SP,A2 ; RETURN HERE FROM FORTRAN ROUTINE
CAIE A2,(SP) ; HAS STACK BEEN SHIFTED ?
LIBERR 6,0 ; YES - VERY FATAL
POP SP,DL ; RESTORE ENVIRONMENT
POP SP,DB ; ..
MOVEM A0,.EXIT+1(DL) ; STORE ANSWER (IF ANY)
MOVEM A1,.EXIT+2(DL) ; (2 WORDS IF LONG REAL)
CALL10: SOS A2,@LINKDL-1(DL); STEP ARRAY WORD POINTER BACK ONE
SKIPGE A1,@A2 ; PICK UP A WORD
JRST CALL15 ; NEGATIVE MEANS BLOCK POINTER
HRRZ A3,(A1) ; GET ALGOL BASE ADDRESS
SOJ A3,.+1 ; (MINUS 1, FOR "PUSH")
HLRZ A4,(A1) ; AND FORTRAN BASE ADDRESS
MOVE A0,-2(A4) ; GET WORDS PER ELEMENT
CALL11: MOVEI A5,2(A1) ; GET ADDRESS OF TABLE
PUSH A3,(A4) ; COPY ONE WORD BACK TO ALGOL ARRAY
CAIN A0,2 ; TWO WORDS PER ELEMENT ?
PUSH A3,1(A4) ; YES - COPY OVER SECOND WORD
CALL12: ADD A4,2(A5) ; STEP TO NEXT FORTRAN ADDRESS
SOSLE 1(A5) ; ALL DONE FOR THIS SUBSCRIPT ?
JRST CALL11 ; NO - COPY NEXT ELEMENT
MOVE A6,0(A5) ; YES - RESET SUBSCRIPT RANGE
MOVEM A6,1(A5) ; TO (UB-LB)+1
SUB A4,-1(A5) ; STEP BACK OVER SUB-ARRAY
MOVEI A5,3(A5) ; STEP TO NEXT SUBSCRIPT
SKIPE (A5) ; ALL DONE ?
JRST CALL12 ; IF NOT, CONTINUE COPYING
SETZM A0 ; FLAG GIVING BACK SPACE
PUSHJ SP,GETOWN ; RETURN IT
JRST CALL10 ; REPEAT FOR NEXT ARRAY
CALL15: MOVEI A2,@A2 ; GET DESIRED TOP-OF-STACK
SUBI A2,(SP) ; GET CORRECTION TO SP
HRLI A2,(A2) ; GET CORRECTION IN LH ALSO
ADD SP,A2 ; ADJUST STACK POINTER
JRST .EXIT(DL) ; **** UNWIND BLOCK STRUCTURE ****
CALL20: MOVEI A2,@(SP) ; GET ADDRESS OF RETURN ADDRESS (+2)
SUBI A2,2(SP) ; STEP STACK POINTER BACK OVER THE
HRLI A2,(A2) ; CALL TO PARAM THAT WAS BUILT UP
ADD SP,A2 ; ON THE STACK
POPJ SP, ; AND RETURN TO CALLING PROGRAM
ARGVAR: JUMPGE A4,STATIC ; DYNAMIC VARIABLE ?
PUSH SP,A1 ; YES - SAVE CURRENT VALUES
PUSH SP,A2 ; OF A1,A2 AND A3
PUSH SP,A3 ; ..
XCTA @A3 ; TRY AND GET ADDRESS OF VARIABLE
HRRZ A13,A2 ; SUCCESS - GET 23-BIT ADDRESS
CAIG A13,(SP) ; IN A13 (DELOCATED IF DYNAMIC,
CAIG A13,(DB) ; IN WHICH CASE WE NEED TO SET
JRST .+3 ; DB IN THE INDEX FIELD, AND
SUBI A13,(DB) ; SET THE RIGHT HALF OF A13
HRLI A13,DB ; TO THE OFFSET FOR THIS VARIABLE)
JRST ARGRET ; RESTORE A1,A2,A3,A4 & RETURN
STATIC: HLRZ A13,A4 ; GET DESCRIPTOR
ANDI A13,$STATUS ; MASK TO STATUS FIELD
CAIN A13,$FON ; AND IF FORMAL-BY-NAME
JRST ARGEXP ; TREAT AS A LOCAL (BY VALUE)
MOVEI A13,@A3 ; GET ACTUAL ADDRESS OF 3-WORD BLOCK
TLNE A4,$VAR1 ; LONG REAL ?
JUMPG DB,.+2 ; YES - SPECIAL IF KA10
SKIPA A13,(A13) ; GET F[0] (MOVE/DMOVE INSRUCTION)
MOVE A13,2(A13) ; LR ON KA10 - ADDRESS IS IN F[2]
TLZ A13,777760 ; CLEAR OPCODE & AC FIELDS
POPJ SP, ; AND RETURN
ARGEXP: PUSH SP,A1 ; ACTUAL ARGUMENT IS AN EXPRESSION
PUSH SP,A2 ; FIRST SAVE A1,A2 AND A3, AS EXPRESSION
PUSH SP,A3 ; COULD INVOLVE A PROCEDURE CALL
XCT @A3 ; EVALUATE EXPRESSION INTO A0,A1
MOVEI A3,@(SP) ; GET ADDRESS OF 3 WORD AREA ON LOCAL
MOVEM A0,0(A3) ; FIXED STACK, AND USE THIS TO STORE
MOVEM A1,1(A3) ; THE VALUE OF THE EXPRESSION
MOVE A13,(SP) ; GET ADDRESS OF PARAMETER
JRST ARGRET ; RESTORE A1,A2,A3,A4 & RETURN
ARGARR: PUSH SP,A1 ; SAVE CURRENT VALUES OF
PUSH SP,A2 ; A1,A2,A3 (DELOCATED, AS
PUSH SP,A3 ; GETOWN MAY SHIFT STACK)
MOVEI A1,@A3 ; GET STATIC ADDRESS OF DESCRIPTOR
HRLI A1,A3 ; AND SET A3 INTO INDEX FIELD
MOVE A2,1(A1) ; GET POINTER TO BOUND PAIRS
HLRE A0,A2 ; GET -(NO OF SUBSCRIPTS) IN A0
MOVEI A5,1 ; ASSUME ONE WORD PER ELEMENT
TLNE A4,$VAR1 ; LONG REAL ARRAY ?
MOVEI A5,2 ; YES - TWO WORDS PER ELEMENT
ARRAY1: HRR A1,(A1) ; GET ADDRESS OF 0'TH ELEMENT
MOVE A3,(A2) ; GET LOWER SUBSCRIPT BOUND
HRRI A1,@A1 ; "ADD" OFFSET TO A1
SUB A3,1(A2) ; -(UB-LB)
MOVN A3,A3 ; +(UB-LB)
AOJ A3,.+1 ; (UB-LB)+1
PUSH SP,A3 ; SAVE RANGE OF SUBSCRIPT
IMUL A5,A3 ; AND ADJUST SIZE
AOBJP A2,ARRAY2 ; LAST SUBSCRIPT ?
AOJA A2,ARRAY1 ; NO - REPEAT FOR NEXT
EDIT(064); Correct base address for long real arrays
ARRAY2: TLNE A4,$VAR1 ; [E064] LONG REAL ARRAY ?
ADD A1,-1(A2) ; [E064] YES - DOUBLE FINAL SUBSCRIPT
PUSH SP,A0 ; SAVE NUMBER OF SUBSCRIPTS
PUSH SP,A1 ; ADDRESS OF FIRST (ALGOL) ELEMENT
PUSH SP,A5 ; SIZE OF ARRAY
MOVN A0,A0 ; OVERHEAD = 3 WORDS PER DIMENSION
IMULI A0,3 ; PLUS THREE HOUSEKEEPING
ADDI A0,3(A5) ; GET SIZE OF OWN AREA NEEDED
PUSHJ SP,GETOWN ; AND ASK FOR IT FROM OTS
POP SP,A2 ; GET SIZE OF ARRAY AGAIN
POP SP,A0 ; AND ADDRESS OF FIRST ALGOL ELEMENT
HRRZM A0,(A1) ; SAVE IN LOCAL AREA
MOVEM A2,1(A1) ; SAVE TOTAL ARRAY SIZE
POP SP,A0 ; GET NUMBER OF DIMENSIONS
MOVEI A13,3(A1) ; INITIALIZE POINTER
ARRAY3: POP SP,A3 ; GET RANGE OF SUBSCRIPT
MOVEM A3,-1(A13) ; SAVE SUBSCRIPT RANGE
MOVEM A3,00(A13) ; AND CURRENT VALUE
IDIVI A2,(A3) ; GET SUB-ARRAY SIZE
MOVEM A2,+1(A13) ; AND SAVE THAT AS WELL
MOVEI A13,3(A13) ; INCREASE POINTER BY THREE
AOJL A0,ARRAY3 ; REPEAT FOR EACH SUBSCRIPT
SETZM -1(A13) ; SET FLAG WORD AT END
HRLM A13,(A1) ; ADDRESS OF FIRST (FORTRAN) ELEMENT
AOS A3,@LINKDL-1(DL); STEP POINTER TO ARRAY WORDS
MOVEM A1,@A3 ; SAVE ADDRESS OF OWN AREA
HRRZ A3,(A1) ; GET ALGOL BASE ADDRESS
HLRZ A4,(A1) ; AND FORTRAN BASE ADDRESS
MOVE A0,-2(A4) ; GET WORDS/ELEMENT
SOJ A0,.+1 ; A0 NOW NON-ZERO FOR TYPE LONG REAL
ARRAY4: MOVEI A5,2(A1) ; GET ADDRESS OF TABLE
MOVE A6,(A3) ; COPY ONE WORD OF THE ALGOL
MOVEM A6,(A4) ; ARRAY TO THE FORTRAN ARRAY
AOJ A3,.+1 ; STEP ALGOL ARRAY ADDRESS
JUMPE A0,ARRAY5 ; TWO WORDS PER ELEMENT ?
MOVE A6,(A3) ; YES - COPY OVER LOW ORDER
MOVEM A6,1(A4) ; WORD OF LONG REAL ITEM
AOJ A3,.+1 ; STEP ALGOL ADDRESS AGAIN
ARRAY5: ADD A4,2(A5) ; STEP TO NEXT FORTRAN ADDRESS
SOSLE 1(A5) ; FINISHED WITH THIS SUBSCRIPT ?
JRST ARRAY4 ; NO - COPY ANOTHER ELEMENT
MOVE A6,(A5) ; YES - GET SUBSCRIPT RANGE
MOVEM A6,1(A5) ; RESET SUBSCRIPT VALUE
SUB A4,-1(A5) ; STEP BACK OVER ENTIRE SUB-ARRAY
MOVEI A5,3(A5) ; STEP TO NEXT SUBSCRIPT
SKIPE (A5) ; LAST ONE ?
JRST ARRAY5 ; IF NOT, CARRY ON COPYING
ARGRET: POP SP,A3 ; RESTORE ORIGINAL VALUES
POP SP,A2 ; OF A1,A2 AND A3
POP SP,A1 ; ..
MOVE A4,@A2 ; GET DESCRIPTOR WORD AGAIN
POPJ SP,
ARGPRO: MOVEI A13,(A4) ; GET PROCEDURE ADDRESS INTO A13
POPJ SP, ; AND RETURN
FORER.::LIBERR 7,0 ; ALLOW FORTRAN TO HAVE ERRORS !
F40PMB: 0 ; PROFILE WORD
XWD 1,5 ; WORDS,,BYTES
SIXBIT /CALL*/
F10PMB: 0 ; PROFILE WORD
XWD 2,10 ; WORDS,,BYTES
SIXBIT /F10CAL/
SIXBIT /L*/
LIT
PRGEND
TITLE NEWSTRING - NEW BYTE STRING ROUTINE
; STRING PROCEDURE NEWSTRING(M,N); VALUE M,N; INTEGER M,N;
.EXIT=1
.M=4
.N=5
SEARCH ALGPRM,ALGSYS
LIBENT(320,NEWSTRING)
XWD 0,5
XWD $PRO!$S!$SIM,3
XWD $VAR!$I!$FOV,.M
XWD $VAR!$I!$FOV,.N
MOVE A0,.N(DL) ; BYTE SIZE
JUMPLE A0,.+2
CAILE A0,^D36 ; 1 <= N <= 36?
SYSER1 15,0 ; NO - COMPLAIN
MOVEI A1,^D36
IDIV A1,A0 ; NUMBER OF BYTES PER WORD
MOVE A0,.M(DL) ; NUMBER OF BYTES REQUIRED
JUMPE A0,NEW1 ; TREAT SPECIAL CASE OF NULL STRING
TLNE A0,777700 ; EXCEEDS MAXIMUM LENGTH?
SYSER1 2,0 ; YES - COMPLAIN
IDIVI A0,(A1)
JUMPE A1,.+2
ADDI A0,1 ; CALCULATE NUMBER OF WORDS REQUIRED
PUSHJ SP,GETCLR ; AND ASK FOR THEM (ZEROED)
MOVEM A1,.EXIT+1(DL) ; SET UP FIRST WORD OF RESULT
HRLZ A0,.N(DL)
LSH A0,6
TLO A0,440000
HLLM A0,.EXIT+1(DL) ; COMPLETE STR1
MOVE A0,.M(DL) ; GET NUMBER OF BYTES
TLO A0,STRDYN!STRPRC ; FLAG STRING DYNAMIC & RESULT OF PROC
MOVEM A0,.EXIT+2(DL) ; AND SET UP SECOND WORD OF RESULT
JRST .EXIT(DL)
NEW1: SETZM .EXIT+2(DL) ; SPECIAL CASE OF A NULL STRING
HRLZ A0,.N(DL)
LSH A0,6
MOVEM A0,.EXIT+1(DL)
JRST .EXIT(DL)
LIT
PRGEND
TITLE LENGTH - LENGTH OF STRING ROUTINE
; INTEGER PROCEDURE LENGTH(S); STRING S;
.EXIT=1
.S=3
SEARCH ALGPRM,ALGSYS
LIBENT(321,LENGTH)
XWD 0,5
XWD $PRO!$I!$SIM,2
XWD $VAR!$S!$FON,.S
XCT .S(DL) ; GET VALUE OF STRING
MOVEI A2,@A2
SKIPN STR1(A2) ; IS THIS A NULL STRING ?
TDZA A0,A0 ; YES - LENGTH IS ZERO
LDB A0,[
POINT 24,STR2(A2),35] ; NO - GET ITS LENGTH
MOVEM A0,.EXIT+1(DL) ; STORE RESULT
JRST .EXIT(DL)
LIT
PRGEND
TITLE SIZE - BYTE-SIZE OF STRING ROUTINE
; INTEGER PROCEDURE SIZE(S); STRING S;
.EXIT=1
.S=3
SEARCH ALGPRM,ALGSYS
LIBENT(326,SIZE)
XWD 0,5
XWD $PRO!$I!$SIM,2
XWD $VAR!$S!$FON,.S
XCT .S(DL) ; GET VALUE OF STRING
MOVEI A2,@A2 ; STATICISE
LDB A0,[
POINT 6,STR1(A2),11] ; GET BYTE-SIZE
MOVEM A0,.EXIT+1(DL) ; & RETURN IT
JRST .EXIT(DL)
LIT
PRGEND
TITLE DELETE - DELETE STRING ROUTINE
; PROCEDURE DELETE(S); STRING S;
.EXIT=1
.S=2
SEARCH ALGPRM,ALGSYS
LIBENT(322,DELETE)
XWD 0,4
XWD $PRO!$N!$SIM,2
XWD $VAR!$S!$FON,.S
XCT .S(DL) ; GET ADDRESS OF STRING
EDIT (133) ; AVOID STACK-SHIFT PROBLEMS
DEL1: ADDI A2,1 ; [E133]
MOVE A0,@A2 ; [E133]
SUBI A2,1 ; [E133]
TLNN A0,STRDYN ; DYNAMIC?
JRST .EXIT(DL) ; NO - LEAVE THIS ONE
HRRZ A1,@A2
JUMPE A1,DEL2 ; MAKE SURE THERE IS A BYTE STRING
MOVEI A0,0
PUSH SP,A2 ; SAVE ADDRESS
PUSHJ SP,GETOWN ; DELETE STRING
POP SP,A2 ; RESTORE ADDRESS
DEL2: MOVEI A2,@A2 ; [E133]
SETZM STR1(A2) ; CLEAR BYTE STRING POINTER
SETZM A0,STR2(A2) ; CLEAR SECOND WORD
JRST .EXIT(DL) ; EXIT
LIT
PRGEND
TITLE CONCAT - STRING CONCATENATION ROUTINE
SEARCH ALGPRM,ALGSYS
; STRING PROCEDURE CONCAT(S1,S2,...,Sn); STRING S1,S2,...,Sn;
.EXIT=1
.N=4 ; COUNT OF PARAMETERS
.W=5 ; WHERE IN STACK WE ARE
.F=6
.S=3
DEFINE REP(M,S,I),<
Q=0
V=S-I
REPEAT PRMMAX,<
IF2,<
Q=Q+1
V=V+I>
M(\Q,\V)>>
DEFINE DEC(A,B),<
IF2,<.S'A=B>>
DEFINE PAR(A,B),<
IF1,<BLOCK 1>
IF2,<XWD $VAR!$S!$FON,.S'A>>
REP(DEC,.F,.S)
LIBENT(325,CONCAT,.N)
XWD 0,3*PRMMAX+5 ; PL,,STACK-SIZE
XWD $PRO!$S!$SIM,PRMMAX+1; STRING PROCEDURE
REP(PAR,.F,.S) ; WITH A VARIABLE NUMBER OF PARAMETERS
SOSG A1,.N(DL) ; GET COUNT OF PARAMETERS
SYSER1 10,0 ; NONE - ERROR.
PUSH SP,A1 ; SAVE COUNT OF PARAMETERS
SETZM .EXIT+1(DL) ; INITIALIZE RESULT TO THE
SETZB A0,.EXIT+2(DL) ; NULL STRING
PUSH SP,A0 ; AND SET MAXIMUM BYTE-SIZE TO ZERO
MOVE A0,[XWD DL,.F] ; INITIALIZE INDIRECT POINTER
MOVEM A0,.W(DL) ; IN W
CONCA1: XCT @.W(DL) ; GET A STRING HEADER INTO A0,A1
SKIPN A0 ; IS IT A NULL STRING ?
SETZ A1, ; YES - SET LENGTH TO ZERO
MOVEI A2,@.W(DL) ; GET ACTUAL ADDRESS
MOVEM A0,STR1(A2) ; STORE BYTE POINTER
MOVEM A1,STR2(A2) ; AND LENGTH
LDB A0,[
POINT 6,STR1(A2),11] ; GET BYTE-SIZE INTO A0
LDB A1,[
POINT 24,STR2(A2),35] ; AND LENGTH INTO A1
CAMLE A0,(SP) ; IF THIS BYTE SIZE IS LARGEST
MOVEM A0,(SP) ; SO FAR, REMEMBER IT
ADDB A1,.EXIT+2(DL) ; ADD LENGTH INTO RUNNING TOTAL
MOVEI A2,.S ; THEN STEP .W TO POINT TO
ADDM A2,.W(DL) ; THE NEXT FORMAL PARAMETER
SOSLE .N(DL) ; COUNT DOWN PARAMETER COUNT
JRST CONCA1 ; REPEAT FOR EACH PARAMETER
POP SP,A3 ; GET BYTE-SIZE INTO A3
POP SP,.N(DL) ; AND RESTORE NUMBER OF PARAMETERS
TLO A1,STRDYN!STRPRC; MARK AS DYNAMIC, AND PROCEDURE RESULT
EXCH A1,.EXIT+2(DL) ; SAVE AS STR2 OF RESULT
JUMPE A1,CONCA7 ; RETURN IF LENGTH IS ZERO
MOVE A0,A1 ; GET NUMBER OF BYTES INTO A0
MOVEI A1,^D36 ; FIND OUT HOW MANY BYTES
IDIVI A1,(A3) ; FIT INTO A 36-BIT WORD
ADDI A0,-1(A1) ; AND HENCE HOW MANY WORDS
IDIVI A0,(A1) ; WILL BE NEEDED FOR THE STRING
ROT A3,-^D12 ; SHIFT BYTE-SIZE INTO BITS 6-11
TLO A3,440000 ; SET 'P' FIELD
MOVEM A3,.EXIT+1(DL) ; AND STORE LH OF STR1 OF RESULT
PUSHJ SP,GETCLR ; GET THE SPACE NEEDED
HRRM A1,.EXIT+1(DL) ; AND STORE ADDRESS IN STR1.
MOVE A1,.EXIT+1(DL) ; GET BYTE-POINTER TO RESULT
MOVEI A2,.F(DL) ; GET ADDRESS OF FIRST HEADER
SKIPA A3,.N(DL) ; GET NUMBER OF STRINGS
CONCA2: ADDI A2,.S ; STEP ON TO NEXT STRING
MOVE A4,STR1(A2) ; GET BYTE POINTER TO SOURCE
LDB A5,[
POINT 24,STR2(A2),35] ; GET LENGTH OF STRING
JUMPE A5,CONCA4 ; IGNORE IF NULL STRING
CONCA3: ILDB A0,A4 ; GET BYTE FROM SOURCE STRING
IDPB A0,A1 ; STORE IN DESTINATION STRING
SOJG A5,CONCA3 ; REPEAT FOR ENTIRE STRING
CONCA4: SOJG A3,CONCA2 ; REPEAT FOR EACH STRING
CONCA5: MOVNI A2,.S ; GET SIZE OF ENTRY
ADDB A2,.W(DL) ; COUNT W DOWN TO POINT TO HEADER
MOVEI A2,@A2 ; DELOCATE ADDRESS
MOVEI A1,@STR1(A2) ; GET ADDRESS OF STRING
MOVE A0,STR2(A2) ; GET LENGTH INTO A0
TLZE A0,STRDYN ; IF STRING IS NOT DYNAMIC
TLZN A0,STRPRC ; OR NOT RESULT OF A PROCEDURE
JRST CONCA6 ; LEAVE IT ALONE
TDZE A0,A0 ; CLEAR A0 AND UNLESS ALREADY ZERO
PUSHJ SP,GETOWN ; CALL GETOWN TO RETURN THE SPACE
CONCA6: SOSLE .N(DL) ; COUNT ONE MORE CHECKED
JRST CONCA5 ; REPEAT FOR EACH STRING
CONCA7: JRST .EXIT(DL) ; THEN RETURN
LIT
PRGEND
TITLE INSYMBOL - INPUT SYMBOL ROUTINE
; PROCEDURE INSYMBOL(I); INTEGER I;
.EXIT=1
.I=2
SEARCH ALGPRM,ALGSYS
LIBENT(401,INSYMBOL)
XWD 0,4
XWD $PRO!$N!$SIM,2
XWD $VAR!$I!$FON,.I
XCTA .I(DL) ; GET ADDRESS OF I
PUSH SP,A2
JSP AX,INCHAR ; INPUT CHARACTER
MOVE A0,A13
POP SP,A2 ; RESTORE ADDRESS.
XCT .I+1(DL) ; AND STORE IN I
JRST .EXIT(DL)
LIT
PRGEND
TITLE OUTSYMBOL - OUTPUT SYMBOL ROUTINE
; PROCEDURE OUTSYMBOL(N); VALUE N; INTEGER N;
.EXIT=1
.N=2
SEARCH ALGPRM,ALGSYS
LIBENT(402,OUTSYMBOL)
XWD 0,2
XWD $PRO!$N!$SIM,2
XWD $VAR!$I!$FOV,.N
MOVE A13,.N(DL) ; GET BYTE
MOVEI AX,.EXIT(DL)
JRST OUCHAR ; AND OUTPUT IT
LIT
PRGEND
TITLE NEXTSYMBOL - NEXT SYMBOL ROUTINE
; PROCEDURE NEXTSYMBOL(I); INTEGER I;
.EXIT=1
.I=2
SEARCH ALGPRM,ALGSYS
LIBENT(403,NEXTSYMBOL)
XWD 0,4
XWD $PRO!$N!$SIM,2
XWD $VAR!$I!$FON,.I
;
; Edit(1015) Evaluate parameter by NAME correctly.
;
XCTA .I(DL) ; [E1015] Get address of I
PUSH SP,A2 ; [E1015] Save over NXTBYT
PUSHJ SP,NXTBYT ; GET NEXT BYTE
IOERR 6,(A13) ; EOF - CHAN # IN A13
MOVE A0,A13 ; [E1015] Not EOF - byte in A13
POP SP,A2 ; [E1015] Get back address of I
XCT .I+1(DL) ; AND STORE IN I
JRST .EXIT(DL)
LIT
PRGEND
TITLE SKIPSYMBOL - SKIP SYMBOL ROUTINE
; PROCEDURE SKIPSYMBOL;
.EXIT=1
SEARCH ALGPRM,ALGSYS
LIBENT(404,SKIPSYMBOL)
XWD 0,1
XWD $PRO!$N!$SIM,1
MOVEI AX,.EXIT(DL)
JRST INCHAR ; INPUT BYTE AND IGNORE IT
LIT
PRGEND
TITLE BREAKOUTPUT - BREAK OUTPUT ROUTINE
; PROCDURE BREAKOUTPUT;
.EXIT=1
SEARCH ALGPRM,ALGSYS
LIBENT(405,BREAKOUTPUT)
XWD 0,1
XWD $PRO!$N!$SIM,1
MOVEI AX,.EXIT(DL)
JRST BRKCHR ; BREAK OUTPUT
LIT
PRGEND
TITLE SPACE - SPACE ROUTINE
; PROCEDURE SPACE(N); VALUE N; INTEGER N;
.EXIT=1
.N=2
.V=3
SEARCH ALGPRM,ALGSYS
LIBENT(406,SPACE,.V)
XWD 0,3
XWD $PRO!$N!$SIM,2
XWD $VAR!$I!$FOV,.N
MOVEI A0,1 ; SET DEFAULT
SOSE .V(DL) ; ANY ARGUMENT
MOVE A0,.N(DL) ; YES - GET IT
JUMPLE A0,SPACE2 ; IGNORE IF <= 0
SPACE1: MOVEI A13," "
JSP AX,OUCHAR ; OUTPUT SPACE
SOJN A0,SPACE1 ; REPEAT UNTIL FINISHED
SPACE2: JRST .EXIT(DL)
LIT
PRGEND
TITLE TAB - TAB ROUTINE
; PROCEDURE TAB(N); VALUE N; INTEGER N;
.EXIT=1
.N=2
.V=3
SEARCH ALGPRM,ALGSYS
LIBENT(407,TAB,.V)
XWD 0,3
XWD $PRO!$N!$SIM,2
XWD $VAR!$I!$FOV,.N
MOVEI A0,1 ; SET DEFAULT
SOSE .V(DL) ; ANY ARGUMENT?
MOVE A0,.N(DL) ; YES - GET IT
JUMPLE A0,TAB2 ; IGNORE IF <= 0
TAB1: MOVEI A13," "
JSP AX,OUCHAR ; OUTPUT TAB
SOJN A0,TAB1 ; REPEAT UNTIL FINISHED
TAB2: JRST .EXIT(DL)
LIT
PRGEND
TITLE NEWLINE - NEWLINE ROUTINE
; PROCEDURE NEWLINE(N); VALUE N; INTEGER N;
.EXIT=1
.N=2
.V=3
SEARCH ALGPRM,ALGSYS
LIBENT(410,NEWLINE,.V)
XWD 0,3
XWD $PRO!$N!$SIM,2
XWD $VAR!$I!$FOV,.N
MOVEI A0,1 ; SET DEFAULT
SOSE .V(DL) ; ANY ARGUMENT
MOVE A0,.N(DL) ; YES - GET IT
JUMPLE A0,NEWL2 ; IGNORE IF <= 0
NEWL1: MOVEI A13,CR
JSP AX,OUCHAR ; CARRIAGE RETURN
MOVEI A13,LF
JSP AX,OUCHAR ; LINE FEED
SOJN A0,NEWL1 ; REPEAT UNTIL FINISHED
TLNE A11,TTYDEV ; TTY TYPE DEVICE?
JSP AX,BRKCHR ; YES - BREAK OUTPUT
NEWL2: JRST .EXIT(DL)
LIT
PRGEND
TITLE PAGE - PAGE ROUTINE
; PROCEDURE PAGE(N); VALUE N; INTEGER N;
.EXIT=1
.N=2
.V=3
SEARCH ALGPRM,ALGSYS
LIBENT(411,PAGE,.V)
XWD 0,3
XWD $PRO!$N!$SIM,2
XWD $VAR!$I!$FOV,.N
MOVEI A13,CR
JSP AX,OUCHAR ; CARRIAGE RETURN
MOVEI A13,LF
JSP AX,OUCHAR ; LINE FEED
MOVEI A0,1 ; SET DEFAULT
SOSE .V(DL) ; ANY ARGUMENT
MOVE A0,.N(DL) ; YES - GET IT
JUMPLE A0,PAGE2 ; IGNORE IF <= 0
PAGE1: MOVEI A13,FF
JSP AX,OUCHAR ; FORM FEED
SOJN A0,PAGE1 ; REPEAT UNTIL FINISHED
TLNE A11,TTYDEV ; TTY TYPE DEVICE?
JSP AX,BRKCHR ; YES - BREAK OUTPUT
PAGE2: JRST .EXIT(DL)
LIT
PRGEND
TITLE READ - READ ROUTINE
; PROCEDURE READ(A); (INTEGER/REAL/LONG REAL/BOOLEAN/STRING) A;
SEARCH ALGPRM,ALGSYS
DEFINE REP(M,A,I)
<Q=0
R=A-I
REPEAT PRMMAX, <
IF2,
<Q=Q+1
R=R+I>
M \Q,\R>>
DEFINE DECL(A,B)
<IF2, <.WV'A=B>>
DEFINE PAR(A,B)
<IF1, <Z>
IF2, <XWD $VAR!$WV!$FON,.WV'A>>
.EXIT=1
.V1=2
.V2=3
REP DECL,4,3
LIBENT(412,READ,.V1)
XWD 0,3*PRMMAX+3
XWD $PRO!$N!$SIM,PRMMAX+1
REP PAR,4,3
SOSN A5,.V1(DL) ; CHECK NUMBER OF PARAMETERS
SYSER1 10,0 ; NONE
MOVE A1,PRGLNK(DL) ; GET PROGRAM LINK
SUBI A1,1(A5) ; MOVE BEFORE FIRST ACTUAL PARAMETER
MOVEM A1,.V1(DL) ; AND SAVE IN V1
MOVN A5,A5
HRLZI A5,(A5)
HRRI A5,.WV1(DL) ; MAKE COUNTER/POINTER TO FORMALS
SUBI A5,(DB) ; AND DELOCATE IT
READ12: MOVEM A5,.V2(DL) ; UPDATE FORMAL POINTER
AOS A1,.V1(DL) ; UPDATE ACTUAL POINTER
HLRZ A0,@A1
ANDI A0,$D!$KIND!$TYPE!$STAT
CAIN A0,$D!$VAR!$S!$REG
; DYNAMIC VARIABLE REGULAR STRING?
JRST READ3 ; YES - BYTE
ANDI A0,$TYPE ; GET TYPE
CAIN A0,$S
JRST READ4 ; STRING
MOVEI A2,2 ; SET UP FOR LONG REAL
CAIN A0,$LR
JRST READ1 ; LONG REAL
CAIE A0,$R
READ3: TDZA A2,A2 ; INTEGER/BOOLEAN
MOVEI A2,1 ; REAL
READ1: PUSH SP,A2 ; SAVE READ MODE
MOVE A5,.V2(DL) ; GET ADDRESS OF NEXT FORMAL
ADDI A5,(DB)
XCTA (A5)
EXCH A2,(SP) ; AND EXCHANGE THEM
PUSHJ SP,READ. ; READ NUMBER
JOV READOV ; [E060] TRAP OVERFLOW
READ2: POP SP,A2 ; RESTORE ADDRESS OF PARAMETER
AOS A5,.V2(DL) ; INCREMENT FORMAL ADDRESS
ADDI A5,(DB)
XCT (A5) ; AND STORE RESULT
READ13: AOS A5,.V2(DL)
AOBJN A5,READ12 ; CARRY ON IF MORE ACTUALS
JRST .EXIT(DL)
READ4: MOVE A5,.V2(DL) ; GET FORMAL ADDRESS
ADDI A5,(DB)
XCTA (A5)
PUSH SP,A2 ; AND SAVE IT
MOVEI A0,0 ; FOR DELETE
MOVEI A2,@A2 ; STATICISE
SKIPE A1,STR1(A2) ; OLD STRING
PUSHJ SP,GETOWN ; DELETE, IF EXISTS
MOVSI A0,400000
EDIT(035) ; DONT WASTE TIME CLEARING THE SPACE FIRST
PUSHJ SP,GETOWN ; [E035] FLEX GETOWN
HLRZ A0,-1(A1)
ADDI A0,-2(A1) ; UPPER BOUND OF SPACE OBTAINED
MOVEI A2,0 ; CLEAR BYTE COUNT
HRLI A1,440700
MOVE A3,A1 ; INITIAL BYTE POINTER
READ6: JSP AX,INCHAR
CAIE A13,"""" ; SEARCH FOR "
JRST READ6
READ7: JSP AX,INCHAR ; GET NEXT SYMBOL
CAIN A13,"""" ; "?
JRST READ9 ; YES
READ8: CAILE A0,(A3) ; NO - SAFE TO STORE?
JRST READ5 ; YES
CCORE1 ^D128 ; NO - SHIFT UP THE STACK
HRLZI A4,^D128
ADDM A4,-1(A1) ; AND UPDATE THE LENGTH WORD
ADDI A0,^D128 ; AND THE TOP ADDRESS
READ5: IDPB A13,A3 ; YES - STORE BYTE
AOJA A2,READ7 ; COUNT BYTES AND CONTINUE
;
; Edit(1017) Don't lose the character after end of string.
;
READ9: PUSHJ SP,NXTBYT ; [E1017] " found.
IOERR 6,(A13) ; [E1017] EOF - channel # in A13.
CAIE A13,"""" ; [E1017] another ?
JRST .+3 ; [E1017] No - so end of string
JSP AX,INCHAR ; [E1017] Yes - advance buffer pointer
JRST READ8 ; [E1017] .. and store byte.
POP SP,A4 ; FINISHED - RESTORE STRING ADDRESS
MOVEI A4,@A4
JUMPE A2,READ11 ; NULL STRING?
TLO A2,STRDYN
; NO - ADD CORRECT BITS TO COUNT
LRSTOR A1,STR1(A4) ; AND SET UP STRING WORDS
SUBI A0,(A3) ; REMAINING SPACE
JUMPE A0,READ14 ; FINISHED IF ALL USED (UNLIKELY!)
HRLZ A0,A0 ; MOVE TO LEFT HALF
MOVEM A0,1(A3) ; AND SET UP LENGTH OF REMAINDER
SUB A0,-1(A1)
MOVNM A0,-1(A1) ; SET UP LENGTH OF USED PORTION
MOVEI A1,2(A3) ; SET UP ADDRESS OF REMAINDER
READ10: MOVEI A0,0
PUSHJ SP,GETOWN ; DELETE REMAINDER
READ14: MOVE A5,.V2(DL)
ADDI A5,2
AOBJN A5,READ12 ; CARRY ON IF MORE
JRST .EXIT(DL)
READ11: SETZM STR1(A4) ; NULL STRING
SETZM STR2(A4)
JRST READ10 ; DELETE SPACE OBTAINED
EDIT(060); Trap fixed point overflow on data input
READOV: HLRZ A1,%CHAN(DB) ; [E060] GET CHANNEL NUMBER
IOERR 11,(A1) ; [E060] CAUSE CORRECT ERROR
LIT
PRGEND
TITLE INLINE - READ NEXT LINE FROM INPUT
; INTEGER PROCEDURE INLINE(S); STRING(S);
.EXIT=1
.CHAR=2
.S=3
SEARCH ALGPRM,ALGSYS
LIBENT(433,INLINE)
XWD 0,5
XWD $PRO!$I!$SIM,2
XWD $VAR!$S!$FON,.S
XCT 1,.S(DL) ; GET ADDRESS OF STRING
PUSH SP,A2 ; SAVE IT ON THE STACK
SETZB A0,A1 ; CLEAR COUNT
MOVSI A2,(POINT 7,A0) ; SET A2 TO A BYTE POINTER
INLIN1: JSP AX,INCHR0 ; [E145] READ NEXT CHARACTER
CAIL A13,40 ; CONTROL CHAR ?
JRST INLIN4 ; NO - ACCEPT IT
CAIN A13,15 ; CARRIAGE RETURN ?
JRST INLIN1 ; YES - IGNORE IT
CAIG A13,14 ; IS IT A TERMINATOR
CAIG A13,11 ; (FF=14, VT=13, LF=12)
JRST INLIN3 ; NO - ACCEPT CHAR
MOVEM A13,.CHAR(DL) ; SAVE TERMINATOR
SKIPN A2,A1 ; ANY CHARACTERS READ ?
JRST INLIN2 ; NO - EASY
EXCH A0,(SP) ; YES - STORE FINAL WORD
PUSH SP,A0 ; REPLACE HEADER ADDRESS
ADDI A2,4 ; ROUND UP CHAR COUNT
IDIVI A2,5 ; CONVERT TO # OF WORDS
MOVNI A0,-1(A2) ; GET -(# OF WORDS)
ADDI A0,-1(SP) ; GET BASE ADDRESS
SUBI A0,(DB) ; DELOCATE IT
HRLI A0,(<POINT 7,0(DB)>); AND FORM BYTE POINTER
HRLI A2,(A2) ; COPY COUNT TO L.H. OF A2
INLIN2: EXCH A2,(SP) ; SAVE COUNT, GET HEADER ADDRESS
XCT .S+1(DL) ; WRITE NEW STRING
POP SP,A2 ; RESTORE COUNT
SUB SP,A2 ; TIDY UP THE STACK
JRST .EXIT(DL) ; AND EXIT
INLIN3: CAIN A13,33 ; ALTMODE ?
JRST INLIN5 ; YES
CAIN A13,11 ; OR TAB ?
JRST INLIN6 ; YES
MOVSI A13,100(A13) ; NO - SAVE CONTROL CHAR
HRRI A13,"^" ; GET UP-ARROW
JSP AX,INLIN7 ; PLACE IN BUFFER
HLRZ A13,A13 ; GET CHAR AGAIN
INLIN4: CAIE A13,"[" ; IF CHARACTER IS A SQUARE
CAIN A13,"]" ; BRACKET (SPECIAL CASE)
JSP AX,INLIN7 ; PUT IT IN TWICE
CAIL A13,175 ; IS IT AN ESCAPE ?
INLIN5: MOVEI A13,"$" ; YES - SUBSTITUTE DOLLAR
INLIN6: MOVEI AX,INLIN1 ; SET TRANSFER ADDRESS
INLIN7: TLNE A2,760000 ; FILLED A COMPLETE WORD ?
JRST INLIN8 ; NO
EXCH A0,(SP) ; YES - PLACE IT ON THE STACK
PUSH SP,A0 ; REPLACE HEADER ADDRESS
MOVSI A2,(POINT 7,A0) ; AND RESET BYTE POINTER
SETZ A0, ; CLEAR JUNK CHARS
INLIN8: IDPB A13,A2 ; STORE CHARACTER IN A0
AOJA A1,(AX) ; AND GO READ NEXT
LIT
PRGEND
TITLE WRITE - WRITE STRING ROUTINE
; PROCEDURE WRITE(S); STRING(S);
.EXIT=1
.S=2
SEARCH ALGPRM,ALGSYS
LIBENT(413,WRITE)
XWD 0,4
XWD $PRO!$N!$SIM,2
XWD $VAR!$S!$FON,.S
XCT .S(DL) ; GET ARGUMENT
MOVEI A2,@A2
MOVEI A4,0 ; CLEAR SPECIAL MODE FLAG
MOVEI AX,WRIT5 ; SET LINK
WRIT1: MOVE A3,STR1(A2) ; GET BYTE-POINTER
LDB A1,[
POINT 24,STR2(A2),35] ; GET STRING LENGTH
WRIT2: SOJL A1,.EXIT(DL) ; DECREMENT BYTE COUNT - EXHAUSTED?
ILDB A13,A3 ; NO - LOAD UP BYTE
JUMPE A13,WRIT2 ; IGNORE NULLS
JRST (AX)
WRIT4: JSP AX,WRIT2 ; GET NEXT BYTE
WRIT5: CAIN A13,"[" ; LEFT SQUARE BRACKET?
XCT [
AOJA A4,WRIT4
AOJA A4,WRIT4
SOJA A4,WRIT6]+1(A4)
CAIN A13,"]" ; NO - RIGHT SQUARE BRACKET?
XCT [
AOJA A4,WRIT6
SOJA A4,WRIT4
SOJA A4,WRIT6]+1(A4)
XCT [
AOJA A4,WRIT6
JRST WRIT6
JRST WRIT8]+1(A4) ; NO
WRIT6: MOVEI AX,WRIT4
JRST OUCHAR ; OUTPUT CHARACTER
WRIT7: TDZA A5,A5 ; CLEAR COUNT (SUBSEQUENT TIMES)
WRIT8: TDZA A5,A5 ; CLEAR COUNT (FIRST TIME)
WRIT9: JSP AX,WRIT2 ; GET NEXT CHARACTER
CAIL A13,"0"
CAIL A13,"0"+^D10 ; DIGIT?
JRST WRIT11 ; NO
JUMPL A5,WRIT9 ; YES - IGNORE IF OVERFLOWED
IMULI A5,^D10 ; MULTIPLY BY TEN
JOV WRIT10 ; AND CHECK FOR OVERFLOW
ADDI A5,-"0"(A13) ; ADD IN DIGIT
JOV WRIT10 ; AND CHECK AGAIN
JRST WRIT9 ; CARRY ON
WRIT10: MOVNI A5,1 ; FLAG OVERFLOW
JRST WRIT9
WRIT11: CAIN A13,"]" ; RIGHT SQUARE BRACKET?
SOJA A4,WRIT4 ; YES
JUMPG A5,WRIT12 ; NO - GOT A NUMBER?
AOJE A5,WRIT9 ; NO - SORT IT OUT
WRIT12: ANDI A13,137 ; CONVERT LOWER CASE TO UPPER
CAIN A13,"S"
JRST WRIT18 ; SPACE
CAIN A13,"T"
JRST WRIT17 ; TAB
CAIN A13,"P"
JRST WRIT15 ; PAGE
CAIE A13,"C"
CAIN A13,"N"
JRST WRIT13 ; NEWLINE
CAIE A13,"B"
JRST WRIT7 ; RUBBISH
JRST WRIT20 ; BREAK
WRIT13: MOVEI A13,CR ; NEWLINE
JSP AX,OUCHAR
MOVEI A13,LF
JSP AX,OUCHAR
SOJG A5,WRIT13
WRIT14: TLNE A11,TTYDEV ; TTY TYPE DEVICE?
WRIT20: JSP AX,BRKCHR ; YES - BREAK OUTPUT
JRST WRIT9
WRIT15: MOVEI A13,CR ; PAGE
JSP AX,OUCHAR
MOVEI A13,LF
JSP AX,OUCHAR
WRIT16: MOVEI A13,FF
JSP AX,OUCHAR
SOJG A5,WRIT16
JRST WRIT14
WRIT17: SKIPA A7,[" "] ; TAB
WRIT18: MOVEI A7," " ; SPACE
WRIT19: MOVE A13,A7
JSP AX,OUCHAR
SOJG A5,WRIT19
JRST WRIT9
LIT
PRGEND
TITLE PRINT NUMBER ROUTINE
; PROCEDURE PRINT(I,M,N); VALUE I,M,N; INTEGER I,M,N;
; PROCEDURE PRINT(X,M,N); VALUE X,M,N; REAL X; INTEGER M,N;
; PROCEDURE PRINT(D,M,N); VALUE D,M,N; LONG REAL D; INTEGER M,N;
.EXIT=1
.IXD=2
.M=4
.N=5
.V=6
SEARCH ALGPRM,ALGSYS
LIBENT(414,PRINT,.V)
XWD 0,6
XWD $PRO!$N!$SIM,4
XWD $VAR!$WA!$FOV,.IXD
XWD $VAR!$I!$FOV,.M
XWD $VAR!$I!$FOV,.N
SOSE A5,.V(DL)
JRST PRIN1(A5) ; BRANCH ON NUMBER OF PARAMETERS
PRIN1: SYSER1 10,0 ; 0
SETZM .M(DL) ; 1
SETZM .N(DL) ; 2
MOVM A3,.M(DL)
MOVM A4,.N(DL) ; GET M,N
EDIT(103); Allow for stacked call to PRINT
MOVEI A1,@PRGLNK(DL) ; [E103] GET PROGRAM LINK
SUBI A1,(A5) ; AND LOCATE FIRST PARAMETER
HLRZ A0,(A1)
ANDI A0,$D!$KIND!$TYPE!$STAT
MOVEI A2,1 ; SET REAL MODE
CAIN A0,$D!$VAR!$S!$REG
; DYNAMIC VARIABLE REGULAR STRING?
SOJA A2,PRIN2 ; YES - BYTE
ANDI A0,$TYPE ; GET ITS TYPE
CAIN A0,$I
SOJA A2,PRIN2 ; INTEGER
CAIN A5,2 ; TWO PARAMETERS?
EXCH A3,A4 ; YES - SWAP M AND N
CAIE A0,$R
MOVEI A2,2 ; LONG REAL
PRIN2: LRLOAD A0,.IXD(DL) ; LOAD UP FIRST PARAMETER
PUSHJ SP,PRINT. ; AND PRINT IT
JRST .EXIT(DL)
LIT
PRGEND
TITLE READOCTAL - READ OCTAL ROUTINE
; PROCEDURE READOCTAL(A); (INTEGER/REAL/LONG REAL/BOOLEAN) A;
.EXIT=1
.A=2
SEARCH ALGPRM,ALGSYS
LIBENT(415,READOCTAL)
XWD 0,4
XWD $PRO!$N!$SIM,2
XWD $VAR!$AB!$FON,.A
XCTA .A(DL) ; GET ADDRESS OF A
PUSH SP,A2 ; AND SAVE IT
MOVE A1,PRGLNK(DL) ; GET PROGRAM LINK
HLRZ A0,-1(A1)
ANDI A0,$TYPE ; GET TYPE
CAIN A0,$LR ; LONG REAL?
JRST RDOCT3 ; YES
RDOCT1: PUSHJ SP,RDOCT ; READ OCTAL NUMBER
RDOCT2: POP SP,A2 ; RESTORE ADDRESS OF A
XCT .A+1(DL) ; AND STORE RESULT
JRST .EXIT(DL)
RDOCT3: PUSHJ SP,RDOCT ; READ HIGH ORDER WORD
PUSH SP,A0 ; AND SAVE IT
PUSHJ SP,RDOCT ; READ LOW ORDER WORD
MOVE A1,A0
POP SP,A0 ; RESTORE LOW ORDER WORD
JRST RDOCT2
LIT
PRGEND
TITLE PRINTOCTAL - PRINT OCTAL ROUTINE
; PROCEDURE PRINTOCTAL(A); VALUE A; (INTEGER/REAL/LONG REAL/BOOLEAN) A;
.EXIT=1
.A=2
SEARCH ALGPRM,ALGSYS
LIBENT(416,PRINTOCTAL)
XWD 0,4
XWD $PRO!$N!$SIM,2
XWD $VAR!$AB!$FOV,.A
MOVE A1,.A(DL) ; GET VALUE OF A
MOVE A2,PRGLNK(DL) ; GET PROGRAM LINK
HLRZ A2,-1(A2)
ANDI A2,$TYPE ; GET TYPE
CAIN A2,$LR ; LONG REAL?
JRST PROCT1 ; YES
PUSHJ SP,PROWD ; NO - PRINT WORD
JRST .EXIT(DL)
PROCT1: PUSH SP,.A+1(DL) ; SAVE LOW ORDER WORD
PUSHJ SP,PROWD ; PRINT HIGH ORDER WORD
MOVEI A13," "
JSP AX,OUCHAR ; SPACE
POP SP,A1 ; RESTORE LOW ORDER WORD
PUSHJ SP,PROWD ; AND PRINT IT
JRST .EXIT(DL)
PROWD: MOVEI A13,"%" ; PRINT OCTAL WORD
JSP AX,OUCHAR ; "%"
MOVS A1,A1
PUSHJ SP,PROCT ; PRINT HIGH HALF WORD
MOVS A1,A1
JRST PROCT ; PRINT LOW HALF WORD
LIT
PRGEND
TITLE INPUT/OUTPUT - INPUT/OUTPUT CHANNEL ROUTINES
; PROCEDURE INPUT(N,S,M,B,L); VALUE N,M,B,L; INTEGER N,M,B; STRING S; LABEL L;
; PROCEDURE OUTPUT(N,S,M,B,L); VALUE N,M,B,L; INTEGER N,M,B; STRING S; LABEL L;
.EXIT=1
.IO=2 ; IO FLAG
.N=3 ; CHANNEL NUMBER
.S=4 ; DEVICE NAME/LOGICAL STRING
.M=7 ; MODE
.B=10 ; NUMBER OF BUFFERS
.L=11
.V=14
SEARCH ALGPRM,ALGSYS
LIBENT(417,INPUT,.V)
XWD 0,14
XWD $PRO!$N!$SIM,6
XWD $VAR!$I!$FOV,.N
XWD $VAR!$S!$FON,.S
XWD $VAR!$IB!$FOV,.M
XWD $VAR!$I!$FOV,.B
XWD $VAR!$L!$FOV,.L
SETZM .IO(DL) ; FLAG AS INPUT
JRST IO1
LIBENT(420,OUTPUT,.V)
XWD 0,14
XWD $PRO!$N!$SIM,6
XWD $VAR!$I!$FOV,.N
XWD $VAR!$S!$FON,.S
XWD $VAR!$IB!$FOV,.M
XWD $VAR!$I!$FOV,.B
XWD $VAR!$L!$FOV,.L
MOVEI A0,1
MOVEM A0,.IO(DL) ; FLAG AS OUTPUT
IO1: SOSE A1,.V(DL)
IO2: JRST IO2(A1) ; BRANCH ON NUMBER OF PARAMETERS
SYSER1 10,0 ; 0,1
SETZM .M(DL) ; 2
SETZM .B(DL) ; 3
SETZM .L(DL) ; 4
SKIPL A1,.N(DL) ; GET CHANNEL NUMBER
CAIL A1,40 ; 0 <= N < 40?
IOERR 14,(A1) ; NO - COMPLAIN
CAIGE A1,20 ; LOGICAL CHANNEL?
JRST IO3 ; NO
XCTA .S(DL) ; YES - GET ADDRESS OF STRING
MOVE A0,A2
MOVE A1,.N(DL) ; RESTORE CHANNEL NUMBER
MOVE A2,.IO(DL)
PUSHJ SP,INPT(A2) ; AND OPEN LOGICAL DEVICE
JRST IO6 ; [E124] GO TEST FOR ERRORS
IO3: XCT .S(DL) ; PHYSICAL DEVICE - GET STRING ADDRESS
MOVEI A2,@A2 ; STATICISE IT
LDB A0,[
POINT 24,STR2(A2),35] ; GET ITS LENGTH
CAIL A0,6
MOVEI A0,6 ; ONLY SIX BYTES REQUIRED
JUMPE A0,IO5 ; NO NAME - FAILS LATER ON
MOVE A5,A0 ; BYTE INDEX
MOVEI A0,0 ; NAME ACCUMULATOR
MOVSI A6,(POINT 6,A0,)
; SET UP BYTE POINTER
MOVEI A7,1 ; BYTE NUMBER
MOVE A4,STR1(A2) ; GET BYTE POINTER TO STRING
IO4: ILDB A2,A4 ; LOAD BYTE
SUBI A2,40
JUMPL A2,IO5 ; TOO LOW
CAILE A2,132
JRST IO5 ; TOO HIGH
CAIL A2,100 ; LOWER CASE ALPHA?
SUBI A2,40 ; YES - RECODE TO UPPER CASE ALPHA
IDPB A2,A6 ; INSERT SIXBIT BYTE
CAIE A7,(A5) ; FINISHED?
AOJA A7,IO4 ; NO
IO5: MOVE A1,.N(DL) ; GET CHANNEL NUMBER
HRL A1,.B(DL) ; GET NUMBER OF BUFFERS
MOVE A2,.M(DL) ; GET MODE
MOVE A3,.IO(DL)
PUSHJ SP,INPT(A3) ; AND GO TO INPT OR OUTPT
EDIT(124); Remember A1 not preserved !
IO6: JUMPE A1,.EXIT(DL) ; [E124] RETURN IF NO ERROR
MOVEM A1,.IO(DL) ; [E124] OTHERWISE SAVE IOERR
SKIPE A2,.L(DL) ; IF HE GAVE AN ERROR-LABEL
XCT .L(DL) ; ELABORATE IT
JUMPN A2,(A2) ; GOTO ERR (UNLESS IT'S AN OUT OF RANGE SWITCH)
XCT .IO(DL) ; [E124] OTHERWISE REPORT ERROR
LIT
PRGEND
TITLE SELIN/SELOUT - SELECT INPUT/OUTPUT ROUTINES
; PROCEDURE SELECTINPUT(N); VALUE N; INTEGER N;
; PROCEDURE SELECTOUTPUT(N); VALUE N; INTEGER N;
.EXIT=1
.IO=2
.N=3
SEARCH ALGPRM,ALGSYS
LIBENT(421,SELECTINPUT)
XWD 0,3
XWD $PRO!$N!$SIM,2
XWD $VAR!$I!$FOV,.N
MOVEI A3,0 ; FLAG AS SELIN
JRST SEL1
LIBENT(422,SELECTOUTPUT)
XWD 0,3
XWD $PRO!$N!$SIM,2
XWD $VAR!$I!$FOV,.N
MOVEI A3,1 ; FLAG AS SELOUT
SEL1: MOVE A1,.N(DL) ; GET ARGUMENT
CAML A1,[-1]
CAIL A1,40 ; -1 <= N < 40?
IOERR 14,(A1) ; NO - COMPLAIN
PUSHJ SP,SELIN(A3) ; YES - SELECT RELEVANT INPUT/OUTPUT CHANNEL
JRST .EXIT(DL)
LIT
PRGEND
TITLE INCHAN/OUTCHAN - INPUT/OUTPUT CHANNEL ROUTINES
; INTEGER PROCEDURE INCHAN;
; INTEGER PROCEDURE OUTCHAN;
.EXIT=1
.IO=2
SEARCH ALGPRM,ALGSYS ; SEARCH PARAMETER-FILE.
LIBENT(316,INCHAN)
XWD 0,2
XWD $PRO!$I!$SIM,1
MOVEI A1,0 ; FLAG AS INCHAN
JRST INCH1
LIBENT(317,OUTCHAN)
XWD 0,2
XWD $PRO!$I!$SIM,1
MOVEI A1,1 ; FLAG AS OUTCHAN
INCH1: XCT [
HLRE A0,%CHAN(DB)
HRRE A0,%CHAN(DB)](A1)
MOVEM A0,.IO(DL) ; CURRENT INPUT/OUTPUT CHANNEL
JRST .EXIT(DL)
LIT
PRGEND
TITLE RELEASE - RELEASE ROUTINE
; PROCEDURE RELEASE(N); VALUE N; INTEGER N;
.EXIT=1
.N=2
SEARCH ALGPRM,ALGSYS
LIBENT(423,RELEASE)
XWD 0,2
XWD $PRO!$N!$SIM,2
XWD $VAR!$I!$FOV,.N
SKIPL A1,.N(DL) ; GET ARGUMENT
CAIL A1,40 ; 0 <= N < 40?
IOERR 14,(A1) ; NO - COMPLAIN
PUSHJ SP,RELESE ; YES - RELEASE RELEVANT CHANNEL
IOERR 13,(A1) ; CHANNEL NOT IN USE
JRST .EXIT(DL)
LIT
PRGEND
TITLE OPENFILE - OPEN FILE ROUTINE
; PROCEDURE OPENFILE(N,S,P,PP,L,I); VALUE N,P,PP,L; INTEGER N,I; STRING S;
; LABEL L; BOOLEAN P,PP;
.EXIT=1
.N=2
.S=3
.P=6
.PP=7
.L=10
.I=13
.LU=16
.V=17
SEARCH ALGPRM,ALGSYS
LIBENT(424,OPENFILE,.V)
XWD 0,17
XWD $PRO!$N!$SIM,7
XWD $VAR!$I!$FOV,.N
XWD $VAR!$S!$FON,.S
XWD $VAR!$IB!$FOV,.P
XWD $VAR!$IB!$FOV,.PP
XWD $VAR!$L!$FOV,.L
XWD $VAR!$I!$FON,.I
SOSE A1,.V(DL)
OPF0: JRST OPF0(A1) ; BRANCH ON NUMBER OF PARAMETERS
SYSER1 10,0 ; 0,1
SETZM .P(DL) ; 2
SETZM .PP(DL) ; 3
SETZM .L(DL) ; 4
SETZM .I(DL) ; 5
SKIPL A1,.N(DL) ; GET CHANNEL NUMBER
CAIL A1,20 ; 0 <= N < 20?
IOERR 14,(A1) ; NO - COMPLAIN
XCT .S(DL) ; GET ADDRESS OF STRING
MOVEM A2,.LU(DL) ; AND SAVE IT
SKIPE A2,.L(DL) ; IF HE GAVE A LABEL
XCT .L(DL) ; EVALUATE IT
PUSH SP,A2 ; AND SAVE IT
SKIPE .I(DL) ; IF HE GAVE A STATUS-WORD
XCTA .I(DL) ; EVALUATE ITS ADDRESS
PUSH SP,A2 ; AND SAVE THAT
MOVE A2,.LU(DL) ; RESTORE ADDRESS OF STRING
MOVEI A2,@A2 ; STATICISE IT
LDB A0,[
POINT 24,STR2(A2),35] ; GET ITS LENGTH
MOVE A4,STR1(A2) ; AND SAVE BYTE POINTER
SETZB A5,A6 ; CLEAR FILE AND EXTENSION
JUMPE A0,OPF5 ; NULL STRING?
MOVE A7,[
POINT 6,A5,] ; BYTE POINTER FOR FILE NAME
MOVEI A10,1 ; BYTE INDEX
OPF1: PUSHJ SP,OPF6 ; GET NEXT BYTE
CAIN A2,'.' ; POINT?
AOJA A10,OPF3 ; YES
IDPB A2,A7 ; PLANT BYTE IN NAME
CAIGE A10,6 ; NAME FULL?
AOJA A10,OPF1 ; NO - KEEP GOING
OPF2: PUSHJ SP,OPF6 ; SCAN FOR POINT
CAIE A2,'.'
AOJA A10,OPF2
ADDI A10,1
OPF3: MOVE A7,[
POINT 6,A6,] ; BYTE POINTER FOR FILE EXTENSION
MOVEI A11,3 ; BYTE COUNT
OPF4: PUSHJ SP,OPF6 ; GET NEXT BYTE
IDPB A2,A7 ; AND PLANT IT IN EXTENSION
SOJE A11,OPF5 ; ANY MORE EXTENSION?
AOJA A10,OPF4 ; NO - KEEP GOING
EDIT(); FIX STACK ON RETURN FROM OPF6
OPF5A: POP SP,(SP) ; [E037] STEP BACK OVER RETURN ADDRESS
OPF5: MOVE A1,.N(DL) ; RESTORE CHANNEL NUMBER
LRLOAD A2,A5 ; LOAD FILE NAME AND EXTENSION
HRLZ A4,.P(DL)
LSH A4,11 ; PROTECTION
MOVE A5,.PP(DL) ; PROJECT-PROGRAMMER
PUSHJ SP,OPFILE ; AND OPEN FILE
POP SP,A2 ; GET ADDR OF I (OR 0)
POP SP,A3 ; GET LABEL (OR 0)
SKIPN A0, ; ERROR ?
JRST .EXIT(DL)
SUBI A0,100 ; ERR-CODE HAS 100 ADDED TO IT BY OTS
SKIPE .I(DL) ; YES - I ?
XCT .I+1(DL) ; YES - PUT ERROR-CODE IN IT
EDIT(020) ; FORLAB NEEDS ADDRESS IN A2, NOT A3 !
SKIPE A2,A3 ; [E020] IS THERE AN ERROR EXIT ?
JRST (A2) ; [E020] IF SO, TAKE IT
IOERR 5,(A1) ; ELSE GIVE ERROR MESSAGE
OPF6: CAMLE A10,A0 ; GET SIXBIT BYTE SUBROUTINE
JRST OPF5A ; [E037] NONE LEFT - ERROR RETURN
ILDB A2,A4 ; AND GET NEXT BYTE
SUBI A2,40
JUMPL A2,OPF7 ; TOO LOW
CAILE A2,132
JRST OPF7 ; TOO HIGH
CAIL A2,100 ; LOWER CASE ALPHA?
SUBI A2,40 ; YES - RECODE TO UPPER CASE ALPHA
POPJ SP,0
OPF7: MOVEI A2,0
POPJ SP,0
LIT
PRGEND
TITLE CLOSEFILE - CLOSEFILE ROUTINE
; PROCEDURE CLOSEFILE(N); VALUE N; INTEGER N;
.EXIT=1
.N=2
SEARCH ALGPRM,ALGSYS
LIBENT(425,CLOSEFILE)
XWD 0,2
XWD $PRO!$N!$SIM,2
XWD $VAR!$I!$FOV,.N
SKIPL A1,.N(DL) ; GET ARGUMENT
CAIL A1,40 ; 0 <= N < 40?
IOERR 14,(A1) ; NO - COMPLAIN
PUSHJ SP,CLFILE ; YES - CLOSE RELEVANT FILE
JRST .EXIT(DL)
LIT
PRGEND
TITLE TRANSFILE - TRANSFER FILE ROUTINE
; PROCEDURE TRANSFILE;
.EXIT=1
SEARCH ALGPRM,ALGSYS
LIBENT(426,TRANSFILE)
XWD 0,1
XWD $PRO!$N!$SIM,1
PUSHJ SP,XFILE ; TRANSFER FILE
JRST .EXIT(DL)
LIT
PRGEND
TITLE BACKSPACE - MAGNETIC TAPE BACKSPACE ROUTINE
; PROCEDURE BACKSPACE(N); VALUE N; INTEGER N;
.EXIT=1
.N=2
SEARCH ALGPRM,ALGSYS
LIBENT(427,BACKSPACE)
XWD 0,2
XWD $PRO!$N!$SIM,2
XWD $VAR!$I!$FOV,.N
SKIPL A1,.N(DL) ; GET CHANNEL NUMBER
CAIL A1,20 ; 0 <= N < 20?
IOERR 14,(A1) ; NO - COMPLAIN
PUSHJ SP,BSPACE
JRST .EXIT(DL)
LIT
PRGEND
TITLE ENDFILE - MAGNETIC TAPE ENDFILE ROUTINE
; PROCEDURE ENDFILE(N); VALUE N; INTEGER N;
.EXIT=1
.N=2
SEARCH ALGPRM,ALGSYS
LIBENT(430,ENDFILE)
XWD 0,2
XWD $PRO!$N!$SIM,2
XWD $VAR!$I!$FOV,.N
SKIPL A1,.N(DL) ; GET CHANNEL NUMBER
CAIL A1,20 ; 0 <= N < 20?
IOERR 14,(A1) ; NO - COMPLAIN
PUSHJ SP,ENFILE
JRST .EXIT(DL)
LIT
PRGEND
TITLE REWIND - MAGNETIC TAPE REWIND ROUTINE
; PROCEDURE REWIND(N); VALUE N; INTEGER N;
.EXIT=1
.N=2
SEARCH ALGPRM,ALGSYS
LIBENT(431,REWIND)
XWD 0,2
XWD $PRO!$N!$SIM,2
XWD $VAR!$I!$FOV,.N
SKIPL A1,.N(DL) ; GET CHANNEL NUMBER
CAIL A1,20 ; 0 <= N < 20?
IOERR 14,(A1) ; NO - COMPLAIN
PUSHJ SP,REWND.
JRST .EXIT(DL)
LIT
PRGEND
TITLE IOCHAN - INPUT/OUTPUT CHANNEL STATUS ROUTINE
; BOOLEAN PROCEDURE IOCHAN(N); VALUE N; INTEGER N;
.EXIT=1
.N=3
SEARCH ALGPRM,ALGSYS
LIBENT(432,IOCHAN)
XWD 0,3
XWD $PRO!$B!$SIM,2
XWD $VAR!$I!$FOV,.N
EDIT(036) ; ALLOW IOCHAN TO REFERENCE DEFAULT TTY CHANNEL
AOSL A1,.N(DL) ; [E036] GET CHANNEL NUMBER + 1
CAILE A1,40 ; [E036] -1 <= N < 40?
IOERR 14,(A1) ; NO - COMPLAIN
ADDI A1,-1(DB) ; [E036] RELOCATE CHANNEL NUMBER
MOVE A0,%IODR(A1) ; GET CHANNEL ENTRY
HLRZM A0,.EXIT+1(DL) ; AND SET UP RESULT
JRST .EXIT(DL)
PRGEND
TITLE INFO - GENERAL INFORMATION ROUTINE
; INTEGER PROCEEDURE INFO(I); INTEGER I; VALUE I;
.EXIT=1
.I=3
SEARCH ALGPRM,ALGSYS
EXTERNAL .JBREL
LIBENT(441,INFO)
XWD 0,3
XWD $PRO!$I!$SIM,2
XWD $VAR!$I!$FOV,.I
SETO A2, ; PRESET ANSWER
MOVE A1,.I(DL) ; GET FUNCTION REQUIRED
CAIL A1,0 ; SENSIBLE ?
CAIL A1,MAXINF
AOJA A2,INFO1 ; NO
XCT INFOTB(A1) ; DO IT
INFO1: MOVEM A2,.EXIT+1(DL) ; AND RETURN RESULT
JRST .EXIT(DL)
INFOTB: HRRZ A2,.JBREL ; 0 -CORE SIZE
DATE A2, ; 1 - DATE (15 BIT FORMAT)
TIMER A2, ; 2 - TIME (TICKS FROM MIDNIGHT)
MSTIME A2, ; 3 - TIME (MSEC FROM MIDNIGHT)
PUSHJ SP,INFRUN ; 4 - RUNTIME
PUSHJ SP,INFPRC ; 5 - PROCESSOR (1=KA,2=KI,3=KL)
MOVE A2,%SYS20(DB) ; 6 - # OF STACK-SHIFTS
MOVE A2,%SYS23(DB) ; 7 - COMPILER VERSION WORD
MAXINF==.-INFOTB
INFRUN: PJOB A2,
RUNTIM A2,
POPJ SP,
INFPRC: HLRZ A2,DB
LSH A2,-^D16 ; GET OMC BITS (PROCESSOR TYPE)
AOS 2(A2) ; KLUDGE - IF 0, MAKE IT 1 !
POPJ SP,
PRGEND
TITLE FDATE/VDATE - STRING DATE ROUTINES
; STRING PROCEDURE FDATE/VDATE;
.EXIT=1
.LU=4
SEARCH ALGPRM,ALGSYS
EXTERNAL .JBREL
LIBENT(442,FDATE)
XWD 0,4
XWD $PRO!$SIM!$S,1
MOVEI A0,3 ; FLAG AS FDATE
JRST DATE0
LIBENT(443,VDATE)
XWD 0,4
XWD $PRO!$SIM!$S,1
MOVEI A0,77
DATE0: MOVEM A0,.LU(DL)
MOVEI A0,4
PUSHJ SP,GETCLR ; GET SPACE
HRLI A1,440700 ; MAKE BYTE-POINTER
MOVEM A1,.EXIT+1(DL) ; SET AS WORD 0 OF ANSWER
MOVEI A4,^D8 ; INITIALIZE COUNT
MOVE A2,[
XWD %CNDAY,.GTCNF]
GETTAB A2, ; GET YEAR
LIBERR 5,0 ; DISASTER !
IDIVI A2,^D10
ADDI A2,"0" ; TO ASCII
CAIN A2,"0" ; IF 0
MOVEI A2," " ; SUPPRESS IT
IDPB A2,A1
ADDI A3,"0"
IDPB A3,A1
MOVEI A5,"-"
IDPB A5,A1
MOVE A2,[
XWD %CNMON,.GTCNF]
GETTAB A2, ; GET MONTH
LIBERR 5,0 ; FAILED
LSH A2,1 ; * 2
ADD A2,[
POINT 7,MONTAB-2] ; GET POINTER TO ASCII MONTH
MOVE A0,.LU(DL) ; RECOVER # CHARS (3 OR MANY)
DATE2: ILDB A3,A2 ; GET CHARACTER OF MONTH
SOJL A0,DATE3 ; DONE IF FDATE & 3 CHARS DONE
JUMPE A3,DATE3 ; OR IF VDATE & ALL DONE
IDPB A3,A1
AOJA A4,DATE2 ; COUNT THE CHARACTERS
DATE3: IDPB A5,A1 ; "-"
MOVE A2,[
XWD %CNYER,.GTCNF]
GETTAB A2, ; GET YEAR
LIBERR 5,0
DATE4: IDIVI A2,^D10
ADDI A3,"0"
PUSH SP,A3
JUMPN A2,DATE4
MOVEI A0,4
POP SP,A3
IDPB A3,A1
SOJG A0,.-2
TLO A4,STRDYN!STRPRC ; MARK DYNAMIC (R.H. = # CHARS)
MOVEM A4,.EXIT+2(DL) ; AND PLANT AS WORD 2 OF RESULT
JRST .EXIT(DL)
MONTAB:
ASCIZ/January/
ASCIZ/February/
ASCIZ/March/
ASCIZ/April/
ASCIZ/May/
0 ; THEY MUST ALL BE 2 WORDS LONG
ASCIZ/June/
0
ASCIZ/July/
0
ASCIZ/August/
ASCIZ/September/
ASCIZ/October/
ASCIZ/November/
ASCIZ/December/
PRGEND
TITLE TIME - GET TIME OF DAY STRING ROUTINE
; STRING PROCEDURE TIME;
.EXIT=1
SEARCH ALGPRM,ALGSYS
LIBENT(444,TIME)
XWD 0,3
XWD $PRO!$SIM!$S,1
MOVEI A0,2
PUSHJ SP,GETCLR ; GET SPACE FOR STRING
HRLI A1,440700 ; MAKE BYTE-POINTER TO IT
MOVE A2,[
STRDYN!STRPRC,,^D8]
LRSTOR A1,.EXIT+1(DL) ; THE ANSWER (8 CHARS, DYNAMIC, RESULT-OF-PROC)
MOVEI A4,":" ; GET SEPARATOR
MOVE A2,[
XWD %CNHOR,.GTCNF]
PUSHJ SP,TIME2 ; GET HOUR & CONVERT TO ASCII
IDPB A4,A1 ; DEPOSIT SEPARATOR
MOVE A2,[
XWD %CNMIN,.GTCNF] ; MINUTE
PUSHJ SP,TIME2
IDPB A4,A1
MOVE A2,[
XWD %CNSEC,.GTCNF] ; SECOND
PUSHJ SP,TIME2
JRST .EXIT(DL) ; DONE
TIME2: GETTAB A2, ; GET THE PIECE OF TIME
LIBERR 5,0 ; CAN'T
IDIVI A2,^D10
ADDI A2,"0"
ADDI A3,"0"
IDPB A2,A1
IDPB A3,A1
POPJ SP,
PRGEND
TITLE RAN / SETRAN / SAVRAN - RANDOM NUMBER GENERATOR
; INTEGER PROCEDURE RAN;
; PROCEDURE SETRAN(I); VALUE I; INTEGER I;
; INTEGER PROCEDURE SAVRAN;
.EXIT=1
.I=2
SEARCH ALGPRM,ALGSYS
LIBENT(445,RAN)
XWD 0,2
XWD $PRO!$SIM!$I,1
MOVE A0,[
4544503720] ; 14**29
MUL A0,%RAND(DB) ; LAST NUMBER
ASHC A0,4
LSH A1,-4
ADD A0,A1
TLZE A0,760000 ; IF OVERFLOW
ADDI A0,1 ; ADD 1
MOVEM A0,%RAND(DB)
MOVEM A0,.EXIT+1(DL) ; RETURN IT
JRST .EXIT(DL)
LIBENT(446,SETRAN)
XWD 0,2
XWD $PRO!$SIM!$N,2
XWD $VAR!$I!$FOV,.I
SKIPN A1,.I(DL) ; IF PARAM IS 0
MOVE A1,[
XWD 1,-1] ; THEN SET DEFAULT START
MOVEM A1,%RAND(DB)
JRST .EXIT(DL)
LIBENT(447,SAVRAN)
XWD 0,2
XWD $PRO!$SIM!$I,1
MOVE A1,%RAND(DB)
MOVEM A1,.EXIT+1(DL) ; RETURN LAST RANDOM NUMBER
JRST .EXIT(DL)
PRGEND
TITLE TRACEON /OFF - TURN ON/OFF DYNAMIC TRACE FLAG.
; PROCEDURE TRACEON;
; PROCEDURE TRACEOFF;
.EXIT=1
SEARCH ALGPRM,ALGSYS
EDIT(121); DECLARE %ALGDR AS AN EXTERNAL
EXTERN %ALGDR
LIBENT(455,TRACEON)
XWD 0,1
XWD $PRO!$N!$SIM,1
TLO DB,STMTST ; LIGHT BIT.
JRST .EXIT(DL)
LIBENT(456,TRACEOFF)
XWD 0,1
XWD $PRO!$N!$SIM,1
TLZ DB,STMTST
JRST .EXIT(DL)
PRGEND
TITLE TRAPNO - GET TRAP # (USE ONLY IN TRAP ROUTINE)
; INTEGER PROCEDURE TRAPNO;
.EXIT=1
SEARCH ALGPRM,ALGSYS
LIBENT(460,TRAPNO)
XWD 0,2
XWD $PRO!$I!$SIM,1
HLRZ A0,%SYS17(DB)
ANDI A0,77 ; ISOLATE TRAP #
MOVEM A0,.EXIT+1(DL)
JRST .EXIT(DL)
PRGEND
TITLE PAUSE - DO AN EXIT 1,
; PROCEDURE PAUSE;
.EXIT=1
SEARCH ALGPRM,ALGSYS
LIBENT(461,PAUSE)
XWD 0,1
XWD $PRO!$N!$SIM,1
EXIT 1,
JRST .EXIT(DL)
PRGEND
TITLE DUMP - GET ALGDDT DUMP.
; PROCEDURE DUMP(N); VALUE(N); INTEGER(N); !N IS # OF BLOCKS TO DUMP. 0 = ALL;
.EXIT=1
.N=2
SEARCH ALGPRM,ALGSYS
LIBENT(462,DUMP)
XWD 0,2
XWD $PRO!$N!$SIM,2
XWD $VAR!$I!$FOV,.N
SKIPN A7,.N(DL)
MOVEI A7,777777 ; 'ALL'
PUSHJ SP,DDDUMP ; DO IT (TO CURRENT O/P CHANNEL)
JRST .EXIT(DL)
END