&&&&&&&&&&&& XLIB.SUB XLIB.SUB MTAPE.INC MTAPE.IMP EBTOAS.IMP MTHLIB.MAC SETSRC.IMP MPBQUE.IMP QUEUE.IMP GALAXY.MAC DRAFTS.IMP LINEQ.IMP MATRIX.IMP PAGEIM.MAC $$$$$$$$$$$$ &&&&&&&&&&&& MTAPE.INC %ENDOFLIST !MTAPE.INC %EXTERNALROUTINESPEC WATI(%INTEGER I) %EXTERNALROUTINESPEC WATO(%INTEGER I) %EXTERNALROUTINESPEC REWI(%INTEGER I) %EXTERNALROUTINESPEC REWO(%INTEGER I) %EXTERNALROUTINESPEC EOFI(%INTEGER I) %EXTERNALROUTINESPEC EOFO(%INTEGER I) %EXTERNALROUTINESPEC SKRI(%INTEGER I) %EXTERNALROUTINESPEC SKRO(%INTEGER I) %EXTERNALROUTINESPEC BSRI(%INTEGER I) %EXTERNALROUTINESPEC BSRO(%INTEGER I) %EXTERNALROUTINESPEC EOTI(%INTEGER I) %EXTERNALROUTINESPEC EOTO(%INTEGER I) %EXTERNALROUTINESPEC UNLI(%INTEGER I) %EXTERNALROUTINESPEC UNLO(%INTEGER I) %EXTERNALROUTINESPEC BLKI(%INTEGER I) %EXTERNALROUTINESPEC BLKO(%INTEGER I) %EXTERNALROUTINESPEC SKFI(%INTEGER I) %EXTERNALROUTINESPEC SKFO(%INTEGER I) %EXTERNALROUTINESPEC BSFI(%INTEGER I) %EXTERNALROUTINESPEC BSFO(%INTEGER I) %EXTERNALROUTINESPEC DECI(%INTEGER I) %EXTERNALROUTINESPEC DECO(%INTEGER I) %EXTERNALROUTINESPEC INDI(%INTEGER I) %EXTERNALROUTINESPEC INDO(%INTEGER I) %EXTERNALROUTINESPEC SETINI(%INTEGER I) %EXTERNALROUTINESPEC SETINO(%INTEGER I) %EXTERNALINTEGERFNSPEC GETBSI(%INTEGER I) %EXTERNALINTEGERFNSPEC GETBSO(%INTEGER I) %EXTERNALROUTINESPEC SETBSI(%INTEGER I,SIZE) %EXTERNALROUTINESPEC SETBSO(%INTEGER I,SIZE) %EXTERNALPREDICATESPEC TAPOP(%STRING(6)DEVICE,%INTEGER CODE,NARGS,%INTEGERARRAYNAME ARG,%INTEGERNAME RESULT) %LIST %ENDOFFILE !THE ROUTINES ARE ALL USED ON STREAMS WHICH HAVE BEEN DEFINED !FOR DEVICE "MTA:" !THE MNEMONICS FOR THE ROUTINES ARE THOSE USED IN THE DEC-10 !MONITOR CALLS MANUAL FOR THE MTAPE UUO. !THOSE ROUTINES WHOSE NAME ENDS IN 'I' OPERATE ON THE GIVEN !INPUT STREAM AND THOSE ENDING IN 'O', THE GIVEN !OUTPUT STREAM NUMBER. !WAT WAIT FOR SPACING AND I/O TO FINISH !REW REWIND TO LOAD POINT !EOF WRITE AN EOF !SKR SKIP ONE RECORD !BSR BACKSPACE ONE RECORD !EOT SPACE TO LOGICAL END OF TAPE !UNL REWIND AND UNLOAD !BLK WRITE 3 INCHES OF BLANK TAPE !SKF SKIP ONE FILE !BSF BACKSPACE ONE FILE !DEC INITIALISE AS DEC-COMPATIBLE 9-CHANNEL TAPE !IND INITIALISE AS INDUSTRY-COMPATIBLE 9-CHANNEL TAPE !GETBS RETURNS THE BLOCKSIZE !SETBS SETS THE BLOCKSIZE !NOTE THAT DEFINE INPUT AND DEFINE OUTPUT ALLOW /DENSITY, /PARITY,/BLOCKSIZE !SWITCHES $$$$$$$$$$$$ &&&&&&&&&&&& MTAPE.IMP !MISCELLANEOUS MAGTAPE ROUTINES. THESE ALL USE !THE MTAPE UUO. ! !ALL ROUTINE HAVE TWO INCARNATION, ONE FOR INPUT, !THE OTHER FOR OUTPUT ! %INCLUDE "IMP:IOLIB.INC" %EXTERNALSTRING(6)%FNSPEC SIXTOSTR(%INTEGER N) %EXTERNALINTEGERFNSPEC STRTOSIX(%STRING(255) S) %EXTERNALSTRING(255)%SPEC ERRMSG %EXTERNALRECORD (SCBNAME) %ARRAYSPEC INVEC(0:MAXCHANS) %EXTERNALRECORD (SCBNAME) %ARRAYSPEC OUTVEC(0:MAXCHANS) %EXTERNALPREDICATESPEC CALLI2(%INTEGER FUNCT,%INTEGERNAME AC) %OWNINTEGERARRAY ARGBLK(0:1) %OWNINTEGER RESULT %CONSTINTEGER MTWAT=0,MTREW=1,MTEOF=3,MTSKR=6,MTBSR=7, MTEOT=8,MTUNL=9,MTBLK=11,MTSKF=14, MTIND=65,MTBSF=15,MTDEC=64 %ROUTINE MTAPE(%RECORD(SCB)%NAME S,%INTEGER M) AC(1)=(8_072<<27)!((S_FILOPFN&8_777777000000)<<5)!M *8_256000000001 %END %ROUTINE MTAPEI(%INTEGER I,J) MTAPE(INVEC(I)_NAME,J) %END; %ROUTINE MTAPEO(%INTEGER I,J) MTAPE(OUTVEC(I)_NAME,J) %END %EXTERNALROUTINE WATI(%INTEGER I) MTAPEI(I,MTWAT) %END %EXTERNALROUTINE WATO(%INTEGER I) MTAPEO(I,MTWAT) %END %EXTERNALROUTINE REWI(%INTEGER I) MTAPEI(I,MTREW) %END %EXTERNALROUTINE REWO(%INTEGER I) MTAPEO(I,MTREW) %END %EXTERNALROUTINE EOFI(%INTEGER I) MTAPEI(I,MTEOF) %END %EXTERNALROUTINE EOFO(%INTEGER I) MTAPEO(I,MTEOF) %END %EXTERNALROUTINE SKRI(%INTEGER I) MTAPEI(I,MTSKR) %END %EXTERNALROUTINE SKRO(%INTEGER I) MTAPEO(I,MTSKR) %END %EXTERNALROUTINE BSRI(%INTEGER I) MTAPEI(I,MTBSR) %END %EXTERNALROUTINE BSRO(%INTEGER I) MTAPEO(I,MTBSR) %END %EXTERNALROUTINE EOTI(%INTEGER I) MTAPEI(I,MTEOT) %END %EXTERNALROUTINE EOTO(%INTEGER I) MTAPEO(I,MTEOT) %END %EXTERNALROUTINE UNLI(%INTEGER I) MTAPEI(I,MTUNL) %END %EXTERNALROUTINE UNLO(%INTEGER I) MTAPEO(I,MTUNL) %END %EXTERNALROUTINE BLKI(%INTEGER I) MTAPEI(I,MTBLK) %END %EXTERNALROUTINE BLKO(%INTEGER I) MTAPEO(I,MTBLK) %END %EXTERNALROUTINE SKFI(%INTEGER I) MTAPEI(I,MTSKF) %END %EXTERNALROUTINE SKFO(%INTEGER I) MTAPEO(I,MTSKF) %END %EXTERNALROUTINE BSFI(%INTEGER I) MTAPEI(I,MTBSF) %END %EXTERNALROUTINE BSFO(%INTEGER I) MTAPEO(I,MTBSF) %END %EXTERNALROUTINE DECI(%INTEGER I) MTAPEI(I,MTDEC) %END %EXTERNALROUTINE DECO(%INTEGER I) MTAPEO(I,MTDEC) %END %EXTERNALROUTINE INDI(%INTEGER I) MTAPEI(I,MTIND) %END %EXTERNALROUTINE INDO(%INTEGER I) MTAPEO(I,MTIND) %END %ROUTINE SETIND(%RECORD(SCB)%NAME S) MTAPE(S,MTIND) S_RINGHEAD_BYTPTR=(S_RINGHEAD_BYTPTR&8_777777)!(8_1000<<18) %END %EXTERNALROUTINE SETINI(%INTEGER I) SETIND(INVEC(I)_NAME) %END %EXTERNALROUTINE SETINO(%INTEGER I) SETIND(OUTVEC(I)_NAME) %END %EXTERNALPREDICATE TAPOP(%STRING(6)DEVICE,%INTEGER CODE,NARGS,%INTEGERARRAYNAME ARG,%INTEGERNAME RESULT) %RECORDFORMAT ARGLIST(%INTEGER CODE1,DEV1,%INTEGERARRAY ARGS(1:22)) %RECORD(ARGLIST)A %INTEGER AC,I A_CODE1=CODE A_DEV1=STRTOSIX(DEVICE) %UNLESS NARGS=0 %START %CYCLE I=1,1,NARGS A_ARGS(I)=ARG(I) %REPEAT %FINISH AC=(NARGS+2)<<18!ADDR(A) %UNLESS CALLI2(8_154,AC) %THEN RESULT=AC %AND %FALSE %CYCLE I=1,1,NARGS ARG(I)=A_ARGS(I) %REPEAT RESULT=AC %TRUE %END %INTEGERFN GETBLOCKSIZE(%RECORD(SCB)%NAME S) %IF TAPOP(SIXTOSTR(S_DEVNAM),8_2006,0,ARGBLK,RESULT) %THEN %RESULT=RESULT ERRMSG="TAPOP failure" %SIGNAL 10,15,2006 %END %ROUTINE SETBLOCKSIZE(%RECORD(SCB)%NAME S,%INTEGER SIZE) ARGBLK(0)=SIZE %IF TAPOP(SIXTOSTR(S_DEVNAM),8_1006,1,ARGBLK,RESULT) %THEN %RETURN ERRMSG="TAPOP failure" %SIGNAL 10,15,1006 %END %EXTERNALINTEGERFN GETBSI(%INTEGER I) %RESULT=GETBLOCKSIZE(INVEC(I)_NAME) %END %EXTERNALINTEGERFN GETBSO(%INTEGER I) %RESULT=GETBLOCKSIZE(OUTVEC(I)_NAME) %END %EXTERNALROUTINE SETBSI(%INTEGER I,SIZE) SETBLOCKSIZE(INVEC(I)_NAME,SIZE) %END %EXTERNALROUTINE SETBSO(%INTEGER I,SIZE) SETBLOCKSIZE(OUTVEC(I)_NAME,SIZE) %END %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& EBTOAS.IMP %CONSTINTEGERARRAY EBCDIC(0:255)= 8_000000000, ;!NULL NULL 8_001000001, ;!SOH SOH 8_002000002, ;!STX STX 8_003000003, ;!ETX ETX 8_024000067, ;!DC4 EOT 8_011000055, ;!HT ENQ 8_016000056, ;!LC ACK 8_177000057, ;!DEL BELL 8_777000026, ;!NONE BS 8_777000005, ;!NONE HT 8_777000045, ;!NONE LF 8_777000013, ;!NONE VT 8_777000014, ;!NONE FF 8_777000015, ;!NONE CR 8_777000016, ;!NONE LC 8_777000017, ;!NONE UC 8_777000020, ;!NONE DLE 8_777000021, ;!NONE DC1 8_777000022, ;!NONE DC2 8_034000004, ;!FS DC3 8_777000074, ;!NONE DC4 8_012000075, ;!LF NAK 8_010000027, ;!BS SYN 8_026000046, ;!SYN ETB 8_030000030, ;!CAN CAN 8_031000031, ;!EM EM 8_777000077, ;!NONE SUB 8_777000047, ;!NONE ESC 8_777000042, ;!NONE FS 8_777000035, ;!NONE GS 8_777000065, ;!NONE RS 8_777000037, ;!NONE US 8_777000100, ;!NONE SPACE 8_777000132, ;!NONE ! 8_034000177, ;!FS " 8_777000173, ;!NONE # 8_777000133, ;!NONE $ 8_012000154, ;!LF % 8_036000120, ;!RS & 8_033000175, ;!ESC ' 8_777000115, ;!NONE ( 8_777000135, ;!NONE ) 8_020000134, ;!DLE * 8_777000116, ;!NONE + 8_777000153, ;!NONE , 8_005000140, ;!ENQ - 8_006000113, ;!ACK . 8_007000141, ;!BELL / 8_777000360, ;!NONE 0 8_777000361, ;!NONE 1 8_026000362, ;!SYN 2 8_777000363, ;!NONE 3 8_022000364, ;!DC3 4 8_023000365, ;!DC3 5 8_017000366, ;!UC 6 8_004000367, ;!EOT 7 8_777000370, ;!NONE 8 8_777000371, ;!NONE 9 8_777000172, ;!NONE : 8_777000136, ;!NONE ;! 8_024000114, ;!DC4 < 8_025000176, ;!NAK = 8_777000156, ;!NONE > 8_032000157, ;!SUB ? 8_040000174, ;!SPACE @ 8_777000301, ;!NONE A 8_777000302, ;!NONE B 8_777000303, ;!NONE C 8_777000304, ;!NONE D 8_777000305, ;!NONE E 8_777000306, ;!NONE F 8_777000307, ;!NONE G 8_777000310, ;!NONE H 8_777000311, ;!NONE I 8_135000321, ;!] J 8_056000322, ;!. K 8_074000323, ;!< L 8_050000324, ;!( M 8_053000325, ;!+ N 8_136000326, ;!^ O 8_046000327, ;!& P 8_777000330, ;!NONE Q 8_777000331, ;!NONE R 8_777000342, ;!NONE S 8_777000343, ;!NONE T 8_777000344, ;!NONE U 8_777000345, ;!NONE V 8_777000346, ;!NONE W 8_777000347, ;!NONE X 8_777000350, ;!NONE Y 8_041000351, ;!! Z 8_044000137, ;!$ [ 8_052000777, ;!* NONE 8_051000112, ;!) ] 8_073000117, ;!;! ^ 8_133000155, ;![ _ 8_055000777, ;!- NONE 8_057000201, ;!/ LC-A 8_777000202, ;!NONE LC-B 8_777000203, ;!NONE LC-C 8_777000204, ;!NONE LC-D 8_777000205, ;!NONE LC-E 8_777000206, ;!NONE LC-F 8_777000207, ;!NONE LC-G 8_777000210, ;!NONE LC-H 8_777000211, ;!NONE LC-I 8_777000221, ;!NONE LC-J 8_054000222, ;!, LC-K 8_045000223, ;!% LC-L 8_137000224, ;!_ LC-M 8_076000225, ;!> LC-N 8_077000226, ;!? LC-O 8_777000227, ;!NONE LC-P 8_777000230, ;!NONE LC-Q 8_777000231, ;!NONE LC-R 8_777000242, ;!NONE LC-S 8_777000243, ;!NONE LC-T 8_777000244, ;!NONE LC-U 8_777000245, ;!NONE LC-V 8_777000246, ;!NONE LC-W 8_777000247, ;!NONE LC-X 8_777000250, ;!NONE LC-Y 8_072000251, ;!: LC-Z 8_043000137, ;!# L. BRACE 8_100000117, ;!@ VERTICAL LINE 8_047000112, ;!', R. BRACE 8_075000777, ;!= NONE 8_042000777, ;!" NONE 8_777000777, ;!NONE NONE 8_141000777, ;!LC-A NONE 8_142000777, ;!LC-B NONE 8_143000777, ;!LC-C NONE 8_144000777, ;!LC-D NONE 8_145000777, ;!LC-E NONE 8_146000777, ;!LC-F NONE 8_147000777, ;!LC-G NONE 8_150000777, ;!LC-H NONE 8_151000777, ;!LC-I NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_152000777, ;!LC-J NONE 8_153000777, ;!LC-K NONE 8_154000777, ;!LC-L NONE 8_155000777, ;!LC-M NONE 8_156000777, ;!LC-N NONE 8_157000777, ;!LC-O NONE 8_160000777, ;!LC-P NONE 8_161000777, ;!LC-Q NONE 8_162000777, ;!LC-R NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_163000777, ;!LC-S NONE 8_164000777, ;!LC-T NONE 8_165000777, ;!LC-U NONE 8_166000777, ;!LC-V NONE 8_167000777, ;!LC-W NONE 8_170000777, ;!LC-X NONE 8_171000777, ;!LC-Y NONE 8_172000777, ;!LC-Z NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_077000777, ;!? NONE 8_101000777, ;!A NONE 8_102000777, ;!B NONE 8_103000777, ;!C NONE 8_104000777, ;!D NONE 8_105000777, ;!E NONE 8_106000777, ;!F NONE 8_107000777, ;!G NONE 8_110000777, ;!H NONE 8_111000777, ;!I NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_072000777, ;!: NONE 8_112000777, ;!J NONE 8_113000777, ;!K NONE 8_114000777, ;!L NONE 8_115000777, ;!M NONE 8_116000777, ;!N NONE 8_117000777, ;!O NONE 8_120000777, ;!P NONE 8_121000777, ;!Q NONE 8_122000777, ;!R NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_123000777, ;!S NONE 8_124000777, ;!T NONE 8_125000777, ;!U NONE 8_126000777, ;!V NONE 8_127000777, ;!W NONE 8_130000777, ;!X NONE 8_131000777, ;!Y NONE 8_132000777, ;!Z NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_060000777, ;!0 NONE 8_061000777, ;!1 NONE 8_062000777, ;!2 NONE 8_063000777, ;!3 NONE 8_064000777, ;!4 NONE 8_065000777, ;!5 NONE 8_066000777, ;!6 NONE 8_067000777, ;!7 NONE 8_070000777, ;!8 NONE 8_071000777, ;!9 NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_777000777, ;!NONE NONE 8_137000777 ;!_ NONE %EXTERNALINTEGERFN EBTOAS(%INTEGER I) %IF 0<=I<=255 %THEN %RESULT=EBCDIC(I)>>18 %RESULT=8_777 %END %EXTERNALINTEGERFN ASTOEB(%INTEGER I) %IF 0<=I<=127 %THEN %RESULT=EBCDIC(I)&8_777777 %RESULT=8_777 %END %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& MTHLIB.MAC TITLE TAN %EXTERNALREALFN TAN(%REAL X) ;THIS FUNCTION CALCULATES TAN(X) AS SIN(X)/COS(X) ;IF COS(X)=0 AN EVENT IS SIGNALLED SEARCH IMPPRM ENTRY TAN EXTERN SIN EXTERN COS TWOSEG 400000 TAN: MOVEM ARG1,ARGSAV ;SAVE THE ARGUMENT FOR USE LATER CALL COS ;GET COS(X) JUMPE AC,INFRES ;ERROR IF COS(ARG)=0 MOVEM AC,COSSAV ;SAVE THE COS FOR LATER MOVE ARG1,ARGSAV ;GET THE ORIGINAL ARG BACK CALL SIN ;GET SIN(X) FDVR AC,COSSAV ;TAN=SIN/COS RETURN ;TAN RETURN INFRES: ERROR(1,1,AC,IMPSTR) RELOC 0 ARGSAV: 0 COSSAV: 0 PRGEND TITLE RAISE %EXTERNALREALFN RAISE(%REAL NUMBER,TO POWER) ;THIS FUNCTION CALCULATES ARG1**ARG2 BY THE ALGORITHM: ; A**B=EXP(B*LOG(A)) ;THE CALLING SEQUENCE IS: ; MOVE ARG1,A ; MOVE ARG2,B ; PUSHJ P,RAISE ;THE RESULT IS RETURNED IN AC SEARCH IMPPRM TWOSEG 400000 ENTRY RAISE EXTERN LOG EXTERN EXP RAISE: MOVEM ARG2,EXPSAV ;SAVE THE POWER FOR LATER JUMPL ARG1,ERR ;ERROR IF THE BASE IS<0 JUMPE ARG1,ZERARG ;ARG=0 IMPLIES RESULT=0 CALL LOG ;CALC LOG(A) FMPR AC,EXPSAV ;GET B*LOG(A) MOVE ARG1,AC CALL EXP ;GET THE ANSWER IN AC RETURN ;RAISE RETURN ERR: ERROR(1,1,ARG1,IMPSTR) ZERARG: MOVE AC,ONE ;RESULT=1 RETURN ;RAISE RETURN RELOC 0 EXPSAV: 0 ONE: 1.0 ;CONSTANT 1 PRGEND TITLE ACOS %EXTERNALREALFN ACOS(%REAL X) SEARCH IMPPRM ENTRY ACOS EXTERN SQR EXTERN ATAN ;FLOATING POINT SINGLE PRECISION ARCCOSINE FUNCTION ;ACOS(X) IS CALCULATED IN THE FOLLOWING MANNER: ; IF X > 0, ACOS(X)=ATAN((SQRT(1-X^2))/X) ; IF X < 0, ACOS(X)=PI + ATAN((SQRT(1-X^2))/X) ; IF X = 0, ACOS(X)=PI/2 ;THE RANGE OF DEFINITION FOR ACOS IS -1.0 TO +1.0. ;ARGUMENTS OUTSIDE OF THIS RANGE WILL CAUSE AN ERROR MESSAGE ;THE CALLING SEQUENCE FOR ACOS IS: ; MOVE ARG1,X ; PUSHJ P,ACOS TWOSEG 400000 ACOS: MOVM 0,ARG1 ;GET /ARG./ IN AC 0. CAMLE 0,ONE ;IS MAGNITUDE OF ARG. GT 1.0? JRST TOOLRG ;YES, GO TO ERROR RETURN. JUMPE 0,ZERARG ;IF ARG=0, GO TO ZERARG. FMPR 0,0 ;X^2 IN AC 0. JFCL ;SUPPRESS ERROR MESSAGE FROM OVTRAP, IF NECESSARY. MOVNS 0 ;-X^2 IN AC 0. FAD 0,ONE ;1.0-X^2 IN AC 0. MOVEM ARG1,ARGSAV ;SAVE THE ORIGINAL ARGUMENT FOR LATER MOVE ARG1,0 ;GET ARGUMENT FOR SQUARE ROOT CALL SQR ;CALC SQRT(1.0-X^2) IFN AC ;GET RESULT IN 0 IF IT ISN'T THERE FDVR 0,ARGSAV ;(SQRT(1.0-X^2))/X IS IN AC 0 JFCL ;SUPPRESS ERROR MESSAGE FROM OVTRAP, IF NECESSARY. MOVE ARG1,0 ;GET THE ARGUMENT FOR ATAN PUSHJ P,ATAN ;FIND ATAN(SQRT(1.0-X^2)/X). SKIPGE ARGSAV ;SKIP IF ORIGINAL ARG >= 0. FAD 0,PII ;ANSWER IS PI - ORIGINAL ANSWER. IFN AC ;IN CASE AC<>0 RETURN ;AND RETURN FROM ACOS ZERARG: MOVE AC,PI2 ;ANSWER IS PI/2. RETURN ;ACOS RETURN TOOLRG: ERROR(6,2,0,IMPSTR) ;CAUSE A LIBRARY FUNCTION EVENT RELOC 0 ONE: 201400000000 ;1.0 PI2: 201622077325 PII: 202622077325 ARGSAV: 0 PRGEND TITLE ASIN %EXTERNALREALFN ASIN(%REAL X) ;FLOATING POINT SINGLE PRECISION ARCSINE FUNCTION ;THE ARCSINE IS CALCULATED WITH THE FOLLOWING ALGORITHM: ; ASIN(X) = ATAN(X/SQRT(1-X^2)) ;THE RANGE OF DEFINITION FOR ASIN IS (-1.0,1.0) ;OTHER ARGUMENTS WILL CAUSE AN EVENT A= 0 B= 1 SEARCH IMPPRM TWOSEG 400000 ENTRY ASIN EXTERN ATAN EXTERN SQR ASIN: MOVM B,ARG1 ;GET MAGNITUDE OF ARG. IN B MOVEM ARG1,ASIN2 ;SAVE THE ARGUMENT FOR FURTHER USE CAMLE B,ONE ;IS THE MAGNITUDE OF THE ARG. LE 1.0? JRST TOOLRG ;NO, GO TO ERROR RETURN. MOVN A,ARG1 ;GET THE NEGATIVE OF ARG FMP A,ARG1 ;CALCULATE -(X^2) JFCL ;SUPPRESS ERROR MESSAGE FROM OVTRAP, IF NECESSARY. FAD A, ONE ;CALCULATE 1-(X^2) JUMPE A, ASIN1 ;WAS X EITHER -1.0 OR 1.0? MOVE ARG1,A ;SET UP FOR CALL TO SQR CALL SQR ;CALCULATE SQRT(1-X^2) MOVE B,ASIN2 ;GET THE ARGUMENT BACK AGAIN FDV B, A ;CALCULATE X/SQRT(1-X^2) MOVEM B,ARG1 ;THEN CALL ATAN ;CALCULATE ATAN(X/SQR(1-X^2)) RETURN ;ASIN RETURN ASIN1: MOVE AC,PIOT ;ANSWER IS EITHER PI/2 OR-PI/2 SKIPG ASIN2 ;WAS ORIGINAL ARGUMENT POSITIVE? MOVNS AC ;NO, GET -PI/2 RETURN ;ASIN RETURN TOOLRG: ERROR(6,2,0,IMPSTR) RELOC 0 ;NOW THE DATA SEGMENT ASIN2: 0 ;STORAGE FOR ARGUMENT PIOT: 201622077325 ;PI/2 ONE: 1.0 PRGEND TITLE ATAN %EXTERNALREALFN ATAN(%REAL X) ;FLOATING POINT SINGLE PRECISION ARCTANGENT FUNCTION ;ATAN(X) = X(B0+A1(Z+B1-A2(Z+B2-A3(Z+B3)**-1)**-1)**-1) ;WHERE Z=X^2, IF 01, THEN ATAN(X) = PI/2 - ATAN(1/X) ;IF X>1, THEN RH(D) =-1, AND LH(D) = -SGN(X) ;IF X<1, THEN RH(D) = 0, AND LH(D) = SGN(X) ;THE ROUTINE IS CALLED IN THE FOLLOWING MANNER: ; MOVE ARG1,X ; PUSHJ P,ATAN ;THE ANSWER IS RETURNED IN ACCUMULATOR AC SEARCH IMPPRM TWOSEG 400000 ENTRY ATAN A= 0 B= 1 C= 2 D= 3 ATAN: MOVE A, ARG1 ;PICK UP THE ARGUMENT IN A ATAN1: MOVM B, A ;GET ABSF OF ARGUMENT CAMG B, A1 ;IF X<2^-33, THEN RETURN WITH... JRST AT5 ;ATAN(X) = X MOVEM D, D1 ;SAVE ACCUMULATOR D HLLO D, A ;SAVE SIGN, SET RH(D) = -1 CAML B, A2 ;IF A>2^33, THEN RETURN WITH JRST AT4 ;ATAN(X) = PI/2 MOVEM C, C1 ;SAVE ACCUMULATOR C MOVSI C, 201400 ;FORM 1.0 IN C CAMG B, C ;IS ABSF(X)>1.0? TRZA D, -1 ;IF B .LE. 1.0, THEN RH(D) = 0 FDVM C, B ;B IS REPLACED BY 1.0/B TLC D, (D) ;XOR SIGN WITH .G. 1.0 INDICATOR MOVEM B, C3 ;SAVE THE ARGUMENT FMP B, B ;GET B^2 MOVE C, KB3 ;PICK UP A CONSTANT FAD C, B ;ADD B^2 MOVE A, KA3 ;ADD IN NEXT CONSTANT FDVM A, C ;FORM -A3/(B^2 + B3) FAD C, B ;ADD B^2 TO PARTIAL SUM FAD C, KB2 ;ADD B2 TO PARTIAL SUM MOVE A, KA2 ;PICK UP -A2 FDVM A, C ;DIVIDE PARTIAL SUM BY -A2 FAD C, B ;ADD B^2 TO PARTIAL SUM FAD C, KB1 ;ADD B1 TO PARTIAL SUM MOVE A, KA1 ;PICK UP A1 FDV A, C ;DIVIDE PARTIAL SUM BY A1 FAD A, KB0 ;ADD B0 FMP A, C3 ;MULTIPLY BY ORIGINAL ARGUMENT TRNE D, -1 ;CHECK .G. 1.0 INDICATOR FSB A, PIOT ;ATAN(A) = -(ATAN(1/A)-PI/2) SKIPA C, C1 ;RESTORE ACCUMULATOR C AND SKIP AT4: MOVE A, PIOT ;GET PI/2 AS ANSWER SKIPGE D ;LH(D) = -SGN(B) IF B>1.0 MOVNS A ;NEGATE ANSWER IFN AC ;GET ANSWER IN AC IF IT ISN'T MOVE D, D1 ;RESTORE ACCUMULATOR AT5: RETURN ;ATAN TERURN RELOC 0 ;DATA SEGMENT A1: 145000000000 ;2**-33 A2: 233000000000 ;2**33 KB0: 176545543401 ;0.1746554388 KB1: 203660615617 ;6.762139240 KB2: 202650373270 ;3.316335425 KB3: 201562663021 ;1.448631538 KA1: 202732621643 ;3.709256262 KA2: 574071125540 ;-7.106760045 KA3: 600360700773 ;-0.2647686202 C1: 0 C3: 0 D1: 0 PIOT: 201622077325 ;PI/2 PRGEND TITLE SINH %EXTERNALREALFN SINH(%REAL X) ;FLOATING POINT SINGLE PRECISION HYPERBOLIC SINE FUNCTION. ;SINH IS CALCULATED AS FOLLOWS: ; IF ABS(X)>88.029, ; SINH(X)=(EXP[ABS(X)-LN(2)])*SIGN(X) ; IF ABS(X)<=0.10, ; SINH(X)=X+(X**3)/6+(X**5)/120 ; FOR ALL OTHER VALUES OF X, ; SINH(X)=1/2[EXP(X)-1/EXP(X)] ;THE CALLING SEQUENCE IS: ; MOVE ARG1,X ; PUSHJ P,SINH ;THE ANSWER IS RETURNED IN AC. SEARCH IMPPRM ENTRY SINH EXTERN EXP TWOSEG 400000 SINH: MOVE 0,ARG1 ;PICK UP THE ARG. MOVEM 2,SAVE2 ;SAVE AC 2. MOVEM 0,ARGTMP ;SAVE ARG. MOVM 2,0 ;GET MAGNITUDE OF ARG IN AC 2. CAMLE 2,EIGHT8 ;IF ABS(X)>88.029, JRST OV88 ;THEN GO TO OV88. CAMG 2,ONE10T ;IF ABS(X)<=0.10, JRST SERIES ;THEN GO TO SERIES. MOVE ARG1,2 ;PREPARE FOR EXP CALL EXP ;CALCULATE EXP(ABS(X)). IFN AC HRLZI 1,576400 ;PUT -1.0 IN AC 1. FDVR 1,0 ;CALC. -EXP(-ABS(X)). FADR 0,1 ;CALC. EXP(ABS(X))-EXP(-ABS(X)). FDVRI 0,202400 ;CALC. THIS/2.0 SKIPGE ARGTMP ;ANSWER IS POSITIVE. MOVNS 0,0 ;ANSWER IS NEGATIVE. MOVE 2,SAVE2 ;RESTORE AC 2. IFN AC ;COND ARG SELECT RETURN ;SINH RETURN SERIES: FMPR 2,2 ;CALC. X^2. JFCL ;SUPPRESS ERROR MESSAGE FROM OVTRAP. MOVEM 2,SX2 ;SAVE X^2 IN SX2. FDVR 2,ONE120 ;CALC.X^2/120 JFCL ;SUPPRESS ERROR MESSAGE FROM OVTRAP. FADR 2,ONESIX ;CALC. (X^2/120)+1/6 FMPR 2,SX2 ;MULTIPLY IT BY X^2. JFCL ;SUPPRESS ERROR MESSAGE FROM OVTRAP. FADRI 2,201400 ;ADD 1.0. FMPR 0,2 ;MULTIPLY BY X. MOVE 2,SAVE2 ;RESTORE AC 2. IFN AC ;COND RESULT SELECT RETURN ;SINH RETURN OV88: FSBR 2,LN2BE ;CALC.ABS(X)-LN(2) CAMG 2,EIGHT8 ;OVERFLOW? JRST EXPP ;NO,GO TO CALC. ERROR(1,1,0,IMPSTR) EXPP: MOVE ARG1,2 ;GET READY FOR EXP CALL EXP ;CALCULATE EXP IFN AC EXPP1: SKIPGE ARGTMP ;RETURN ANS. >0 IF X>0. MOVNS 0 ;O'E, ANS. <0. MOVE 2,SAVE2 ;RESTORE AC 2. IFN AC ;RESULT IN AC IF NOT THERE RETURN ;AND RETURN RELOC 0 SAVE2: 0 LN2BE: 200542710300 ;LN(2) EIGHT8: 207540074636 ;88.029 ARGTMP: 0 ONE10T: 0.10 SX2: 0 ONE120: 207740000000 ;120.0 ONESIX: 0.16666667 PRGEND TITLE COSH %EXTERNALREALFN COSH(%REAL X) ;FLOATING POINT SINGLE PRECISION HYPERBOLIC COSINE FUNCTION. ;COSH(X) IS CALCULATED AS FOLLOWS: ; IF ABS(X) <= 88.029, ; COSH(X) = 1/2(EXP(X) + 1.0/EXP(X)) ; IF ABS(X) > 88.029 AND (ABS(X)-LN(2)) <= 88.029, ; COSH(X) = EXP(ABS(X)-LN(2)) ;THE ROUTINE IS CALLED IN THE FOLLOWING MANNER: ; MOVE ARG1,X ; PUSHJ P,COSH ;THE ANSWER IS RETURNED IN AC. SEARCH IMPPRM ENTRY COSH EXTERN EXP TWOSEG 400000 COSH: MOVE 0,ARG1 ;PICK UP THE ARGUMENT. MOVEM 2,SAVE2 ;SAVE AC 2. MOVM 2,0 ;PUT ABS(X) IN AC 2. CAMLE 2,EIGHT8 ;IF ABS(X) > 88.029, JRST OV88 ;GO TO OV88. MOVE ARG1,2 CALL EXP IFN AC ;CALCULATE EXP(ABS(X)) MOVSI 2,201400 ;PUT 1.0 IN AC 2. FDVR 2,0 ;CALC. 1.0/EXP(ABS(X)). FADR 0,2 ;CALC. EXP(ABS(X)) + EXP(-ABS(X)). FDVRI 0,202400 ;DIVIDE THIS BY 2.0. MOVE 2,SAVE2 ;RESTORE AC 2. IFN AC RETURN ;COSH RETURN OV88: FSBR 2,LN2BE ;FORM ABS(X)-LN(2). CAMG 2,EIGHT8 ;OVERFLOW? JRST EXPP ;NO,GO AHEAD. ERROR(1,1,0,IMPSTR) EXPP: MOVE ARG1,2 CALL EXP MOVE 2,SAVE2 ;RESTORE AC 2. RETURN ;COSH RETURN RELOC 0 SAVE2: 0 EIGHT8: 207540074636 ;88.029 LN2BE: 200542710300 ;LOG(2) BASE E. PRGEND TITLE TANH %EXTERNALREALFN TANH(%REAL X) ;FLOATING POINT SINGLE PRECISION HYPERBOLIC TANGENT ROUTINE ;THIS ROUTINE CALCULATES THE TANH BY THE FOLLOWING ALGORITHM: ;IF ABSF(X) <.00034, THEN TANH(X) = X ;IF ABSF(X) >12.0, THEN TANH(X) = 1.0*SIGN(X) ;IF 0.17 <= X < 12.0, THEN TANH IS CALCULATED AS ; TANH(X) = 1.0 - 2(1.0 + EXP(2*X))**-1 ;IF .00034 <= X < 0.17, THEN TANH IS CALCULATED AS ;TANH(X) = F(A+F^2(B+C(D+F^2)**-1))**-1 ;WHERE X = 4*LOG(E) (BASE 2) ;THE ROUTINE IS CALLED IN THE FOLLOWING MANNER: ; MOVE ARG1,X ; PUSHJ P,TANH ;THE ANSWER IS RETURNED IN ACCUMULATOR AC SEARCH IMPPRM ENTRY TANH EXTERN EXP TWOSEG 400000 A= 0 B= 1 TANH: MOVE A, ARG1 ;PICK UP THE ARGUMENT MOVM B, A ;GET ABSF(ARGUMENT) CAMGE B, KT1 ;RETURN TANH(X)=X IF JRST TH2 ;ABSF(X) .LE. .00034 CAMLE B, KT2 ;RETURN TANH(X) = 1.0 IF JRST TH5 ;ARGUMENT GREATER THAN 12.0 CAMGE B, KT3 ;USE RATIONAL APPROXIMATION IF JRST TH3 ;ARGUMENT IS LESS THAN 0.17 MOVEM A,SAVEA ;SAVE ARG. FMPRI B,202400 ;GET 2*ARG. MOVE ARG1,B ;SET UP FOR EXP CALL EXP IFN AC ;COND RESULT SELECT MOVSI B, 201400 ;FORM 1.0 FAD A, B ;1 + EXP(2X) FDVM B, A ;(1 + EXP(2X))**-1 FMPRI A,202400 ;2*(1 + EXP(2X))**-1 FSBRM B, A ;1 - 2*(1 + EXP(2X))**-1 SKIPGE SAVEA ;SKIP AHEAD IF ARG WAS >=0. MOVNS A ;OTHERWISE,NEGATE THE ANSWER. TH2: IFN AC RETURN ;TANH RETURN TH3: FMP A, KT7 ;FORM 4*X*LOG(E) BASE 2 MOVEM A, TM1 ;SAVE IT IN TM1 FMP A, A ;SQUARE IT MOVEM A, TM2 ;SAVE IT FAD A, KT4 ;FORM F^2 + T4 MOVE B, KT5 ;GET T5 IN ACCUMULATOR B FDV B, A ;KT5/(F^2 + KT4) FAD B, KT6 ;KT6 + KT5/(F^2 + KT4) FMP B, TM2 ;MULTIPLY BY F^2 FAD B, KT7 ;ADD T7 (4*LOG(E) BASE 2) MOVE A, TM1 ;GET F IN ACCUMULATOR A TH5: FDV A, B ;DIVIDE F BY PARTIAL SUM IFN AC RETURN ;TANH RETURN RELOC 0 KT1: 165544410070 ;0.00034 KT2: 204600000000 ;12.0 KT3: 176534121727 ;0.17 KT4: 211535527022 ;349.6699888 KT5: 204704333567 ;14.1384514018 KT6: 173433723376 ;0.01732867951 KT7: 203561250731 ;5.7707801636 TM1: 0 TM2: 0 SAVEA: 0 PRGEND TITLE LGT %EXTERNALREALFN LGT(%REAL X) ;SINGLE PRECISION LOG TO THE BASE 10 FUNCTION ;LOG10(X) IS CALCULATED AS LOG10(E)*LOGE(X) ;THE CALLING SEQUENCE IS: ; MOVE ARG1,X ; PUSHJ P,LGT ;THE ANSWER IS RETURNED IN ACCUMULATOR AC A= 0 B= 1 SEARCH IMPPRM TWOSEG 400000 ENTRY LGT EXTERN LOG LGT: JUMPE ARG1,LZERO ;CHECK FOR ZERO ARG. CALL LOG ;CALC LOG(X) FMPR AC,LOG10A ;MULTIPLY IT BY LOG10(E). RETURN ;LGT RETURN LZERO: ERROR(1,1,0,IMPSTR) RELOC 0 LOG10A: 177674557305 PRGEND TITLE LOG %EXTERNALREALFN LOG(%REAL X) ;FLOATING POINT SINGLE PRECISION LOGARITHM FUNCTION ;LOG(ABSF(X)) IS CALCULATED BY THE SUBROUTINE, AND AN ;FOR LOGE(X), THE ALGORITHM IS: ; LOGE(X) = (I + LOG2(F))*LOGE(2) ; WHERE X = (F/2)*2^(I+1), AND LOG2(F) IS GIVEN BY ; LOG2(F) = C1*Z + C3*Z^3 + C5*Z^5 - 1/2 ; AND Z = (F-SQRT(2))/(F+SQRT(2)) ;THE CALLING SEQUENCE FOR THE ROUTINE IS AS FOLLOWS: ; MOVE ARG1,X ; PUSHJ P,LOG ;THE ANSWER IS RETURNED IN ACCUMULATOR AC A=0 B=1 ENTRY LOG TWOSEG 400000 SEARCH IMPPRM LOG: MOVE A, ARG1 ;GET ABSF(X) JUMPG A,ALOGOK ;ARG IS GREATER THAN 0 JUMPE A, LZERO ;CHECK FOR ZERO ARGUMENT ERROR(1,1,0,IMPSTR) ALOGOK: CAMN A, ONE ;CHECK FOR 1.0 ARGUMENT JRST ZERANS ;IT IS 1.0 RETURN ZERO ANS. ASHC A, -33 ;SEPARATE FRACTION FROM EXPONENT ADDI A, 211000 ;FLOAT THE EXPONENT AND MULT. BY 2 MOVSM A, LS ;NUMBER NOW IN CORRECT FL. FORMAT MOVSI A, 567377 ;SET UP -401.0 IN A FADM A, LS ;SUBTRACT 401 FROM EXP.*2 ASH B, -10 ;SHIFT FRACTION FOR FLOATING TLC B, 200000 ;FLOAT THE FRACTION PART FAD B, L1 ;B = B-SQRT(2.0)/2.0 MOVE A, B ;PUT RESULTS IN A FAD A, L2 ;A = A+SQRT(2.0) FDV B, A ;B = B/A MOVEM B, LZ ;STORE NEW VARIABLE IN LZ FMP B, B ;CALCULATE Z^2 MOVE A, L3 ;PICK UP FIRST CONSTANT FMP A, B ;MULTIPLY BY Z^2 FAD A, L4 ;ADD IN NEXT CONSTANT FMP A, B ;MULTIPLY BY Z^2 FAD A, L5 ;ADD IN NEXT CONSTANT FMP A, LZ ;MULTIPLY BY Z FAD A, LS ;ADD IN EXPONENT TO FORM LOG2(X) FMP A, L7 ;MULTIPLY TO FORM LOGE(X) IFN AC ;GET RESULT RETURN ;LOG RETURN LZERO: ERROR(1,1,0,IMPSTR) ZERANS: MOVEI AC, 0 ;MAKE ANSWER ZERO RETURN ;LOG RETURN RELOC 0 ONE: 201400000000 L1: 577225754146 ;-0.707106781187 L2: 201552023632 ;1.414213562374 L3: 200462532521 ;0.5989786496 L4: 200754213604 ;0.9614706323 L5: 202561251002 ;2.8853912903 L7: 200542710300 ;0.69314718056 LS: 0 LZ: 0 PRGEND TITLE COS %EXTERNALREALFN COS(%REAL X) ;FLOATING POINT SINGLE PRECISION COSINE FUNCTION ;COS CALLS SIN TO CALCULATE SIN(PI/2+X) ;THE ROUTINE IS CALLED AS FOLLOWS ; MOVE ARG1,X ; PUSHJ P,COS ;THE ANSWER IS RETURNED IN ACCUMULATOR AC SEARCH IMPPRM ENTRY COS EXTERN SIN TWOSEG 400000 COS: FADR ARG1,PIOT ;ADD PI/2. CALL SIN ;CALCULATE SIN(PI/2+X) RETURN ;COS RETURN RELOC 0 PIOT: 201622077325 ;PI/2 PRGEND TITLE SIN %EXTERNALREALFN SIN(%REAL X) ;FLOATING POINT SINGLE PRECISION SINE FUNCTION ;THIS ROUTINE CALCULATES SINES AFTER REDUCING THE ARGUMENT TO ;THE FIRST QUADRANT AND CHECKING THE OVERFLOW BITS TO DETERMINE ;THE QUADRANT OF THE ORIGINAL ARGUMENT. ;000 - 1ST QUADRANT ;001 - 2ND QUADRANT ;010 - 3RD QUADRANT ;011 - 4TH QUADRANT ;THE ALGORITHM USES A MODIFIED TAYLOR SERIES TO CALCULATE ;THE SINE OF THE NORMALIZED ARGUMENT. ;THE ROUTINES ARE CALLED IN THE FOLLOWING MANNER: ; MOVE ARG1,X ; PUSHJ P,SIN ;THE RESULT IS RETURNED IN ACCUMULATOR AC SEARCH IMPPRM TWOSEG 400000 ENTRY SIN A=0 B=1 C=2 D=3 SIN: MOVE B,ARG1 ;PICK UP THE ARG. S1: MOVEM B,SX ;SAVE THE ARG. MOVMS B ;GET ABS OF ARG. CAMG B,SP2 ;SIN(X)=X IF X<2^-9. JRST S3A ;EXIT WITH ARG. IN A. MOVEM C,SC ;SAVE AC C. FDV B,PIOT ;DIVIDE X BY PI/2. CAMG B,ONE ;IS X/(PI/2) < 1.0 ? JRST S2 ;YES,ARG IN 1ST QUADRANT ALREADY. MULI B,400 ;NO,SEPARATE FRACTION AND EXP. LSH C,-202(B) ;GET X MODULO 2PI. TLZ C,(1B0) ;SUPRESS ERROR MESSAGE FROM OVTRAP. MOVEI B,200 ;PREPARE FLOATING FRACTION. ROT C,3 ;SAVE THREE BITS TO DETERMINE QUADRANT. LSHC B,33 ;ARGUMENT NOW IN THE RANGE (-1,1). FAD B,SP3 ;NORMALIZE THE ARGUMENT. JUMPE C,S2 ;REDUCED TO 1ST QUAD IF BITS 000. TLCE C,1000 ;SUBTRACT 1.0 FROM ARG IF BITS ARE FSB B,ONE ;001 OR 011. TLCE C,3000 ;CHECK FOR FIRST QUADRANT, 001. TLNN C,3000 ;CHECK FOR THIRD QUADRANT, 010. MOVNS B ;001,010. S2: SKIPGE SX ;CHECK SIGN OF ORIGINAL ARG. MOVNS B ;SIN(-X)=-SIN(X). MOVEM B,SX ;STORE REDUCED ARG. FMPR B,B ;CALCULATE X^X MOVE A,SC9 ;GET 1ST CONSTANT. FMP A,B ;MULTIPLY BY X^2 FAD A,SC7 ;ADD IN NEXT CONSTANT. FMP A,B ;MULTIPLY BY X^2. FAD A,SC5 ;ADD IN NEXT CONSTANT. FMP A,B ;MULTIPLY BY X^2. FAD A,SC3 ;ADD IN NEXT CONSTANT. FMP A,B ;MULTIPLY BY X^2. FAD A,PIOT ;ADD IN LAST CONSTANT. S2B: FMPR A,SX ;MULTIPLY BY X. SKIPA C,SC ;RESTORE AC C. S3A: MOVE A,SX ;ANSWER IN X. IFN AC ;RESULT IN AC RETURN ;SIN RETURN RELOC 0 SC3: 577265210372 SC5: 175506321276 SC7: 606315546346 SC9: 164475536722 SP2: 170000000000 SP3: 0 SX: 0 CD1: 90.0 SCD1: 206712273406 PIOT: 201622077325 SC: 0 ONE: 1.0 PRGEND TITLE SQR %EXTERNALREALFN SQR(%REAL X) ;FLOATING POINT SINGLE PRECISION SQUARE ROOT FUNCTION ;THE SQUARE ROOT OF THE ABSOLUTE VALUE OF THE ARGUMENT IS ;CALCULATED. THE FIRST GUESS IS CALCULATED TO BE OPTIMUM ;FOR NUMBERS BETWEEN 1/2 AND 2 ;FOLLOWED BY TWO ITERATIONS OF NEWTON'S METHOD. ;THE CALLING SEQUENCE FOR THE SQUARE ROOT IS AS FOLLOWS: ; MOVE ARG1,X ; PUSHJ P,SQR ;THE ANSWER IS RETURNED IN ACCUMULATOR AC. SEARCH IMPPRM TWOSEG 400000 ENTRY SQR A=0 B=1 SQR: SKIPG B,ARG1 ;PICK UP ARG. CHECK IF > 0 JRST SQRTLE ;NO, HANDLE NON-POSITIVE ARGUMENT SQRTP: MOVE A,B ;SAVE NUMBER LSH B,-1 ;DIVIDE EXP BY 2 TLZE B,400 ;WAS EXPONENT ODD? JRST SQRT2 ;YES ;HERE WHEN EXPONENT WAS EVEN. B CONTAINS AN UNNORMALIZED FLOATING ; POINT NUMBER, THE FRACTION PART OF WHICH IS 1/2 THE FRACTION OF ; THE ARGUMENT. OUR INITIAL GUESS IS MADE BY A LINEAR APPROXIMATION ; USING Y0 = SE (X + C), WHERE SE AND C ARE CONSTANTS USED FOR ; EVEN EXPONENTS IN X. ADD B,CONST1 ;COMPUTE LINEAR APPROXIMATION FMPRI B,301454 ;RESCALE EXPONENT JRST SQRT3 ;HERE WITH ODD EXPONENT, USE Y0 = SO * (X+C). SQRT2: ADD B,CONST1 ;LINEAR APPROXIMATION FMPRI B,301650 ;RESCALE EXPONENT SQRT3: FDV A,B ;ORIGINAL / INITIAL GUESS FAD B,A ;AVERAGE THEM FSC B,-1 MOVM A,ARG1 ;GET ORIGINAL NUMBER FDV A,B ;SECOND ITERATION FADR A,B FSC A,-1 ;AVERAGE THIRD GUESS WITH SECOND IFN AC ;GET RESULT IN AC IF IT ISN'T RETURN ;SQR RETURN SQRTLE: JUMPE B,ZERO ERROR(6,2,0,IMPSTR) ZERO: MOVEI AC,0 ;HERE ON NON-POSITIVE ARG. RETURN ZERO RETURN ;SQRT RETURN RELOC 0 ;DATA SEGMENT CONST1: XWD 267,607000 ;CONSTANT FOR 1ST APPROX PRGEND TITLE EXP %EXTERNALREALFN EXP(%REAL X) ;FLOATING POINT SINGLE PRECISION EXPONENTIAL FUNCTION ;IF X<=-89.415..., THE PROGRAM RETURNS ZERO AS THE ANSWER ;IF X>= 88.029 AN OVERFLOW EVENT IS SIGNALLED ;THE RANGE OF THE ARGUMENT IS REDUCED AS FOLLOWS: ;EXP(X) = 2**(X*LOG(E)BASE2) = 2**(M+F) ;WHERE M IS AN INTEGER AND F IS A FRACTION ;2**M IS CALCULATED BY ALGEBRAICALLY ADDING M TO THE EXPONENT ;OF THE RESULT OF 2**F. 2**F IS CALCULATED AS ;2**F = 2(0.5+F(A+B*F^2 - F-C(F^2 + D)**-1)**-1 ;THE ROUTINE HAS THE FOLLOWING CALLING SEQUENCE: ; MOVE ARG1,X ; PUSHJ P,EXP ;THE ANSWER IS RETURNED IN ACCUMULATOR AC A= 0 B= 1 C= 2 D= 3 SEARCH IMPPRM ENTRY EXP TWOSEG 400000 EXP: MOVE B,ARG1 ;PICK UP THE ARGUMENT IN B CAMGE B,E77 ;IS EXP. < -89.41...? JRST OUT2 ;YES, GO TO EXIT. CAMG B,E7 ;IS EXP. > +88.029...? JRST EXP1 ;GO TO STANDARD ALGORITHM. HALT ;!*** TEMP ***! HRLOI A, 377777 ;GET LARGEST FLOATING NUMBER RETURN ;RETURN OUT2: MOVEI AC,0 ;EXPONENT <-88 IMPLIES RESULT=0 RETURN ;EXP RETURN EXP1: MOVEM C, ES1 ;SAVE ACCUMULATOR C MOVEM D, ES3 ;SAVE ACCUMULATOR D SETZM ES2 ;INITIALIZE ES2 MULI B, 400 ;SEPARATE FRACTION AND EXPONENT TSC B, B ;GET A POSITIVE EXPONENT MUL C, E5 ;FIXED POINT MULTIPLY BY LOG2(E) ASHC C, -242(B) ;SEPARATE FRACTION AND INTEGER AOSG C ;ALGORITHM CALLS FOR MULT. BY 2 AOS C ;ADJUST IF FRACTION WAS NEGATIVE HRRM C, TEMP ;SAVE FOR FUTURE SCALING JUMPG D,ASHH ;GO AHEAD IF ARG > 0. TRNN D,377 ;ARE ALL THESE BITS 0? JRST ASHH ;YES, GO AHEAD. ADDI D,200 ;NO, FIX UP. ASHH: ASH D, -10 ;MAKE ROOM FOR EXPONENT TLC D, 200000 ;PUT 200 IN EXPONENT BITS FADB D, ES2 ;NORMALIZE, RESULTS TO D AND ES2 FMP D, D ;FORM X^2 MOVE A, E2 ;GET FIRST CONSTANT FMP A, D ;E2*X^2 IN A FAD D, E4 ;ADD E4 TO RESULTS IN D MOVE B, E3 ;PICK UP E3 FDV B, D ;CALCULATE E3/(F^2 + E4) FSB A, B ;E2*F^2-E3(F^2 + E4)**-1 MOVE C, ES2 ;GET F AGAIN FSB A, C ;SUBTRACT FROM PARTIAL SUM FAD A, E1 ;ADD IN E1 FDVM C, A ;DIVIDE BY F FAD A, E6 ;ADD 0.5 EX1: MOVE B,TEMP ;GET THE SCALE FACTOR FSC A,(B) ;SCALE THE RESULTS MOVE C, ES1 ;RESTORE ACCUMULATOR C MOVE D, ES3 ;RESTORE ACCUMULATOR D IFN AC ;GET THE ANSWER IF ITS NOT THERE ALREADY RETURN ;AND RETURN RELOC 0 E1: 204476430062 ;9.95459578 E2: 174433723400 ;0.03465735903 E3: 212464770715 ;617.97226953 E4: 207535527022 ;87.417497202 E5: 270524354513 ;LOG(E), BASE 2 E6: 0.5 E7: 207540074636 ;88.029... E77: 570232254037 ;-89.415986 ES1: 0 ES2: 0 ES3: 0 TEMP: 0 PRGEND END $$$$$$$$$$$$ &&&&&&&&&&&& SETSRC.IMP %INCLUDE "IMP:IOLIB.INC" %EXTERNALRECORD(SCB)%NAME%SPEC INSCB %EXTERNALSTRING(6)%FNSPEC SIXTOSTR(%INTEGER I) %EXTERNALROUTINESPEC RESET INPUT %EXTERNALROUTINESPEC USET INPUT(%INTEGER N) %OWNINTEGER N,F,C,CC,I,I1,I2,J,NENTRY %CONSTINTEGER MAX ENTRIES=5500 %OWNINTEGERARRAY PPNS(1:MAX ENTRIES) %OWNINTEGERARRAY LOCATION(1:MAX ENTRIES) %CONSTINTEGER UUPHS=8_400000000000; !Physical lookup %CONSTINTEGER IODMP=8_17; !Dump mode I/O %CONSTINTEGER OPEN=8_050; !Open UUO %CONSTINTEGER LOOKUP=8_076 %CONSTINTEGER ENTER=8_077 %CONSTINTEGER USETO=8_075 %CONSTINTEGER UFD=8_654644000000; !SIXBIT/UFD/ %CONSTINTEGER RBDIR=8_400000; !This is a directory bit %CONSTINTEGER STRUUO=8_50; !STRUUO code %OWNINTEGERARRAY STR ARG(1:50); !Where STRUUO args get built ! !Standard library ROUTINE s ! %EXTERNALSTRING(255)%SPEC ERRMSG %EXTERNALROUTINESPEC SLEEP(%INTEGER TIME) %EXTERNALPREDICATESPEC CALLI2(%INTEGER N,%INTEGERNAME AC) %SYSTEMROUTINESPEC CLOSE(%INTEGER CHAN) %SYSTEMINTEGERFNSPEC GET CHANNEL %SYSTEMPREDICATESPEC IO UUO(%INTEGER UUO,CHAN,%NAME ARG) %SYSTEMROUTINESPEC RELEASE(%INTEGER CHAN) ! ! %OWNINTEGER NSTRUCS; !No of structures %OWNINTEGER CREATION=0; !Creation date/time of AUXACC.SYS %OWNINTEGER CHAN=0; !I/O channel %CONSTINTEGER TEMP STREAM=13; !TEMP STREAM NUMBER %ROUTINE READ AUXACC(%INTEGERNAME NO) !============================================= ! !Reads AUXACC.SYS putting PPN's into array PPN, and Location of the !first word (-1) of an entry into Location ! %ON %EVENT 9 %START NO=N %RETURN %FINISH %INTEGERFN NEXT READ SYMBOL(C) F=F+1 %RESULT=C %END F=0 CC=NEXT; !Throw away first entry N=0 %CYCLE %SIGNAL %EVENT 15,1,1 %UNLESS NEXT=-1 N=N+1 %IF N>MAX ENTRIES %THEN %SIGNAL 15,1,6 NO=NEXT; !No of words to follow PPNS(N)=NEXT; !PPN LOCATION(N)=F-3 CC=NEXT %FOR I=1,1,NO-1 %REPEAT %END %INTEGERFN FIND(%INTEGER PPN) !===================================== N=0 %FOR I=1,1,NENTRY %CYCLE %IF PPN=PPNS(I) %THEN %RESULT=LOCATION(I) %IF PPNFALSE %FINISH %TRUE %IF PPN=PREVIOUS PPN CHAN=-1 IN=INSTREAM DEFINE INPUT(TEMP STREAM,"SYS:AUXACC.SYS/MODE:#400000000014/EXTEND:#35/BUFF:1") SELECT INPUT(TEMP STREAM) %IF CREATION#INSCB_LKENT_TIM %START READ AUXACC(NENTRY) CREATION=INSCB_LKENT_TIM RESET INPUT %FINISH I1=FIND(PPN) %IF I1=0 %THEN ->FALSE I2=I1>>7 I1=I1&8_177 USET INPUT(I2+1) %IF I1>0 %START SKIP SYMBOL %FOR I=1,1,I1 %FINISH READ SYMBOL(C) READ SYMBOL(N) READ SYMBOL(CC) %SIGNAL %EVENT 15,1,1 %UNLESS C=-1 %AND (CC=PPN %OR CC=PPN!8_777777) CHAN=GET CHANNEL N=N//5 NSTRUCS=0 ZERO SEARCH LIST DO UFD(PPN) %FOR I=1,1,N SET SEARCH LIST RELEASE(CHAN) CLOSE INPUT; SELECT INPUT(IN) PREVIOUS PPN=PPN %TRUE FALSE: RELEASE(CHAN) %IF CHAN>=0; !IF ONE IN USE CLOSE INPUT SELECT INPUT(IN) PREVIOUS PPN=0 %FALSE %END %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& MPBQUE.IMP ! !Q1 contains a template for the spool request file ! %CONSTINTEGERARRAY Q1(1:31)= %C 8_000000010101,8_023014000001,8_546064000000,8_000001000002,8_514255444555,8_000000000000,8_000000055012,8_000000000000 %C ,8_000000000000,8_000000000000,8_000000000000,8_000000000000,8_000000000372,8_464151546341,8_464500000000,8_000000000000 %C ,8_000000000010,8_000000000000,8_000000000000,8_446353442000,8_000110000112,8_000000000000,8_000000000000,8_000000000000 %C ,8_000000000000,8_000000000000,8_514255444555,8_647064000000,8_000000000000,8_000000000001,8_010000111101 %EXTERNALSTRING(50)%FNSPEC DEFUNI(%INTEGER I,%STRING(20)S1,S2) %EXTERNALRECORD(FILESPEC)%FNSPEC STRTOFS(%STRING(1)SPEC) %EXTERNALROUTINESPEC REPORT(%STRING(255) S) %EXTERNALINTEGERFNSPEC STRTOSIX(%STRING(1)S) %OWNINTEGERNAME P=8_17; !STACK %OWNINTEGER SAVEP %OWNINTEGERNAME ARG1=1 %EXTERNALROUTINESPEC QUEUER %EXTERNALROUTINE MPBQUEUE(%STRING(255)FSPEC,JOB NAME,USER NAME,DEVICE,%INTEGER PPN,LOCATION,SIZE,DELETE) !===================================================================================================== ! !This is a complete kludge to enter files into a LPT or IBM queue. for MPB ! !Arguments are: !FSPEC a full filespec including structure and PPN !JOB NAME JOB NAME in queue. Will eventually default to filename !USER NAME User name. Will default to user name of this job !DEVICE Device for queue request. must be "LPT" or "IBM" !PPN PPN for request. Default is as for file, or jobs ppn !LOCATION Node number for queue, default is node for this job !SIZE Size of file (can probably be omitted) !DELETE =1 delete file after sending, otherwise preserve ! !N.B. This routine calls QUEUER, which calls QMANGR by doing a GETSEG ! !BEWARE !====== ! !Programs using this routine MUST be shareable, and MUST have the stack in the !low segment ! %RECORD(FILESPEC) FILE %INTEGER %ARRAY Q2(0:31) %STRING (50) FNAME %INTEGER I,J %INTEGERFN GETJOB(%INTEGER I) !========================== ! !Does a GETTAB for this job on table I ! %EXTERNALPREDICATESPEC CALLI2(%INTEGER NUM,%INTEGERNAME AC) I=-1<<18+I %SIGNAL %EVENT 15 %UNLESS CALLI2(8_41,I) %RESULT=I %END %ON %EVENT 15 %START REPORT("GETTAB failed in PRINT request") %RETURN %FINISH %UNLESS DEVICE="LPT" %OR DEVICE="IBM" %START; !First check an allowed queue REPORT("Illegal QUEUE request for Device ".DEVICE) %RETURN %FINISH Q2(I)=Q1(I) %FOR I=1,1,31; !Copy template into parameter area FILE=STRTOFS(FSPEC); !Get FSPEC into record to ease later processing %IF LOCATION<=0 %OR LOCATION>63 %THEN LOCATION=8_50; !Set a default location Q2(3)=STRTOSIX(DEVICE."S")+(LOCATION&8_70)<<3+LOCATION&8_7+8_2020; !make device acceptable to QMANGR (i.e. LPTS50) %IF PPN=0 %START %IF FILE_PPN=0 %THEN PPN=GETJOB(8_02) %ELSE PPN=FILE_PPN; !FIind a convenient default for PPN %FINISH %IF FILE_PPN=0 %THEN FILE_PPN=PPN %IF JOB NAME#"" %THEN Q2(5)=STRTOSIX(JOB NAME) %ELSE Q2(5)=STRTOSIX(FILE_FILE); !DEFAULT FOR JOB NAME %IF USERNAME#"" %START; !unless user name null then J=LENGTH(USER NAME) %IF J<6 %THEN I=J %ELSE I=6 Q2(14)=STRTOSIX(SUB STRING(USER NAME,1,I)) %IF J>6 %THEN Q2(15)=STRTOSIX(SUB STRING(USER NAME,7,J)) %FINISH %ELSE %START Q2(14)=GETJOB(8_31); !First half of user name in SIXBIT Q2(15)=GETJOB(8_32); !Second half of user name %FINISH Q2(17)=Q2(17)+(SIZE<<18); !Size to print (QMANGR will probably sort this out) Q2(20)=STRTOSIX(FILE_DEV) %IF Q2(20)=0 %THEN Q2(20)=STRTOSIX("ALL"); !If no structure given spread the net widely Q2(21)=FILE_PPN I=1 %CYCLE J=STRTOSIX(FILE_SFDS(I)) Q2(21+I)=J I=I+1 %REPEAT %UNTIL I=5 %OR J=0; !Copy file spec Q2(27)=STRTOSIX(FILE_FILE); !File name Q2(28)=STRTOSIX(FILE_EXT); !Extension Q2(31)=Q2(31)!(DELETE<<7) %BEGIN %INTEGERARRAY FOO(0:50); !Kludge to ensure sufficient stack FOO(50)=0 %END SAVEP=P; !Preserve stack pointer P=-50<<18+P&8_777777; !QMANGR assumes PDL is of normal form ARG1=32<<18+ADDR(Q2(0)); !Pass request in AC1 QUEUER P=SAVEP %END %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& QUEUE.IMP !QUEUE.IMP !ENTERS A FILE INTO A GIVEN GALAXY QUEUE %INCLUDE "IMP:IOLIB.INC" %CONSTINTEGER MAX STREAMS=15 %EXTERNALRECORD(SCBNAME)%ARRAY %SPEC INVEC(-1:MAX STREAMS) %EXTERNALRECORD(SCB)%NAMESPEC INSCB %EXTERNALRECORD(FILESPEC)%FNSPEC STRTOFS(%STRING(255) STR) %EXTERNALPREDICATESPEC CALLI2(%INTEGER N,%INTEGERNAME X) %EXTERNALSTRING(6)%FNSPEC SIXTOSTR(%INTEGER N) %EXTERNALINTEGERFNSPEC PPN %SYSTEMPREDICATESPEC GETTAB(%INTEGER N,M,%INTEGERNAME RES) %EXTERNALINTEGERFNSPEC STRTOSIX(%STRING(6) S) %EXTERNALROUTINESPEC QUEUEIT(%NAME N,%STRING(1)%NAME MESS); !TO SEND REQUEST TO QUASAR %EXTERNALSTRING(255)%SPEC ERRMSG %STRING(6)%FN DEVICE OF(%RECORD(FILESPEC) FS) !================================================== !returns the device on which a file exists ! %INTEGER N,TEMP,ARG,DEVNAME %RECORDFORMAT DSKCHR(%INTEGER NAM,UFT,FCT,UNT,SNM) %RECORD(DSKCHR) D %IF FS_DEV#"" %THEN %RESULT=FS_DEV %ELSE FS_DEV="ALL" %FOR N=1,1,MAX STREAMS %CYCLE %IF INVEC(N)_NAME_DEVTYP=UNDEV %START TEMP=N; ->OK %FINISH %REPEAT ERRMSG="No free streams for routine QUEUE " %SIGNAL 10 OK: FS_SWITCHES="/EXT:#16" XDEFINE INPUT(TEMP,FS) N=INSTREAM; SELECT INPUT(TEMP) DEVNAME=INSCB_LKENT_DEV CLOSE INPUT SELECT INPUT(N) D=0 D_NAM=DEVNAME ARG=5<<18!ADDR(D) %IF CALLI2(8_45,ARG) %START; %FINISH %RESULT = SIXTOSTR(D_SNM) %END %EXTERNALROUTINE QUEUE(%STRING(70) FILSPEC, %STRING(12) JOB NAME, USER NAME,DEVICE,%INTEGER USER PPN,SIZE,LIMIT,DISPOSE,LOG,%STRING(1)%NAME MESSAGE) !==================================================================================================== ! !This routine sends a file request to QUASAR ! !Arguments are: !FILSPEC a full filespec which if it does not include a structure name ! the file will be looked up for it. !JOB NAME the JOB NAME in the queue which defaults to the file name !USER NAME which defaults to the user name of this job !DEVICE any device recognised by QUASAR, may include node number !USER PPN PPN of request, defaults to this jobs PPN !SIZE OUTPUT blocks in file, should be present. or INPUT core page limit !LIMIT OUTPUT page limit or INPUT time limit(seconds) !DISPOSE for OUTPUT 1 = delete after printing, 0 = preserve ! for INPUT /output:value !LOG what to do with the log file for batch jobs ! %RECORDFORMAT FPARAM(%INTEGER SIZE,INF,START,REP1,REP2) %RECORDFORMAT FD(%INTEGER DEV,FILE,EXT,PPN,%INTEGERARRAY SFD(1:5)) %RECORDFORMAT EQ(%INTEGER HEAD,PID,LEN,REQDEV,JOBNAME,SEQ,SPC,AFT,DED,LIM1, %C LIM2,LIM3,LIM4,LIM5,%INTEGERARRAY CHECK(1:5),ACC(1:8),USERNAME(1:2), %C %INTEGER OWNER, %INTEGERARRAY OWN PATH(1:5),%RECORD(FPARAM) FP, %RECORD(FD) F, %C %RECORD(FPARAM) FP1, %RECORD(FD) F1) %RECORD(EQ) E %RECORD(FILESPEC) FS %INTEGER N,I,EPPN,LEN,SIZ,NUM OF FILES, DELETE, OUTPUT SW %CONSTINTEGER QSRVER=8_33; !QUEUE VERSION %CONSTINTEGER EQLEN=35, FPLEN=9 ; !LENGTH OF EQ AND BASIC F %CONSTINTEGER INP DEV=8_515660; !SIXBIT/INP/ %INTEGERFN ERSATZ(%STRING(6) DEV) !RETURNS THE PPN IMPLIED BY AN ERSATZ DEVICE NAME %INTEGER PN %CONSTINTEGER DEVPPN=8_55, DSK=8_446353 000000; !SIXBIT 'DSK' %RESULT=0 %IF LENGTH(DEV)#3 PN=STRTOSIX(DEV) %RESULT=0 %IF PN=DSK %OR %NOT CALLI2(DEVPPN,PN) %RESULT=PN %END %INTEGERFN GETJOB(%INTEGER N) %INTEGER M %UNLESS GETTAB(N,-1,M) %START ERRMSG="GETTAB failure"; %SIGNAL 15 %FINISH %RESULT=M %END %ON %EVENT 15 %START PRINTSTRING(ERRMSG) PRINTSTRING("IN QUEUE routine") %RETURN %FINISH %IF GETTAB(8_126,3,N) %AND N#0 %START; !GALAXY V4 - GET PID FOR MDA MESSAGE="[file ".FILSPEC." not queued to GALAXY]" %return %FINISH FS=STRTOFS(FILSPEC) %IF FS_FILE="" %START ERRMSG="filename missing in QUEUE request" %signal 15 %FINISH EPPN=ERSATZ(FS_DEV) %IF EPPN#0 %START FS_PPN=EPPN; FS_DEV=""; !USE ERSATZ PPN %FINISH FS_DEV=DEVICE OF(FS) E=0; !initialise the record E_LEN=QSRVER<<18!EQLEN E_REQDEV=STRTOSIX(DEVICE) %IF E_REQDEV>>18=INP DEV %START; !DISTINGUISH BETWEEN INPUT AND OUTPUT QUEUES NUM OF FILES=2; DELETE=0; OUTPUT SW=DISPOSE!8_500!LOG; !UNIQUE AND NON-RESTARTABLE %ELSE NUM OF FILES=1; DELETE=DISPOSE; OUTPUT SW=0 %FINISH %IF JOBNAME="" %THEN E_JOBNAME=STRTOSIX(FS_FILE) %ELSE E_JOBNAME=STRTOSIX(JOBNAME) E_SEQ=8_600!(GETJOB(8_26)<<12); !STATION # OF LAST LOCATE COMMAND AND PRIV BIT TO ALLOW DELETES AFTER PRINTING E_SPC=NUM OF FILES ;!NUMBER OF REQUESTS E_LIM1=OUTPUT SW<<27 E_LIM2=SIZE<<18!LIMIT N=LENGTH(USERNAME) %IF N=0 %START E_USERNAME(1)=GETJOB(8_31) E_USERNAME(2)=GETJOB(8_32) %ELSE %IF N<6 %THEN I=N %ELSE I=6 E_USERNAME(1)=STRTOSIX(SUBSTRING(USERNAME,1,I)) E_USERNAME(2)=STRTOSIX(SUBSTRING(USERNAME,7,N)) %IF N>6 %FINISH %IF USER PPN=0 %THEN E_OWNER=PPN %ELSE E_OWNER=USER PPN !Now fill the file parameter block E_FP_INF=8_10001 000001!(DELETE&1)<<17; !STANDARD BIT SETTINGS E_FP_START=1 !Now fill the file definition record E_F_DEV=STRTOSIX(FS_DEV) E_F_FILE=STRTOSIX(FS_FILE) E_F_EXT=STRTOSIX(FS_EXT) %IF FS_PPN=0 %THEN E_F_PPN=PPN %ELSE E_F_PPN=FS_PPN SIZ=4; !SIZE OF PATH BLOCK LEN=EQLEN+FPLEN; !BASIC LENGTH OF ENTRY %FOR N=1,1,5 %CYCLE %EXIT %IF FS_SFDS(N)="" SIZ=SIZ+1; !INCREASE LENGTH OF PATH BLOCK COUNT LEN=LEN+1; !INCREASE LENGTH OF ENTRY COUNT E_F_SFD(N)=STRTOSIX(FS_SFDS(N)) %REPEAT E_FP_SIZE=5<<18!SIZ %IF NUM OF FILES=2 %START E_FP1=E_FP; E_F1=E_F; E_F1_EXT=STRTOSIX("LOG"); !PUT IN A LOG FILE E_FP1_INF=E_FP1_INF!8_200000; !SAY THIS IS THE LOG FILE E_FP_SIZE=5<<18!FPLEN; !USE MAX PATH SIZE FOR FIRST SPEC LEN=LEN+FPLEN+5; !ADD ONE MORE FILESPEC OVER THE BASIC LENGTH %FINISH E_HEAD=8_400000 000007!(LEN<<18); !REPLY, LENGTH AND TYPE(7=CREATE) QUEUEIT(E,MESSAGE) %END %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& GALAXY.MAC TITLE GALAXY interface to GALAXY SEARCH QSRMAC ;GALAXY PARAMETERS SEARCH SBSMAC ;SUB-SYSTEMS GROUP MACROS SEARCH MACTEN ;USEFUL MACROS SEARCH UUOSYM ;TOPS10-UUO SYMBOLS IFN FTJSYS, ;TOPS20-JSYS SYMBOLS SEARCH QPRM ;MPB PARAMETERS SEARCH IMPPRM ;IMP PARAMETERS DEFINE FAIL(MSG)< JRST [MOVEI 1,%A MOVEI 2,ERRMSG## JSP J,.$MOVE## POP P,J ;GET ORIG RETURN ADDRESS MOVEI ARG1,^D15 ;%SIGNAL 15 SETZB ARG2,ARG3 GOTO .$SNAL## %A: MSG] > ;END OF DEFINE FAIL ; MACRO TO MOVE DATA AROUND -- WIPES TEMP DEFINE DATAM(SWRD,SFIELD,DWRD,DFIELD)< LOAD(TEMP,SWRD,SFIELD) XLIST STORE(TEMP,DWRD,DFIELD) LIST SALL > ;END OF DEFINE DATAM TWOSEG RELOC 400000 ;%EXTERNALROUTINE QUEUEIT(%NAME ARG BLOCK,%STRING(1)%NAME MESSAGE) QUEUEIT:: SETMM 110(P) ;STACK CHECK PUSHJ P,SAVEACS## ;SAVE IMP REGISTERS MOVEM ARG2,SARG2# ;SAVE THE STRING NAME ADDRESS HRRZ M,ARG1 ;SET UP M MOVEI T1,1000 ;NUMBER OF WORDS PUSHJ P,CORGET ;GET A PAGE MOVE T1,.JBFF## ;GET TOP OF CORE SOS T1 ;MAKE SURE IN LOWER PAGE ANDI T1,777000 ;GET START OF PAGE MOVEI T2,(T1) ;GET ANOTHER COPY SETZM (T1) ;CLEAR IT HRLI T3,(T1) ;SET UP BLT POINTER HRRI T3,1(T1) BLT T3,777(T1) ;ZERO PAGE HRL T1,M ;SET UP BLT POINTER BLT T1,77(T2) ;COPY ARG BLOCK INTO FREE PAGE MOVE M,T2 ;SET UP NEW M TXO M,1B0 ;MARK AS PAGE MODE PUSHJ P,MSGSND ;SEND THE MESSAGE PUSHJ P,RCVACK ;GET THE ACK PJRST RESTORE## ;RESTORE ACS AND RETURN TO CALLER CPOPJ: POPJ P, CORGET: ADDB T1,.JBFF## ;BUMP HIGHEST, GET SAME SUBI T1,1 ;BACK OFF BY ONE CAMG T1,.JBREL## ;ALREADY HAVE ENOUGH POPJ P, ;YES, CAN SAVE A CORE UUO CORE T1, ;ACQUIRE THE CORE FAIL(IMPSTR) POPJ P, ;AND RETURN ;ERROR ROUTINES ;ERR CONCATENATES THE STRING POINTED TO BY T1 ONTO THE END OF ERRMSG ERR: MOVE 1,T1 MOVEI 2,ERRMSG## JSP J,.$CONC## ;CONCATENATE ONTO ERRMSG POPJ P, IFN FTUUOS,< QUEQRY: SETZB T1,T2 ;CLEAR QUERY BLOCK SETZB T3,T4 ;FOR GOOD MEASURE MOVE S2,[4,,T1] ;LENGTH,,ARGUMENTS IPCFQ. S2, ;FIND OUT WHATS THERE SETZ T4, ;NOTHING, CLEAR T4 MOVE S2,T4 ;COPY QUEUE STATUS INTO S2 JUMPE S2,CPOPJ ;RETURN IF NOTHING THERE CAMN T2,QSRPID ;FROM QUASAR POPJ P, ;YES, RETURN NOW PUSHJ P,QUEIGN ;FLUSH THE JUNK MAIL JRST QUEQRY ;LOOK AGAIN QUEIGN: ANDX T1,IP.CFV ;CLEAR ALL BUT PAGE MODE BIT TXO T1,IP.CFT ;SET TO TRUNCATE SETZB T2,T3 ;CLEAR THEM AGAIN MOVEI T4,1 ;LENGTH = 0 , LOC = 1 MOVE S2,[4,,T1] ;SET UP LENGTH AND BLOCK ADDRESS IPCFR. S2, ;THROW AWAY THE MESSAGE FAIL(IMPSTR) POPJ P, ;RETURN QUEWAT: PUSHJ P,QUEQRY ;FIND OUT WHATS THERE JUMPN S2,CPOPJ ;SOMETHING, RETURN MOVX S2, ;FLAGS,,NAP TIME HIBER S2, ;WAIT FOR A REASONABLE TIME JFCL ;WATCH THIS LOOP JRST QUEWAT ;TRY NOW > ;END OF IFN FTUUOS ; SUBROUTINE TO RECEIVE AN EXPECTED "ACK" FROM QUASAR ; IT RETURNS TO THE CALLER AFTER RECEIVING A "GOOD" ONE ; ISSUES AN ERROR MESSAGE AND QUITS ON A "BADDY" RCVACK: MOVEI M,FBTEMP ;AREA FOR SHORT RECEIVE IFN FTUUOS,< PUSHJ P,QUEWAT ;WAIT FOR A RETURNED MESSAGE ANDX T1,IP.CFV ;CLEAR ALL BUT THE PAGE MODE BIT SETZB T2,T3 ;CLEAR THESE AGAIN HRRI T4,(M) ;WHERE TO RECEIVE INTO TXNN T1,IP.CFV ;IS IT A PAGE JRST RCVA.1 ;NO, GO GET IT MOVE M,.JBREL## ;GET A PAGE TO RECEIVE INTO MOVEI M,777(M) ;ROUND UP ADR2PG M ;CONVERT TO PAGE NUMBER HRRI T4,(M) ;SET THE ADDRESS HRLI T4,1000 ;LENGTH OF A PAGE PG2ADR M ;STILL NEED TO POINT TO IT RCVA.1: MOVE S2,[4,,T1] ;READY TO GET IT IPCFR. S2, ;GET THE ACK FROM QUASAR FAIL(IMPSTR) > ;END OF IFN FTUUOS IFN FTJSYS,< SETZB T1,T2 ;CLEAR FLAGS, SENDER MOVE T3,MYPID ;RECEIVER HRLI T4,FBAREA ;SIZE OF SHORT MESSAGE HRRI T4,FBTEMP ;TEMPORARY BLOCK PUSH P,S1 ;SAVE USER AREA BASE MOVEI S1,4 ;FOUR WORDS MOVEI S2,T1 ;IN T1-T4 MRECV ;RECEIVE THE ACK FAIL(IMPSTR) POP P,S1 ;RESTORE USER BASE > ;END OF IFN FTJSYS LOAD S2,TEX.ST(M) ;GET THE MESSAGE STATUS WORD TXNE S2,TX.NMS ;NORMAL "ACK" (NO MESSAGE ASSOCIATED) JRST RCVA.3 ;YES, SEE IF IT IS TIME TO RETURN ;FALL ONTO THE NEXT PAGE FOR THE OUTPUT OF THE MESSAGE RECEIVED ;HERE TO OUTPUT THE BODY OF THE ACK MESSAGE RCVA.4: SETZM ERRMSG## ;CLEAR ERROR MESSAGE PUSH P,S2 ;SAVE S2 MOVEI T1,[IMPSTR<[>] ;CHARACTER FOR INFORMATIONAL MESSAGES TXNN S2,TX.FAT!TX.WRN ;FATAL OR WARNING JRST RCVA.2 ;NEITHER, JUST REPORT THE TEXT MOVEI T1,[IMPSTR] ;FATAL CHARACTER TXNN S2,TX.FAT ;WAS IT FATAL MOVEI T1,[IMPSTR<%QSR>] ;NO, LOAD WARNING CHARACTER PUSHJ P,ERR ;OUTPUT THE "?" OR "%" LOAD T1,TEX.ST(M),TX.SUF ;GET THE MESSAGE SUFFIX HRLZS T1 ;INTO THE OTHER SIDE FOR TTYSIX MOVE ARG1,T1 ADDI P,4 PUSHJ P,SIXTOS## ;OUTPUT THE FULL ERROR CODE MOVEI T1,-1(P) PUSHJ P,ERR SUBI P,4 MOVEI T1,[IMPSTR< >] RCVA.2: PUSHJ P,ERR ;MAKE THE OUTPUT PRETTY MOVEI ARG1,TEX.MS(M) ;AND FINALLY, OUTPUT THE MESSAGE ADDI P,103 PUSHJ P,ASCTOS## MOVEI T1,-77(P) PUSHJ P,ERR SUBI P,103 MOVE S2,(P) TXNN S2,TX.FAT!TX.WRN ;ANOTHER CHECK JRST [MOVEI T1,[IMPSTR<]>] ;GEE..IT TAKES A LOT TO DO NICE WORK PUSHJ P,ERR JRST .+1] POP P,S2 TXNE S2,TX.FAT ;AGAIN, WAS IT FATAL JRST FAIL1 ;NO, WELL STORE IT FOR IMP PUSH P,S2 MOVEI 1,ERRMSG MOVE 2,SARG2 JSP J,.$MOVE ;MOVE IT TO SECOND ARGUMENT POP P,S2 RCVA.3: TXNE S2,TX.MOR ;MORE COMING JRST RCVACK ;YES, DO THIS ALL OVER AGAIN POPJ P, ;CONTINUE PROCESSING FAIL1: POP P,J ;GET ORIGINAL RETURN ADDRESS MOVEI ARG1,^D15 SETZB ARG2,ARG3 JRST .$SNAL## IFN FTUUOS,< MSGSND: MOVX T4,%CNST2 ;GET SECOND STATES WORD GETTAB T4, ;TO LOOK FOR GALAXY-10 ZERO T4 ;WHAT!! TXNN T4,ST%GAL ;SYSTEM HAVE SUPPORT FOR GALAXY-10 FAIL(IMPSTR) SETO T4, ;FLAG INDICATING FIRST TRY MSGS.1: MOVX T3,%SIQSR ;GETTAB FOR PID OF [SYSTEM]QUASAR GETTAB T3, ;SEE IF IT IS RUNNING FAIL(IMPSTR) MOVEM T3,QSRPID ;REMEMBER QUASAR'S PID SETOM RTYCNT ;INIT RETRY COUNTER JUMPN T3,MSGGO ;THERE HE IS, SEND THE MESSAGE MOVEI T3,3 ;NOT UP YET, TRY A SLEEP SLEEP T3, ;GIVE IT A CHANCE AOJN T4,MSGS.1 ;JUMP IF ALREADY GAVE A MESSAGE OUTSTR [ASCIZ/ %QMRWFQ Waiting For [SYSTEM]QUASAR to Start /] JRST MSGS.1 ;TRY NOW MSGGO: SETZB T1,T2 ;CLEAR FLAGS,MY PID MOVEI T4,(M) ;MESSAGE ADDRESS, T3 = QSRPID LOAD S2,.MSTYP(M),MS.CNT ;GET THE LENGTH OF THE MESSAGE TXNN M,1B0 ;IS THIS A PAGE MODE REQUEST JRST MSGGO1 ;NO, SEND IT MOVX T1,IP.CFV ;INDICATE A PAGE SEND LSH T4,-^D9 ;CONVERT 'M' TO A PAGE NUMBER MOVEI S2,1000 ;LENGTH MUST BE 1000 MSGGO1: HRL T4,S2 ;INCLUDE CORRECT SIZE IN HEADER MSGGO2: MOVE S2,[4,,T1] ;ARGUMENT FOR SEND IPCFS. S2, ;SEND THE MESSAGE SKIPA ;FAILED, SEE WHY POPJ P, ;RETURN TO CALLER CAIE S2,IPCDD% ;QUASAR DISABLED CAIN S2,IPCRS% ;OR MY QUOTA EXHAUSTED JRST RETRY ;YES, TRY IT AGAIN CAIE S2,IPCRR% ;QUASAR FULL CAIN S2,IPCRY% ;OR SYSTEM FULL JRST RETRY ;YES, TRY IT AGAIN FAIL(IMPSTR) RETRY: MOVEI S2,2 ;WAIT BEFORE TRYING AGAIN SLEEP S2, ;TAKE A QUICK NAP AOSE RTYCNT ;COUNT THE RETRIES JRST MSGGO2 ;TRY NOW OUTSTR [ASCIZ/ %QMRMBR Send has failed, Message Being Re-sent /] JRST MSGGO2 ;NOW RETRY IT > ;END OF IFN FTUUOS IFN FTJSYS,< MSGSND: SETO T4, ;FLAG INDICATING FIRST TRY PUSH P,S1 ;SAVE USER BASE MSGS.1: MOVEI S1,3 ;NUMBER OF WORDS MOVEI S2,T1 ;USE T1-T3 MOVEI T1,.MURSP ;READ SYSTEM PID TABLE MOVX T2,.SPQSR ;WANT PID OF SYSTEM QUASAR MUTIL ;READ THE TABLE SETZ T3, ;ASSUME IT CONTAINS AN INVALID PID MOVEM T3,QSRPID ;REMEMBER QUASAR'S PID SETOM RTYCNT ;INIT RETRY COUNTER JUMPN T3,MSGGO ;JUMP IF QUASAR IS RUNNING MOVEI S1,^D3000 ;WAIT FOR IT DISMS ;TAKE A NAP AOJN T4,MSGS.1 ;JUMP IF ALREADY GAVE A MESSAGE OUTSTR [ASCIZ/ %QMRWFQ Waiting For [SYSTEM]QUASAR to Start /] JRST MSGS.1 ;TRY NOW MSGGO: SETZ T1, ;ASSUME NO FLAGS SKIPN T2,MYPID ;DO I HAVE A PID TXO T1,IP%CPD ;NO, CREATE ONE ON THIS SEND MOVEI T4,(M) ;POINT TO THE MESSAGE LOAD S2,.MSTYP(M),MS.CNT ;GET THE LENGTH OF THE MESSAGE TXNN M,1B0 ;IS THIS PAGED JRST MSGGO1 ;NO, SEND IT TXO T1,IP.CFV ;SET PAGE MODE FLAG LSH T4,-^D9 ;CONVERT ADDR TO A PAGE NUMBER MOVEI S2,1000 ;LENGTH OF A PAGE MSGGO1: HRL T4,S2 ;INCLUDE THE LENGTH MOVEI S1,4 ;FOUR WORDS MOVEI S2,T1 ;IN T1-T4 MSEND ;SEND THE PACKET JRST MSGGO2 ;FAILED, SEE WHY SKIPN MYPID ;DO I ALREADY HAVE THE PID MOVEM T2,MYPID ;NO, SAVE IT POP P,S1 ;RESTORE S1 POPJ P, ;AND RETURN TO CALLER ;MORE OF THE TOPS20 VERSION ON THE NEXT PAGE MSGGO2: CAIE S1,IPCFX6 ;CHECK FOR EXHAUSTED QUOTAS CAIN S1,IPCFX7 ;AND RETRY IF POSSIBLE JRST RETRY ;IS POSSIBLE CAIE S1,IPCFX8 ;ANOTHER RECOVERABLE ERROR CAIN S1,IPCFX5 ;QUASAR DISABLED JRST RETRY ;YES, TRY AGAIN FAIL(IMPSTR) RETRY: SKIPN MYPID ;DO I HAVE A PID MOVEM T2,MYPID ;NO, MAYBE THIS IS IT MOVEI S1,^D2000 ;WAIT BEFORE TRYING AGAIN DISMS ;WAIT AOSE RTYCNT ;COUNT THE RETRIES JRST MSGGO ;TRY NOW OUTSTR [ASCIZ/ %QMRMBR Send has failed, Message Being Re-sent /] JRST MSGGO ;AND TRY THE SEND AGAIN > ;END OF IFN FTJSYS SUBTTL Data Storage XLIST ;FORCED OUT LITERAL POOL LIT LIST SALL FBSIZE==FPXSIZ+FDXSIZ ;THE LARGEST FD/FP WE CAN BUILD MAX FBAREA==MAXSIZ ;THE LARGEST FILE BLOCK/MESSAGE NEEDED RELOC 0 MYPID: BLOCK 1 ;MY PID (NECESSARY FOR SEND/RECEIVE) QSRPID: BLOCK 1 ;PID OF SYSTEM QUASAR RTYCNT: BLOCK 1 ;RETRY COUNTER WHEN SEND TO QUASAR FAILS FBTEMP: BLOCK FBAREA ;LARGEST FILE BLOCK THAT CAN BE BUILT FROM MPB DATA ;ALSO USED TO SEND/RECEIVE "SHORT" MESSAGES END ;END, NO STARTING ADDRESS $$$$$$$$$$$$ &&&&&&&&&&&& DRAFTS.IMP %BEGIN ! DRAFT4S. %EXTERNALROUTINESPEC PROMPT(%STRING(255) S) %INTEGERFN INPUT %RESULT=0 %END %INTEGERARRAY COMP,OPP(0:24) %OWNINTEGERARRAY CONSCOMP(0:24)='W',86,66,46,26,17,37,57,77,88,68, 48,28,1,1,1,1,1,1,1,1,1,1,1,1 %OWNINTEGERARRAY CONSOPP(0:24)='B',13,33,53,73,82,62,42,22,11,31, 51,71,1,1,1,1,1,1,1,1,1,1,1,1 %OWNINTEGERARRAY CENTSQ(1:8)=33,35,44,46,53,55,64,66 %INTEGERARRAY MIN,MAX(1:12) %OWNINTEGERARRAY MOVES(1:8)=-11,-22,9,18,11,22,-9,-18 %OWNINTEGERARRAY REPLY(1:8) %OWNINTEGER SEARCH LIMIT=3 %INTEGER BEST PIECE TO MOVE,BEST MOVE,BEST TAKE,%C VALUEP,VALUEB,I,P,M,PIECE,JMAN,JUMP,DIF,MODIF,PIECEWT,MOBWT,%C CENTWT,ADVWT,PRINTB,MORE,NPCS,OLDPOS,NEWPOS,LASTPOS,COMPOS,NODES,MON %INTEGER NPOS,CRAMPWT,ADV2WT,PLY NUMBER,AWIN !PLAYING FNS. %INTEGERFN CROWNED(%INTEGER PIECE,%INTEGERARRAYNAME COMP) %INTEGER POS POS=COMP(PIECE) %IF COMP(0)='W' %START %IF POS=11 %OR POS=31 %OR POS=51 %OR POS=71 %THEN %RESULT=2 %RESULT=1 %FINISH !BLACK PIECE. %IF POS=28 %OR POS=48 %OR POS=68 %OR POS=88 %THEN %RESULT=2 %RESULT =1 %END %INTEGERFN COND OF(%INTEGER POS,%INTEGERARRAYNAME COMP,OPP) %INTEGER I ! ON THE BOARD? %IF POS<11 %OR POS>88 %THEN %RESULT=-1 %CYCLE I=19,10,79 %IF POS=I %OR POS=I+1 %THEN %RESULT=-1 %REPEAT %CYCLE I=1,1,12 %IF POS=COMP(I) %OR POS=OPP(I) %THEN %RESULT=2 %REPEAT %RESULT=0 ; ! OKAY. %END %INTEGERFN PARITY(%INTEGER N) %RESULT=N&1 %END %INTEGERFN APPLICABLE MOVE(%INTEGER MOVE,P,%INTEGERARRAYNAME COMP,OPP) %INTEGER I,T %IF COMP(P)=0 %THEN %RESULT=-1 %IF COMP(0)='W' %AND MOVE>4 %AND COMP(P+12)=1 %THEN %RESULT=-1 %IF COMP(0)='B' %AND MOVE<5 %AND COMP(P+12)=1 %THEN %RESULT=-1 %IF PARITY(MOVE)=1 %START %IF COND OF(COMP(P)+MOVES(MOVE),COMP,OPP)=0 %THEN %RESULT=0 %RESULT=-1 %FINISH ! TAKE MOVE. %IF COND OF(COMP(P)+MOVES(MOVE),COMP,OPP)#0 %THEN%RESULT=-1 T=COMP(P)+MOVES(MOVE-1) %CYCLE I=1,1,12 %IF T=OPP(I) %THEN %RESULT=I %REPEAT %RESULT=-1 %END %INTEGERFNSPEC CAN TAKE(%INTEGERARRAYNAME COMP,OPP) %INTEGERFN VALUE OF POSITION(%INTEGERARRAYNAME COMP,OPP) %INTEGER V1,V2,V3,V4,V5,V6,V8,P,M,J,B1,B2,APEX V1=0 ; !PIECE COUNT. V2=0;V3=0;V4=0 %CYCLE P=1,1,12 I=P+12 %IF COMP(I)=1 %THEN V1=V1+1 %IF COMP(I)=2 %THEN V2=V2+2 %IF OPP(I)=1 %THEN V3=V3+1 %IF OPP(I)=2 %THEN V4=V4+2 %REPEAT V1=V1+V2-(V3+V4) V8=0; ! BACK. %IF COMP(0)='W' %THEN B1=28 %AND B2=68 %AND APEX=57 %ELSE B1=31 %ANDC B2=71 %AND APEX=42 %IF V4=0 %START %IF COMP(12)=B1 %THEN V8=V8+3 %IF COMP(10)=B2 %THEN V8=V8+3 %IF COMP(7)=APEX %THEN V8=V8+4 %FINISH %IF V2=0 %START B1=59-B1;B2=149-B2;APEX=99-APEX %IF OPP(10)=B1 %THEN V8=V8-3 %IF OPP(12)=B2 %THEN V8=V8-3 %IF OPP(7)=APEX %THEN V8=V8-4 %FINISH ! MOBILITY. V2=0;V3=0 %CYCLE P=1,1,12 %CYCLE M=1,1,8 %IF APPLICABLE MOVE(M,P,COMP,OPP)>=0 %THENC V2=V2+PARITY(M+1)+1 %IF APPLICABLE MOVE(M,P,OPP,COMP)>=0 %THENC V3=V3+(PARITY(M+1)+1) %REPEAT %REPEAT %IF V2=0 %START %IF COMP(0)='W' %THEN %RESULT=-100000 + PLY NUMBER %RESULT=100000-PLY NUMBER %FINISH V2=V2-V3 V3=0; ! CENTER CONTROL %CYCLE P=1,1,12 %CYCLE M=1,1,8 %IF COMP(P)=CENTSQ(M) %THEN V3=V3+COMP(P+12) %IF OPP(P)=CENTSQ(M) %THEN V3=V3-OPP(P+12) %REPEAT %REPEAT V4=0; ! ADVANCEMENT. %CYCLE P=1,1,12 %CYCLE M=1,1,8 %IF APPLICABLE MOVE(M,P,COMP,OPP)>=0 %START COMP(P)=COMP(P)+MOVES(M) %IF CROWNED(P,COMP)=2 %AND COMP(P+12)=1 %THEN V4=V4+1 %ANDC COMP(P)=COMP(P)-MOVES(M) %ANDEXIT COMP(P)=COMP(P)-MOVES(M) %FINISH %REPEAT %CYCLE M=1,1,8 %IF APPLICABLE MOVE(M,P,OPP,COMP)>=0 %START OPP(P)=OPP(P)+MOVES(M) %IF CROWNED(P,OPP)=2 %AND OPP(P+12)=1 %THEN V4=V4-1 %ANDC OPP(P)=OPP(P)-MOVES(M) %ANDEXIT OPP(P)=OPP(P)-MOVES(M) %FINISH %REPEAT %REPEAT !V5 - CRAMP. V5=0 %CYCLE P=1,1,12 %CYCLE M=1,2,7 %IF APPLICABLE MOVE(M,P,OPP,COMP)>=0 %START OPP(P)=OPP(P)+MOVES(M) %CYCLE I=1,1,12 %CYCLE J=2,2,8 %IF APPLICABLE MOVE(J,I,COMP,OPP)>=0 %THEN V5=V5+OPP(P+12) %ANDEXIT %REPEAT %REPEAT OPP(P)=OPP(P)-MOVES(M) %FINISH %IF APPLICABLE MOVE(M,P,COMP,OPP)>=0 %START COMP(P)=COMP(P)+MOVES(M) %CYCLE I=1,1,12 %CYCLE J=2,2,8 %IF APPLICABLE MOVE(J,I,OPP,COMP)>=0 %THEN V5=V5-COMP(P+12)%ANDEXIT %REPEAT %REPEAT COMP(P)=COMP(P)-MOVES(M) %FINISH %REPEAT %REPEAT ! V6 - ADV2. V6=0 %CYCLE P=1,1,12 %IF COMP(P+12)=1 %START %CYCLE M=1,2,7 %IF APPLICABLE MOVE(M,P,COMP,OPP) >=0 %START COMP(P)=COMP(P)+MOVES(M) %CYCLE J=1,2,7 %IF APPLICABLE MOVE(J,P,COMP,OPP)>=0 %START COMP(P)=COMP(P)+MOVES(J) %IF CROWNED(P,COMP)=2 %THEN V6=V6+1 %ANDC COMP(P)=COMP(P)-MOVES(J) %ANDEXIT COMP(P)=COMP(P)-MOVES(J) %FINISH %REPEAT COMP(P)=COMP(P)-MOVES(M) %FINISH %REPEAT %FINISH %REPEAT %CYCLE P=1,1,12 %IF OPP(P+12)=1 %START %CYCLE M=1,2,7 %IF APPLICABLE MOVE(M,P,OPP,COMP)>=0 %START OPP(P)=OPP(P)+MOVES(M) %CYCLE J=1,2,7 %IF APPLICABLE MOVE(J,P,OPP,COMP)>=0 %START OPP(P)=OPP(P)+MOVES(J) %IF CROWNED(P,OPP)=2 %THEN V6=V6-1 %ANDC OPP(P)=OPP(P)-MOVES(J) %AND %EXIT OPP(P)=OPP(P)-MOVES(J) %FINISH %REPEAT OPP(P)=OPP(P)-MOVES(M) %FINISH %REPEAT %FINISH %REPEAT V1=PIECEWT*V1+MOBWT*V2+CENTWT*V3+ADVWT*V4+CRAMPWT*V5+ADV2WT*V6 V1=V1+V8 -PLY NUMBER %IF COMP(0)='B' %THEN V1 =-V1 %RESULT=V1 %END %ROUTINE EXPLAIN POS PRINTSTRING("Blurb in preparation") NEWLINE %END %ROUTINE SAY PLEASE PRINTSTRING ("Please re-type your move ") NEWLINE %END %ROUTINE PRINT BOARD %INTEGER I,J,POS,COL,ROW %INTEGERARRAY A(1:64) %INTEGERMAP BOARD(%INTEGER I,J) %RESULT==A(8*(I-1)+J) %END ! WIPE BOARD. %CYCLE I=1,1,64 A(I)=' ' %REPEAT %CYCLE I=1,2,7 %CYCLE J=1,2,7 BOARD(I,J)='%' BOARD(I+1,J+1)='%' %REPEAT %REPEAT %CYCLE I=1,1,12 %IF COMP(I)#0 %START POS=COMP(I) ROW=POS//10 COL=POS-10*ROW %IF COMP(I+12)=1 %THEN BOARD(ROW,COL)='C'%ELSE BOARD(ROW,COL)='K' %FINISH %IF OPP(I)#0 %START POS=OPP(I) ROW=POS//10 COL=POS-10*ROW %IF OPP(I+12)=1 %THEN BOARD(ROW,COL)='o'%ELSE BOARD(ROW,COL)='=' %FINISH %REPEAT NEWLINE;PRINTSTRING(" A B C D E F G H") %CYCLE I=8,-1,1 NEWLINE WRITE(I,1) %CYCLE J=1,1,8 SPACE PRINT SYMBOL(BOARD(J,I)) %REPEAT WRITE(I,1) %REPEAT NEWLINE;PRINTSTRING (" A B C D E F G H");NEWLINE %END %ROUTINE TROUT(%INTEGER OLDPOS,NEWPOS,MODE) %INTEGER X,Y,S1,S2,T1,T2 X=OLDPOS//10 Y=OLDPOS-10*X S1=X+'A'-1 S2=Y+'0' X=NEWPOS//10 Y=NEWPOS-10*X T1=X+'A'-1 T2=Y+'0' %IF MODE =1 %START PRINTSTRING ("DRAFT4's move is ") PRINT SYMBOL(S1);PRINT SYMBOL(S2);PRINT SYMBOL('-') PRINT SYMBOL(T1);PRINT SYMBOL(T2) %FINISHELSESTART SPACE;PRINT SYMBOL(',');SPACE;PRINT SYMBOL(S1);PRINT SYMBOL(S2) PRINT SYMBOL('-');PRINT SYMBOL(T1);PRINT SYMBOL(T2) %FINISH %END %ROUTINE TAKE(%INTEGER T,P,MV,%INTEGERARRAYNAME COMP,OPP,%INTEGERC MODE,TAKES) %INTEGER M,APP %IF MODE='P' %THEN TROUT(COMP(P),COMP(P)+MOVES(MV) ,TAKES+1) COMP(P)=COMP(P)+MOVES(MV);OPP(T)=0; OPP(T+12)=0 %IF COMP(P+12)=1 %START COMP(P+12)=CROWNED(P,COMP) %IF COMP(P+12)=2 %THEN %RETURN %FINISH %CYCLE M=2,2,8 APP=APPLICABLE MOVE(M,P,COMP ,OPP) %IF APP>0 %THEN TAKE(APP,P,M,COMP,OPP,MODE,TAKES+1) %ANDRETURN %REPEAT %END %ROUTINE MAKE MOVE(%INTEGER M,P,T,%INTEGERARRAYNAME COMP,OPP,%C %INTEGER MODE) %IF T=0 %START %IF MODE='P'%THEN TROUT(COMP(P),COMP(P)+MOVES(M),1) COMP(P)=COMP(P)+MOVES(M) %UNLESS COMP(P+12)=2 %THEN COMP(P+12)=CROWNED(P,COMP) %RETURN %FINISH ! TAKE MOVE. TAKE(T,P,M,COMP,OPP,MODE,0) %END %INTEGERFN CAN TAKE(%INTEGERARRAYNAME OPP,COMP) %INTEGER P,M %CYCLE P=1,1,12 %CYCLE M=2,2,8 %IF APPLICABLE MOVE(M,P,OPP,COMP)>0 %THEN %RESULT='T' %REPEAT %REPEAT %RESULT='F' %END %INTEGERFN TRY POSSIBLE MOVES(%INTEGER PLY,DEPTH ,%INTEGERARRAYNAMEC COMP,OPP) %INTEGERARRAY TCOMP,TOPP(0:24) %INTEGER APT,P,M,VALUE,TAKEFLAG,I,FOR %INTEGERFN PURSUIT VALUE(%INTEGER M) %IF PLY=1 %THEN %RESULT=1 %RESULT=PARITY(M) %END FOR=COMP(0); ! CONSIDER MOVES FOR COMP (='W') OR OPP (='B'). NODES =NODES+1 ! Principle of hot pursuit. %IF (DEPTH>=SEARCH LIMIT %AND CAN TAKE(COMP,OPP)='F') %ORC PLY>12 %THEN PLY NUMBER=PLY-1 %AND %RESULT=VALUE OF POSITION(COMP,OPP) MIN(PLY)=100000;MAX(PLY)=-100000;TAKE FLAG=0 %IF CAN TAKE(COMP,OPP)='T' %THEN TAKEFLAG=1 %CYCLE P=1,1,12 %CYCLE M=1,1,8 %IF PARITY(M)=1 %AND TAKEFLAG=1 %THEN APT=-1 %ELSEC APT=APPLICABLE MOVE(M,P,COMP,OPP) %UNLESS APT<0 %START ! COPY COMP->TCOMP,OPP->TOPP. %CYCLE I=0,1,24 TCOMP(I)=COMP(I) TOPP(I)=OPP(I) %REPEAT MAKE MOVE(M,P,APT,TCOMP,TOPP,'Q') VALUE=TRY POSSIBLE MOVES(PLY+1,DEPTH+ PURSUIT VALUE(M),TOPP,TCOMP) %IF VALUE >MAX(PLY) %AND FOR='W' %START MAX(PLY)=VALUE %IF PLY=1 %START BEST MOVE=M BEST PIECE TO MOVE=P BEST TAKE=APT %FINISH %FINISH %IF VALUE=MIN(PLY-1) %AND FOR='W' %THENC %RESULT=MAX(PLY) %REPEAT %REPEAT ! mini-maxing. %IF FOR='W' %THEN %RESULT=MAX(PLY) %RESULT=MIN(PLY) %END %INTEGERFN POSITION OF(%INTEGER S1,S2) %RESULT=10*(S1-'A'+1) +(S2-'0') %END %ROUTINE READ BOARD %ROUTINE SKIP SPACES AND NLS SKIP SYMBOL%WHILE NEXT SYMBOL=' ' %OR NEXT SYMBOL=NL %END %INTEGER P,S1,S2,S3,POS %CYCLE P=1,1,24 COMP(P)=0 OPP(P)=0 %REPEAT PRINTSTRING("Where are your pieces?");NEWLINE %CYCLE P=1,1,12 PROMPT(":") SKIP SPACES AND NLS READ SYMBOL(S1);%IF S1='*' %THENEXIT READ SYMBOL(S2) READ SYMBOL(S3) POS=POSITION OF(S1,S2);OPP(P)=POS %IF S3=' ' %THEN OPP(P+12)=1 %ELSE OPP(P+12)=2 SKIP SPACES AND NLS %REPEAT SKIP SYMBOL %WHILE INPUT#0 PRINTSTRING("Where are my pieces?");NEWLINE %CYCLE P=1,1,12 PROMPT(":") SKIP SPACES AND NLS READ SYMBOL(S1);%IF S1='*' %THENEXIT READ SYMBOL(S2) READ SYMBOL(S3) POS=POSITION OF(S1,S2);COMP(P)=POS %IF S3=' ' %THEN COMP(P+12)=1 %ELSE COMP(P+12)=2 %REPEAT %END ! ! ** MAIN PROGRAM ** ! PIECEWT=1000;MOBWT=6 CENTWT=4;ADVWT=550;CRAMPWT=6;ADV2WT=50 MON='Q' NEWLINE PRINTSTRING ("The Draughts Program , DRAFT4.") NEWLINE ! Setting up the pieces. %CYCLE P=0,1,24 COMP(P)=CONSCOMP(P) OPP(P)=CONSOPP(P) %REPEAT PRINTSTRING ("Have you played me before?");NEWLINE PROMPT(":") READ SYMBOL(REPLY(1)) READ SYMBOL(REPLY(2)) READ SYMBOL(REPLY(3)) %UNLESS REPLY(3)=NL %THEN SKIP SYMBOL %IF REPLY(1)='N' %THEN EXPLAIN POS PRINTSTRING ("Do you want to start?");NEWLINE PROMPT(":") READ SYMBOL(REPLY(1)) SKIP SYMBOL %WHILE INPUT#0 %IF REPLY(1)='R' %START READ BOARD SKIP SYMBOL %WHILE INPUT#0 PRINTSTRING("Is it your move?");NEWLINE PROMPT(":") READ SYMBOL(REPLY(1)) SKIP SYMBOL %UNTIL INPUT=0 %IF REPLY(1)='Y' %THEN -> READ MOVE %ELSE -> COMP MOVE %FINISH %IF REPLY(1)='N'%START PRINTSTRING("Think of a number please");NEWLINE PROMPT(":") READ(I);SKIP SYMBOL I=I&3 %IF I=0 %THEN PRINTSTRING("DRAFT4's opening move is D6-C5") %AND %C COMP(3)=35 %IF I=1%THEN PRINTSTRING("DRAFT4's opening move is D6-E5")%ANDC COMP(3)=55 %IF I=2%OR I=3%THEN PRINTSTRING("DRAFT4's opening move is F6-E5") %ANDC COMP(2)=55 NEWLINE %FINISH AWIN=0 PRINTB=' ' READ MOVE: %IF PRINTB='P'%THEN PRINT BOARD PROMPT(":") %CYCLE I=1,1,8 READ SYMBOL(REPLY(I)) %IF REPLY(I)=NL %THENEXIT %REPEAT REPLY(I)=' ' %AND I=I+1 %UNTIL I=9 %IF REPLY(1)='M' %THEN MON='M' %AND -> READ MOVE %IF REPLY(1)='Q' %THEN MON='Q' %AND -> READ MOVE %IF REPLY(1)='P'%THEN PRINT BOARD %AND -> READ MOVE TRANS: %IF REPLY(1)='I'%THEN -> STOP %IF REPLY(6)=','%THEN MORE='M'%ELSE MORE=' ' %IF REPLY(6)='P'%THEN PRINTB='P'%ELSE PRINTB=' ' OLDPOS=POSITION OF(REPLY(1),REPLY(2)) NEWPOS=POSITION OF(REPLY(4),REPLY(5)) %IF COND OF(OLDPOS,COMP,OPP)=-1 %START PRINTSTRING ("The square ");PRINT SYMBOL(REPLY(1)) PRINT SYMBOL(REPLY(2)) PRINTSTRING(" does not exist!"); NEWLINE SAY PLEASE -> READ MOVE %FINISH M=COND OF(NEWPOS,COMP,OPP) %IF M=-1 %START PRINTSTRING ("You cannot move to square ") PRINT SYMBOL(REPLY(4));PRINT SYMBOL(REPLY(5)) PRINTSTRING(". It does not exist!");NEWLINE SAY PLEASE -> READ MOVE %FINISH %IF M=2 %START PRINTSTRING ("You cannot move to square ") PRINT SYMBOL(REPLY(4));PRINT SYMBOL(REPLY(5)) NEWLINE PRINTSTRING ("It is already occupied!");NEWLINE SAY PLEASE -> READ MOVE %FINISH %CYCLE P=1,1,12 %IF OLDPOS=OPP(P)%THENEXIT %REPEAT %UNLESS OLDPOS=OPP(P)%START PRINTSTRING ("You do not have a piece on square ") PRINT SYMBOL(REPLY(1));PRINT SYMBOL(REPLY(2)) NEWLINE SAY PLEASE -> READ MOVE %FINISH PIECE=P DIF=NEWPOS-OLDPOS MODIF=IMOD(DIF) %IF MODIF<12 %AND CAN TAKE(OPP,COMP)='T'%START PRINTSTRING ("You MUST take the piece that I am offering you ") SAY PLEASE -> READ MOVE %FINISH %IF MODIF<12 %AND MORE='M'%START PRINTSTRING("That's not part of a multiple jump move");NEWLINE SAY PLEASE -> READ MOVE %FINISH %IF (DIF=-11 %OR DIF=-22 %OR DIF=9 %OR DIF=18)%ANDC OPP(PIECE+12)=1 %START PRINTSTRING("You cannot move that piece backwards!");NEWLINE SAY PLEASE -> READ MOVE %FINISH %UNLESS MODIF=11 %OR MODIF=9 %OR MODIF=22 %OR MODIF=18 %START PRINTSTRING ("That move does not exist in my rule book!");NEWLINE SAY PLEASE -> READ MOVE %FINISH %IF MODIF>11 %START JUMP=DIF//2 COMPOS=OLDPOS+JUMP %CYCLE I=1,1,12 %IF COMPOS=COMP(I)%THENEXIT %REPEAT %UNLESS COMPOS=COMP(I)%START PRINTSTRING("You cannot do that.You are not jumping one of my pieces ") SAY PLEASE -> READ MOVE %FINISHELSE JMAN=I %FINISHELSE JMAN=0 OPP(PIECE)=OPP(PIECE)+DIF %UNLESS OPP(PIECE+12)=2 %THEN OPP(PIECE+12)=CROWNED(PIECE,OPP) COMP(JMAN)=0 %AND COMP(JMAN+12)=0 %UNLESS JMAN=0 %IF MORE='M'%START LASTPOS=NEWPOS READ AGAIN: PROMPT("&") %CYCLE I=1,1,8 READ SYMBOL(REPLY(I)) %IF REPLY(I)=NL %THENEXIT %REPEAT %IF REPLY(1)='.'%THEN -> COMP MOVE REPLY(I)=' '%AND I=I+1 %UNTIL I=9 OLDPOS=POSITION OF(REPLY(1),REPLY(2)) NEWPOS=POSITION OF(REPLY(4),REPLY(5)) DIF=NEWPOS-OLDPOS DIF=IMOD(DIF) %IF DIF>11 %AND OLDPOS=LASTPOS %THEN -> TRANS PRINTSTRING("That's not part of a multiple jump");NEWLINE PRINTSTRING("Please re-type that part");NEWLINE -> READ AGAIN %FINISH COMP MOVE: ! COMPUTER MAKES MOVE. NPCS=0 NPOS=0 %CYCLE P=1,1,12 %IF COMP(P)#0 %THEN NPCS=NPCS+1 %IF OPP(P)#0 %THEN NPOS=NPOS+1 %REPEAT %IF NPCS=0 %START PRINTSTRING ("I have no pieces left so you have won") ;NEWLINE -> STOP %FINISH I=0 %CYCLE P=1,1,12 %CYCLE M=1,1,8 %IF APPLICABLE MOVE(M,P,COMP,OPP)>=0 %THEN I=1 %ANDEXIT %REPEAT %REPEAT %IF I=0 %START PRINTSTRING("I cannot move any of my pieces so you win") NEWLINE -> STOP %FINISH ! If in end game then increase search. %IF NPCS+NPOS<=4 %THEN SEARCH LIMIT=4 ! FIND BEST MOVE. NODES=0 VALUEB=TRY POSSIBLE MOVES(1,1,COMP,OPP) %IF VALUEB<=-99990 %START PRINTSTRING("I resign");NEWLINE -> STOP %FINISH VALUEP=VALUE OF POSITION(COMP,OPP) %IF MON='M' %START PRINTSTRING("Nodes considered = ");WRITE(NODES,3);NEWLINE PRINTSTRING("Value of board= ");WRITE(VALUEB,3);NEWLINE %FINISH MAKE MOVE(BEST MOVE,BEST PIECE TO MOVE,BEST TAKE,COMP,OPP,'P') NEWLINE NPOS=0 %CYCLE P=1,1,12 %IF OPP(P)#0 %THEN NPOS=1 %ANDEXIT %REPEAT %IF NPOS=0 %START PRINTSTRING ("You have no pieces left so I win");NEWLINE -> STOP %FINISH I=0 %CYCLE P=1,1,12 %CYCLE M=1,1,8 %IF APPLICABLE MOVE(M,P,OPP,COMP)>=0 %THEN I=1 %ANDEXIT %REPEAT %REPEAT %IF I=0 %START PRINTSTRING("You cannot move any of your pieces so I win") NEWLINE -> STOP %FINISH %IF VALUEB>=99990 %AND AWIN=0 %START PRINTSTRING("He-He! I am going to win!");NEWLINE AWIN=1 %FINISH -> READ MOVE STOP: NEWLINE PRINTSTRING ("The final board position is -");NEWLINE PRINT BOARD %ENDOFPROGRAM $$$$$$$$$$$$ &&&&&&&&&&&& LINEQ.IMP %EXTERNALROUTINE SOLVE LN EQ(%LONGREALARRAYNAME A,B,%INTEGER N,%LONG %C %REALNAME DET) %LONGREAL AMAX,CH %INTEGER I,J,J MAX,S -> 3 %IF N> 0 PRINTSTRING(' SOLVE LN EQ DATA FAULT: N=') WRITE(N,2); NEWLINE; %STOP 3:-> 1 %IF N>1 DET=A(1,1) -> 2 %IF DET=0 B(1)=B(1)/DET -> 2 1:DET = 1 %CYCLE I = 1,1,N-1 A MAX = 0 ; J MAX = 0 %CYCLE J = I,1,N -> 4 %IF !A(J,I)!<=AMAX AMAX=!A(J,I)!; JMAX=J 4: %REPEAT -> 5 %IF J MAX = I DET=-DET -> 6 %IF J MAX # 0 DET = 0 ; -> 2 6: %CYCLE J = I,1,N CH=A(I,J) A(I,J)=A(J MAX,J) A(J MAX,J)=CH %REPEAT CH=B(I) B(I)=B(J MAX) B(J MAX) = CH 5: CH=A(I,I) DET = DET*CH %CYCLE J = I+1,1,N A MAX = A(J,I)/CH %CYCLE S=I+1 ,1,N A(J,S)=A(J,S)-A(I,S)*A MAX %REPEAT B(J)=B(J)-B(I)*A MAX %REPEAT %REPEAT CH=A(N,N) DET=DET*CH -> 2 %IF DET = 0 B(N)=B(N)/CH %CYCLE I=N-1,-1,1 CH=B(I) %CYCLE J=I+1,1,N CH=CH-A(I,J)*B(J) %REPEAT B(I)=CH/A(I,I) %REPEAT 2: %END %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& MATRIX.IMP %EXTERNALROUTINESPEC SOLVE LN EQ(%LONGREALARRAYNAME A,B,%INTEGER N,%LONGREALNAME DET) %EXTERNALROUTINE DIV MATRIX(%LONGREALARRAYNAME A,B,%INTEGER N,M,%LONGREALNAME DET) %COMMENT A=INV(B)A : BNXN, ANXM %LONGREAL AMAX,CH %INTEGER I,J,JMAX,S,K -> 3 %IF N>0 PRINTSTRING(' DIV MATRIX DATA FAULT N=') WRITE(N,2) NEWLINE ; %STOP 3: -> 1 %IF N>1 DET = B(1,1) -> 2 %IF DET = 0 %CYCLE I=1,1,M A(1,I)=A(1,I)/DET %REPEAT -> 2 1: DET=1 %CYCLE I=1,1,N-1 AMAX=0; JMAX = 0 %CYCLE J=I,1,N -> 4 %IF !B(J,I)!<=AMAX AMAX=!B(J,I)!; JMAX=J 4:%REPEAT -> 5 %IF J MAX =I DET=-DET -> 6 %IF JMAX # 0 DET = 0 ; -> 2 6: %CYCLE J=I,1,N CH=B(I,J) B(I,J)=B(JMAX,J) B(JMAX,J)=CH %REPEAT %CYCLE K=1,1,M CH=A(I,K) A(I,K)=A(JMAX,K) A(JMAX,K)=CH %REPEAT 5: CH=B(I,I) DET=DET*CH %CYCLE J=I+1,1,N AMAX=B(J,I)/CH %CYCLE S=I+1,1,N B(J,S)=B(J,S)-B(I,S)*AMAX %REPEAT %CYCLE K=1,1,M A(J,K)=A(J,K)-A(I,K)*AMAX %REPEAT %REPEAT %REPEAT CH=B(N,N) DET=DET*CH -> 2 %IF DET = 0 %CYCLE K=1,1,M A(N,K)=A(N,K)/CH %REPEAT %CYCLE I=N-1,-1,1 AMAX=B(I,I) %CYCLE K=1,1,M CH=A(I,K) %CYCLE J=I+1,1,N CH=CH-B(I,J)*A(J,K) %REPEAT A(I,K)=CH/AMAX %REPEAT %REPEAT 2: %END %EXTERNALROUTINE UNIT(%LONGREALARRAYNAME A,%INTEGER N) %INTEGER I,J ->10 %IF N>0 PRINTSTRING(' MATRIX BOUND ZERO OR NEGATIVE') NEWLINE %STOP 10: %CYCLE I=1,1,N %CYCLE J=1,1,N A(I,J)=0 %REPEAT A(I,I)=1 %REPEAT %END %EXTERNALROUTINE INVERT(%LONGREALARRAYNAME A,B,%INTEGER N,%LONGREALNAME DET) %COMMENT A=INV B USING DIV MATRIX -> 3 %IF N>0 PRINTSTRING(' INVERT DATA FAULT N=') WRITE(N,2); NEWLINE; %STOP 3:UNIT(A,N) DIV MATRIX(A,B,N,N,DET) %END %EXTERNALLONGREALFN DET(%LONGREALARRAYNAME A,%INTEGER N) %LONGREALARRAY B(1:N); %LONGREAL DET %INTEGER I ->10 %IF N>0 PRINTSTRING(' MATRIX BOUND ZERO OR NEGATIVE') NEWLINE %STOP 10: %CYCLE I=1,1,N B(I)=0 %REPEAT SOLVE LN EQ(A,B,N,DET) %RESULT = DET %END %EXTERNALROUTINE NULL(%LONGREALARRAYNAME A,%INTEGER N,M) %INTEGER I,J ->10 %IF N>0 %AND M>0 PRINTSTRING(' MATRIX BOUND ZERO OR NEGATIVE') NEWLINE %STOP 10: %CYCLE I=1,1,N %CYCLE J=1,1,M A(I,J)=0 %REPEAT %REPEAT %END %EXTERNALROUTINE ADD MATRIX(%LONGREALARRAYNAME A,B,C,%INTEGER N,M) %INTEGER I,J ->10 %IF N>0 %AND M>0 PRINTSTRING(' MATRIX BOUND ZERO OR NEGATIVE') NEWLINE %STOP 10: %CYCLE I=1,1,N %CYCLE J=1,1,M A(I,J)=B(I,J)+C(I,J) %REPEAT %REPEAT %END %EXTERNALROUTINE SUB MATRIX(%LONGREALARRAYNAME A,B,C,%INTEGER N,M) %INTEGER I,J ->10 %IF N>0 %AND M>0 PRINTSTRING(' MATRIX BOUND ZERO OR NEGATIVE') NEWLINE %STOP 10: %CYCLE I=1,1,N %CYCLE J=1,1,M A(I,J)=B(I,J)-C(I,J) %REPEAT %REPEAT %END %EXTERNALROUTINE COPY MATRIX(%LONGREALARRAYNAME A,B,%INTEGER N,M) %INTEGER I,J ->10 %IF N>0 %AND M>0 PRINTSTRING(' MATRIX BOUND ZERO OR NEGATIVE') NEWLINE %STOP 10: %CYCLE I=1,1,N %CYCLE J=1,1,M A(I,J)=B(I,J) %REPEAT %REPEAT %END %EXTERNALROUTINE MULT MATRIX(%LONGREALARRAYNAME A,B,C,%INTEGER N,P,M) %COMMENT A=B*C, A IS N X M %INTEGER I,J,K %LONGREAL R ->10 %IF N>0 %AND M>0 %AND P>0 PRINTSTRING(' MATRIX BOUND ZERO OR NEGATIVE') NEWLINE %STOP 10: %CYCLE I=1,1,N %CYCLE J=1,1,M R=0 %CYCLE K=1,1,P R=R+B(I,K)*C(K,J) %REPEAT A(I,J)=R %REPEAT %REPEAT %END %EXTERNALROUTINE MULT TR MATRIX(%LONGREALARRAYNAME A,B,C,%INTEGER N,P,M) %LONGREAL R %COMMENT A = B*C', A IS N X M %INTEGER I,J,K ->10 %IF N>0 %AND M>0 %AND P>0 PRINTSTRING(' MATRIX BOUND ZERO OR NEGATIVE') NEWLINE %STOP 10: %CYCLE I=1,1,N %CYCLE J=1,1,M R=0 %CYCLE K=1,1,P R=R+B(I,K)*C(J,K) %REPEAT A(I,J)=R %REPEAT %REPEAT %END %EXTERNALROUTINE TRANS MATRIX(%LONGREALARRAYNAME A,B,%INTEGER N,M) %COMMENT AN X M, B M X N %INTEGER I,J ->10 %IF N>0 %AND M>0 PRINTSTRING(' MATRIX BOUND ZERO OR NEGATIVE') NEWLINE %STOP 10: %CYCLE I=1,1,N %CYCLE J=1,1,M A(I,J)=B(J,I) %REPEAT %REPEAT %END %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& PAGEIM.MAC TITLE PAGEIMP - DEMAND PAGING ROUTINES FOR DATA SUBTTL W.D.HAY, UNIVERSITY OF EDINBURGH, MAY '74 PAGED==1 PAGVER==50 ;V2 REORGANISED CALLING SEQUENCE TO ALLOW ARBITRARY LOWER BOUND ;V3 INTRODUCED ROUTINE FILL AND CALLS TO IT AS APPROPRIATE ;V4 SPEEDES UP INITIALISATION BY ONLY CALLING ALCOR. ONCE ;V5 INCLUDES LOCKING IN PAGE CODE. ; EDIT 1 FIX HRRZ @IOPAG+1 TO BE MOVE. ALLOWS ADDRESSES > 256K ;V50 BUTCHERED VERSION OF V5 FOR IMP SEARCH IMPPRM ;AC DEFINITIONS T0=0 T1=1 ;CURRENT PAGE NO T2=2 ;OFFSET WITHIN PAGE T3=3 ;POINTER TO DATA BASE T4=4 ;IN-CORE PAGE NO T5=5 ;MISCELLANEOUS T6=6 ;UNUSED EXCEPT IN RANIO ROUTINES T7=7 ;DO L=ARG1 ;FIRST IMP ARGUMENT? P=17 ;STACK ;MACRO DEFINITIONS FOR DEFINING OFFSETS ;SUBSTITUE FORPRM MACROS DEFINE HELLO(NAME) < SIXBIT/NAME/ NAME:: > DEFINE GOODBYE < POPJ P, > DEFINE ZERO DEFINE OFF(SYMBOL) < SYMBOL=A.. A..=A..+1 > ;DATA BASE DEFINITIONS SALL ;SUPRESS MACRO EXPANSION ZERO ;RESET OFFSET OFF (D.RAND) ;RANDOM ACCESS CHANNEL ETC. OFF (D.MAXP) ;LARGEST PAGE NO FOR SWAPPING PAGES OFF (D.MAXA) ;LARGEST IN-CORE PAGE NO OFF (D.NXTP) ;NEXT PAGE NO OFF (D.ICPT) ;CORRESPONDANCE TABLE FROM CORE TO VIRTUAL PAGE NO OFF (D.ICPA) ;ADDRESS OF IN-CORE PAGE OFF (D.NWOR) ;NO OF WORDS PER PAGE OFF (D.NWM1) ;NO OF WORDS -1 (USED FOR ROUNDING PURPOSES) OFF (D.RTAB) ;POINTER TO READ TABLE OFF (D.WTAB) ;POINTER TO WRITE TABLE DLEN=A.. ;LENGTH OF TABLE ;ARGUMENTS FOR IVALUE/ENTER ZERO ;OFFSET RESET OFF (S.IDBA) ;POINTER TO DATA BASE TABLE OFF (S.IADR) ;VIRTUAL ADDRESS OFF (S.IVAL) ;VALUE TO DEPOSIT (ENTER ONLY) ;ARGUMENTS FOR PAGINI ZERO ;RESET OFFSET OFF (P.ADDR) ;ADDRESS OF BUFFER FOR WORKSPACE OFF (P.SIZE) ;SIZE OF BUFFER OFF (P.CHAN) ;MONITOR I/O CHANNEL OFF (P.LBND) ;LOWER BOUND OFF (P.UBND) ;UPPER BOUND OFF (P.NWIP) ;NUMBER OF WORDS IN PAGE OFF (P.NICP) ;NUMBER OF IN-CORE PAGES OFF (P.STRT) ;PAGING STRATEGY (UNUSED AT PRESENT) OFF (P.IDBA) ;ASSOCIATED VARIABLE OFF (P.IERR) ;ERROR VARIABLE ;RANIO ARGUMENTS EXP ^D8 ;8 ARGUMENTS FOR RANIO RANARG: .RFILE: 0 ;FILE-ADDRESS WILL BE PATCHED .RPJNO: 0 ;PROJECT # .RPGNO: 0 ;PROGRAMMER # .RNWIP: 0 ;# OF WORDS IN PAGE .RTNOP: ARG TNOP ;TOTAL NO OF PAGES .RSUPR: 0 ;SUPERSEED .RIDBA: 0 ;ASSOCIATED VAR .RIERR: 0 ;ERROR WORD ;MACRO TO TRANSFER ARGUMENTS FROM PAGINI TO RANIO DEFINE XFR(X) < SALL MOVE 0,P.'X'(L) MOVEM 0,.R'X > ;LOCAL STORAGE FOR AC'S TEMP: 0 TNOP: 0 ;HOLDS TOTAL NO OF PAGES DURING PAGINI ADR: 0 ;HOLDS ADDRESS DURING ALCOR SIMULATION COUNT: 0 ;- # OF WORDS OF FREE STORE IN ALCOR SIMULATION PAGE SUBTTL TRACING MACROS ETC RPTRAC==400000 ;TRACE PAGE CHANGES BIT RATRAC==200000 ;TRACE ADDRESSE IFNDEF TRACEP,< TRACEP==0> IFNDEF TRACEA,< TRACEA==0> IFE TRACEP,< DEFINE $PTRCE (A,%B) <> DEFINE $SKPPN (A) <> DEFINE $SKPPF (A) <> > IFE TRACEA,< DEFINE $ATRCE(A) <> DEFINE $SKPAN(A) <> DEFINE $SKPAF (A) <> > IFN TRACEP,< IF2, DEFINE $PTRCE (A,%B) < TLNN T3,RPTRAC JRST %B A %B: > DEFINE $SKPPN (A) < TLNN T3,RPTRAC A > DEFINE $SKPPF (A) < TLNE T3,RPTRAC A > > IFN TRACEA,< IF2, DEFINE $ATRCE (A,%B) < TLNN T3,RATRAC JRST %B A %B: > DEFINE $SKPAN (A) < TLNN T3,RATRAC A > DEFINE $SKPAF (A) > PAGE SUBTTL BASIC GET AND PUT ROUTINES ; I=IVALUE(IDB,IADR) ; ; RETURNS WORD STORED AT ADDRESS IADR IN PAGED DATA ; SET IDB ; HELLO (IVALUE) ;ENTRY SEQUENCE PUSHJ P,IOPAG ;DO COMMON THINGS $ATRCE < PUSH P,L ;SAVE LINK MOVEI L,T.ARG1 ;SET POINTER PUSHJ P,WTB.## MOVEI L,T.ARG2 PUSHJ P,IOLST.## PUSHJ P,FIN. POP P,L ;RESTORE LINK > XCT @D.RTAB(T3) ;DO THE PICK-UP $PTRCE < HRRZ T2,@D.RTAB(T3) AOS -1(T2) > MOVE AC,0 ;RETURN RESULT BYEBYE: GOODBYE ;AND EXIT ; ; CALL ENTER(IDB,IADR,IDAT) ; ; DEPOSITS IDAT AT LOC IADR IN IDB ; HELLO (ENTER) PUSHJ P,IOPAG ;DO THE COMMON STUFF MOVE 0,ARG3 ;GET THE DATA XCT @D.WTAB(T3) ;DO THE DEPOSIT $ATRCE < PUSH P,L MOVNS T.ADDR MOVEI L,T.ARG1 PUSHJ P,WTB. MOVEI L,T.ARG2 PUSHJ P,IOLST. PUSHJ P,FIN.## POP P,L > $PTRCE < HRRZ T2,@D.WTAB(T3) AOS -2(T2) > GOODBYE ; & RETURN ; IOPAG SETS UP AC'S AS FOLLOWS ; ; T1 - PAGE NO ; T2 - OFFSET ; T3 - POINTER TO DATA BASE ; IOPAG: MOVE T3,ARG1 ;GET POINTER MOVE T1,ARG2 ;**ED 1 AND ADDRESS $SKPAF ADD T1,D.NWM1(T3) ;ROUND BLOCKS UP 1 AND OFFSET DOWN 1 IDIV T1,D.NWOR(T3) ;SPLIT INTO PAGE & OFFSET POPJ P, ;& RETURN PAGE SUBTTL PAGE FAULT ROUTINES WFAULT: PUSHJ P,GETPAG ;GET IN-CORE PAGE HRLI T4,(MOVE (T2)) ;PATCH INSTRUCTION MOVEM T4,@D.RTAB(T3) ;INTO READ TABLE HRLI T4,(SETAM (T2)); AND INTO MOVEM T4,@D.WTAB(T3) ;WRITE TABLE SOS (P) ;SET UP SO THAT POPJ CAUASES POPJ P, ;REEXECUTION OF THE XCT RFAULT: PUSHJ P,GETPAG ;GET IN-CORE PAGE ADDRESS INTO T4 HRLI T4,(MOVE (T2)) ;PATCH INSTRUCTION INTO MOVEM T4,@D.RTAB(T3) ;INTO WRITE TABLE MOVE T4,[PUSHJ P,FWRITE] ;AND PATCH JUMP TO FIRST WRITE MOVEM T4,@D.WTAB(T3) ;INT WRITE TABLE MPOP: SOS (P) ;AND SET TO REEXECUTE THE XCT POPJ P, ; FWRITE IS CALLED ON THE FIRST WRITE TO A PAGE THAT WAS ; BROUGHT INTO CORE ON A READ. IT ALLOWS THE PAGER TO FIND OUT ; IF A WRITE HAS BEEN DONE, AND CONSEQUENTLY WHETHER IT NEEDS ; PAGE OUT HTIS PAGE. FWRITE: MOVE T4,@D.RTAB(T3) ;GET POINTER TO IN-CORE PAGE HRLI T4,(SETAM (T2));PATCH THE INSTRUCTION MOVEM T4,@D.WTAB(T3) ;INTO WRITE TABLE JRST MPOP PAGE SUBTTL DISK PAGEING ROUTINE GETPAG: SOSG T4,D.NXTP(T3) ;GET PAGE TO SWAP OUT MOVE T4,D.MAXP(T3) ;IF 0 WRAP AROUND MOVEM T4,D.NXTP(T3) ; MOVE T6,@D.ICPA(T3) ;GET POINTER TO CORE BLOCK MOVEM T6,TEMP ; & SAVE IT EXCH T1,@D.ICPT(T3) ;PICK UP OLD PAGE NO-SAVE NEW ONE $PTRCE < MOVEM T1,OPAG PUSH P,L JUMPLE T1,GETP10 HRRZ L,@D.ICPA(T3) MOVE T5,-1(L) MOVEM T5,READS SETZM -1(L) MOVE T5,-2(L) MOVEM T5,WRITES SETZM -2(L) GETP10: MOVEI L,F1000 PUSHJ P,OUT.## MOVEI L,F2000 PUSHJ P,IOLST.## POP P,L > JUMPL T1,REDPAG ;VIRGIN-DONT WRITE IT SKIPL @D.WTAB(T3) ;EVER WRITTEN? JRST DRWT ;NO-DONT WRITE IT OUT PUSHJ P,RANWRT ;WRITE THE PAGE DRWT: MOVE T6,[PUSHJ P,RFAULT] ; PATCH DISPATCH TO FAULT ROUTINE MOVEM T6,@D.RTAB(T3) ;PATCH READ TABLE HRRI T6,WFAULT ;WRITE FAULT MOVEM T6,@D.WTAB(T3) ;PATCH WRITE TABLE REDPAG: SKIPGE T1,@D.ICPT(T3) ;GET NEW PAGE NO JRST GETEX ;DONT READ -VE PAGES SKIPGE @D.RTAB(T3) ;HAS THIS PAGE EVER BEEN ALLOCATED ON DISK JRST NVRALC ;NO-ZERO THE AREA PUSHJ P,RANRED ;READ THE NEW PAGE GETEX: MOVE T4,@D.ICPA(T3) ;GET THE ADDRESS OF THE PAGE POPJ P, ; & RETURN NVRALC: MOVEI T5,0 ;PREPARE TO ZERO THE IN-CORE PAGE MOVE T6,D.NWOR(T3) ;NO OF WORDS TO DO MOVE T7,TEMP ;ADDRESS TO START THE ZERO PUSHJ P,FILL ;DO IT JRST GETEX ;AND DO THE RETURN STUFF PAGE SUBTTL INITIALISATION ROUTINES PAGINI:: MOVE P.UBND(L) ;GET UPPER BOUND ON ADDRESS SUB P.LBND(L) ;GET # OF WORDS + 1 SOS 0 ;# OF WORDS IDIV P.NWIP(L) ;NO OF PAGES -1 AOS 0 ;# OF PAGES MOVEM TNOP ;SAVE FOR LATER MOVE T1,P.ADDR(L) ;BASE OF BUFFER MOVEM T1,ADR ;SAVE FOR ALCOR MOVN T1,P.SIZE(L) ;LENGTH OF BUFFER MOVEM T1,COUNT MOVEI T1,DLEN ;LENGTH OF DATA RECORD MOVEM T1,TEMP PUSHJ P,ALCOR ;GET IT MOVE T3,0 ;T3 POINTS TO DATA BASE RECORD MOVE T1,P.NWIP(L) ;# OF WORDS IN A PAGE SUBI T1,1 ; LSH T1,-7 ADDI T1,1 MOVE T2,P.CHAN(L) ;IMP CHANNEL NUMBER HRL T2,DASQVEC##(T2);GET IMP SCB FOR STREAM HRR T2,T1 ; MOVEM T2,D.RAND(T3) MOVE 0,P.NWIP(L) ;GET NO OF WORDS IN PAGE MOVEM 0,D.NWOR(T3) ;SAVE IN DATA BASE SUB 0,P.LBND(L) ;FOR PAGE / OFFSET ROUNDING MOVEM 0,D.NWM1(T3) ;SAVE IT MOVE 0,P.NICP(L) ;MAXIMUM # OF PAGES MOVEM 0,D.MAXA(T3) ;SAVE AS MAX PAGE IN CORE MOVEM 0,D.MAXP(T3) ;SAVE AS MAX PAGE MOVEM 0,D.NXTP(T3) ;AND NEXT TO GO MOVEM 0,TEMP PUSHJ P,ALCOR ;GRAB SOME CORE MOVE T7,0 ;SAVE FOR FILL ADD 0,[-1(T4)] ;INDEX & OFFSET IT MOVEM 0,D.ICPT(T3) ; & SAVE IT SETO T5,0 ;DO MOVE T6,TEMP ;ADDR PUSHJ P,FILL ;FILL THE ARRAY PUSHJ P,ALCOR ;FOR D.ICPA TABLE ADD 0,[-1(T4)] ;INDEX & OFFSTE IT MOVEM 0,D.ICPA(T3) ;& SAVE POINTER MOVN T1,D.MAXP(T3) ;BUILD AOBJN POINTER HRLI T1,(T1) ; .. HRR T1,0 ; MOVE 0,D.NWOR(T3) ;LENGTH OF PAGE $SKPPF < ADDI 0,2 ;EXTRA 2 WORDS IF DEBUG > MOVEM 0,TEMP ;SAVE GICP: PUSHJ P,ALCOR ;GET AN IN-CORE PAGE $SKPPF < ADDI 0,2 ;STEP OVER READS AND WRITES COUNTER > MOVEM 0,1(T1) ;BUILD D.ICPA AOBJN T1,GICP ;FOR AS LONG AS NECESSARY MOVE T6,TNOP ;GET NO OF PAGES IN TOTLA MOVEM T6,TEMP MOVE T5,[PUSHJ P,WFAULT] PUSHJ P,SVTABS ;SET UP TABLE ADD 0,[-1(T1)] ;PATCH IN INDEX AND OFFSET FROM 1 MOVEM 0,D.WTAB(T3) ;AND SAVE IN DATA BASE HLRZ T6,D.RAND(T3) ;GET SCB HRRZ T6,LKENT(T6) ;GET LOOKUP BLOCK MOVE T6,5(T6) ;LENGTH OF FILE IN WORDS MOVE T7,D.NWOR(T3) ;NO OF WORDS/PAGE ADDI T7,177 ;ROUND UP TO NO OF BLOCKS TRZ T7,177 ;AND NOW NO OF WORDS/PAGE ROUNDED TO NEAREST BLOCK ADDI T6,-1(T7) ;ROUND UP NO OF WORDS WRITTEN IDIVI T6,(T7) ;AND FIND NO OF PGES WRITTEN PUSHJ P,ALCOR ;GET THE CORE HRRZ T7,0 ;ADDRESS OF CORE ADD 0,[-1(T1)] ;PATCH IN INDEX FIELD & OFFSET MOVEM 0,D.RTAB(T3) ;SET POINTER INTO DATA BASE MOVE T5,[PUSHJ P,RFAULT] ; INSTRUCTION TO BE EXECUTED ON ALLOCATED PAGE MOVEM T6,TEMP ;SAVE COUNT PUSHJ P,FILL ;FILL IT MOVE T6,TNOP ;TOTAL # OF PAGES SUB T6,TEMP ;# UNALLOCATED MOVSI T5,(SETZ 0,0) ;INSTRUCTION TO EXECUTE PUSHJ P,FILL ;FILL IT $ATRCE < MOVEI L,T.ARG3 ;ARGUMENT FOR OPEN PUSHJ P,OPEN.## ;OPEN IT MOVE 15,(P) ;GET THE OLD LINK MOVEI L,T.ARG1 PUSHJ P,WTB. MOVEI L,T.ARG5 PUSHJ P,IOLST. PUSHJ P,FIN. > MOVE AC,T3 ;RETURN POINTER TO DATA BASE POPJ P, ;&RETURN FROM PROGRAM NOCORE: POP P,L ;RESTORE THE LINK MOVEI 0,5 ;ERROR CODE 5 MOVEM 0,P.IERR(L) ;STORE IT GOODBYE ;& RETURN SVTABS: PUSHJ P,ALCOR ;GET THE CORE HRRZ T7,0 ;ADDRESS ; FALL INTO FILL ; FILL FILLS AN ARRAY WITH GIVEN VALUE ; ; CALLING SEQUENCE IS - ; ; MOVE T5,VALUE ;WHAT TO FILL ARRAY WITH ; MOVE T6,LENGTH ;LENGTH OF ARRA ; MOVEI T7,ADDR ;BASE ADDR ; ; RETURN HERE ALWAYS ; ; ON RETURN T5 IS UNALTERED ; T6 IS DESTROYED ; T7 POINTS TO ADDRESS AFTER END OF ARRAY ; FILL: JUMPLE T6,EFILL ;SKIP IT IF <=0 MOVEM T5,(T7) ;DEPOSIT FIRST WORD MOVEI T7,1(T7) ;INCRENET T7 SOJE T6,EFILL ;FINISHED? ADDI T6,(T7) ;NO-PREPARE FOR BLT HRLI T7,-1(T7) ;T7 NOW CONTAINS BLT AC EXCH T7,T6 ;EXCHANGE THEM BLT T6,-1(T7) ;FILL IT UP EFILL: POPJ P, ; & RETURN ; ALCOR SIMULATES ALCOR. BUT IS QUICKER ALCOR: MOVE T4,TEMP ;# OF WORDS WANTED AOS T4 ;INCREMENT BY 1 FOR COUNT HRLZM T4,@ADR ;DEPOSIT AT ADR MOVE 0,ADR ;GET BASE ADDM T4,ADR ;INCREMENT ON THE ADDRESS ADDB T4,COUNT ;MODIFY THE COUNT JUMPG T4,SCREW ;COMPLAIN AOS 0 ;INCREMENT THE ADDRESS PAST THE COUNT POPJ P, ;& RETURN SCREW: OUTSTR [ASCIZ/? ALCOR EXPIRED - SEE W.D.HAY ABOUT THIS /] EXIT PAGE SUBTTL CLOSE ROUTINE HELLO (PAGCLS) ;ENTRY SEQUENCE MOVE T3,ARG1 ;GET DATA BASE POINTER MOVE T1,D.MAXA(T3) ;UNLOCK PAGES BY CHANGING MOVEM T1,D.MAXP(T3) ;D.MAXP MOVNI T1,(T1) ;AND SET UP COUNTER PUSHJ P,GETPAG ;FORCE IT AOJL T1,.-1 ;UNTIL FINISHED POPJ P, ;AND RETURN PAGE SUBTTL LOCK AND UNLOCK ROUTINES HELLO (LOCKP) PUSHJ P,LOCKSU ;SETUP T1-T3 LOCK10: MOVE T4,D.MAXP(T3) ;GET MAX PAGE NO $PTRCE < MOVEM T1,NPAG PUSH P,L MOVEI L,F1001 PUSHJ P,OUT. MOVEI L,F2001 PUSHJ P,IOLST. POP P,L > CAIG T4,2 ;MUST HAVE AT LEAST TWO FREE PAGES JRST LOCKEX ;DONT-SO DONT LOCK IT PUSHJ P,FILP ;FIND IN-CORE PAGE PUSHJ P,LOKEXC ;EXCHANGE PAGES (RETURN 1) SOS D.MAXP(T3) ;LOCK IT (RETURN 2) LOCKEX: GOODBYE ;ALREADY LOCKED (RETURN 3) HELLO (ULOCKP) PUSHJ P,LOCKSU ;SETUP T1-T3 ULOC10: $PTRCE < MOVEM T1,NPAG MOVEI L,F1002 PUSHJ P,OUT. MOVEI L,F2001 PUSHJ P,IOLST. POP P,L > PUSHJ P,FILP ;FIND IN-CORE PAGE POPJ P, ;RETURN 1-WAS UNLOCKED POPJ P, ; DO AOS D.MAXP(T3) ;UNLOCK THE PAGE CAME T4,D.MAXP(T3) ;IS IT NOW =? PUSHJ P,LOKEXC ;NO-SWOP PAGE REFERENCES POPJ P, ;& RETURN ; LOCKSU SETS UP AC'S T1-T3 AND FORCES PAGE INTO CORE IF NOT ; ALREADY THERE ; LOCKSU: HRRZ T3,@S.IDBA(L) ;GET DATA BASE POINTER HRRZ T1,@S.IADR(L) ;GET PAGE NO SETZ T2, ;ZERO OFFSET XCT @D.RTAB(T3) ;DO A READ TO FORCE IN PAGE POPJ P, ;RETURN FILP: MOVE T4,D.MAXA(T3) ;GET MAX PAGE NO FILP10: CAMN T1,@D.ICPT(T3) ;IS IT THIS ONE ? JRST FILP20 ;YES SOJG T4,FILP10 ;NO-TRY TO GET NEXT ONE OUTSTR [ASCIZ/? PAGE TABLE FOULED UP /] EXIT FILP20: CAMGE T4,D.MAXP(T3) ;>=MAX IN CORE SWAPPING PAGE? POPJ P, ;NO-RETURN 0 CAME T4,D.MAXP(T3) ;>MAX IN CORE SWAPPING PAGE? AOS (P) ;RETURN 1 AOS (P) ;RETURN 1 POPJ P, ;RETURN ; LOKEXC EXCHANGES REFERENCE TO PAGE POINTED TO BY ; T4 WITH THAT POINTED TO BY D.MAXP LOKEXC: MOVE T5,@D.ICPA(T3) ;GET ADDREESS POINTED TO MOVE T6,@D.ICPT(T3) ;GET CORRESPONDANCE EXCH T4,D.MAXP(T3) ;SAVE T4, PICK UP D.MAXP EXCH T5,@D.ICPA(T3) EXCH T6,@D.ICPT(T3) EXCH T4,D.MAXP(T3) ;RESTORE T4 AND D.MAXP MOVEM T5,@D.ICPA(T3) MOVEM T6,@D.ICPT(T3) POPJ P, HELLO (LOCKA) PUSHJ P,IOPAG ;GET THE AC'S SET UP XCT @D.RTAB(T3) ;FORCE PAGE INTO CORE JRST LOCK10 ;AND DO COMMON LOCK STUFF HELLO (ULOCKA) PUSHJ P,IOPAG ;SET UP AC'S XCT @D.RTAB(T3) ;FORCE IN PAGE JRST ULOC10 ; & DO COMMON STUFF PAGE SUBTTL RANRED AND RANWRT PUT HERE T11=11 T12=12 T13=13 T10=10 RANRED: MOVEI T10,-1(T1) ;PAGE # -1 HRRZ T11,D.RAND(T3) ;NO OF BLOCKS/PAGE IMUL T10,T11 ;FIRST BLOCK OF PAGE-1 AOS T10 ;FIRST BLOCK HLRZ T11,D.RAND(T3) ;GET SCB IOR T10,USETI(T11) ;FORM USETI XCT T10 ;DO IT MOVN T10,D.NWOR(T3) ;LENGTH OF PAGE HRL T10,TEMP ;ADDRESS MOVSM T10,CLST ;IOWD+1 SOS CLST SETZM CLST+1 ;MAKE SURE IT TERMINATES MOVE T10,IBUFOP(T11) ;MAKE AN IN UUO HRRI T10,CLST XCT T10 ;EXECUTE IT POPJ P, ;OK OUTSTR [ASCIZ/?PAGINF ERROR ON PAGING READ /] EXIT RANWRT: MOVEI T10,-1(T1) ;PAGE # -1 HRRZ T11,D.RAND(T3) ;NO OF BLOCKS/PAGE IMUL T10,T11 ;FIRST BLOCK OF PAGE-1 AOS T10 ;FIRST BLOCK HLRZ T11,D.RAND(T3) ;GET SCB IOR T10,USETO(T11) ;FORM USETI XCT T10 ;DO IT MOVN T10,D.NWOR(T3) ;LENGTH OF PAGE HRL T10,TEMP ;ADDRESS MOVSM T10,CLST ;IOWD+1 SOS CLST SETZM CLST+1 ;MAKE SURE IT TERMINATES MOVE T10,OBUFOP(T11) ;MAKE AN IN UUO HRRI T10,CLST XCT T10 ;EXECUTE IT POPJ P, ;OK OUTSTR [ASCIZ/PAFOUF ERROR IN PAGING WRITE /] EXIT CLST: BLOCK 2 ;IOWD PAGE SUBTTL DEBUGGERY IFN TRACEP,< NPAG: 0 OPAG: 0 READS: 0 WRITES: 0 XWD -5,0 F1000: 24 0 0 XWD 340,[ASCIZ/(' C',4I6)/] 2 XWD -5,0 F2000: XWD 1100,NPAG XWD 1100,OPAG XWD 1100,READS XWD 1100,WRITES XWD 4000,0 XWD -5,0 F1001: 24 0 0 XWD 340,[ASCII/(' L',I6)/] 2 XWD -2,0 F2001: XWD 1100,NPAG XWD 4000,0 XWD -5,0 F1002: 24 0 0 XWD 340,[ASCII/(' U',I6)/] 2 > PAGE SUBTTL TRACE STUFF IFN TRACEA,< XWD -3,0 T.ARG1: XWD 0,20 XWD 0,0 XWD 0,0 XWD -2,0 T.ARG2: XWD 1100,T.ADDR XWD 4000,0 XWD -6,0 T.ARG3: XWD 0,20 0 0 XWD 3740,[ASCII/MTA0/] XWD 2740,[ASCIZ/SEQOUT/] XWD 12740,[ASCIZ/IMAGE/] XWD 4100,[EXP 6] XWD -3,0 T.ARG5: XWD 1100,@P.LBND(15) XWD 1100,@P.UBND(15) XWD 4000,0 T.ADDR: 0 > END $$$$$$$$$$$$