Trailing-Edge
-
PDP-10 Archives
-
decuslib10-10
-
43,50520/forwmu.mac
There are 4 other files named forwmu.mac in the archive. Click here to see a list.
TITLE FORWMU - LOCAL FOROTS PATCHES
SUBTTL T HAGADONE
SEARCH FORPRM
IFNDEF FTWMU,<FTWMU==0>
IFN FTWMU,<
ENTRY INDVT.
INDVT.: MOVSI T2,ACC.SV+20(P4);FIRST LOC TO ZERO
HRRI T2,ACC.SV+21(P4)
SETZM ACC.SV+20(P4) ;ZERO IT
BLT T2,@.JBREL ;TO TOP OF CORE
MOVEI T1,DEVTB. ;ADDRESS OF DEVTB.
MOVEM T1,DEV.TB(P4) ;STORE IT FOR FOROTS
MOVEI T1,DVEND.-DEVTB.-1 ;SIZE OF DEVTAB
MOVEM T1,DEV.SZ(P4) ;STORE IT FOR FOROTS
JRST (P) ;RETURN
SUBTTL DEVTB. DEFAULT DEVICE TABLE FOR FORTRAN IV
SIXBIT .REREAD. ;-6; REREAD
SIXBIT .CDR. ;-5; READ
SIXBIT .TTY. ;-4; ACCEPT
SIXBIT .LPT. ;-3; PRINT
SIXBIT .PTP. ;-2; PUNCH
SIXBIT .TTY. ;-1; TYPE
DEVTB.: Z ;00; ILLEGAL DEVICE NUMBER
SIXBIT .DSK. ;01; DISC
SIXBIT .CDR. ;02; CARD READER
SIXBIT .LPT. ;03; LINE PRINTER
SIXBIT .CTY. ;04; CONSOLE TELETYPE
SIXBIT .TTY. ;05; USER'S TELETYPE
SIXBIT .PTR. ;06; PAPER TAPE READER
SIXBIT .PTP. ;07; PAPER TAPE PUNCH
SIXBIT .DIS. ;08; DISPLAY
SIXBIT .DTA1. ;09; DECTAPE
SIXBIT .DTA2. ;10;
SIXBIT .DTA3. ;11;
SIXBIT .DTA4. ;12;
SIXBIT .DTA5. ;13;
SIXBIT .DTA6. ;14;
SIXBIT .DTA7. ;15;
SIXBIT .MTA0. ;16; MAG TAPE
SIXBIT .MTA1. ;17;
SIXBIT .MTA2. ;18;
SIXBIT .FORTR. ;19;
SIXBIT .DSK. ;20;
SIXBIT .DSK. ;21;
SIXBIT .DSK. ;22;
SIXBIT .DSK. ;23;
SIXBIT .DSK. ;24;
SIXBIT .DEV1. ;25;
SIXBIT .DEV2. ;26;
SIXBIT .DEV3. ;27;
SIXBIT .DEV4. ;28;
SIXBIT .CDP. ;29;
SIXBIT .TTY. ;30;
DVEND.:
> ;END FTWMU
PRGEND
TITLE DEVCHG
SUBTTL CHANGE DEVTB. ENTRIES TO NEW DEVICES
SEARCH FORPRM
IFNDEF FTWMU,<FTWMU==0>
IFN FTWMU,<
BP7=0
BP6=1
CTR=2
A=3
IND=5
CH=6
P4=7
Q=16
P=17
HELLO (DEVCHG)
HRRZ P4,.JBOPS ;LOAD BASE REGISTER
SETZ A,
SKIPLE IND,@1(Q) ;GET FLU, IS IT LEGAL
CAMLE IND,DEV.SZ(P4) ;TOP AND BOTTOM?
JRST [OUTSTR DEVERR
MOVEI 16,[EXP 0,0]+1 ;ARG FOR EXIT.
PUSHJ P,EXIT.##]
MOVEI BP7,@(Q) ;ADDRESS OF DEVICE NAME
HRLI BP7,440700
MOVE BP6,POINT
HRROI CTR,-5 ;NUMBER OF CHARS PER WORD
GETDEV: ILDB CH,BP7
JUMPE CH,DONE
SUBI CH,40
IDPB CH,BP6
AOJL CTR,GETDEV
DONE: ADD IND,DEV.TB(P4) ;ADDRESS OF ENTRY
MOVEM A,(IND) ;STORE NEW DEVICE
GOODBY
POINT: POINT 6,A,
DEVERR: ASCIZ /?FRSDVC - ILLEGAL DEVICE NUMBER IN CALL TO DEVCHG
/
> ;END FTWMU
PRGEND
TITLE BLOCKT
SUBTTL BLOCK TRANSFER SUBROUTINE
SEARCH FORPRM
COMMENT *
USAGE CALL BLOCKT(ARRAY1,ARRAY2,NWORDS)
WHERE ARRAY1: IS ARRAY (VECTOR) TO BE TRANSFERED
ARRAY2: IS ARRAY (VECTOR) TO TRANSFER ARRAY1 TO
NWORDS: IS THE NUMBER OF WORDS TO TRANSFER
*
HELLO (BLOCKT, ) ;BLOCKT ENTRY
MOVSI 0,@0(16) ;PICK UP STARTING ADDRESS
HRRI 0,@1(16) ;PICK UP DESTINATION ADDRESS
HRRZ 1,0 ;COPY
ADD 1,@2(16) ;ADD LENGTH
BLT 0,-1(1) ;TRANSFER. LIMIT =C(1)-1
GOODBY (3) ;RETURN
PRGEND
TITLE LDBDPB - DO LDB AND DPB INSTRUCTIONS
SEARCH FORPRM
COMMENT %
USAGE CALL GETBYT(SRCWD,IBYTE,ISIZE,IRMOST,IERR)
WHERE SRCWD - WORD TO GET BYTE OUT OF
IBYTE - WORD TO PUT BYTE INTO
ISIZE - SIZE OF BYTE (1 TO 36)
MUST NOT BE GREATER THAN IRMOST+1
IRMOST - POSITION OF RIGHTMOST BIT OF BYTE (0 TO 35)
IERR - ERROR CODE. NON-ZERO IF ARGUMENTS ARE ILLEGAL
CALL GETBYT(DSTWD,IBYTE,ISIZE,IRMOST,IERR)
WHERE DSTWD - WORD TO PUT THE BYTE IN
IBYTE - WORD TO DPB FROM
OTHERS - SAME AS ABOVE
%
HELLO (GETBYT)
PUSHJ P,MAKPNT ;SET UP THE BYTE POINTER
GOODBY (1) ;ERROR
LDB 0,3 ;LOAD THE BYTE
MOVEM 0,@1(16) ;RETURN IT TO THE USER
GOODBY (1) ;RETURN
HELLO (PUTBYT)
PUSHJ P,MAKPNT ;SET UP THE BYTE POINTER
GOODBY (1) ;ERROR
MOVE 0,@1(16) ;GET THE BYTE
DPB 0,3 ;DEPOSIT THE BYTE
GOODBY (1) ;RETURN
MAKPNT: SETZM @4(16) ;ASSUME NO ERROR
SKIPL 2,@3(16) ;IS "RIGHTMOST BIT" LEGAL?
CAILE 2,^D35 ;...
JRST ERRORR ;NO. ERROR
SKIPLE 1,@2(16) ;IS SIZE LEGAL?
CAILE 1,1(2) ;...
JRST ERRORR ;NO. ERROR
MOVEI 3,^D35 ;GET BITS TO THE RIGHT
SUB 3,2 ;...
LSH 3,6 ;MAKE SPACE FOR SIZE
IOR 3,1 ;PUT IN SIZE
LSH 3,^D24 ;POSITION
HRRI 3,@0(16) ;GET ADDRESS
AOS (P) ;SKIP RETURN
POPJ P,
ERRORR: SETOM @4(16)
POPJ P,
PRGEND
TITLE BYTE PACKING/UNPACKING
SEARCH FORPRM
COMMENT %
WRITTEN BY NORM GRANT. W.M.U. NOVEMBER 2, 1973
PURPOSE PACK AND UNPACK ASCII WORDS
USAGE CALL GETCHR(WORD,IBYTE,CHAR)
WHERE WORD: IS PACKED WORD(S)
IBYTE: IS BYTE NUMBER (.GT. ZERO)
CHAR: IS CHARACTER UNPACKED (TRAILING BLANKS)
CALL PUTCHR(WORD,IBYTE,CHAR)
WHERE WORD: IS PACKED WORD(S)
IBYTE: IS BYTE NUMBER (.GT. ZERO)
CHAR: IS CHARACTER TO BE PACKED (LEFT JUSTIFIED)
%
Q=16
HELLO (GETCHR, ) ;GETCHR ENTRY
MOVE 0,[ASCII' '] ;BLANK OUT CHAR
MOVEM 0,@2(Q)
PUSHJ P,BYTE
LDB 0,2 ;PICK UP CHARACTER FROM WORD
DPB 0,3 ;STORE IN CHAR
GOODBY (3) ;RETURN
HELLO (PUTCHR, ) ;PUTCHR ENTRY
PUSHJ P,BYTE
LDB 0,3 ;PICK UP CHARACTER FROM CHAR
DPB 0,2 ;STORE IN WORD
GOODBY (3) ;RETURN
BYTE: MOVE 2,@1(Q) ;GET BYTE NUMBER
JUMPLE 2,NULL ;NON-POSITIVE IS AN ERROR
SUBI 2,1 ;MINUS ONE FOR DIVIDE
IDIVI 2,5 ;FIVE CHARACTERS PER WORD
ADD 2,BYTTAB(3) ;ADD PROPER POINTER WORD
ADDI 2,@0(Q) ;ADD IN ADDRESS OF WORD
MOVEI 3,@2(Q) ;GET POINTER TO CHARACTER
HRLI 3,350700
POPJ P, ;RETURN
BYTTAB: POINT 7,0,6 ;FIRST BYTE IN WORD
POINT 7,0,13 ;SECOND
POINT 7,0,20 ;THIRD
POINT 7,0,27 ;FOURTH
POINT 7,0,34 ;FIFTH AND LAST
NULL: OUTSTR [ASCIZ/
Non-positive byte number is illegal!
/]
POP P,0
GOODBY (2)
PRGEND
TITLE CLOCK
SUBTTL TIME OF DAY.
SEARCH FORPRM
COMMENT %
WRITTEN BY NORM GRANT. W.M.U.
USAGE CALL CLOCK(IHOUR,IMIN,ISEC,ITICK)
WHERE IHOUR: HOUR OF DAY-24 HOUR TIME.
IMIN: MINUTE.
ISEC: SECOND.
ITICK: CLOCK TICK(1/60 TH SECOND).
%
HELLO (CLOCK, ) ;CLOCK ENTRY
TIMER
IDIVI 0,^D60
MOVEM 1,@3(16)
IDIVI 0,^D60
MOVEM 1,@2(16)
IDIVI 0,^D60
MOVEM 1,@1(16)
MOVEM 0,@0(16)
GOODBY (4)
PRGEND
TITLE DAY
SUBTTL DATE
SEARCH FORPRM
COMMENT %
WRITTEN BY NORM GRANT. WMU. SEPTEMBER 2,1971.
PURPOSE: TO DETERMINE YEAR, MONTH, AND DAY.
USAGE CALL DAY(IYEAR,IMONTH,IDAY)
WHERE IYEAR: INTEGER YEAR(RETURNED)
IMONTH: INTEGER MONTH(1-12)(RETURNED)
IDAY: INTEGER DATE OF MONTH.
%
HELLO (DAY, ) ;DAY ENTRY
DATE
IDIVI 0,^D31
AOJ 1,
MOVEM 1,@2(16)
IDIVI 0,^D12
AOJ 1,
MOVEM 1,@1(16)
ADDI 0,^D1964
MOVEM 0,@0(16)
GOODBY (3)
PRGEND
TITLE DLOGIC
SUBTTL FORTRAN SUBROUTINES FOR LSHC AND ROTC.
REMARK WRITTEN BY NORM GRANT. W.M.U.
SEARCH FORPRM
COMMENT %
USAGE CALL DSHIFT(WORD,IPLACES,WORD1)
CALL DROTATE(WORD,IPLACES,WORD1)
WHERE WORD: IS DOUBLE PRECISION WORD TO BE SHIFTED OR ROTATED.
IPLACES: IS NUMBER OF PLACES TO SHIFT OR ROTATE.
POSITIVE IS LEFT, NEGATIVE IS RIGHT.
WORD1: DOUBLE PRECISION RESULT.
%
HELLO (DSHIFT, ) ;DSHIFT ENTRY
DMOVE 0,@0(16)
MOVE 2,@1(16)
LSHC 0,0(2)
DRET: DMOVEM 0,@2(16)
GOODBY (3)
HELLO (DROTAT, ) ;DROTAT ENTRY
DMOVE 0,@0(16)
MOVE 2,@1(16)
ROTC 0,0(2)
JRST DRET
PRGEND
TITLE DYTIME
SUBTTL GET DAY TIME, IN MS.
SEARCH FORPRM
COMMENT %
WRITTEN BY NORM GRANT. W.M.U.
USAGE CALL DYTIME(ITIME)
WHERE ITIME: IS DAYTIME IN MILLISECONDS.(RETURNED)
%
HELLO (DYTIME, ) ;DYTIME ENTRY
MSTIME 0,
MOVEM 0,@0(16)
GOODBY (1)
PRGEND
TITLE ECHO - SUBROUTINE TO TURN TTY ECHO ON OR OFF.
SUBTTL WRITTEN BY JERRY FOCHTMAN. W.M.U.
SEARCH FORPRM
COMMENT %
USAGE CALL ECHO(ICMD)
WHERE ICMD - IS A SWITCH TO TURN ECHO EITHER ON OR OFF.
0 - ON
1 - OFF
NOTE - A CARRIAGE RETURN DOES NOT GENERATE A LINE FEED
WHEN ECHO IS OFF, SO THE MAIN PROGRAM MUST ALLOW
FOR IT.
%
HELLO (ECHO, ) ;ECHO ENTRY
MOVE 1,@0(16)
SETO 0,
GETLCH 0,
JUMPN 1,NEO
TLZ 0,4
JRST DONE
NEO: TLO 0,4
DONE: SETLCH 0,
GOODBY (1)
PRGEND
TITLE TYPEON
SEARCH FORPRM
HELLO (TYPEON, )
SKPINL ;TURN ON ECHOING
JFCL ;DON'T CARE
GOODBY (0)
PRGEND
TITLE GES
SEARCH FORPRM
HELLO (GES, )
SETZ 7,
MOVE 1,@1(16)
ADDI 1,@0(16)
SOJ 1,
HRRM 1,BLL
HRLI 1,@0(16)
MOVEI 2,@0(16)
AOJ 2,
HRRM 2,1
MOVE 2,BL
MOVEM 2,@(16)
BLL: BLT 1,0
MOVEI 1,@0(16)
HRRM 1,MOV
SETZM @2(16)
MOVE 1,@1(16)
SETZ 4,
TT: INCHWL 2
CAIN 2,15
JRST TT
CAIN 2,12
JRST EOL
JUMPL 7,NEXT
MOVE 3,BL
DPB 2,[POINT 7,3,6]
MOV: MOVEM 3,(4)
NEXT: CAIG 2,175
CAIN 2,33
JRST ALT
CAIN 2,32
JRST EOF
A: AOJ 4,
CAML 4,1
SETO 7,
JRST TT
ALT: SETOM @2(16)
JRST CRLF
EOL: MOVEI 5,1
MOVEM 5,@2(16)
GOODBY (3)
EOF: MOVEI 5,2
MOVEM 5,@2(16)
CRLF: OUTSTR [BYTE (7)15,12]
GOODBY (3)
BL: ASCII/ /
PRGEND
TITLE GETPPN
SUBTTL RETURN PROJECT-PROGRAMMER PAIR.
SEARCH FORPRM
COMMENT %
WRITTEN BY NORM GRANT. AUGUST 30,1971.
USAGE CALL GETPPN(IPROJ,IPROG)
WHERE IPROJ: PROJECT NUMBER(OCTAL) RETURNED.
IPROG: PROGRAMMER NUMBER(OCTAL) RETURNED.
%
HELLO (GETPPN, ) ;GETPPN ENTRY
CALLI 0,24
HRRZM 0,@1(16)
HLRZM 0,@0(16)
GOODBY (2)
PRGEND
TITLE JOBNUM
SUBTTL GET JOB NUMBER
SEARCH FORPRM
COMMENT %
WRITTEN BY NORM GRANT. WMU. SEPTEMBER 2,1971.
PURPOSE: TO DETERMINE JOB NUMBER OF USER'S JOB.
USAGE CALL JOBNUM(IJOB)
WHERE IJOB: INTEGER JOB# (RETURNED)
%
HELLO (JOBNUM, ) ;JOBNUM ENTRY
PJOB
MOVEM 0,@0(16)
GOODBY (1)
PRGEND
TITLE LOGIC
SUBTTL FORTRAN SUBROUTINES FOR LSH AND ROT.
REMARK WRITTEN BY NORM GRANT. W.M.U.
SEARCH FORPRM
COMMENT %
USAGE CALL SHIFT(WORD,IPLACES,WORD1)
CALL ROTATE(WORD,IPLACES,WORD1)
WHERE WORD: IS WORD TO BE SHIFTED OR ROTATED.
IPLACES: IS NUMBER OF PLACES TO SHIFT OR ROTATE.
POSITIVE IS LEFT, NEGATIVE IS RIGHT.
WORD1: RESULT
%
HELLO (SHIFT, ) ;SHIFT ENTRY
MOVE 1,@1(16)
MOVE 0,@0(16)
LSH 0,0(1)
RET: MOVEM 0,@2(16)
GOODBY (3)
HELLO (ROTATE, ) ;ROTATE ENTRY
MOVE 1,@1(16)
MOVE 0,@0(16)
ROT 0,0(1)
JRST RET
PRGEND
TITLE MAXIMUMS
SUBTTL FIND MAXIMUM ENTRY IN LIST
SEARCH FORPRM
COMMENT %
WRITTEN BY NORM GRANT. W.M.U.
USAGE CALL MAXIMU(ARRAY,NUM,ANS)
WHERE ARRAY IS ARRAY FROM WHICH TO SELECT MAXIMUM.
NUM SIZE OF ARRAY(>=1)
ANS MAXIMUM(SAME MODE AS ARRAY)
%
HELLO (MAXIMU, ) ;MAXIMUM ENTRY
MOVE 2,@1(16)
MOVE 0,@0(16)
SOJLE 2,DONE
MOVEI 1,@0(16)
AOJ 1,
CAMGE 0,0(1)
MOVE 0,0(1)
SOJG 2,.-3
DONE: MOVEM 0,@2(16)
GOODBY (3)
PRGEND
TITLE MAXWYT
SEARCH FORPRM
MIDNIT: EXP ^D24*^D3600*^D1000 ;NUMBER OF MILLISECONDS IN A DAY
HELLO (MAXWYT, )
MOVE 1,@0(16) ;GET TIME LIMIT
IMULI 1,^D1000 ;CONVERT TO MILLISECONDS
MSTIME 3, ;GET CURRENT TIME
ADD 3,1 ;MAKE TIME LIMIT
IDIV 3,MIDNIT ;MAY BE DAYS
DATE 2,
ADD 3,2 ;GET FINAL DAY TOO
CHECK: SKPINL ;ANY INPUT LINES?
CAIA ;NO
JRST GOTINP ;YES. GOOD RETURN
DATE 2, ;CURRENT DATE
MOVN 2,2
ADD 2,3
IMUL 2,MIDNIT ;DAYS YET
ADD 2,4
MSTIME 0, ;CURRENT TIME
SUB 2,0 ;TOTAL TIME YET TO WAIT
JUMPLE 2,BADRET ;TOO LATE IF NOT POSITIVE
CAILE 2,^D60000 ;60 SECONDS OR LESS
MOVEI 2,^D60000 ;NO. USE 60 SECONDS
TLO 2,(1B13) ;WAKE ON INPUT LINE
HIBER 2, ;HIBERNATE
JRST USESLP ;IF GET ERROR, WE MUST USE SLEEP
JRST CHECK ;GO CHECK ON INPUT
USESLP: MOVEI 2,1 ;SLEEP ONE SECOND
SLEEP 2,
JRST CHECK ;AND GO CHECK
GOTINP: SETZM @1(16) ;GOOD EXIT
GOODBY (2)
BADRET: MOVEI 0,1 ;BAD RETURN
MOVEM 0,@1(16)
CLRBFI ;CLEAR ANY INPUT (PARTIAL LINES)
GOODBY (2) ;AND EXIT
PRGEND
TITLE MINIMUMS
SUBTTL FIND MINIMUM ENTRY IN LIST
SEARCH FORPRM
COMMENT %
WRITTEN BY NORM GRANT. W.M.U.
USAGE CALL MINIMUM(ARRAY,NUM,ANS)
WHERE ARRAY IS ARRAY FROM WHICH TO SELECT MINIMUM.
NUM SIZE OF ARRAY(>=1)
ANS MINIMUM(SAME MODE AS ARRAY)
%
HELLO (MINIMU, ) ;MINIMUM ENTRY
MOVE 2,@1(16)
MOVE 0,@0(16)
SOJLE 2,DONE
MOVEI 1,@0(16)
AOJ 1,
CAMLE 0,0(1)
MOVE 0,0(1)
SOJG 2,.-3
DONE: MOVEM 0,@2(16)
GOODBY (3)
PRGEND
TITLE PEEK
SUBTTL SUBROUTINE TO EXAMINE MONITOR.
SEARCH FORPRM
COMMENT %
WRITTEN BY NORM GRANT. W.M.U.
USAGE CALL PEEK(IEXEC,IWORD)
WHERE IEXEC: IS EXECUTIVE ADDRESS TO BE EXAMINED.
IWORD: IS CONTENTS OF IEXEC.
%
OPDEF PEEK [CALLI 33]
HELLO (PEEK, ) ;PEEK ENTRY
MOVE 0,@0(16)
PEEK
MOVEM 0,@1(16)
GOODBY (2)
PRGEND
TITLE RESTART
SUBTTL RESTART PROGRAM
SEARCH FORPRM
ENTRY RESTAR
COMMENT %
WRITTEN BY NORM GRANT. W.M.U. MARCH 8,1971.
PURPOSE TO IMMEDIATELY RESTART A PROGRAM FROM ANY POINT WITHIN IT.
USAGE CALL RESTART
%
RESTAR:
IFN F40LIB,< JFCL ;PERMIT BOTH F40 AND F10 ENTRIES>
HRRZ 1,.JBSA##
JRST 0(1)
PRGEND
TITLE RNTIME
SUBTTL GET PROGRAM RUN TIME, IN MS.
SEARCH FORPRM
COMMENT %
WRITTEN BY NORM GRANT. W.M.U.
USAGE CALL RNTIME(ITIME)
WHERE ITIME: IS RUNTIME OF JOB, TO PRESENT, IN MILLISECONDS.(RETURNED)
%
HELLO (RNTIME, ) ;RNTIME ENTRY
SETZ 0,
RUNTIM 0,
MOVEM 0,@0(16)
GOODBY (1)
PRGEND
TITLE RUNUUO
SUBTTL MIMIC CONCISE COMMAND LANGUAGE
; WRITTEN BY NORM GRANT. W.M.U
ENTRY RUNUUO
COMMENT %
USAGE CALL RUNUUO(COMMAND)
WHERE COMMAND: IS ASCII COMMAND STRING, 200 CHARACTERS
OR LESS; MUST END WITH ZERO WORD.(IF COMMAND STRING IS
LITERAL ENCLOSED IN QUOTES IN CALL STATEMENT, WILL DO SO
AUTOMATICALLY.)
VALID COMMANDS ARE R,RUN,EXECUTE,DEBUG,LOAD,COMPILE,MAKE,TECO,
CREATE,EDIT,RENAME,DELETE,TYPE,LIST,COPY,PRESERVE,PROTECT,REWIND,
UNLOAD,ZERO,SKIP,BACKSPACE,EOF,LABEL AND THEIR
STANDARD ABBREVIATIONS.
%
POINTA: POINT 7,BUFFER,
POINTS: POINT 6,FX+1,
COUNT=1
LIM=2
SVCNT=3
FLAG=4
NUM=6
POINT=10
POINT1=11
CH=12
Q=16
P=17
BLOCK: SIXBIT/SVC/
IOWD 1,BUFFER
OBUF: BLOCK 3
BUFFER: BLOCK ^D40
NAME: SIXBIT/000SVC/
SIXBIT/TMP/
0
0
RUNUUO: JFCL ;PERMIT BOTH F40 AND F10 ENTRIES
SETZ FLAG,
RUNUU1: RESET
MOVEI POINT,@0(16)
HRLI POINT,440700 ;440700=(POINT 7,0,)
MOVE POINT1,POINTA
SETZM BUFFER
MOVE 0,[XWD BUFFER,BUFFER+1]
BLT 0,BUFFER+^D39
SETZ 1,
LOOP: PUSHJ P,GETCHR
JUMPE CH,ERMSG
CAIN CH," "
JRST LOOP
CAIN CH,"R"
JRST RUNR
CAIA
LOOP1: PUSHJ P,GETCHR
JUMPE CH,TRAN
IDPB CH,POINT1
JRST LOOP1
TRAN: MOVE SVCNT,COUNT
ADDI COUNT,4
IDIVI COUNT,5
MOVNS COUNT
HRLM COUNT,BLOCK+1
MOVE 0,[XWD 3,BLOCK]
TMPCOR
JRST DSKIT
RUNS: MOVE 0,[XWD 1,E]
JRST GET1
DSKIT: INIT 0,0
SIXBIT/DSK/
XWD OBUF,0
JRST NOGO
PJOB
IDIVI 0,^D10
DPB 1,[POINT 4,NAME,17]
IDIVI 0,^D10
DPB 1,[POINT 4,NAME,11]
DPB 0,[POINT 4,NAME,5]
ENTER 0,NAME
JRST NOGO
MOVE POINT,POINTA
LOOP2: SOSG OBUF+2
OUTPUT 0,
PUSHJ P,GETCHR
IDPB CH,OBUF+1
SOJG SVCNT,LOOP2
CLOSE 0,
JRST RUNS
NOGO: OUTSTR [ASCIZ/CANNOT ENTER TMP FILE!
/]
EXIT
RUNR: JUMPN FLAG,LOOP1+1
SETO FLAG,
MOVE POINT1,POINTS
MOVEI LIM,6
PUSHJ P,GETCHR
CAIN CH," "
JRST R
CAIE CH,"U"
JRST RUNUU1
PUSHJ P,GETCHR
CAIN CH,"N"
PUSHJ P,GETCHR
CAIE CH," "
JRST RUNUU1
SOS POINT1
SETZM FX
PUSHJ P,LOOP4
LOOP6: CAIE CH," "
CAIN CH,":"
JRST NEXT
CAIE CH,"." ;PREMATURE EXTENSION?
CAIN CH,"[" ;OR PROJECT PROGRAMMER?
JRST DEVFAL ;YES, USE DEFAULT DEVICE, THAT WAS FILENAME.
JUMPE CH,DEVFAL ;SAME IF END OF STRING.
JRST ERMSG ;ERROR IF NONE OF ABOVE.
NEXT: MOVEI LIM,6
MOVE POINT1,POINTS
PUSHJ P,LOOP3
SKIPN FX+1 ;NULL NAME?
JRST DEVFAL ;YES, SO DEVICE WAS FILENAME.
NEXT1: CAIN CH,"."
JRST EXTEND
EXEN: JUMPE CH,ENDS
CAIN CH,"["
JRST LL2
CAIE CH," "
JRST ERMSG ;BAD SYNTAX.
PUSHJ P,GETCHR
JRST EXEN
DEVFAL: MOVSI 5,'DSK' ;DEFAULT DEVICE IS DSK.
EXCH 5,FX ;AND THAT WAS A FILENAME.
MOVEM 5,FX+1 ;SO PUT IT WHERE IT BELONGS.
JRST NEXT1 ;AND GO CHECK FOR EXTENSION.
ERMSG: OUTSTR [ASCIZ/Command error: /]
OUTSTR @0(16) ;USERS COMMAND
OUTSTR [BYTE (7)15,12] ;CRLF
EXIT
EXTEND: MOVEI LIM,3
MOVE POINT1,[POINT 6,FX+2,]
PUSHJ P,LOOP5
JRST EXEN
LL2: SETZ NUM,
LL3: PUSHJ P,GETCHR
CAIE CH," "
CAIN CH,"]"
JRST ENDNUM
CAIN CH,","
JRST FNUM
CAIG CH,"7"
CAIGE CH,"0"
JRST ERMSG
LSH NUM,3
ADDI NUM,-"0"(CH)
JRST LL3
FNUM: HRLZM NUM,FX+4
JRST LL2
ENDNUM: HRRM NUM,FX+4
JRST ENDS
R: PUSHJ P,LOOP3
MOVSI 0,'SYS'
MOVEM 0,FX
ENDS: MOVEI 0,F
GET1: MOVE 3,[XWD GETX,GET]
BLT 3,GETEND
JRST GET
LOOP3: SETZM FX+1
MOVE 3,[XWD FX+1,FX+2]
BLT 3,FX+5
LOOP4: PUSHJ P,GETCHR
CAIN CH," " ;BLANKS
JRST LOOP4 ;ARE IGNORED HERE
SKIPA
LOOP5: PUSHJ P,GETCHR ;SCAN UNTIL WE FIND BAD CHARACTER.
CAIGE CH,"0"
POPJ P,
CAIG CH,"9"
JRST OK
CAIL CH,"A"
CAILE CH,"Z"
POPJ P,
OK: JUMPLE LIM,.+3 ;DON'T DEPOSIT IF ALREADY HAVE ENOUGH.
ADDI CH,40
IDPB CH,POINT1
SOJA LIM,LOOP5
GETCHR: ILDB CH,POINT
CAIL COUNT,^D200
SETZ CH,
AOJ COUNT,
CAIN CH,11
MOVEI CH," "
POPJ P,
GETX: PHASE 140
GET: MOVE 1,[XWD 1,777]
CORE 1,
JFCL
RUN 0,
SPHASE: HALT .
DEPHASE
FX: PHASE SPHASE+1
F: 0
0
0
0
0
0
E: SIXBIT/SYS/
SIXBIT/COMPIL/
0
0
0
GETEND: 0
DEPHASE
PRGEND
TITLE SIZE OF OVERLAY IN CHAINB
SEARCH FORPRM
HELLO (SIZE, )
MOVE 1,@0(16)
HLRE 0,OVTAB##-1(1)
MOVMM 0,@1(16)
GOODBY (2)
PRGEND
TITLE SLEEP
SEARCH FORPRM
OPDEF SLEEP[CALLI 31]
COMMENT %
WRITTEN BY NORM GRANT. WMU. SEPTEMBER 2,1971.
PURPOSE: TO FORCE JOB TO SLEEP.
USAGE CALL SLEEP(ISEC)
WHERE ISEC: MINIMUM NUMBER OF SECONDS TO SLEEP.(MAY SLEEP
LONGER)(INTEGER.)
%
MIDNIT: EXP ^D24*^D3600*^D1000 ;MILLISECONDS PER DAY
ARGBLK: 2 ;CLOCK FUNCTION
BLOCK 1
HELLO (SLEEP, ) ;SLEEP ENTRY
MOVE 1,@0(16)
JUMPLE 1,NOWAIT
IMULI 1,^D1000
MSTIME 3,
ADD 3,1 ;GET FINAL TIME (MAY BE DAYS)
IDIV 3,MIDNIT ;SO GET NUMBER OF DAYS
DATE 2, ;CURRENT DATE
ADD 3,2 ;FINAL DATE
RESLP: PUSH P,1
IDIVI 1,^D1000 ;GET SECONDS
MOVEM 1,ARGBLK+1
POP P,1
MOVEI 0,ARGBLK ;ASSUME DAEMON
CAILE 1,^D60000 ;.LT. ONE MINUTE?
DAEMON 0, ;NO. TRY DAEMON
JRST USEHIB ;USE STRAIGHT HIBER
SETZ 1, ;INFINITE HIBER
USEHIB: CAILE 1,^D60000 ;MAX OF ONE MINUTE
MOVEI 1,^D60000 ;DO IT ONE MINUTE AT TIME
HIBER 1, ;HIBER.
JRST USESLP ;DAMN
CHECK: DATE 2, ;GET NEW DATE
MSTIME 0, ;GET NEW TIME
CAMLE 2,3 ;PAST DATE?
JRST NOWAIT ;YES
CAMN 2,3 ;SAME DATE?
CAMGE 0,4 ;YES. PAST TIME?
JRST NEWSLP ;NO. MORE WAITING
NOWAIT: GOODBY (1)
NEWSLP: MOVN 1,2
ADD 1,3 ;DATEF-DATE
IMUL 1,MIDNIT ;TIMES MILLISECONDS/DAY
ADD 1,4 ;PLUS TIMEF
SUB 1,0 ;MINUS TIME
JRST RESLP
USESLP: IDIVI 1,^D1000 ;MUST USE SLEEP
SLEEP 1,
JRST CHECK ;ARE WE THROUGH
PRGEND
TITLE TRMOPS
SEARCH FORPRM
COMMENT %
USAGE CALL REDTTY(IFUNCT,IVAL,IERR)
TO READ FUNCTION IFUNCT INTO IVAL
USAGE CALL SETTTY(IFUNCT,IVAL,IERR)
TO SET FUNCTION IFUNCT FROM IVAL
IERR IS AN ERROR CODE
0 OK
-1 NOT ON TTY
1 FUNCTION NOT IMPLEMENTED
2 PRIVILEGED FUNCTION
3 ARGUMENT OUT OF RANGE
4 ARGUMENT LIST LENGTH OR ADDRESS ILLEGAL(ERROR IN SUBROUTINE)
5 DATASET ACTIVITY ON NON DATASET
6 ??
7 SUBFUNCTION FAILED
8 TERMINAL NOT AVAILABLE
FOR LIST OF FUNCTIONS, SEE TRMOP. UUO IN MONITOR CALLS MANUAL.
ALL FUNCTION CODES ARE IN RANGE 0-777(BASE EIGHT)
%
FUNCT: BLOCK 1 ;FUNCTION
UDX: BLOCK 1 ;TTY UDX
VAL: BLOCK 1 ;ARGUMENT
HELLO (REDTTY)
MOVEI 0,1000 ;READ BIT
JRST TRMOPS
HELLO (SETTTY)
MOVEI 0,2000 ;WRITE BIT
MOVE 1,@1(16) ;GET VALUE
MOVEM 1,VAL ;STORE IT
TRMOPS: SKIPL 1,@0(16) ;PICK UP FUNCTION
CAILE 1,777 ;AND RANGE CHECK IT
JRST ERR0 ;ILL FUNCTION
IOR 1,0 ;PUT IN READ/WRITE BIT
MOVEM 1,FUNCT ;STORE IT
PJOB 1, ;GET OUT JOB NUMBER
TRMNO. 1, ;GET UDX
JRST ERRM1 ;OOPS?
MOVEM 1,UDX ;STORE IT
MOVE 1,[XWD 3,FUNCT] ;ARGUMENT
TRMOP. 1, ;DO FUNCTION
JRST WHATER ;OOPS
MOVE 0,FUNCT ;GET FUNCTION BACK
TRNE 0,1000 ;READ?
MOVEM 1,@1(16) ;YES. RETURN ANSWER
SETZ 1, ;SET NO ERROR
RETFIN: MOVEM 1,@2(16) ;RETURN ERROR CODE
GOODBY (3) ;RETURN
ERRM1: SKIPA 1,[-1] ;ERROR MINUS ONE
ERR0: MOVEI 1,1 ;ERROR ONE
JRST RETFIN ;RETURN IT
WHATER: CAMN 1,[XWD 3,FUNCT] ;UNIMPLEMENTED UUO?
SETZ 1, ;YES. PRETEND NO SUCH FUNCTION
AOJA 1,RETFIN ;INCREMENT AND RETURN
PRGEND
TITLE TRUTH
SUBTTL PROGRAM TO MAINTAIN AND TEST COMPRESSED TRUTH TABLES.
REMARK WRITTEN BY NORM GRANT. W.M.U. OCTOBER 11,1971.
SEARCH FORPRM
COMMENT %
USAGE CALL TRUTH(TABLE,IFUNCT,IENTRY,VALUE)
WHERE TABLE: IS TRUTH TABLE.
IFUNCT: IS FUNCTION TO BE PERFORMEED.
IF IFUNCT=0, TEST TABLE ENTRY.
IF IFUNCT#0, SET TABLE ENTRY TO VALUE.
IENTRY: NUMBER OF ENTRY TO BE TESTED OR SET.
VALUE: VALUE OF ENTRY, IF IFUNCT=0.
VALUE TO SET ENTRY TO IF IFUNCT#0.
(# MEANS NOT EQUAL.)
PURPOSE: TO COMPRESS A LARGE TRUTH TABLE INTO LITTLE SPACE.
FOR EXAMPLE, A 360 ENTRY TABLE WOULD OCCUPY 10 WORDS.
%
HELLO (TRUTH, ) ;TRUTH ENTRY
MOVE 1,@2(16)
SUBI 1,1 ;BITS RUN 0-35
IDIVI 1,^D36
MOVNS 2 ;GET NEGATIVE OF REMAINDER
ADDI 1,@0(16)
MOVE 0,0(1)
MOVE 3,@1(16)
MOVEI 5,1
ROT 5,0(2)
JUMPE 3,TEST
SKIPL @3(16)
TDZA 0,5
TDO 0,5
MOVEM 0,0(1)
GOODBY (4)
TEST: SETZ 4,
TDNE 0,5
SETO 4,
MOVEM 4,@3(16)
GOODBY (4)
PRGEND
TITLE TTYNAM
SEARCH FORPRM
COMMENT %
WRITTEN BY NORM GRANT. W.M.U.
USAGE CALL TTYNAM(NAME)
WHERE NAME IS PHYSICAL NAME OF USER'S TTY.
%
HELLO (TTYNAM, ) ;TTYNAM ENTRY
LDB 1,[POINT 4,0(16),12]
PUSHJ P,TYPE..## ;CHECK SINGLE/DOUBLE WORD ARG
MOVEI 2,@0(16) ;ADDR OF ARG WORD
MOVE 1,[ASCII " "]
MOVEM 1,(2) ;BLANK OUT WORD
CAILE 0,5 ;SINGLE WORD ARG?
MOVEM 1,1(2) ;NO. TWO WORD
HRLI 2,440700 ;SET UP BYTE POINTER
GETLIN 4,
LOOP: SETZ 3,
LSHC 3,6
ADDI 3,40
IDPB 3,2
JUMPN 4,LOOP
GOODBY (1)
PRGEND
TITLE TTYPTY
SUBTTL CHECK FOR TTY/PTY
SEARCH FORPRM
COMMENT %
USAGE CALL TTYPTY(ICODE)
WHERE ICODE IS CODE FOR TELETYPE OR PSUEDO-TELETYPE.
ICODE=0 TELETYPE.
ICODE=-1 PSEUDO-TELETYPE.
WRITTEN BY NORM GRANT. WMU. APRIL 1,1971.
THIS PROGRAM DETERMINES WHETHER PROGRAM IS RUNNING
FROM TTY OR PTY,AND RETURNS THE APPROPRIATE CODE.
%
HELLO (TTYPTY, ) ;TTYPTY ENTRY
SETZM @0(16)
SETO 0, ;MAKE LINE NEGATIVE.
GETLCH 0 ;GET LINE CHARACTERISTICS.
SKIPGE 0
SETOM @0(16) ;CONSOLE IS PTY. THEREFORE BATCH.
GOODBY (1)
PRGEND
TITLE MINVSQ
SUBTTL INVERSE MATRIX PROGRAM.
SEARCH FORPRM
COMMENT %
WRITTEN BY NORM GRANT. WMU. DECEMBER 23, 1970.
PROGRAM INVERTS A SQUARE MATRIX WITHIN ITSELF.
;
;
USAGE CALL MINVSQ(A,N,TOL,MC,MR,NDIM,IOUT,METHOD,DET,IEXP)
WHERE A: MATRIX TO BE INVERTED.
N: NUMBER OF ROWS(COLUMNS)IN MATRIX.
TOL: TOLERANCE FOR INVERSE(IF LARGEST AVAILABLE
PIVOT(IN ABS.)IS LESS THAN .000001*TOL,
INVERSE IS CONSIDERED NOT TO EXIST).
MC: BOOK-KEEPING VECTOR(AT LEAST N LONG)
MR: BOOK-KEEPING VECTOR(AT LEAST N LONG)
NDIM: DIMENSION OF MATRIX A IN MAINLINE(NDIM BY NDIM)
IOUT: OUTPUT DEVICE SPECIFICATION FOR ERROR MESSAGES.
METHOD: SWITCH FOR SELECTING PIVOT METHOD.
=0 LEAST ACCURATE(FASTEST)USES FIRST NON-ZERO.
=1 COMPROMISE.USES LARGEST REMAINING IN ROW.
=2 MOST ACCURATE(SLOWEST)USES LARGEST REMAINING.
DET: DETERMINENT OF MATRIX A(CHARACTERISTIC ONLY).
IEXP: POWER OF 10 OF DETERMINENT.
%
K=15
J=14
I=13
II=12
JJ=11
KK=10
LL=7
KI=6
KKK=5
HELLO (MINVSQ, ) ;MINVSQ ENTRY
MOVEM 15,TEMP.
MOVEM 16,TEMP.+1
MOVEI 0,TEMP.+1
PUSH 0,@1(16)
PUSH 0,@2(16)
PUSH 0,@5(16)
PUSH 0,@6(16)
PUSH 0,@7(16)
;
M0: MOVEI 2,@3(16) ;SET UP BASE ADDRESSES OF ARRAYS.
SOJ 2,
HRRM 2,MC1
HRRM 2,MC2
HRRM 2,MC3
;
MOVEI 2,@4(16)
SOJ 2,
HRRM 2,MR1
HRRM 2,MR2
HRRM 2,MR3
;
MOVEI 2,@0(16)
SOJ 2,
HRRM 2,A1
HRRM 2,A3
HRRM 2,A4
HRRM 2,A5
HRRM 2,A6
HRRM 2,A8
HRRM 2,A9
HRRM 2,A10
HRRM 2,A11
HRRM 2,A12
HRRM 2,A14
HRRM 2,A15
HRRM 2,A16
HRRM 2,A17
HRRM 2,A18
HRRM 2,A19
HRRM 2,A21
HRRM 2,A22
HRRM 2,A23
HRRM 2,A24
HRRM 2,A26
HRRM 2,A27
HRRM 2,A28
;
;
; INITIALIZE ZTOL,DET,AND BOOK-KEEPING ARRAYS.
;
MOVE 2,[1.E-6]
FMPR 2,TOL
MOVEM 2,ZTOL#
MOVSI 2,201400
MOVEM 2,DET
SETZM IEXP
MOVEI I,1
M3:MR1: MOVEM I,777777(I)
MC1: MOVEM I,777777(I)
CAMGE I,N
AOJA I,M3
MOVEI 2,1
MOVEM 2,KSGN#
;
; BEGIN MAIN INVERSION LOOP.
;
MOVN KK,NDIM
$7: MOVEI K,1
M4: ADD KK,NDIM
MOVE 2,N
MOVEM 2,NL#
;
; SELECT PIVOT METHOD AND THEN PIVOT ELEMENT.
;
MOVNI 2,1
ADD 2,METHOD
JUMPL 2,$4
JUMPG 2,$2
$3: MOVEM K,NL
$2: SETZM AMAX#
MOVE JJ,KK
SUB JJ,NDIM
MOVE J,K
M6: ADD JJ,NDIM
MOVE I,K
M8: MOVE 2,I
ADD 2,JJ
MOVEM 2,IJ#
A1: MOVM 0,777777(2)
CAMG 0,AMAX
JRST $5
MOVEM 0,AMAX
MOVEM I,NR#
MOVEM J,NC#
$5: CAMGE I,NL
AOJA I,M8
$6: CAMGE J,N
AOJA J,M6
JRST $10
$4: MOVE II,KK
SUB II,NDIM
MOVE I,K
M12: ADD II,NDIM
MOVE KI,K
ADD KI,II
A3: MOVM 0,777777(KI)
CAMLE 0,ZTOL
JRST $11
$62: CAMGE I,N
AOJA I,M12
$13: MOVE 0,IOUT
JUMPE 0,M16
HRRZS IOUT ;IF NEGATIVE, MAKE JUST RIGHT HALFWORD
MOVEI 16,%1M
PUSHJ P,OUT.##
MOVEI 16,%2M
PUSHJ P,IOLST.##
M16: SETZM DET
SETZM IEXP
JRST M17
$11:A4: MOVE 2,777777(KI)
MOVEM 2,AMAX
MOVEM K,NR
MOVEM I,NC
$10: MOVM 0,AMAX
CAMG 0,ZTOL
JRST $13
CAMN K,NR ;SEE IF IN SAME ROW.
JRST $9
MOVNS 0,KSGN ;IF NOT, CHANGE SIGN ON DETERMINENT.
MOVE 3,NR
MR2: MOVEM 3,777777(K)
MOVN JJ,NDIM
MOVEI J,1
M19: ADD JJ,NDIM
MOVE 2,K
ADD 2,JJ
MOVE 4,JJ
ADD 4,NR
A5: MOVE 0,777777(2) ;AND SWITCH ROWS.
A6: EXCH 0,777777(4)
A8: MOVEM 0,777777(2)
CAMGE J,N
AOJA J,M19
$9: CAMN K,NC ;SEE IF IN SAME COLUMN.
JRST $22
MOVNS 0,KSGN ;IF NOT, CHANGE SIGN ON DETERMINENT.
MOVE 3,NC
MC2: MOVEM 3,777777(K)
SUBI 3,1
IMUL 3,NDIM
MOVEM 3,NCNC#
MOVEI J,1
M21: MOVE 2,KK
ADD 2,J
MOVE 4,NCNC
ADD 4,J
A9: MOVE 0,777777(2) ;AND SWITCH COLUMNS.
A10: EXCH 0,777777(4)
A11: MOVEM 0,777777(2)
CAMGE J,N
AOJA J,M21
$22: MOVE KKK,KK
ADD KKK,K
A12: MOVE 0,777777(KKK)
MOVEM 0,D# ;STORE PIVOT ELEMENT.
FMPRB 0,DET ;MULTIPLY DETERMINENT BY PIVOT.
JUMPE 0,$13
$205: MOVM 0,DET
CAMGE 0,[10.]
JRST $200
MOVE 2,DET
FDVR 2,[10.]
MOVEM 2,DET
AOS IEXP
JRST $205
$200: MOVM 0,DET
CAML 0,[1.]
JRST $210
MOVSI 2,204500
FMPRM 2,DET
SOS IEXP
JRST $200
$210: MOVEI I,1
M23: MOVE 2,I
ADD 2,KK
$30:A14:MOVE 0,777777(2) ;DIVIDE COLUMN BY PIVOT.
FDVR 0,D
A15: MOVEM 0,777777(2)
CAMGE I,N
AOJA I,M23
MOVSI 2,201400
FDVR 2,D
A16: MOVEM 2,777777(KKK) ;PIVOT=1./PIVOT.
;
; BEGIN MAIN REDUCTION LOOP FOR REST OF MATRIX.
;
MOVN II,NDIM
MOVEI I,1
M24: ADD II,NDIM
MOVE KI,K
ADD KI,II
A17: MOVE 0,777777(KI)
JUMPE 0,$40
MOVEM 0,C#
CAMN I,K
JRST $40
;
; BEGIN INNERMOST REDUCTION LOOP.
;
$41: MOVEI J,1
M27: MOVE 2,J
ADD 2,II
MOVE 4,J
ADD 4,KK
MOVN 0,C
A18: FMPR 0,777777(4)
A19: FADRM 0,777777(2) ;A(J,I)=A(J,I)-C*A(J,K)
$50: CAMGE J,N
AOJA J,M27
;
; END OF INNERMOST LOOP.
;
MOVE 2,C
FDVR 2,D
A21: MOVNM 2,777777(KI) ;A(K,I)=-C/D
$40: CAMGE I,N
AOJA I,M24
;
; END OF MAIN REDUCTION LOOP.
;
$100: CAMGE K,N
AOJA K,M4
;
; END OF MAIN INVERSION LOOP.
;
MOVE 0,KSGN
FSC 0,233 ;FLOAT NUMBER
FMPRM 0,DET
;
; NOW SORT COLUMNS INTO CORRECT ORDER.
;
MOVE K,N
M28:MC3:MOVE 2,777777(K)
MOVEM 2,L#
CAMN K,L
JRST $155
$150: MOVE II,N
IMUL II,NDIM
MOVE I,N
M31: SUB II,NDIM
MOVE 3,II
ADD 3,L
MOVE 2,K
ADD 2,II
A22: MOVE 0,777777(3)
A23: EXCH 0,777777(2)
A24: MOVEM 0,777777(3)
SOJG I,M31
$155: SOJG K,M28
;
; NOW SORT ROWS INTO ORDER.
;
MOVE KK,N
IMUL KK,NDIM
MOVE K,N
M32: SUB KK,NDIM
MR3: MOVE 2,777777(K)
MOVEM 2,L
SUB 2,K
JUMPE 2,$175
$180: MOVNI LL,1
ADD LL,L
IMUL LL,NDIM
MOVEI I,1
M35: MOVE 2,I
ADD 2,LL
MOVE 4,I
ADD 4,KK
A26: MOVE 0,777777(2)
A27: EXCH 0,777777(4)
A28: MOVEM 0,777777(2)
CAMGE I,N
AOJA I,M35
$175: SOJG K,M32
;
; RETURN!
;
M17: MOVE 15,TEMP.
MOVE 16,TEMP.+1
HRROI 0,TEMP.+10
POP 0,@11(16)
POP 0,@10(16)
GOODBY (12)
%1M: 100,,IOUT
0
0
340,,[ASCII "('0',I4,' BY',I4,' INVERSE DOES NOT EXIST.'//)"]
12
0
%2M: 1100,,N
1100,,N
4000,,0
TEMP.: BLOCK 2
N: 0
TOL: 0
NDIM: 0
IOUT: 0
METHOD: 0
DET: 0
IEXP: 0
PRGEND
TITLE XPRODH
SUBTTL CROSS-PRODUCT MATRIX SUBROUTINE.
SEARCH FORPRM
COMMENT %
WRITTEN BY NORMAN GRANT. WMU. DECEMBER 16,1970.
GENERATES LOWER CORNER CROSS-PRODUCTS ONLY.
USAGE CALL XPRODH(X,SX,SXX,N,NDIM)
WHERE X: IS SET OF OBSERVATIONS.(1-DIMENSIONAL ARRAY)
SX: IS SUMS OF VARIABLES.(1-DIMENSIONAL ARRAY)
SXX: IS SUMS OF CROSS-PRODUCTS.(2-DIMENSIONAL)
N: IS NUMBER OF VARIABLES.
NDIM: IS DIMENSION OF SXX.(SXX(NDIM,NDIM) )
%
SXX=0
XIXJ=1
XI=2
J=3
I=4
HELLO (XPRODH, ) ;XPRODH ENTRY
MOVEI 0,N-1 ;INIT PUSH DOWN LIST TO GET ARGS
PUSH 0,@3(16) ;GET N
PUSH 0,@4(16) ;GET NDIM
MOVEI SXX,@2(16) ;GET ADR OF SXX
SOJ SXX, ;MINUS ONE
MOVEI 1,@0(16) ;GET BASE FOR X
SOJ 1,
HRRM 1,L1
HRRM 1,L2
MOVEI 1,@1(16) ;GET BASE FOR SX
SOJ 1,
HRRM 1,SX1 ;AND STORE
MOVEI I,1 ;SET INDEX OF OUTER LOOP TO 1
L1: MOVE XI,777777(I) ;SET VALUE OF X(I)
SX1: FADRM XI,777777(I) ;SX(I)=SX(I)+X(I).
MOVE J,I ;SET COUNTER ON INNER LOOP
HRRM SXX,SXX1 ;SET BASE ADDR INTO ARRAY
L2: MOVE XIXJ,777777(J) ;GET X(J)
FMPR XIXJ,XI ;X(I)*X(J)
SXX1: FADRM XIXJ,777777(J) ;SXX(J,I)=SXX(J,I)+X(I)*X(J)
CAMGE J,N ;END OF KNNER LOOP?
AOJA J,L2 ;NO. INCREMENT AND REPEAT
ADD SXX,NDIM ;MOVE TO NEXT COLUMN OF SXX
CAMGE I,N ;END OF OUTER LOOP?
AOJA I,L1 ;INCREMENT I AND JUMP TO BEGINNING OUTER LOOP
GOODBY (5) ;RETURN TO CALLING PROGRAM
N: 0
NDIM: 0
PRGEND
TITLE XPRODP
SUBTTL CROSS-PRODUCT MATRIX SUBROUTINE.
SEARCH FORPRM
COMMENT %
WRITTEN BY NORMAN GRANT. WMU. DECEMBER 16,1970.
GENERATES UPPER CORNER CROSS-PRODUCTS ONLY.(BY COLUMN)
(STORED IN CLOSE PACKED FORMAT)
USAGE CALL XPRODP(X,SX,SXX,N)
WHERE X: IS SET OF OBSERVATIONS.(1-DIMENSIONAL ARRAY)
SX: IS SUMS OF VARIABLES.(1-DIMENSIONAL ARRAY)
SXX: IS SUMS OF CROSS-PRODUCTS.(2-DIMENSIONAL)
(IN CLOSE PACKED UPPER TRIANGULAR FORM.)
N: IS NUMBER OF VARIABLES.
%
N=1
SXX=2
XI=3
XIXJ=4
J=5
I=6
HELLO (XPRODP, ) ;XPRODP ENTRY
MOVE N,@3(16) ;GET VALUE OF N
MOVEI 0,@0(16) ;GET BASE ADDR FOR X
SOJ 0,
HRRM 0,X1
HRRM 0,X2
MOVEI 0,@1(16) ;GET BASE ADDR FOR SX
SOJ 0,
HRRM 0,SX1
MOVEI SXX,@2(16)
MOVEI I,1 ;SET INDEX OF OUTER LOOP TO 1
L1:X1: MOVE XI,777777(I) ;GET X(I)
SX1: FADRM XI,777777(I) ;SX(I)=SX(I)+X(I)
MOVEI J,1 ;SET INDEX OF INNER LOOP TO 1
L2: AOJ SXX, ;INCREMENT ADDR INTO SXX
X2: MOVE XIXJ,777777(J) ;X(J)
FMPR XIXJ,XI ;X(I)*X(J)
SXX1: FADRM XIXJ,-1(SXX) ;SXX(J,I)=SXX(J,I)+X(I)*X(J)
CAMGE J,I ;END OF INNER LOOP?
AOJA J,L2 ;NO. CONTINUE
CAMGE I,N ;END OF OUTER LOOP
AOJA I,L1 ;NO. CONTINUE
GOODBY (4) ;RETURN TO CALLING PROGRAM
PRGEND
TITLE ZEROH
SUBTTL PROGRAM TO ZERO MATRIX.
SEARCH FORPRM
COMMENT %
WRITTEN BY NORMAN GRANT. WMU. NOVEMBER 17,1970.
USAGE CALL ZEROH(A,A2,N,NDIM)
WHERE NDIM: DIMENSION OF A2 IN CALLING PROGRAM.
A: A VECTOR OF NDIM ELEMENTS.
A2: AN NDIM BY NDIM ARRAY
N: NUMBER OF ROWS AND COMUMNS TO ZERO
%
A=5
A2=6
N=7
NDIM=10
HELLO (ZEROH, ) ;ZEROH ENTRY
MOVEI A,@0(16) ;GET ADDRESS OF ARRAY A.
MOVEI A2,@1(16) ;GET ADDRESS OF MATRIX A2.
MOVE N,@2(16) ;GET VALUE OF N.
MOVE NDIM,@3(16) ;GET VALUE OF DIMENSION(NDIM).
SETZM 0(A) ;ZERO FIRST ELEMENT OF A
CAIG N,1 ;MORE THAN ONE ELEMENT?
JRST Z1 ;NO.
HRLZ 0,A ;SET UP BLT
HRRI 0,1(A) ;A,,A+1
MOVE 1,A ;A+N-1
ADD 1,N ;...
BLT 0,-1(1)
Z1: MOVEI 1,-1(N)
HRRM 1,B1 ;UPPER LIMIT =N-1(A2+(I-1)*NDIM)
Z2: HRRZ 0,A2 ;SET UP BLT WORD
HRL 0,A ;A,,A2+(I-1)*NDIM
B1: BLT 0,-1(A2)
ADD A2,NDIM ;GET TO NEXT COLUMN
SOJG N,Z2 ;N COLUMNS
GOODBY (4) ;RETURN TO CALLING PROGRAM.
PRGEND
TITLE ZEROP
SUBTTL PROGRAM TO ZERO ARRAY.
SEARCH FORPRM
COMMENT %
WRITTEN BY NORMAN GRANT. WMU. JANUARY 6,1971.
USAGE CALL ZEROP(A,N)
WHERE A: IS VECTOR TO BE ZEROED
N: IS NUMBER OF ELEMENTS TO ZERO
%
A=1
N=2
HELLO (ZEROP, ) ;ZEROP ENTRY
MOVEI A,@0(16) ;GET ADDRESS OF ARRAY A.
MOVE N,@1(16) ;GET VALUE OF N.
SETZM 0(A)
CAIG N,1
GOODBY (2)
HRLZ 0,A
HRRI 0,1(A)
ADD A,N
BLT 0,-1(A)
POPJ P,
PRGEND
TITLE ACMSRT
SEARCH FORPRM
;AC DEFINITIONS
I=14
IJ=13
J=12
K=11
LL=10
M=7
T=6
TT=5
L=0
; SUBROUTINE ACMSRT(L,N)
; C SORT ARRAY L
; C ORDERING IS BY INTEGER SUBTRACTION
; C ARRAYS IU(K) LND IL(K) PERMIT SORTING UP TO 2**(K+1)-1 ELEMENTS
; DIMENSION L(1),IU(16),IL(16)
DIM==^D16
IU: BLOCK DIM
IL: BLOCK DIM
; INTEGER T,TT
;ENTRANCE CODE
HELLO (ACMSRT, ) ;ACMSRT ENTRY
MOVEI 0,@0(16)
HRRM 0,LP1
HRRM 0,LP2
HRRM 0,LP3
SOJ 0,
HRRM 0,L1
HRRM 0,L2
HRRM 0,L3
HRRM 0,L4
HRRM 0,L6
HRRM 0,L7
HRRM 0,L8
HRRM 0,L10
HRRM 0,L11
HRRM 0,L12
HRRM 0,L14
HRRM 0,L15
HRRM 0,L16
HRRM 0,L17
HRRM 0,L18
HRRM 0,L19
HRRM 0,L20
HRRM 0,L21
HRRM 0,L22
; M=1
MOVEI M,1
; I=1
MOVEI I,1
; J=N
MOVE J,@1(16)
; 5 IF(I.GE.J) GO TO 70
$5: CAML I,J
JRST $70
; 10 K=I
$10: MOVE K,I
; IJ=(J+I)/2
MOVE IJ,I
ADD IJ,J
ASH IJ,-1
; T=L(IJ)
L1: MOVE T,L-1(IJ)
; IF(L(I).LE.T) GO TO 20
L2: CAML T,L-1(I)
JRST $20
; L(IJ)=L(I)
; L(I)=T
; T=L(IJ)
L3: EXCH T,L-1(I)
L4: MOVEM T,L-1(IJ)
; 20 LL=J
$20: MOVE LL,J
; IF(L(J).GE.T) GO TO 40
L6: CAMG T,L-1(J)
JRST $40
; L(IJ)=L(J)
; L(J)=T
; T=L(IJ)
L7: EXCH T,L-1(J)
L8: MOVEM T,L-1(IJ)
; IF(L(I).LE.T) GO TO40
L10: CAML T,L-1(I)
JRST $40
; L(IJ)=L(I)
; L(I)=T
; T=L(IJ)
L11: EXCH T,L-1(I)
L12: MOVEM T,L-1(IJ)
; GO TO 40
JRST $40
; 30 L(LL)=L(K)
L14:
$30: MOVE 02,L-1(K)
L15: MOVEM 02,L-1(LL)
; L(K)=TT
L16: MOVEM TT,L-1(K)
; 40 LL=LL-1
$40: SOJ LL,
; IF(L(LL).GT.T) GO TO 40
L17: CAMGE T,L-1(LL)
JRST $40
; TT=L(LL)
L18: MOVE TT,L-1(LL)
; 50 K=K+1
$50: AOJ K,
; IF(L(K).LT.T) GO TO 50
L19: CAMLE T,L-1(K)
JRST $50
; IF(K.LE.LL) GO TO 30
CAMG K,LL
JRST $30
; IF((LL-I).LE.(J-K)) GO TO 60
MOVE 02,J
SUB 02,K
ADD 02,I
CAML 02,LL
JRST $60
; IL(M)=I
MOVEM I,IL-1(M)
; IU(M)=LL
MOVEM LL,IU-1(M)
; I=K
MOVE I,K
; M=M+1
; GO TO80
AOJA M,$80
; 60 IL(M)=K
$60: MOVEM K,IL-1(M)
; IU(M)=J
MOVEM J,IU-1(M)
; J=LL
MOVE J,LL
; M=M+1
; GO TO 80
AOJA M,$80
; 70 M=M-1
$70: SOJE M,M3
; IF(M.EQ.0) RETURN
; I=IL(M)
MOVE I,IL-1(M)
; J=IU(M)
MOVE J,IU-1(M)
; 80 IF((J-I).GE.(11)) GO TO 10
$80:
IFG <DIM-16>,<
MOVE 02,J
SUB 02,I
CAIL 02,^D11>
IFLE <DIM-16>,<
CAIL J,^D11(I)>
JRST $10
; IF(I.EQ.1) GO TO 5
CAIN I,1
JRST $5
; I=I-1
SOJ I,
; 90 I=I+1
$90: AOJ I,
; IF(I.EQ.J) GO TO 70
CAMN I,J
JRST $70
; T=L(I+1)
LP1: MOVE T,L(I)
; IF(L(I).LE.T) GO TO 90
L20: CAML T,L-1(I)
JRST $90
; K=I
MOVE K,I
; 100 L(K+1)=L(K)
L21:
$100: MOVE 02,L-1(K)
LP2: MOVEM 02,L(K)
; K=K-1
SOJ K,
; IF(T.LT.L(K)) GO TO 100
L22: CAMGE T,L-1(K)
JRST $100
; L(K+1)=T
LP3: MOVEM T,L(K)
; GO TO90
JRST $90
; END
M3: GOODBY (2)
PRGEND
TITLE SORT
SUBTTL MERGE-SORT PROGRAM.
;
REMARK PROGRAM ORIGINALLY WRITTEN IN FORTRAN BY DICK HOUCHARD. WMU.
REMARK TRANSLATED TO MACRO FOR INCREASED EFFICIENCY BY NORM GRANT. WMU.
REMARK DECEMBER 19,1970.
;
;
; USAGE CALL SORT(IA,N,JA,ISF,IFIELD,IW,IB,ITAG)
; WHERE IA: MATRIX TO BE SORTED.
; N: NUMBER OF ROWS FILLED IN MATRIX.
; JA: NUMBER OF COLUMS FILLED IN MATRIX.
; ISF: NUMBER OF SORT FIELDS.
; IFIELD: VECTOR TELLING WHICH COLUMN IN MOST MAJOR,
; NEXT MOST,ETC.
; IW: NUMBER OF ROWS DIMENSIONED IN MATRIX.
; IB: WORKING STORAGE(AT LEAST 3N/2).
; ITAG: WORKING STORAGE(AT LEAST N).
;
SEARCH FORPRM
;
;
I=15
J=14
M=13
K=12
MA=11
MC=10
MP=7
JK=6
IC=5
;
HELLO (SORT, ) ;SORT ENTRY
MOVEM 15,TEMP
MOVEM 16,TEMP+1
MOVEI 0,TEMP+1
PUSH 0,@1(16)
PUSH 0,@2(16)
PUSH 0,@3(16)
PUSH 0,@5(16)
;
M0: MOVEI 2,@0(16) ;IA
SOJ 2,
HRRM 2,IA1
HRRM 2,IA2
HRRM 2,IA3
HRRM 2,IA4
;
MOVEI 2,@6(16) ;IB
SOJ 2,
HRRM 2,IB1
HRRM 2,IB2
HRRM 2,IB3
HRRM 2,IB4
HRRM 2,IB5
HRRM 2,IB6
HRRM 2,IB7
HRRM 2,IB8
HRRM 2,IB9
HRRM 2,IB10
HRRM 2,IB11
HRRM 2,IB12
HRRM 2,IB13
HRRM 2,IB14
;
MOVEI 2,@4(16) ;IFIELD
SOJ 2,
HRRM 2,IF1
;
MOVEI 2,@7(16) ;ITAG
SOJ 2,
HRRM 2,IT1
HRRM 2,IT2
HRRM 2,IT5
HRRM 2,IT6
HRRM 2,IT7
;
M1: MOVE 0,N
IDIVI 0,2
ADD 0,1
MOVEM 0,KL#
MOVEI I,1
M3: MOVE 2,KL
ADD 2,I
IB1: MOVEM I,777777(2)
CAMGE I,N
AOJA I,M3
MOVEI 2,1
MOVEM 2,IM#
$15: MOVEI M,1
ADD M,KL
MOVEI K,1
$13: MOVE 2,IM
ADD 2,M
MOVEM 2,IEND#
MOVEM 2,J
ADD 2,IM
MOVEM 2,JEND#
$5: MOVEI I,1
M4: MOVNI 2,1
IF1: ADD 2,777777(I)
IMUL 2,IW
MOVE MA,2
IB2: ADD MA,777777(J)
MOVE MC,2
IB3: ADD MC,777777(M)
IA1: MOVE 2,777777(MA)
IA2: MOVE 3,777777(MC)
CAMGE 2,3
JRST $3
CAME 2,3
JRST $4
$2: CAMGE I,ISF
AOJA I,M4
$3:IB4: MOVE 3,777777(J)
IB5: MOVEM 3,777777(K)
AOJ K,
AOJ J,
CAMGE J,JEND
JRST $5
$6:IB6: MOVE 3,777777(M)
IB7: MOVEM 3,777777(K)
AOJ K,
AOJ M,
CAML M,IEND
JRST $7
JRST $6
$4:IB8: MOVE 3,777777(M)
IB9: MOVEM 3,777777(K)
AOJ K,
AOJ M,
CAMGE M,IEND
JRST $5
$8:IB10:MOVE 3,777777(J)
IB11: MOVEM 3,777777(K)
AOJ K,
AOJ J,
CAMGE J,JEND
JRST $8
$7: MOVN 2,KL
SUB 2,N
ADD 2,IM
ADD 2,JEND
JUMPG 2,$10
MOVE M,JEND
ADD 2,IM
JUMPLE 2,$13
MOVE 2,IM
ADD 2,M
MOVEM 2,IEND
MOVEM 2,J
MOVEI 2,1
ADD 2,KL
ADD 2,N
MOVEM 2,JEND
JRST $5
$10: MOVNI I,1
ADD I,K
M7: MOVE MP,KL
ADD MP,I
IB12: MOVE 3,777777(I)
IB13: MOVEM 3,777777(MP)
SOJG I,M7
MOVE 2,IM
ASH 2,1
MOVN 3,N
ADD 3,2
JUMPGE 3,$16
MOVEM 2,IM
ADD 3,IM
JUMPLE 3,$15
$20: MOVEI 2,1
ADD 2,KL
MOVEM 2,JEND
MOVEI K,1
JRST $7
;
; BEGIN FINAL PHASE OF SORT PUTTING IN ORDER BY TAGS.
;
$16: MOVEI I,1
ADD I,KL
MOVE MC,KL
ADD MC,N
M9:IB14:MOVE M,777777(I)
$21: MOVN 2,KL
ADD 2,I
IT1: MOVEM 2,777777(M)
CAMGE I,MC
AOJA I,M9
MOVEI I,1
M10:IT2:MOVE 2,777777(I)
JUMPE 2,$22
$27: CAMN 2,I
JRST $22
MOVE IC,2
MOVEI J,1
M13: MOVNI 2,1
ADD 2,J
IMUL 2,IW
MOVE JK,I
ADD JK,2
$24:IA3:MOVE 2,777777(JK)
MOVEM 2,IX-1(J)
CAMGE J,JA
AOJA J,M13
$25: MOVEI J,1
M15: MOVNI 2,1
ADD 2,J
IMUL 2,IW
MOVE JK,IC
ADD JK,2
MOVE 0,IX-1(J)
IA4: EXCH 0,777777(JK)
MOVEM 0,IX-1(J)
CAMGE J,JA
AOJA J,M15
IT5: MOVE 2,777777(IC)
IT6: SETZM 777777(IC)
MOVE IC,2
IT7: MOVE 2,777777(IC)
JUMPG 2,$25
$22: CAMGE I,N
AOJA I,M10
M16: MOVE 15,TEMP
MOVE 16,TEMP+1
GOODBY (10)
TEMP: BLOCK 2
N: 0
JA: 0
ISF: 0
IW: 0
IX: BLOCK ^D40
PRGEND
TITLE SSORT
SEARCH FORPRM
COMMENT * USAGE DESCRIPTION
CALL SSORT(NV,NC,MV,MC,DATA,IS,KKL,IV,SP)
OR CALL SSORT(NV,NC,MV,MC,DATA,IS,KKL,IV,SP,ITYP)
WHERE DATA IS ARRAY TO BE SORTED (ONE OR TWO DIMENSIONAL)
MC NUMBER OF ROWS DIMENSIONED IN MATRIX DATA (1ST SUBSCRIPT)
MV NUMBER OF COLUMNS DIMENSIONED IN MATRIX (SECOND
SUBSCRIPT OR 1 IF DATA IS SINGLE SUBSCRIPTED)
NC NUMBER OF ROWS FILLED
NV NUMBER OF COLUMNS FILLED
KKL NUMBER OF SORT FIELDS TO BE USED
IS VECTOR OF INDEXES OF SORT FIELDS
IV WORKING STORAGE VECTOR. AT LEAST NC IN LENGTH
SP WORKING STORAGE VECTOR. AT LEAST NV IN LENGTH
ITYP OPTIONAL VECTOR TELLING HOW TO SORT.
IF ITH ENTRY IS ZERO, SORT ITH FIELD AS SIGNED INTEGER
IF NONZERO, SORT AS UNSIGNED INTEGER OR ALPHANUMERIC
(LEFT JUSTIFIED)
*
COMMENT * ACCUMULATOR ASSIGNMENTS *
NEXTRA=15
I=14
J=13
K=12
L=11
II=10
IJ=7
M=6
LL=5
P1==4
T1=0
T2=1
; SUBROUTINE SSORT(NV,NC,MV,MC,DATA,IS,KKL,IV,SP)
HELLO (SSORT, ) ;SSORT ENTRY
MOVEM 15,TEMP.
MOVEM 16,TEMP.+1
MOVEI 00,TEMP.+1
PUSH 00,@0(16)
PUSH 00,@1(16)
PUSH 00,@2(16)
PUSH 00,@3(16)
PUSH 00,@6(16)
MOVEI 0,@4(16)
SOJ 0,
SUB 0,MC
HRRM 0,DATA1
HRRM 0,DATA2
HRRM 0,DATA3
HRRM 0,DATA4
HRRM 0,DATA5
HRRM 0,DATA6
HRRM 0,DATA7
HRRM 0,DATA8
HRRM 0,DATA9
HRRM 0,DATA10
HRRM 0,DATA11
HRRM 0,DATA12
HRRM 0,DATA13
HRRM 0,DATA14
HRRM 0,DATA15
HRRM 0,DATA16
HRRM 0,DATA17
MOVEI 0,@5(16)
SOJ 0,
HRRM 0,IS1
HRRM 0,IS2
HRRM 0,IS3
HRRM 0,IS4
HRRM 0,IS5
HRRM 0,IS6
HRRM 0,IS7
HRRM 0,IS8
HRRM 0,IS9
HRRM 0,IS10
HRRM 0,IS11
HRRM 0,IS12
HRRM 0,IS13
MOVEI 0,@7(16)
HRRM 0,IV1A
HRRM 0,IV2A
HRRM 0,IV3A
SOJ 0,
HRRM 0,IV1
HRRM 0,IV2
HRRM 0,IV3
HRRM 0,IV4
HRRM 0,IV5
HRRM 0,IV6
HRRM 0,IV7
HRRM 0,IV9
HRRM 0,IV10
HRRM 0,IV11
HRRM 0,IV12
HRRM 0,IV13
HRRM 0,IV14
HRRM 0,IV15
HRRM 0,IV17
HRRM 0,IV18
HRRM 0,IV19
HRRM 0,IV20
HRRM 0,IV21
HRRM 0,IV22
HRRM 0,IV23
HRRM 0,IV25
HRRM 0,IV26
HRRM 0,IV26.5
HRRM 0,IV27
HRRM 0,IV28
HRRM 0,IV30
HRRM 0,IV31
HRRM 0,IV32
HRRM 0,IV34
HRRM 0,IV35
HRRM 0,IV37
HRRM 0,IV38
HRRM 0,IV39
HRRM 0,IV40
HRRM 0,IV41
HRRM 0,IV42
HRRM 0,IV43
HRRM 0,IV44
HRRM 0,IV45
HRRM 0,IV46
HRRM 0,IV47
HRRM 0,IV48
MOVEI 0,@10(16)
SOJ 0,
HRRM 0,S$1
HRRM 0,S$2
MOVE 0,[JRST COMINT] ;ASSUME COMPARE SIGNED
MOVEM COMTYP#
IFN F40LIB,<
TLNN 16,-1 ;F40 CALL?
JRST CHKF10 ;NO. F10
HLRZ 0,^D9(16) ;OPTIONAL ARG PRESENT
TRZ 0,777
CAIE 0,(JUMP 0)
JRST NOTYPE ;NO. NO TYPE
JRST CHKTYP ;MUST CHECK TYPES
CHKF10:>
HLRE 0,-1(16) ;GET NUMBER OF ARGUMENTS
MOVN 0,0
CAIGE 0,^D10 ;OPTIONAL ARG PRESENT
JRST NOTYPE
CHKTYP: MOVE 0,[SKIPN 0(I)] ;SET UP SKIP WORD TO EXECUTE FOR TYPE
ADDI 0,@^D9(16)
SUBI 0,1 ;ACTUALLY DO SUB SINCE IF IN INSTRUCTION
;IT OVERFLOWS INTO INDEX FIELD
MOVEM 0,COMTYP#
NOTYPE:
; DIMENSION DATA(MC,MV),IV(1),IS(1),IU(16),IL(16),SP(1)
; DIMENSION GIP(25)
; DO 1 I=1,NC
MOVE I,NC
; 1 IV(I)=I
$1:
IV1: MOVEM I,777777(I)
SOJG I,$1
; M=1
MOVEI M,1
; II=1
MOVEI II,1
; J=NC
MOVE J,NC
; 11 IF(II.GE.J) GO TO 18
$11: CAML II,J
JRST $18
; 12 K=II
$12: MOVE K,II
; IJ=(J+II)/2
MOVE IJ,II
ADD IJ,J
SKIPGE IJ
ADDI IJ,1
ASH IJ,777777
; I=0
MOVEI I,0
; 31 I=I+1
$31: AOS I
; IF(I.GT.KKL) GO TO 33
CAMLE I,KKL
JRST $33
; T1=DATA(IV(IJ),IS(I))
IS1: MOVE 03,777777(I)
IMUL 03,MC
IV2: ADD 03,777777(IJ)
DATA1: MOVE T1,777777(3)
; T2=DATA(IV(II),IS(I))
IS2: MOVE 03,777777(I)
IMUL 03,MC
IV3: ADD 03,777777(II)
DATA2: MOVE T2,777777(3)
; IF(T2.EQ.T1) GO TO 31
; IF(T2.LT.T1) GO TO 13
; GO TO 32
JSP P1,COMPAR ;DO THE COMPARE
JRST $32 ;T1.LT.T2
JRST $31 ;T1.EQ.T2
JRST $13 ;T1.GT.T2
; 33 IF(IV(II).LE.IV(IJ)) GO TO 13
$33:
IV4: MOVE 02,777777(II)
IV5: CAMG 02,777777(IJ)
JRST $13
; 32 ISAV=IV(IJ)
$32:
IV6: MOVE 02,777777(IJ)
; IV(IJ)=IV(II)
IV7: EXCH 02,777777(II) ;IV(IJ) INTO IV(II) AND IV(II) INTO 02
; IV(II)=ISAV
IV9: MOVEM 02,777777(IJ) ;IV(II) INTO IV(IJ)
; 13 LL=J
$13: MOVE LL,J
; I=0
MOVEI I,0
; 34 I=I+1
$34: AOS I
; IF(I.GT.KKL) GO TO 36
CAMLE I,KKL
JRST $36
; T1=DATA(IV(IJ),IS(I))
IS3: MOVE 03,777777(I)
IMUL 03,MC
IV10: ADD 03,777777(IJ)
DATA3: MOVE T1,777777(3)
; T2=DATA(IV(J),IS(I))
IS4: MOVE 03,777777(I)
IMUL 03,MC
IV11: ADD 03,777777(J)
DATA4: MOVE T2,777777(3)
; IF(T2.EQ.T1) GO TO 34
; IF(T2.GT.T1) GO TO 5
; GO TO 35
JSP P1,COMPAR ;DO THE COMPARE
JRST $5 ;T1.LT.T2
JRST $34 ;T1.EQ.T2
JRST $35 ;T1.GT.T2
; 36 IF(IV(J).GE.IV(IJ)) GO TO 5
$36:
IV12: MOVE 02,777777(J)
IV13: CAML 02,777777(IJ)
JRST $5
; 35 ISAV=IV(IJ)
$35:
IV14: MOVE 02,777777(IJ)
; IV(IJ)=IV(J)
IV15: EXCH 02,777777(J) ;IV(IJ) INTO IV(J) AND IV(J) INTO 02
; IV(J)=ISAV
IV17: MOVEM 02,777777(IJ) ;IV(J) INTO IV(IJ)
; I=0
MOVEI I,0
; 37 I=I+1
$37: AOS I
; IF(I.GT.KKL) GO TO 39
CAMLE I,KKL
JRST $39
; T1=DATA(IV(IJ),IS(I))
IS5: MOVE 03,777777(I)
IMUL 03,MC
IV18: ADD 03,777777(IJ)
DATA5: MOVE T1,777777(3)
; T2=DATA(IV(II),IS(I))
IS6: MOVE 03,777777(I)
IMUL 03,MC
IV19: ADD 03,777777(II)
DATA6: MOVE T2,777777(3)
; IF(T2.EQ.T1) GOTO 37
; IF(T2.LT.T1) GO TO 5
; GO TO 38
JSP P1,COMPAR ;DO THE COMPARE
JRST $38 ;T1.LT.T2
JRST $37 ;T1.EQ.T2
JRST $5 ;T1.GT.T2
; 39 IF(IV(II).LE.IV(IJ)) GO TO 5
$39:
IV20: MOVE 02,777777(II)
IV21: CAMG 02,777777(IJ)
JRST $5
; 38 ISAV=IV(IJ)
$38:
IV22: MOVE 02,777777(IJ)
; IV(IJ)=IV(II)
IV23: EXCH 02,777777(II) ;IV(IJ) INTO IV(II) AND IV(II) INTO 02
; IV(II)=ISAV
IV25: MOVEM 02,777777(IJ) ;IV(II) INTO IV(IJ)
; GO TO 5
; JRST $5
; 5 DO 6 L=1,KKL
$5: MOVEI L,1
M5: BLOCK 0
; 6 GIP(L)=DATA(IV(IJ),IS(L))
$6:
IS7: MOVE 03,777777(L)
IMUL 03,MC
IV26: ADD 03,777777(IJ)
DATA7: MOVE 02,777777(3)
MOVEM 02,GIP-1(L)
CAMGE L,KKL
AOJA L,M5
; NEXTRA=IV(IJ)
IV26.5: MOVE NEXTRA,777777(IJ)
; GO TO 15
JRST $15
; 14 ISAV=IV(LL)
$14:
IV27: MOVE 02,777777(LL)
; IV(LL)=IV(K)
IV28: EXCH 02,777777(K) ;IV(LL) INTO IV(K) AND IV(K) INTO 02
; IV(K)=ISAV
IV30: MOVEM 02,777777(LL) ;IV(K) INTO IV(LL)
; 15 LL=LL-1
$15: SOS LL
; I=0
MOVEI I,0
; 40 I=I+1
$40: AOS I
; IF(I.GT.KKL) GO TO 41
CAMLE I,KKL
JRST $41
; T1=GIP(I)
MOVE T1,GIP-1(I)
; T2=DATA(IV(LL),IS(I))
IS8: MOVE 03,777777(I)
IMUL 03,MC
IV31: ADD 03,777777(LL)
DATA8: MOVE T2,777777(3)
; IF(T2.EQ.T1) GO TO 40
; IF(T2.GT.T1) GO TO 15
; GO TO 16
JSP P1,COMPAR ;DO THE COMPARE
JRST $15 ;T1.LT.T2
JRST $40 ;T1.EQ.T2
JRST $16 ;T1.GT.T2
; 41 IF(IV(LL).GT.NEXTRA) GO TO 15
$41:
IV32: MOVE 02,777777(LL)
CAMLE 02,NEXTRA
JRST $15
; 16 K=K+1
$16: AOS K
; I=0
MOVEI I,0
; 42 I=I+1
$42: AOS I
; IF(I.GT.KKL) GO TO 44
CAMLE I,KKL
JRST $44
; T1=GIP(I)
MOVE T1,GIP-1(I)
; T2=DATA(IV(K),IS(I))
IS9: MOVE 03,777777(I)
IMUL 03,MC
IV34: ADD 03,777777(K)
DATA9: MOVE T2,777777(3)
; IF(T2.EQ.T1) GO TO 42
; IF(T2.LT.T1) GO TO 16
; GO TO 43
JSP P1,COMPAR ;DO THE COMPARE
JRST $43 ;T1.LT.T2
JRST $42 ;T1.EQ.T2
JRST $16 ;T1.GT.T2
; 44 IF(IV(K).LT.NEXTRA) GO TO 16
$44:
IV35: MOVE 02,777777(K)
CAMGE 02,NEXTRA
JRST $16
; 43 IF(K.LE.LL) GO TO 14
$43: CAMG K,LL
JRST $14
; IF((LL-II).LE.(J-K)) GO TO 17
MOVE 02,J
SUB 02,K
MOVN 03,II
ADD 03,LL
CAML 02,3
JRST $17
; IL(M)=II
MOVEM II,IL-1(M)
; IU(M)=LL
MOVEM LL,IU-1(M)
; II=K
MOVE II,K
; M=M+1
AOS M
; GOTO 19
JRST $19
; 17 IL(M)=K
$17: MOVEM K,IL-1(M)
; IU(M)=J
MOVEM J,IU-1(M)
; J=LL
MOVE J,LL
; M=M+1
; GOTO 19
AOJA M,$19
; 18 M=M-1
; IF(M.EQ.0) GO TO 90
$18: SOJE M,$90
; II=IL(M)
MOVE II,IL-1(M)
; J=IU(M)
MOVE J,IU-1(M)
; 19 IF((J-II).GE.11) GO TO 12
$19: MOVN 02,II
ADD 02,J
CAIL 02,13
JRST $12
; IF(II.EQ.1) GO TO 11
CAIN II,1
JRST $11
; C
; C BUBBLE SORT PORTION (FASTER THAN PARTITION ONLY IF SUBSET
; C BEING LOOKED AT IS 11 OBSERVATIONS OR LESS)
; C
; II=II-1
SOS II
; 20 II=II+1
$20: AOS II
; IF(II.EQ.J) GO TO 18
CAMN J,II
JRST $18
; I=0
MOVEI I,0
; NEXTRA=IV(II+1)
IV1A: MOVE NEXTRA,0(II)
; 45 I=I+1
$45: AOS I
; IF(I.GT.KKL) GO TO 47
CAMLE I,KKL
JRST $47
; T1=DATA(NEXTRA,IS(I))
IS10: MOVE 03,777777(I)
IMUL 03,MC
ADD 03,NEXTRA
DATA10: MOVE T1,777777(3)
; T2=DATA(IV(II),IS(I))
IS11: MOVE 03,777777(I)
IMUL 03,MC
IV37: ADD 03,777777(II)
DATA11: MOVE T2,777777(3)
; IF(T2.EQ.T1) GO TO 45
; IF(T2.LT.T1) GO TO 20
; GO TO 46
JSP P1,COMPAR ;DO THE COMPARE
JRST $46 ;T1.LT.T2
JRST $45 ;T1.EQ.T2
JRST $20 ;T1.GT.T2
; 47 IF(IV(II).LE.NEXTRA) GO TO 20
$47:
IV38: CAML NEXTRA,777777(II)
JRST $20
; 46 K=II
$46: MOVE K,II
; 21 IV(K+1)=IV(K)
$21:
IV39: MOVE 03,777777(K)
IV2A: MOVEM 03,0(K)
; K=K-1
SOS K
; I=0
MOVEI I,0
; 48 I=I+1
$48: AOS I
; IF(I.GT.KKL) GO TO 50
CAMLE I,KKL
JRST $50
; T1=DATA(NEXTRA,IS(I))
IS12: MOVE 03,777777(I)
IMUL 03,MC
ADD 03,NEXTRA
DATA12: MOVE T1,777777(3)
; T2=DATA(IV(K),IS(I))
IS13: MOVE 03,777777(I)
IMUL 03,MC
IV40: ADD 03,777777(K)
DATA13: MOVE T2,777777(3)
; IF(T2.EQ.T1) GOTO 48
; IF(T1.LT.T2) GO TO 21
; GO TO 49
JSP P1,COMPARE ;DO THE COMPARE
JRST $21 ;T1.LT.T2
JRST $48 ;T1.EQ.T2
JRST $49 ;T1.GT.T2
; 50 IF(NEXTRA.LT.IV(K)) GO TO 21
$50:
IV41: CAMGE NEXTRA,777777(K)
JRST $21
; 49 IV(K+1)=NEXTRA
$49:
IV3A: MOVEM NEXTRA,0(K)
; GO TO 20
JRST $20
; C
; C END SORT NOW PLACE TAGS IN CORRECT ORDER
; C
; 90 DO 91 J=1,NC
$90: MOVEI J,1
M6:
; IF(IV(J).EQ.0) GOTO 91
IV42: MOVE 02,777777(J)
JUMPE 02,$91
; IF(IV(J).EQ.J) GO TO 91
IV43: CAMN J,777777(J)
JRST $91
; DO 92 K=1,NV
MOVEI K,1
M9: BLOCK 0
; 92 SP(K)=DATA(J,K)
$92: MOVE 03,K
IMUL 03,MC
ADD 03,J
DATA14: MOVE 02,777777(3)
S$1: MOVEM 02,777777(K)
CAMGE K,NV
AOJA K,M9
; M=J
MOVEM J,M
; L=J
MOVE L,J
; 93 DO 94 K=1,NV
$93: MOVEI K,1
M11: BLOCK 0
; 94 DATA(M,K)=DATA(IV(L),K)
$94:
MOVE 03,K
IMUL 03,MC
IV44: ADD 03,777777(L)
DATA15: MOVE 02,777777(3)
MOVE 03,K
IMUL 03,MC
ADD 03,M
DATA16: MOVEM 02,777777(3)
CAMGE K,NV
AOJA K,M11
; M=IV(L)
IV45: MOVE 02,777777(L)
MOVEM 02,M
; IV(L)=0
IV46: SETZM 777777(L)
; L=M
MOVE L,M
; IF(IV(L).NE.J) GO TO 93
IV47: CAME J,777777(L)
JRST $93
; DO 96 K=1,NV
MOVEI K,1
M13: BLOCK 0
; 96 DATA(L,K)=SP(K)
$96: MOVE 03,K
IMUL 03,MC
ADD 03,L
S$2: MOVE 02,777777(K)
DATA17: MOVEM 02,777777(3)
CAMGE K,NV
AOJA K,M13
; IV(L)=0
IV48: SETZM 777777(L)
; 91 CONTINUE
$91: CAMGE J,NC
AOJA J,M6
; RETURN
; END
M14: MOVE 15,TEMP.
MOVE 16,TEMP.+1
GOODBY (11)
; ROUTINE TO DO APPROPRIATE TYPE COMPARE ON T1,T2
; USES ACS 2,3 IF ALPHA COMPARE
; RETURNS +1 IF T1.LT.T2
; +2 IF T1.EQ.T2
; +3 IF T1.GT.T2
COMPAR: XCT COMTYP ;DO SKIPN OR JRST
JRST COMINT ;SIGNED INTEGER COMPARE
TLC T1,(1B0) ;FLIP SIGN BIT
TLC T2,(1B0) ;FLIP SIGN BIT
COMINT: CAMGE T1,T2 ;COMPARE
JRST (P1) ;T1.LT.T2
CAMG T1,T2 ;...
JRST 1(P1) ;T1.EQ.T2
JRST 2(P1) ;T1.GT.T2
COMMENT * DATA AREA *
TEMP.: BLOCK 2
NV: BLOCK 1
NC: BLOCK 1
MV: BLOCK 1
MC: BLOCK 1
KKL: BLOCK 1
IU: BLOCK ^D16
IL: BLOCK ^D16
GIP: BLOCK ^D25
PRGEND
TITLE BUSY
SEARCH FORPRM
COMMENT %
WRITTEN BY NORM GRANT. W.M.U.
USAGE CALL BUSY(IDEV)
WHERE IDEV: IS FORTRAN DEVICE NUMBER OF DESIRED DEVICE OR
ASCII DEVICE NAME
%
HELLO (BUSY, ) ;BUSY ENTRANCE
PUSHJ P,GTDV..##
JUMPE 0,RETUR1
LOOPB: MOVE 0,2
DEVCHR
TLNE 0,40 ;AVAILABLE?
RETUR1: GOODBY (1)
MOVEI 0,10
SLEEP 0,
JRST LOOPB
PRGEND
TITLE CHKCHN
;WRITTEN BY RUSSELL R. BARR III - 7-DEC-77 - WMU.
;(WITH MUCH GRATEFUL THEFT FROM FORWMU.MAC, WRITTEN BY
;NORMAN D. GRANT - WMU)
;
;PURPOSE:
; FIND AN UNUSED FORTRAN UNIT NUMBER OR INQUIRE WHETHER A UNIT
; NUMBER IS IN USE, AND RETURN THAT NUMBER AND THE NUMBER OF THE
; ASSOCIATED SOFTWARE CHANNEL.
;
;USE:
; CALL CHKCHN(NMUNIT,NUMFND,NMSOFT)
; OR
; CALL CHKCHN(NMUNIT,NUMFND)
; WHERE:
; NMUNIT - FORTRAN UNIT NUMBER DESIRED
; 1-63 - UNIT NUMBER DESIRED
; 0(ZERO) - TO REQUEST ANY FREE UNIT NUMBER
;
; NUMFND - UNIT NUMBER FOUND
; 1-63 - FORTRAN UNIT NUMBER AVAILABLE
; 0(ZERO) - IF NONE AVAILABLE
; (OR REQUESTED UNIT NOT AVAILABLE)
; -1 - ARGUMENT RANGE ERROR
;
; NMSOFT - SOFTWARE CHANNEL RETURNED(OPTIONAL ARGUMENT)
; -1 - IF NMUNIT = 0
; -1 - IF NMUNIT IS AVAILABLE
; 0-17 - IF NMUNIT IS NOT AVAILABLE
;
SEARCH FORPRM
HELLO (CHKCHN)
PUSH P,2 ;SAV ACS
PUSH P,3
SETZM @1(16) ;ZERO THE RETURNED UNIT #
SETZM CHNFRE ;ZERO FREE CHANNEL NUMBER
SETOM CHNSFT# ;# OF SOFTWARE CHANNEL
MOVE 2,@0(16) ;GET ARGUMENT
SETZM CHNFRE# ;# OF FREE CHANNEL
MOVEI 0,^D15 ;# OF FREE CHANNELLS POSSIBLE
MOVEM 0,NUMFRE#
MOVNI 0,5 ;-5 IS LOOP LIMIT
JUMPL 2,CKBADZ ;NO NEGATIVES ALLOWED
CAILE 2,FLU.MX ;LEGAL UNIT #?
JRST CKBADZ ;NO
CKLUP: MOVE 2,0 ;GET COPY OF INDEX
JUMPE 2,CHKINC ;UNIT 0 IS NOT ALLOWED
CKLOOP: MOVEI 2,6(2) ;GET FOROTS INTERNAL FLU NUMBER
IDIVI 2,6 ;SIX ENTRIES PER WORD IN OTS TABLE
IMULI 3,6 ;# OF BITS LEFT
ROT 3,-6 ;POSITION FOR BYTE POINTER
HRRZ 1,.JBOPS## ;BASE FOR OTS DATA
IOR 3,[POINT 6,FLU.TB(1),35] ;SET FULL SIZE
ADDI 3,(2) ;POINT TO WORD ENTRY(SOFTWARE CHANNEL)
LDB 2,3 ;LOAD CHANNEL ENTRY(SOFTWARE CHANNEL)
MOVE 3,2 ;GET SOFTWARE CHANNEL
ADDI 2,CHN.TB(1) ;SET OFSET FOR CHANNEL CONTROL WORD
SKIPN (2) ;UNIT # FREE IF ZERO(PHYNAM IF NOT)
JRST CKAVAL ;THIS UNIT # AVAILABLE
SOS NUMFRE ;DECRIMENT NUMBER OF REMAINING FREE CHANELS
SKIPN @(16) ;REQUESTS SPECIFIC UNIT #?
JRST CHKINC ;NO, TRY NEXT
CAME 0,@(16) ;YES,IS THIS THE ONE?
JRST CHKINC ;NO, TRY NEXT
MOVEM 3,CHNSFT ;RETAIN THE ASSOC. SOFTWARE CHANNEL
JRST CHKINC ;MORE AVAILABLE, KEEP LOOKING
CKAVAL: SKIPG NUMFRE ;ANY CHANNELS LEFT?
JRST CHKINC ;NOPE?
JUMPLE 0,CHKINC ;CAN'T RETURN NEG OR ZERO
SKIPN @(16) ;REQUESTS SPECIFIC UNIT #?
JRST CHKANY ;NO, RETURN ANY UNIT #
CAME 0,@(16) ;YES, IS THIS THE ONE?
JRST CHKINC ;THIS IS NOT THE ONE, TRY NEXT
CHKANY: SKIPN CHNFRE ;FOUND A FREE CHANNEL YET?
MOVEM 0,CHNFRE ;NO,SAVE LOWEST FREE FOUND
CHKINC: ADDI 0,1 ;INCREMENT INDEX
CAIG 0,FLU.MX ;END OF LIST?
JRST CKLUP ;NO, GO BACK FOR ANOTHER
MOVE 0,CHNFRE ;GET NUM OF FREE CHANNEL, IF ANY
JUMPE 0,CKBAK ;JUMP IF NO FREE CHANNEL FOUND
CKGOT: SKIPLE NUMFRE ;ANY LEFT?
JRST CKGOTA ;YES
SETZM CHNFRE ;CAN'T HAVE FREE UNIT #'S IF NO SOFT CHNLS
JRST CKBAK ;NOPE
CKGOTA: SKIPE @(16) ;SINGLE UNIT DESIRED?
MOVE 0,@(16) ;YES, GET UNIT # DESIRED
MOVEM 0,@1(16) ;RETURN INDEX TO ARG2
JRST CKBAK
CKBADZ: SETOM @1(16)
JRST CKBAK
CKBAK:
IFN F40LIB,<
TLNN 16,-1 ;F10 CALL?
JRST CHKF10 ;YES
HLRZ 2,2(16) ;GET LEFT HALF FROM ARG BLOCK(3RD WORD)
ANDI 2,777037 ;CLEAR AC BITS
CAIN 2,(JUMP) ;ARG?
JRST CKARG3 ;YES
JRST CKARG2 ;NO, 2 ARGS ONLY
CHKF10:
>
HLRE 2,-1(16) ;GET # OF ARGS
MOVMS 2 ;MAKE IT POSITIVE
CAIGE 2,3 ;3 ARGS?
JRST CKARG2 ;LESS, WE'RE DONE
CKARG3: SETOB 3,@2(16)
SKIPN @0(16) ;SPECIFIC UNIT # REQUESTED?
JRST CKNSFT ;NO, DON'T RETURN CHANNEL #
SKIPN CHNFRE ;FOUND FREE CHANNEL?
MOVE 3,CHNSFT ;NO, GET ASSCOC. SOFTWARE CHANNEL
CKNSFT: MOVEM 3,@2(16) ;NO, STORE SOFTWARE CHANNEL
CKARG2: POP P,3 ;RESTORE ACS
POP P,2
GOODBY (3)
PRGEND
TITLE CHKDEV
SEARCH FORPRM
COMMENT %
WRITTEN BY NORM GRANT. W.M.U.
ASSIGN
PURPOSE TO ASSIGN A DEVICE TO USER'S JOB.(TTY'S EXCLUDED)
USAGE CALL ASSIGN(IDEV,IERR)
OR CALL ASSIGN(IDEV,IERR,NSECS)
WHERE IDEV: IS FORTRAN DEVICE NUMBER.
IERR: ERROR CODE.
IERR=-1 IF NO SUCH DEVICE OR DEVICE NOT ASSIGNABLE.
IERR=0 IF DEVICE EXISTS.
NSECS: MAXIMUM NUMBER OF SECONDS TO WAIT. IF NOT GIVEN,
PROGRAM SLEEPS UNTIL DEVICE CAN BE ASSIGNED.
DEASSI
PURPOSE TO DEASSIGN A DEVICE FROM USER'S JOB.(TTY'S EXCLUDED)
USAGE CALL DEASSI(IDEV)
WHERE IDEV: IS FORTRAN DEVICE NUMBER. IF NOT ASSIGNED, CALL IS
A NO-OP.
REASSI
PURPOSE TO TRANSFER AN ASSIGNED DEVICE TO ANOTHER JOB.(TTY'S EXCLUDED)
USAGE CALL REASSI(IDEV,IJOB,IERR)
WHERE IDEV: IS FORTRAN DEVICE NUMBER OF DEVICE.
IJOB: IS JOB TO ASSIGN THE DEVICE TO.
IERR: ERROR CODE. IERR=-1 IF DEVICE DOES NOT EXIST,IJOB DOES
NOT EXIST, OR DEVICE CANNOT BE REASSIGNED.
%
OPDEF REASSI[CALLI 21]
HELLO (ASSIGN, ) ;ASSIGN ENTRY
SETOM @1(16)
PUSHJ P,GTDV..##
JUMPE 0,RETUR2
TLNE 0,DV.TTY
JRST RETUR2
IFN F40LIB,<
TLNN 16,-1 ;F10 CALL?
JRST CHKF10 ;YES
HLRZ 3,2(16) ;NO. F40
ANDI 3,777037 ;CLEAR AC BITS
CAIE 3,(JUMP) ;ARG?
JRST LOOPR ;NO
JRST ARG3 ;YES. GET IT
CHKF10:>
HLRE 3,-1(16) ;GET -VE NUMBER OF ARGS
MOVMS 3 ;GET ABS NUMBER
CAIGE 3,3 ;AT LEAST THREE?
JRST LOOPR ;NO.
ARG3: SKIPA 3,@2(16) ;PICK UP ARG
LOOPR: HRLOI 3,377777 ;SLEEP FOREVER IF NECESSARY
MOVE 4,0
ANDI 4,177777 ;GET LEGAL MODES
JFFO 4,.+1 ;FIRST BIT POSITION
SUBI 5,^D35 ;-35
MOVM 4,5 ;ABS IS HIGHEST LEGAL MODE
MOVE 5,2 ;SET UP OPEN BLOCK
SETZ 6, ;NO BUFFERS
LOOPR1: OPEN 0,4 ;TRY TO OPEN IT
JRST [MOVEI 1,1 ;ONE SEC
SLEEP 1, ;SLEEP IT
SOJL 3,RETUR2 ; QUIT IF -VE
JRST LOOPR1]
PJOB 1,
DRPOUT: REASSI 1,
RELEAS 0,0
JUMPE 2,RETUR2
JUMPE 1,RETUR2
SETZM @1(16)
RETUR2: GOODBY (2)
HELLO (REASSI, ) ;REASSIGN ENTRY
SETOM @2(16)
PUSHJ P,GTDV..
MOVE 1,@1(16)
AOJA 16,DRPOUT
HELLO (DEASSI, ) ;DEASSIGN ENTRY
PUSHJ P,GTDV..
SETZ 1,
REASSI 1,
GOODBY (1)
PRGEND
TITLE CHKNAM
SUBTTL SUBROUTINE TO CHECK FILE-NAMES.
SEARCH FORPRM
COMMENT %
WRITTEN BY NORM GRANT. WMU.
CKNAME IS ASCII TO SIXBIT CONVERTER AND NAME CHECKER
;
USAGE CALL CHKNAM(NAME,IERR)
OR CALL CHKNAM(NAME,IERR,IEXT)
WHERE NAME IS FILENAME.EXT(MUST BE A TWO WORD
QUANTITY.)
AND IERR IS ERROR CODE
IERR=0 VALID NAME.
IERR=-1 ILLEGAL NAME.
IEXT: (IF PRESENT) IS -1 IF EXT. NOT NULL, 0 IF NULL.
%
NAME: BLOCK 2
HELLO (CHKNAM, )
SETZM @1(16)
MOVEI 0,@0(16) ;GET ADDRESS OF NAME.
HRRM 0,%1M
PUSH P,16
MOVEI 16,%1M
PUSHJ P,CKNAME##
POP P,16
SKIPE IERR
SETOM @1(16)
IFN F40LIB,<
TLNN 16,-1 ;F10 OR F40?
JRST CHKF10 ;F10!
HLRZ 0,2(16)
TRZ 0,777
CAIE 0,(JUMP 0,0)
GOODBY (2)
JRST ARG3
CHKF10:>
HLRE 1,-1(16)
MOVMS 1 ;GET ABS NUMBER OF ARGS
CAIGE 1,3 ;AT LEAST THREE?
GOODBY (2) ;NO. LEAVE
ARG3: SETZM @2(16)
SKIPE NAME+1
SETOM @2(16)
GOODBY (3)
%1M: JUMP 0,0
JUMP 0,NAME
JUMP 0,IERR#
PRGEND
TITLE DEVCHR
SEARCH FORPRM
COMMENT %
WRITTEN BY NORM GRANT. W.M.U.
DEVCHR
PURPOSE TO DETERMINE THE CHARACTERISTICS OF A DEVICE
USAGE CALL DEVCHR(IDEV,ICHAR)
WHERE IDEV: IS FORTRAN UNIT NUMBER OF DEVICE.
AND ICHAR: IS RETURNED DEVICE CHARACTERISTICS, AS FOLLOWS:
BIT MEANING IF BIT IS SET
0 DECTAPE DIRECTORY IS IN CORE.
1 DEVICE IS A DISK.
2 DEVICE IS A CARD READER.
3 DEVICE IS A LINE PRINTER.
4 TTY ATTACHED TO JOB.
5 TTY IN USE AS A USER CONSOLE(EVEN IF DETACHED)
6 TTY IN USE AS I/O DEVICE.
7 DEVICE IS A DISPLAY.
8 DEVICE HAS A LONG DISPATCH TABLE(RECOGNIZES UUO'S
OTHER THAN INPUT,OUTPUT,CLOSE, AND RELEAS)
9 DEVICE IS A PAPER TAPE PUNCH.
10 DEVICE IS A PAPER TAPE READER.
11 DEVICE IS A DECTAPE.
12 DEVICE IS AVAILABLE TO THIS JOB OR ALREADY
ASSIGNED TO THIS JOB.
13 DEVICE IS A MAGNETIC TAPE.
14 DEVICE IS A TTY.
15 DEVICE HAS A DIRECTORY(DTA OR DSK)
16 DEVICE CAN DO INPUT.
17 DEVICE CAN DO OUTPUT.
18 DEVICE ASSIGNED BY CONSOLE COMMAND.
19 DEVICE ASSIGNED BY PROGRAM(INIT UUO)
REMAINING BITS IF BIT (35-N) CONTAINS A 1, THEN MODE N IS LEGAL
FOR THE DEVICE.
%
HELLO (DEVCHR, )
PUSHJ P,GTDV..##
MOVEM 0,@1(16)
GOODBY (2)
PRGEND
TITLE DEVICE
COMMENT %
USAGE CALL DEVICE(IDEV)
WHERE IDEV IS FORTRAN DEVICE NUMBER
WRITTEN BY NORM GRANT. WMU. DECEMBER 8,1970.
THIS PROGRAM DETERMINES WHETHER PROGRAM IS RUNNING
FROM TTY OR PTY,AND CALL EXIT IF FROM PTY.
IF FROM TTY, IT TAKES A FORTRAN DEVICE NUMBER
AND CHECKS WHETHER IT IS OTHER THAN TTY. IF IT IS, PROGRAM CALLS
EXIT. OTHERWISE, NORMAL RETURN IS MADE.
%
SEARCH FORPRM
HELLO (DEVICE, ) ;DEVICE ENTRY
SETOM 1 ;MAKE LINE NEGATIVE.
GETLCH 1 ;GET LINE CHARACTERISTICS.
JUMPL 1,DOEXIT ;CALL EXIT IF LESS THAN ZERO(CONSOLE IS PTY)
PUSHJ P,GTDV..##
TLNE 0,DV.TTY
GOODBY (1) ;IF USER IS ON TTY, AND DEVICE IS A TTY,RETURN.
DOEXIT: MOVEI 16,[EXP 0,0]+1 ;ARG FOR EXIT.
PUSHJ P,EXIT.##
PRGEND
TITLE DEVTYP
SEARCH FORPRM
COMMENT %
USAGE CALL DEVTYP(IDEV,ICHAR)
WHERE IDEV IS FORTRAN UNIT NUMBER OR ASCII DEVICE NAME
ICHAR RETURNED WORD FROM DEVTYP UUO
BIT MEANING
0 LOOKUP/ENTER MANDATORY.
1-11 RESERVED FOR FUTURE
12 DEVICE IS AVAILABLE TO THIS JOB.
13 SPOOLED ON DISK. (OTHER BITS REFLECT PROPERTIES OF
READ DEVICE, EXCEPT VARIABLE BUFFER SIZE)
14 INTERACTIVE DEVICE (OUTPUT AFTER EACH BREAK CHARACTER)
15 CAPABLE OF VARIABLE BUFFER SIZE (USER CAN SET HIS OWN
BUFFER LENGTHS)
16 CAPABLE OF INPUT
17 CAPABLE OF OUTPUT
18-26 JOB NUMBER THAT CURRENTLY HAS DEVICE ASSIGNED OR INITED
27-28 RESERVED FOR THE FUTURE
29 DEVICE IS A RESTRICTED DEVICE (I.E., CAN ONLY BE ASSIGNED
BY A PRIVILEGED JOB OR THE MOUNT COMMAND)
30-35 DEVICE TYPE CODE (OCTAL)
CODE MNEMONIC MEANING
0 DSK DISK OF SOME SORT
1 DTA DECTAPE
2 MTA MAGNETIC TAPE
3 TTY TTY OR EQUIVALENT
4 PTR PAPER-TAPE READER
5 PTP PAPER-TAPE PUNCH
6 DIS DISPLAY
7 LPT LINE PRINTER
10 CDR CARD READER
11 CDP CARD PUNCH
12 PTY PLOTTER
13 PLT PLOTTER
14 EXT EXTERNAL TASK
15 MPX SOFTWARE MPX
16 PAR PA611R ON DC44
17 YCR PC11(R) ON DC44
20 PAP PA611P ON DC44
21 LPC LPC-11 ON DC44
22 PCP PC-11(P) ON DC44
23-57 RESERVED FOR DIGITAL
60-77 RESERVED FOR CUSTOMER
%
OPDEF DEVTYP[CALLI 53]
HELLO (DEVTYP)
PUSHJ P,GTDV..## ;INTERPRET UNIT NUMBER
DEVTYP 2, ;DO UUO
SETZ 2, ;???
MOVEM 2,@1(16) ;RETURN ANSWER
GOODBY 2
PRGEND
TITLE DTRNAC
SEARCH FORPRM
COMMENT %
WRITTEN BY NORM GRANT. W.M.U.
PURPOSE RANDOM ACCESS ON DECTAPE.
USAGE CALL DTRNAC(N,A,IA,IDTA,NWORDS)
WHERE N: FIRST PHYSICAL BLOCK NUMBER DESIRED.
0<N<578.IF AN ATTEMPT IS MADE TO
ACCESS AN ILLEGAL BLOCK NUMBER, THE
PROGRAM WILL ABORT.
A: DATA MATRIX
IA: CODE FOR INPUT(1) OR OUTPUT(OTHER).
IDTA: FORTRAN DEVICE NUMBER OF DECTAPE.
NWORDS: NUMBER OF WORDS IN A RECORD.
;
NOTE: SINCE THIS PROGRAM INDEXES ON PHYSICAL BLOCK NUMBERS,
NO ATTENTION CAN BE PAYED TO ANY PREEXISTINT FILE STRUCTURE
ON THE TAPE! THEREFORE, THE PROGRAM SHOULD ONLY BE USED WHERE
IT'S FILE IS SOLE OCCUPANT OF THE TAPE!
NOTE: ONE PHYSICAL BLOCK CONTAINS 128 WORDS.
%
%1M: ARG .
HELLO (DTRNAC, ) ;DTRNAC ENTRY
MOVEI 0,@3(16) ;SET UP ARG FOR GTDV..
MOVEM 0,%1M
PUSH P,16 ;SAVE 16
MOVEI 16,%1M
PUSHJ P,GTDV..##
POP P,16 ;RESTORE 16
JUMPE 0,ILDEV
TLNN 0,DV.DTA
JRST ILDEV
MOVEM 2,NAME
INIT 17,116
NAME: 0
0 ;NO BUFFERS. DUMP MODE.
JRST TAPERR
MOVEI 0,@1(16)
SOJ 0,
LOOP: HRRM 0,IOLIST
MOVN 0,@4(16)
HRLM 0,IOLIST
MOVE 0,@0(16)
CAILE 0,0
CAIL 0,1102
JRST ILBLCK
MOVE 1,@2(16)
CAIN 1,1
JRST INPUT
OUTPUT: HRRM 0,USETO
USETO: USETO 17,0
OUTPUT 17,IOLIST
GOODBY (5)
INPUT: HRRM 0,USETI
USETI: USETI 17,0
INPUT 17,IOLIST
GOODBY (5)
ILBLCK: OUTSTR [ASCIZ/
No such block number!
/]
EXIT
TAPERR: OUTSTR [ASCIZ/
Cannot initialize tape!
/]
EXIT
ILDEV: OUTSTR [ASCIZ/
Not a DECtape!
/]
EXIT
IOLIST: IOWD ^D600,0
0
PRGEND
TITLE EXIST
SUBTTL SUBROUTINE TO CHECK FOR FILE EXISTANCE ON DSK OR OTHER DEVICE.
SEARCH FORPRM
COMMENT %
WRITTEN BY NORM GRANT. WMU.
CKNAME IS AN ASCII TO SIXBIT CONVERTER AND NAME CHECKER.
USAGE CALL EXIST(NAME,IERR)
OR CALL EXIST(NAME,IERR,IPROJ,IPROG)
OR CALL EXISTS(IDEV,NAME,IERR)
OR CALL EXISTS(IDEV,NAME,IERR,IPROJ,IPROG)
WHERE NAME IS FILENAME.EXT(SHOULD BE A TWO WORD
QUANTITY OR END WITH A SPACE.)
AND IDEV IS FORTRAN DEVICE NUMBER.( IF UNDEFINED,
DSK IS ASSUMED.
AND IERR IS ERROR CODE:
IERR=0 FILE FOUND AND NAME LEGAL.
IERR=-1 NAME ILLEGAL.
IERR=1 FILE NOT FOUND OR NOT READABLE.
IPROJ: OCTAL PROJECT NUMBER.
IPROG: OCTAL PROGRAMMER NUMBER.
%
%1M: JUMP 0,0
JUMP 0,NAME
JUMP 0,IERR#
NAME: BLOCK 4 ;BLOCK FOR LOOKUP
OPN: BLOCK 3
HELLO (EXISTS, ) ;EXISTS ENTRY
SETOM LONG# ;SAY CALLED EXISTS
MOVE 1,@0(16)
JUMPE 1,UNDEF
PUSHJ P,GTDV..##
JUMPE 0,UNDEF
AOJA 16,BOTH
UNDEF: AOJA 16,EXIST1
HELLO (EXIST, ) ;EXIST ENTRY
SETZM LONG ;SAY CALLED EXIST
EXIST1: MOVSI 2,'DSK'
MOVE 0,2 ;COPY DEVICE
DEVCHR 0, ;AND SIMULATE GTDV..
BOTH: SETZM @1(16)
TLNE 0,(1B12) ;IS IT AVAILABLE?
TLNN 0,(1B16) ;YES. IS IT AN INPUT DEVICE?
JRST NOFILE ;NO. ERROR
TLNN 0,(1B15) ;DIRECTORY DEVICE?
JRST RETUR1 ;NO. GOOD RETURN
MOVEM 2,OPN+1 ;DO OPEN IN ACS
ANDI 0,177777 ;GET LEGAL MODES
JFFO 0,.+1 ;FIND HIGHEST
SUBI 1,^D35 ;AS ABS(JFFO-35)
MOVMM 1,OPN ;FOR OPEN IN HIGHEST LEGAL MODE
SETZM OPN+2 ;NO BUFFERS
MOVEI 0,@0(16) ;GET ADDRESS OF NAME.
HRRM 0,%1M
PUSH P,16
MOVEI 16,%1M
PUSHJ P,CKNAME##
POP P,16
SKIPN IERR
JRST ENDEXT
SETOM @1(16)
JRST RETURN
ENDEXT: MOVEI 1,@0(16) ;GET ADR OF NAME
HRLI 1,(POINT 7,0,)
MOVEI 2,7 ;PERIOD CANNOT BE LATER THAN 7 AND BE LEGAL NAME
EXTCHK: ILDB 0,1 ;GET CHARACTER
CAIN 0,"." ;PERIOD?
JRST EXTOK ;YES
CAILE 0,40 ;SPACE OR NULL?
SOJG 2,EXTCHK ;LOOP
MOVSI 0,'DAT' ;NULL EXTENSION AND NO PERIOD
MOVEM 0,NAME+1 ;MEANS .DAT
EXTOK: SETZM NAME+3 ;ZERO PROJECT PROGRAMMER NUMBER(MONITER
;ASSUMES PRESENT JOBS PPN.)
IFN F40LIB,<
TLNN 16,-1 ;F40 CALL?
JRST CHKF10 ;NO. F10
HLRZ 0,2(16)
TRZ 0,777
CAIE 0,(JUMP 0,0)
JRST END1
HLRZ 0,3(16)
TRZ 0,777
CAIE 0,(JUMP 0,0)
JRST END1
JRST ARG4
CHKF10:>
HLRE 0,-1(16) ;GET -VE NUMBER OF ARGS
SKIPE LONG ;DID WE REALLY CALL EXISTS?
HLRE 0,-2(16) ;YES. 16 HAS BEEN MODIFIED
MOVMS 0 ;ABS NUMBER OF ARGS
CAIGE 0,4 ;AT LEAST FOUR?
JRST END1 ;NO.
ARG4: HRLZ 0,@2(16)
HRR 0,@3(16)
MOVEM 0,NAME+3 ;STORE PPN FOR LOOKUP
END1: OPEN 0,OPN ;INIT DSK.
JRST ERMSG
LOOKUP 0,NAME ;LOOKUP FILE.
JRST NOFILE
JRST RETURN
ERMSG: OUTSTR [ASCIZ/ ERROR ON OPEN!
/] ;PUT OUT ERROR MESSAGE
JRST RETURN
NOFILE: MOVEI 0,1
MOVEM 0,@1(16)
RETURN: RELEAS 0,0
RETUR1: GOODBY (2)
PRGEND
TITLE FNDSPC - FIND STR WITH MOST FREE SPACE USEABLE BY US
COMMENT %
USAGE CALL FNDSPC(STR,IFREE)
WHERE STR - IS THE ASCII NAME OF THE FILE STRUCTURE WITH THE
MOST FREE SPACE ACCESSABLE BY THIS USER.
IFREE - IS THE AMOUNT OF FREE SPACE ON STR AVAILABLE
TO THE USER ON A FCFS BASIS
%
SEARCH FORPRM,UUOSYM
N==3
STRBLK: BLOCK 2 ;JOBSTR BLOCK
DSKBLK: BLOCK 3 ;DSKCHR BLOCK
FILBLK: BLOCK .RBUSD+1 ;UFD LOOKUP BLOCK
SAVSTR: BLOCK 1 ;SAVED STR NAME
SAVSIZ: BLOCK 1 ;SAVED FREE SPACE
HELLO (FNDSPC)
SETOM STRBLK ;START AT BEGINNING
MOVSI 0,'DSK'
MOVEM 0,SAVSTR ;DEFAULT STR IS DSK
SETZM SAVSIZ ;IS EMPTY
NXTSTR: MOVE 0,[XWD 2,STRBLK]
JOBSTR 0, ;GET NEXT STR
JRST ENDSTR ;OOPS!
MOVE 0,STRBLK ;GET STR NAME
CAIE 0,0 ;FENCE?
CAMN 0,[-1] ;OR END?
JRST ENDSTR ;YES. END
MOVEM 0,DSKBLK ;STORE FOR DSKCHR
SKIPGE STRBLK+1 ;READ-ONLY?
JRST NXTSTR ;YES. GET NEXT
MOVE 0,[XWD 3,DSKBLK]
DSKCHR 0, ;DSKCHR
JRST NXTSTR ;OOPS?
TLNE 0,140300 ;WRITE-LOCKED, ETC?
JRST NXTSTR ;YES. IGNORE
MOVE 0,DSKBLK+1 ;GET BLOCKS FCFS LEFT
CAMN 0,[XWD 400000,0] ;DOES MONITOR KNOW?
PUSHJ P,GETQUO ;NO. GET IT FROM UFD
CAMLE 0,DSKBLK+2 ;QUOTA GREATER THAN FREE?
MOVE 0,DSKBLK+2 ;YES. USE FREE
CAMG 0,SAVSIZ ;BETTER THAN REMEMBERED ONE?
JRST NXTSTR ;NO. GET NEXT
MOVEM 0,SAVSIZ ;SAVE NEW GREATEST SIZE
MOVE 1,STRBLK ;AND NAME
MOVEM 1,SAVSTR ;...
JRST NXTSTR ;LOOP AT ALL STRS
ENDSTR: MOVE 0,SAVSIZ ;RETURN FREE SPACE
MOVEM 0,@1(16) ;TO USER
LDB 1,[POINT 4,0(L),12]
PUSHJ P,TYPE..## ;GET SINGLE/DOUBLE PRECISION
MOVE N,0 ;COPY IT
MOVEI 2,@0(L) ;GET ARGUMENT ADDRESS
MOVE 1,[ASCII " "];FIVE SPACES
MOVEM 1,(2) ;STORE IT
CAILE N,5 ;DOUBLE PRECISION ARG?
MOVEM 1,1(2) ;YES. STORE IN SECOND WORD ALSO
HRLI 2,440700 ;SET UP BYTE POINTER TO STORE NAME
MOVE 1,SAVSTR ;GET STR NAME BACK
RETNAM: SETZ 0,
LSHC 0,6
JUMPE 0,RETFIN ;IF ZERO, NAME ENDS
ADDI 0,40
IDPB 0,2
SOJG N,RETNAM
RETFIN: GOODBY (2) ;AND RETURN TO USER
GETQUO: MOVEI 0,16 ;OPEN IN DUMP MODE
MOVE 1,STRBLK ;STR
SETZ 2, ;NO BUFFERS
OPEN 0,0 ;OPEN IT
JRST GETQU2 ;CAN'T. ASSUME ZERO
SETZM FILBLK ;CLEAR LOOKUP BLOCK
MOVE 0,[XWD FILBLK,FILBLK+1]
BLT 0,FILBLK+.RBUSD ;ENOUGH FOR QUOTA INFO
MOVEI 0,25 ;SET RIBCNT
MOVEM 0,FILBLK
MOVSI 0,'UFD' ;EXTENSION
MOVEM 0,FILBLK+.RBEXT
GETPPN 0, ;OUR PPN
JFCL
MOVEM 0,FILBLK+.RBNAM ;IS NAME
MOVE 0,[XWD 0,16] ;GET MFD PPN
GETTAB 0, ;FROM MONITOR
MOVE 0,[XWD 1,1] ;DEFAULT
MOVEM 0,FILBLK+.RBPPN ;WHERE TO FIND UFD
LOOKUP 0,FILBLK ;FIND IT
JRST GETQU2 ;HUNH??
MOVE 0,FILBLK+.RBQTF ;GET FCFS
SUB 0,FILBLK+.RBUSD ;MINUS USED
GETQU1: RELEAS 0, ;FREE CHANNEL
POPJ P, ;RETURN
GETQU2: SETZ 0, ;ZERO QUOTA
JRST GETQU1 ;DONE
PRGEND
TITLE MOUNTS - SUBROUTINE TO MOUNT AND DISMOUNT DEVICES
SUBTTL COMMENTS
SEARCH FORPRM
COMMENT %
USAGE CALL MOUNT(DEV,LOGNAM,LOCK,VID,PHYNAM,IERR)
CALL MOUNT(DEV,LOGNAM,LOCK,VID,PHYNAM,IERR,REELID)
WHERE DEV - IS ASCII NAME OF DEVICE TO MOUNT. THE NAME MAY BE
PHYSICAL OR GENERIC, BUT MUST NOT BE A TTY, DSK, OR
FILE STRUCTURE. ARGUMENT MAY BE SINGLE OR DOUBLE PRECISION.
LOGNAM - IS LOGICAL NAME TO GIVE TO THE DEVICE.
LOCK - SIGNAL WHETHER TO WRITE ENABLE TAPE. VALID ONLY
FOR DECTAPE AND MAGTAPE.
0 = WRITE LOCKED
1 = WRITE ENABLED
VID - VISUAL IDENTIFICATION STRING. ASCII STRING OF
UP TO 25 LETTERS,DIGITS,PERIODS, AND HYPHENS
TERMINATED BY A BLANK OR UP TO 50 CHARACTERS
ENCLOSED IN QUOTES (' OR ")
PHYNAM - IS PHYSICAL NAME OF DEVICE OBTAINED,
IF ANY. THIS SHOULD BE A DOUBLE PRECISION ARGUMENT,
SINCE 510/602 USES SIX CHARACTER DEVICE NAMES.
IF THE ARGUMENT IS SINGLE PRECISION, ONLY
FIVE CHARACTERS WILL BE RETURNED.
IERR - IS AN ERROR CODE.
0 = NO ERRORS. DEVICE OBTAINED.
1 = DEV IS NOT RECOGNIZED OR DOES NOT EXIST
2 = LOGNAM IS ALREADY IN USE OR IS ZERO.
3 = NO MOUNT JOB RUNNING
-1 = MOUNT UNSUCCESSFUL
REELID - OPTIONAL ARGUMENT FOR MTA ONLY, GIVING REELID OF TAPE
USAGE CALL DISMOU(LOGNAM,IERR)
WHERE LOGNAM - IS LOGICAL OR PHYSICAL NAME OF DEVICE TO DISMOUNT
IERR - IS ERROR CODE
0 = NO ERROR. DISMOUNT SUCCESSFUL
1 = ILLEGAL OR NONEXISTENT DEVICE NAME
-1 = DISMOUNT UNSUCCESSFUL
%
SUBTTL DATA AREA
CH=14
NUM=13
WD=12
M=11
N1=10
N=7
.ERPRT==2
.ERIPP==1
.ERFBM==3
.ERNRM==14
DSKCHN: XWD 400000,0
Z
XWD OBUF,0
OBUF: BLOCK 3
SUBTTL CHECK ARGUMENTS FOR MOUNT
HELLO (MOUNT, ) ;MOUNT ENTRANCE
PUSHJ P,MNTON ;SEE IF THE RIGHT MOUNT IS RUNNING
JRST ERR3 ;IT ISN'T
MOVEI 3,0(L) ;GET SIXBIT ARGUMENT
PUSHJ P,ASC6..## ;FROM USERS ASCII ONE
JUMPE 2,ERR1 ;ERROR IF NO DEVICE
MOVEM 2,PHYNAM#
DEVCHR 2,200000 ;GET CHARACTERISTICS
JUMPE 2,ERR1 ;DOESN'T EXIST
TLNE 2,230010 ;IF DISK OR TTY, REJECT IT
JRST ERR1
SKIPN @1(L) ;GET LOGNAM
JRST ERR2 ;ZERO IS AN ERROR
MOVEI 3,1(L) ;ADDRESS OF ARGUMENT
PUSHJ P,ASC6..## ;CONVERT ARGUMENT TO SIXBIT
JUMPE 2,ERR2 ;ZERO IN SIXBIT ALWAYS ILLEGAL
MOVEM 2,LOGSIX# ;SAVE IT FOR LATER
DEVCHR 2,
JUMPN 2,ERR2 ;EXISTENCE OF LOGNAM IS AN ERROR
SUBTTL ENTER MOUNT REQUEST
MOVSI NUM,'M '
PUSHJ P,QSTART
MOVEI M,[ASCIZ\ MOUNT \]
PUSHJ P,MSG
MOVE M,PHYNAM ;GET DEVICE GENERIC NAME
PUSHJ P,SIXMSG ;OUT IT
PUSHJ P,SPACE
MOVE M,LOGSIX ;LOGICAL NAME DESIRED
PUSHJ P,SIXMSG ;OUT IT
MOVE 0,PHYNAM ;GET DEVICE NAME
DEVCHR 0,200000 ;SEE WHAT IT IS
TLNN 0,DV.MTA ;MAG TAPE?
JRST NOREEL ;NO. DON'T LOOK FOR REELID
IFN F40LIB,<
TLNN L,-1 ;IS IT F40 CALL?
JRST REEF10 ;NO. F10
HLRZ 0,6(L) ;GET ARG WORD
ANDI 0,777037 ;CLEAR AC BITS
CAIE 0,(JUMP) ;IS IT AN ARG?
JRST NOREEL ;NO
JRST REELID ;YES. GET IT
REEF10:>
HLRE 0,-1(L) ;GET ARG COUNT
MOVN 0,0 ;MAKE IT POSITIVE
CAIGE 0,^D7 ;AT LEAST NUMBER 7
JRST NOREEL ;NO. NO REELID
REELID: SKIPN 3,@6(L) ;ANY ARGUMENT?
JRST NOREEL ;NO
MOVEI 3,6(L) ;ADDRESS OF REELID ARGUMENT
PUSHJ P,ASC6..## ;CONVERT IT TO SIXBIT
JUMPE 2,NOREEL ;ANY NOW?
MOVEI M,[ASCIZ" /REELID: "]
PUSHJ P,MSG ;PUT SWITCH IN FILE
MOVE M,2 ;MOVE ID
PUSHJ P,SIXMSG ;PUT IT IN FILE
NOREEL: LDB CH,[POINT 7,@3(L),6]
SETZM VIDCNT# ;COUNT OF CHARACTERS IN VID
SETZM VIDQT# ;FLAG FOR QUOTES AROUND VID
SKIPE @3(L) ;ANY ID?
PUSHJ P,VIDCH ;IS EVEN THE FIRST CHARACTER LEGAL?
JRST VIDDON ;NO
MOVEI M,[ASCIZ\ /VID:\]
PUSHJ P,MSG
SETZM VIDCNT# ;COUNT OF CHARACTERS IN VID
SETZM VIDQT# ;FLAG FOR QUOTES AROUND VID
MOVEI 1,@3(L)
HRLI 1,440700
VIDOU2: ILDB CH,1
PUSHJ P,VIDCH
JRST VIDDON ;NOT LEGAL CHARACTER SO DONE
PUSHJ P,W.CMD
JRST VIDOU2
VIDDON: MOVE 0,PHYNAM
DEVCHR 0,200000
TLNN 0,DV.DTA!DV.MTA ;DECTAPE OR MAGTAPE?
JRST NOSWIT ;NEITHER. NO /WX
MOVEI M,[ASCIZ\ /WL\]
SKIPE @2(L)
MOVEI M,[ASCIZ\ /WE\]
PUSHJ P,MSG
NOSWIT: PUSHJ P,CRLF
CLOSE 0,
RELEAS 0,
MOVE 0,SVJBFF
MOVEM 0,.JBFF
PUSHJ P,WAITUP ;WAIT WHILE OMOUNT PROCESS IT
LDB 1,[POINT 4,4(L),12]
PUSHJ P,TYPE..## ;GET SINGLE/DOUBLE PRECISION
MOVE N,0 ;COPY IT
MOVEI 2,@4(L) ;GET ARGUMENT ADDRESS
MOVE 1,[ASCII " "];FIVE SPACES
MOVEM 1,(2) ;STORE IT
CAILE N,5 ;DOUBLE PRECISION ARG?
MOVEM 1,1(2) ;YES. STORE IN SECOND WORD ALSO
HRLI 2,440700 ;SET UP BYTE POINTER TO STORE NAME
MOVE 1,LOGSIX ;GET BACK LOGICAL NAME
DEVNAM 1, ;IS IT DEFINED? (GET PHYSICAL NAME IN 1)
JRST ERRM1 ;NO. BAD MOUNT
RETNAM: SETZ 0,
LSHC 0,6
JUMPE 0,RETFIN ;IF ZERO, NAME ENDS
ADDI 0,40
IDPB 0,2
SOJG N,RETNAM
RETFIN: SETZM @5(L)
GOODBY (6)
SUBTTL ERROR ROUTINES
ERRM1: MOVE 2,PHYNAM ;SEE IF PROBLEM IS "NOT AVAILABLE"
DEVCHR 2,200000
TLNN 2,40 ;IS IT?
JRST ERR4 ;YES. GIVE THAT ERROR
SETOM @5(L)
GOODBY (6)
ERR4: MOVEI 0,4
JRST ERR3A
ERR1: MOVEI 0,1
JRST ERR3A
ERR2: MOVEI 0,2
JRST ERR3A
ERR3: MOVEI 0,3
ERR3A: MOVEM 0,@5(L)
GOODBY (6)
ERRD1: MOVEI 0,1
ERRD1A: MOVEM 0,@1(L)
GOODBY (2)
ERRDM1: SETOM @1(L)
GOODBY (2)
ERRD2: SKIPE REASAN# ;SUCCESSFUL DEASSIGN
JRST ERRDM1 ;NO
SETZM @1(L) ;YES
GOODBY (2) ;RETURN
SUBTTL DISMOUNT COMMAND
HELLO (DISMOU, ) ;DISMOUNT ENTRY
SKIPN @0(L)
JRST ERRD1
MOVEI 3,0(16) ;ADDRESS OF ARGUMENT
PUSHJ P,ASC6..## ;CONVERT TO SIXBIT
JUMPE 2,ERRD1 ;BLANK IS AN ERROR
MOVEM 2,LOGSIX ;AND SAVE IT FOR LATER
DEVCHR 2, ;GET CHARACTERISTICS.
JUMPE 2,ERRD1 ;NON-EXISTENCE IS AN ERROR
MOVE 0,LOGSIX
DEVNAM 0,
MOVE 0,LOGSIX ;TAKE WHAT WAS GIVEN IF IT WON'T TELL
MOVEM 0,PHYNAM
TLNE 2,DV.DTA!DV.MTA ;DECTAPE OR MAGTAPE?
PUSHJ P,UNLOAD ;YES. DO UNLOAD
MOVE 1,LOGSIX ;DO DEASSIGN FIRST FOR OMOUNT VERSION 26
SETZ 0,
REASSI 0,
MOVEM 0,REASAN# ;STORE ANSWER FROM REASSIGN
PUSHJ P,MNTON ;MAKE SURE MOUNT IS RUNNING
JRST ERRD2 ;NOT THERE
MOVSI NUM,'D '
PUSHJ P,QSTART
MOVEI M,[ASCIZ/ DISMOUNT /]
PUSHJ P,MSG
MOVE M,PHYNAM
PUSHJ P,SIXMSG
MOVEI M,[ASCIZ\ /R\]
PUSHJ P,MSG
PUSHJ P,CRLF
CLOSE 0,
RELEAS 0,
MOVE 0,SVJBFF
MOVEM 0,.JBFF ;RESTORE .JBFF
PUSHJ P,WAKEUP ;WAKE UP OMOUNT
JRST ERRD2 ;SEE WHETHER DEASSIGN WORKED, AND RETURN
UNLOAD: MOVEI 0,16 ;OPEN TAPE IN DUMP MODE
MOVE 1,LOGSIX
SETZ 2,
OPEN 0,0
POPJ P, ;OH WELL
MTAPE 0,11 ;UNLOAD TAPE
RELEAS 0, ;AND GET RID OF IT
POPJ P, ;RETURN
SUBTTL CONSTRUCT FIRST PART OF QUEUE ENTRY
QSTART: MOVE 0,[XWD 4,16]
GETTAB ;GET PPN FOR QUEUE AREA
MOVE 0,[XWD 3,3] ;DEFAULT IS 3,3
MOVEM 0,CMDPPN#
MOVE 0,[XWD 15,16]
GETTAB ;GET STRUCTURE FOR QUEUE AREA
MOVSI 0,'DSK'
MOVEM 0,DSKCHN+1
PJOB
MOVEM 0,THSJOB#
GETLIN
MOVEM 0,TTYLIN#
GETPPN
JFCL
MOVEM 0,USRPPN#
TSO 0,0 ;OR HALFS SWAPPED
HRRZM 0,IORPPN#
OPEN 0,DSKCHN
HALT .
SETZM CMDNAM#
MOVEI 0,^D10
MOVEM 0,ENTERS#
FILCL1: HLLZ WD,NUM
TIMER CH, ;FORM A NAME
ANDI CH,7777 ;TWELVE BITS FROM TIMER
TLO WD,(CH) ;IN LEFT HALF OF WORD
IOR WD,IORPPN ;RH OF NAME IS IOR'D PPN
CAMN WD,CMDNAM
JRST FILCL1 ;DON'T RETRY SAME NAME
MOVEM WD,CMDNAM ;STORE NAME
MOVE 0,CMDNAM
MOVSI 1,'CMD'
SETZ 2,
MOVE 3,CMDPPN
LOOKUP 0,0 ;IS THIS NAME FREE?
TRNE 1,-1 ;MAYBE
JRST FILCL1 ;NO
MOVSI 1,'CMD'
SETZ 2,
MOVE 3,CMDPPN
ENTER 0,0
JRST ENTFAI ;CHECK ON ENTER FAILURE
MOVE 0,.JBFF##
MOVEM 0,SVJBFF#
OUTBUF 0,1
MOVE M,NUM
PUSHJ P,SIXMSG
MOVEI M,[ASCIZ/ JOB/]
PUSHJ P,MSG
MOVE N,THSJOB ;JOB NUMBER
PUSHJ P,DECPRT
PUSHJ P,SPACE
SKIPN M,TTYLIN
MOVE M,[SIXBIT/TTYXXX/]
PUSHJ P,SIXMSG
PUSHJ P,SPACE
HLRZ N,USRPPN
PUSHJ P,OCTPRT
PUSHJ P,COMMA
HRRZ N,USRPPN
PUSHJ P,OCTPRT
PUSHJ P,SPACE
MOVSI M,'1 '
PUSHJ P,SIXMSG
POPJ P,
ENTFAI: HRRZS 1
SOSG ENTERS
JRST ENTFI1
CAIN 1,.ERPRT ;PROTECTION FAILURE?
JRST FILCL1 ;YES, TRY ANOTHER NAME.
CAIN 1,.ERFBM ;FILE BEING MODIFIED?
JRST FILCL1 ;YES, TRY ANOTHER NAME
ENTFI1: MOVEI M,[ASCIZ/?SYSTEM ERROR ENTERING MOUNT REQUEST
/]
CAIN 1,.ERNRM ;OUT OF ROOM?
MOVEI M,[ASCIZ/?NO ROOM TO ENTER MOUNT REQUEST
/]
CAIN 1,.ERIPP ;NO SUCH UFD?
MOVEI M,[ASCIZ/?NO UFD FOR MOUNT REQUEST
/]
OUTSTR 0(M)
HALT .
SUBTTL IO SUBROUTINES
SPACE: MOVEI CH," "
PJRST W.CMD
COMMA: MOVEI CH,","
; PJRST W.CMD
W.CMD: SOSLE OBUF+2
JRST W.CDOK
OUTPUT 0,0
STATZ 0,740000 ;ANY ERRORS?
HALT .
W.CDOK: IDPB CH,OBUF+1
POPJ P,
CRLF: MOVEI M,[ASCIZ/
/]
MSG: HRLI M,440700
MSGL: ILDB CH,M
JUMPE CH,CPOPJ
PUSHJ P,W.CMD
JRST MSGL
OCTPRT: IDIVI N,10
HRLM N1,0(P)
SKIPE N
PUSHJ P,OCTPRT
HLRZ CH,0(P)
ADDI CH,"0"
PJRST W.CMD
DECPRT: IDIVI N,^D10
HRLM N1,0(P)
SKIPE N
PUSHJ P,DECPRT
HLRZ CH,0(P)
ADDI CH,"0"
PJRST W.CMD
SIXMSG: PUSH P,M
MOVE M,[POINT 6,0(P)]
SIXMSL: ILDB CH,M
JUMPE CH,MPOPJ ;STOP ON FIRST NULL
ADDI CH,40
PUSHJ P,W.CMD
TLNE M,770000 ;OR ON SIX OUT
JRST SIXMSL
MPOPJ: POP P,M
POPJ P,
SUBTTL MISC.
VIDCH: SKIPE VIDQT ;IN QUOTES?
JRST QUOTVD ;YES.
SKIPE VIDCNT ;FIRST CHARACTER?
JRST VIDCHO ;NO. OLD KIND
CAIE CH,"'" ;IS IT QUOTED?
CAIN CH,42 ;(")
JRST QTVID ;YES. REMEMBER
VIDCHO: AOS 2,VIDCNT ;COUNT CHARACTERS
CAILE 2,^D25 ;ALREADY DONE 25?
POPJ P, ;YES
CAIE CH,"."
CAIN CH,"-"
JRST CPOPJ1
CAIL CH,"0"
CAILE CH,"Z"
JRST CPOPJ
CAILE CH,"9"
CAIL CH,"A"
JRST CPOPJ1
JRST CPOPJ
QTVID: MOVEM CH,VIDQT ;REMEMBER THE QUOTES
AOS VIDCNT ;REMEMBER THE CHARACTER
JRST CPOPJ1 ;RETURN
QUOTVD: CAMN CH,VIDQT ;CLOSING QUOTE?
PJRST W.CMD
AOS 2,VIDCNT ;OR LIMIT REACHED?
CAILE 2,^D50 ;...
POPJ P, ;YES
CAIL CH,40 ;LESS THAN A SPACE?
CAIL CH,175 ;AND LESS THAN OLD ALTMODES?
POPJ P, ;RETURN. DONE
JRST CPOPJ1 ;OK
WAITUP: PUSHJ P,WAKEUP
WAIT1: MOVEI 0,5
MOVE 1,[XWD ^D60000,400024]
HIBER 1,
SLEEP
OPEN 0,DSKCHN
JRST WAIT1
MOVE 0,CMDNAM
MOVSI 1,'CMD'
SETZ 2,
MOVE 3,CMDPPN
LOOKUP 0,0 ;SEE IF IT IS STILL THERE
TRNE 1,-1 ;MAYBE
JRST WAIT1 ;YES
RELEAS 0, ;GET RID OF CHANNEL
POPJ P,
WAKEUP: MOVEI 1,1
WAKE1: HRLZ 0,1
HRRI 0,2 ;LOOK AT PPN
GETTAB
SETZ 0,
CAME 0,[XWD 1,2] ;IS IT 1,2?
JRST WAKEND
HRLZ 0,1
HRRI 0,3 ;GET NAME
GETTAB
SETZ 0,
CAME 0,[SIXBIT/OPROMO/]
CAMN 0,[SIXBIT/OPRMNT/]
JRST .+2
JRST WAKEND
MOVE 0,1
WAKE
POPJ P, ;GIVE UP ON FAILURE
WAKEND: CAMGE 1,JOBS ;DONE YET?
AOJA 1,WAKE1 ;NO
POPJ P,
MNTON: MOVE 0,[XWD 15,11] ;GET NUMBER OF JOBS
GETTAB
MOVEI 0,^D64+1 ;DEFAULT IF WON'T TELL
HRRZS 0
SUBI 0,1 ;DON'T COUNT NULL JOB
MOVEM 0,JOBS#
MOVEI 1,1 ;START WITH JOB 1
RUNLOP: HRLZ 2,1
HRRI 2,2 ;SET UP TO LOOK AT PPN
GETTAB 2,
SETZ 2,
CAME 2,[XWD 1,2] ;IS IT 1,2?
JRST RUNEND ;NO
HRLZ 2,1
HRRI 2,3 ;LOOK AT PROG NAME
GETTAB 2,
SETZ 2,
CAME 2,[SIXBIT/OPROMO/]
CAMN 2,[SIXBIT/OPRMNT/]
JRST CPOPJ1
RUNEND: CAMGE 1,0
AOJA 1,RUNLOP ;NOT DONE, SO LOOP
SKIPA
CPOPJ1: AOS (P)
CPOPJ: POPJ P,
PRGEND
TITLE RENAMS
SUBTTL SUBROUTINE TO RENAME,PROTECT, AND DELETE FILE.
REMARK WRITTEN BY NORM GRANT. WMU.
REMARK CKNAME IS AN ASCII TO SIXBIT CONVERTER AND NAME CHECKER.
SEARCH FORPRM
;
COMMENT %
USAGE CALL DELETE(NAME)
CALL PROTEK(PROT,NAME)
CALL RENAME(NAME1,NAME2)
CALL RENAMS(IDEV,IFUNCT,NAME1,NAME2,PROT)
WHERE NAME1 ASCII FILE NAME, TWO WORD,CURRENT FILE NAME.
NAME2 ASCII FILE NAME, TWO WORD, DESIRED FILE NAME.
IDEV FORTRAN DEVICE NUMBER.
IFUNCT FUNCTION TO PERFORM.
1:DELETE
2:PROTECT
3:RENAME
4:RENAME AND PROTECT
5:DELETE EXISTING FILE OF NAME2,AND RENAME
6:DELETE EXISTING FILE OF NAME2, RENAME, AND PROTECT
OTHER: NO OPERATION.
PROT OCTAL PROTECTION CODE.
%
-3,,0
CK1: JUMP 0,0
JUMP 0,NAME
JUMP 0,IERR#
-5,,0
%1M: JUMP 0,[0]
JUMP 0,[1]
D1: JUMP 0,0
JUMP 0,[0]
JUMP 0,[0]
-5,,0
%2M: JUMP 0,[0]
JUMP 0,[2]
$P2: JUMP 0,0
JUMP 0,[0]
$P1: JUMP 0,0
-5,,0
%3M: JUMP 0,[0]
JUMP 0,[3]
R1: JUMP 0,0
R2: JUMP 0,0
JUMP 0,[0]
HELLO (DELETE, ) ;DELETE ENTRY
MOVEI 0,@0(16)
HRRM 0,D1
PUSH P,16
MOVEI 16,%1M
PUSHJ P,RENAMS
POP P,16
GOODBY (1)
HELLO (PROTEK, ) ;PROTECT ENTRY
MOVEI 0,@0(16)
HRRM 0,$P1
MOVEI 0,@1(16)
HRRM 0,$P2
PUSH P,16
MOVEI 16,%2M
JRST PREREN
HELLO (RENAME, ) ;RENAME ENTRY
MOVEI 0,@0(16)
HRRM 0,R1
MOVEI 0,@1(16)
HRRM 0,R2
PUSH P,16
MOVEI 16,%3M
PREREN: PUSHJ P,RENAMS
POP P,16
GOODBY (2)
HELLO (RENAMS, ) ;RENAMS ENTRY
MOVE 1,@0(16)
JUMPE 1,UNDEF
PUSHJ P,GTDV..##
JUMPN 0,BOTH
UNDEF: MOVSI 2,'DSK'
MOVE 0,2 ;COPY DEVICE NAME
DEVCHR 0, ;SIMULATE GTDV..
BOTH: MOVEM 2,DEVICE
ANDI 0,177777
JFFO 0,.+1
SUBI 1,^D35
MOVMS 1
HRRM 1,INITS ;STORE MODE FOR INIT
MOVEM P,SAVP#
SETZM NAME+3
MOVE 14,@1(16)
JUMPLE 14,RETURN
CAILE 14,6
JRST RETURN
PUSHJ P,@LIST-1(14)
JRST RETURN
LIST: EXP DEL,PRO,PRO,PRO,DELREN,DELREN
DEL1: MOVEI 1,@3(16)
CAIA
DEL: MOVEI 1,@2(16)
HRRM 1,CK1
PUSHJ P,CHNAME
PUSHJ P,INITS
LOOKUP 0,NAME
POPJ P,
SETZM NAME
SETZM NAME+1
SETZM NAME+3
RENAME 0,NAME
JFCL
POPJ P,
PRO: MOVEI 1,@2(16)
HRRM 1,CK1
PUSHJ P,CHNAME
PUSHJ P,INITS
AGAIN: LOOKUP 0,NAME
JRST NOFIL
SETZM NAME+3
CAIG 14,2
JRST PRO1
MOVE 1,3(16)
HRRM 1,CK1
PUSH P,NAME+1
PUSHJ P,CHNAME
POP P,0
HRRM 0,NAME+1 ;DON'T MESS UP HIGH ORDER DATE
PRO1: MOVE 0,14
IDIVI 0,2
JUMPN 1,PRO2
MOVE 0,@4(16)
DPB 0,[POINT 9,NAME+2,8]
PRO2: RENAME 0,NAME
JRST RENERR
POPJ P,
DELREN: PUSHJ P,DEL1
JRST PRO
RETURN: MOVE P,SAVP
RELEAS 0,0
GOODBY (5)
NAME: BLOCK 4
BADNAM: OUTSTR [ASCIZ/ILLEGAL FILENAME./
]
JRST RETURN
NODEV: OUTSTR [ASCIZ/ DEVICE NOT AVAILABLE.
/]
JRST RETURN
RENERR: OUTSTR [ASCIZ/RENAME ERROR!
/]
JRST RETURN
NOFIL: HLLZ 0,NAME+1
JUMPN 0,TYPEIT
MOVSI 0,'DAT'
MOVEM 0,NAME+1
JRST AGAIN
TYPEIT: OUTSTR [ASCIZ/NO SUCH FILE.
/]
JRST RETURN
INITS: INIT 0,16
DEVICE: 0
0
JRST NODEV
POPJ P,
CHNAME: PUSH P,16
MOVEI 16,CK1
PUSHJ P,CKNAME##
POP P,16
SKIPN IERR
POPJ P,
JRST BADNAM
PRGEND
TITLE CKNAME
SUBTTL SUBROUTINE TO TRANSLATE FILENAMES.
REMARK WRITTEN BY NORM GRANT. WMU.
SEARCH FORPRM
COMMENT %
USAGE CALL CKNAME(NAME1,NAME2,IERR)
WHERE NAME IS FILENAME.EXT(MUST BE A TWO WORD
QUANTITY.)
NAME2: FILENAME.EXT IN SIXBIT FORMAT(TWO WORDS.)
(RETURNED.)
IERR: ERROR CODE RETURNED.
IERR=0 ALL RIGHT.
IERR=-1 ILLEGAL.
IERR=1 WARNING. IMBEDDED SPACE(S)OR OVERLENGTH NAME.
%
POINTN: POINT 7,0, ;POINTER TO ASCII NAME.
POINTS: POINT 6,NAME, ;POINTER TO SIXBIT NAME.
POINTE: POINT 6,NAME+1, ;POINTER TO SIXBIT EXTENSION.
POINT: 0
NAME: BLOCK 2 ;FILE-NAME BLOCK.
;
HELLO (CKNAME, )
SETZ 4,
SETZM @2(16)
MOVSI 0,440700 ;SET UP POINTER TO NAME
ADDI 0,@0(16)
MOVEM 0,POINTN ;STORE POINTER TO ASCII NAME.
MOVE 0,POINTS
MOVEM 0,POINT ;STORE POINTER TO SIXBIT NAME.
SETZM NAME ;ZERO SIXBIT NAME AND EXTENSION.
SETZM NAME+1
MOVEI 3,^D10
MOVEI 1,6 ;SET COUNTER TO 6 CHARACTERS MAXIMUM.
L1: ILDB 2,POINTN ;LOAD CHARACTER TO AC2.
SOJ 3,
CAIN 2,"."
JRST ENDNAM ;IF PERIOD, END FILE-NAME.
JSR CHK
SOJG 1,L1 ;CHECK FOR END OF LOOP, AND JUMP ELSE.
ILDB 2,POINTN ;CHECK FOR NULL EXTENSION.
SOJ 3,
CAIE 2,"."
JRST BLANK1
ENDNAM: SETO 4,
MOVEI 1,3 ;SET COUNTER TO 3 CHARACTERS MAXIMUM.
MOVE 0,POINTE
MOVEM 0,POINT ;STORE POINTER TO SIXBIT EXTENSION.
L2: ILDB 2,POINTN
SOJ 3,
JSR CHK
SOJG 1,L2 ;CHECK FOR END OF LOOP.
ENDEXT:
END1: SKIPN NAME
ILNAM: SETOM @2(16)
RETURN: MOVEI 0,@1(16)
SOJ 0,
PUSH 0,NAME
PUSH 0,NAME+1
GOODBY (3)
BLANK: SOJL 3,ENDEXT
ILDB 2,POINTN
BLANK1: CAIN 2," "
JRST BLANK
IMBED: MOVEI 0,1
MOVEM 0,@2(16)
JRST END1
CHK: 0
CAIN 2," "
JRST BLANK ;IF SPACE, END FILE-NAME AND EXTENSION.
CAIGE 2,"0"
JRST ILNAM ;CHECK FOR ILLEGAL CHARACTERS.
CAIG 2,"9"
JRST OKBIT
CAIL 2,"A"
CAILE 2,"Z"
JRST ILNAM
OKBIT: MOVEI 2,40(2) ;CONVERT TO SIXBIT.
IDPB 2,POINT ;AND STORE IN NAME BLOCK.
JRST @CHK
PRGEND
TITLE GTDV..
SEARCH FORPRM
IFNDEF FTWMU,<FTWMU==0>
ENTRY GTDV..
GTDV..: LDB 1,[POINT 4,@0(16),12] ;GET ARG TYPE
PUSHJ P,TYPE..## ;AND FIND IF ITS DOUBLE
CAIE 0,5 ;SINGLE?
JRST ASCII2 ;NO.
MOVE 1,@0(16) ;GET DEVICE NAME OR NUMBER
JUMPE 1,ERMSG ;ZERO IS ILLEGAL
SETCM 2,1 ;COMPLEMENT IT
TLNN 2,-1 ;DEFAULT DEVICE?
JRST NEG ;YES
TLNE 1,-1 ;ASCII DEVICE NAME
JRST ASCII2 ;YES
MOVEI 2,6(1) ;GET FOROTS INTERNAL FLU NUMBER
CAILE 2,FLU.MX+6 ;IN RANGE?
JRST ERMSG ;NO. ILL NUMBER
IDIVI 2,6 ;SIX ENTRIES PER WORD
IMULI 3,6 ;NUMBER OF BITS LEFT
ROT 3,-6 ;POSITION FOR THE BYTE POINTER
HRRZ 4,.JBOPS## ;BASE FOR OTS DATA
IOR 3,[POINT 6,FLU.TB(4),35];SET THE SIZE FIELD
ADDI 3,(2) ;POINT TO THE WORD ENTRY
LDB 2,3 ;LOAD THE CHANNEL ENTRY
ADDI 2,CHN.TB(4) ;SET THE OFFSET FOR CHANNEL CONTROL WD
SKIPN 3,(2) ;GET THE I/O REG
JRST TRYLOG ;NOT OPEN. TRY LOGICAL NAME
MOVE 2,DD.DEV(3) ;GET DEVICE
MOVE 0,DD.STS(3) ;GET DEVCHR STORED BY FOROTS
POPJ P, ;RETURN
TRYLOG: MOVE 2,1
ANDI 2,77
IDIVI 2,^D10
LSH 2,6
IORI 2,2020(3)
CAIGE 2,2120 ;SIXBIT 10, RIGHT JUSTIFIED
LSH 2,6
LSH 2,^D24
MOVE 0,2
DEVCHR 0,
JUMPN 0,CPOPJ
GETDV1:
IFN FTWMU,<
MOVE 3,.JBOPS##
CAMLE 1,DEV.SZ(3) ;ABOVE MAXIMUM?
JRST DEFDSK ;YES, ASSUME DSK
MOVE 3,DEV.TB(3) ;ADDRESS OF DEVTAB
ADDI 3,(1) ;OFFSET FROM DEVTAB
SKIPN 2,(3) ;GET DEVICE NAME
>
IFE FTWMU,<
CAILE 1,DEV.SZ ;ABOVE MAXIMUM?
JRST DEFDSK ;YES, ASSUME DSK
SKIPN 2,DEVTB.(1) ;GET DEVICE NAME
>
DEFDSK: MOVSI 2,'DSK' ;NO. USE DSK
JRST DODEV ;NOW GO RETURN DEVCHR
NEG: CAML 1,[-5] ;NEGATIVE NUMBER OK?
JRST GETDV1 ;YES
ASCII2: MOVEI 3,0(16) ;ADDRESS OF ARG POINTER
PUSHJ P,ASC6..## ;GET SIXBIT FOR NAME
DODEV: MOVE 0,2
DEVCHR 0,
CPOPJ: POPJ P,
ERMSG: OUTSTR [ASCIZ/ILLEGAL DEVICE NUMBER!
/]
MOVEI 16,[EXP 0,0]+1 ;ARG FOR EXIT
PUSHJ P,EXIT.##
IFE FTWMU,<
;COPY FOR DEVTB.
SIXBIT .REREAD. ;-6; REREAD
SIXBIT .CDR. ;-5; READ
SIXBIT .TTY. ;-4; ACCEPT
SIXBIT .LPT. ;-3; PRINT
SIXBIT .PTP. ;-2; PUNCH
SIXBIT .TTY. ;-1; TYPE
DEVTB.: Z ;00; ILLEGAL DEVICE NUMBER
SIXBIT .DSK. ;01; DISC
SIXBIT .CDR. ;02; CARD READER
SIXBIT .LPT. ;03; LINE PRINTER
SIXBIT .CTY. ;04; CONSOLE TELETYPE
SIXBIT .TTY. ;05; USER'S TELETYPE
SIXBIT .PTR. ;06; PAPER TAPE READER
SIXBIT .PTP. ;07; PAPER TAPE PUNCH
SIXBIT .DIS. ;08; DISPLAY
SIXBIT .DTA1. ;09; DECTAPE
SIXBIT .DTA2. ;10;
SIXBIT .DTA3. ;11;
SIXBIT .DTA4. ;12;
SIXBIT .DTA5. ;13;
SIXBIT .DTA6. ;14;
SIXBIT .DTA7. ;15;
SIXBIT .MTA0. ;16; MAG TAPE
SIXBIT .MTA1. ;17;
SIXBIT .MTA2. ;18;
SIXBIT .FORTR. ;19;
SIXBIT .DSK. ;20;
SIXBIT .DSK. ;21;
SIXBIT .DSK. ;22;
SIXBIT .DSK. ;23;
SIXBIT .DSK. ;24;
SIXBIT .DEV1. ;25;
SIXBIT .DEV2. ;26;
SIXBIT .DEV3. ;27;
SIXBIT .DEV4. ;28;
SIXBIT .CDP. ;29;
SIXBIT .TTY. ;30;
DEV.SZ==.-DEVTB.-1
>
PRGEND
TITLE ASC6..
SEARCH FORPRM
ENTRY ASC6..
CH==14
;USAGE MOVEI 3,ADR OF ARGUMENT POINTER
; PUSHJ P,ASC6..##
; ALWAYS RETURNS HERE WITH SIXBIT IN 2
; USES 0,1,2,3,4,14
ASC6..: LDB 1,[POINT 4,(3),12] ;GET TYPE OF ARGUMENT
PUSHJ P,TYPE..## ;GET NUMBER OF CHARACTERS TO READ
MOVEI 3,@(3) ;GET ADDRESS OF STRING
HRLI 3,440700 ;AND SET UP POINTER
MOVE 4,[POINT 6,2]
SETZ 2,
ASCSX1: ILDB CH,3
CAIG CH," "
POPJ P,
CAIGE CH,140 ;LOWER CASE DOESN'T NEED THE +40
ADDI CH,40
IDPB CH,4
SOJG 0,ASCSX1
POPJ P,
PRGEND
TITLE TYPE..
SEARCH FORPRM
ENTRY TYPE..
; USAGE
; LDB 1,[POINT 4,n(L),12]
; PUSHJ P,TYPE..##
; RETURNS NUMBER OF CHARACTERS TO PICK UP IN 0
; IF F10, 6 IFF CODE IS 10,14,17
; IF F40, 6 IFF CODE IS 5,6,7
; ELSE 5
TYPE..: MOVEI 0,6 ;ASSUME WE WILL RETURN SIX CHARACTERS
IFN F40LIB,<
TLNN L,-1 ;F40?
JRST F10TYP ;NO. F10
CAIL 1,5 ;IS IT IN RANGE FOR DOUBLE WORD?
CAILE 1,7 ;..
SUBI 0,1 ;NO. MAKE THE 6 A FIVE
POPJ P,
F10TYP:>
CAIE 1,10 ;IS IT DOUBLE WORD?
CAIN 1,14 ;..
POPJ P, ;YES
CAIE 1,17 ;IS IT?
SUBI 0,1 ;NO
POPJ P,
PRGEND
TITLE CHAINB
EXTERN OVTAB,OVBEG,.JBSA
SEARCH FORPRM
CHN==0
HELLO (CHAINB, ) ;CHAINB ENTRY
MOVEM 5,SAVAC+5
MOVEI 5,SAVAC
BLT 5,SAVAC+4
MOVEI T0,CHAINB
HLRZ T1,.JBSA
CAIL T0,OVBEG ;CHECK IF CHAIN IN OVERLAY
CAILE T0,(T1) ;
JRST OK1 ;
JRST CHNBD1 ;OUTPUT DIAGNOSTIC TO TTY
OK1: MOVE T0,16 ;NOW CHECK RETURN ADDRESS
TLZN T0,-1 ;
HRRZ T0,(P) ;GET ADDRESS FROM PUSH DOWN LIST
CAIG T0,(T1) ;
CAIGE T0,OVBEG ;
JRST OK2 ;
JRST CHNBD2 ;TRAPPED!
OK2: MOVEI T1,@1(16) ;ADDRESS OF FILE NAME STRING
HRLI T1,440700 ;
MOVE T2,[POINT 6, CHNLK]
MOVEI T3,5
SETZM CHNLK ;
;CONVERT FIRST FIVE CHARACTERS TO SIXBIT
CHN2: ILDB T0,T1
CAIL T0,140 ;LOWER CASE?
SUBI T0,40 ;NO. MAKE IT
SUBI T0,40
JUMPLE T0,CHN1A ;SPACE OR LESS?
IDPB T0,T2
SOJG T3,CHN2
CHN1A: SKIPE CHNDEV ;DO WE KNOW WHERE FILE IS?
JRST FNDCHN ;YES. USE IT
HRROI T0,40 ;JBTLIM TABLE
GETTAB T0,
SETZ T0, ;ASSUME NOT SYS
TLNE T0,(1B11) ;PROGRAM FROM SYS?
JRST CHNSYS ;YES. GET CHAIN FROM SPECIAL AREA
HRRZ T3,.JBOPS## ;GET OBJECT TIME SYSTEM
MOVE T0,REGS.1(T3) ;PPN
CAME T0,[1,,4] ;DSK:[1,4]?
CAMN T0,[1,,5] ;OR [1,5]?
JRST CHNSYS ;YES. ASSUME FROM SYS SOME WAY
;DON'T TRY TO HANDLE FUNNY LIB OR PATHS, AND
;BOMB ON PSEUDO:[1,4]
MOVEM T0,CHNPPN ;STORE
SKIPN T1,REGS.2(T3) ;SAVE DEVICE
MOVSI T1,'DSK' ;ASSUME DISK
MOVEM T1,CHNDEV
MOVEI T0,17 ;MODE. NOT PHY ONLY
MOVEM T0,OPNWRD ;REMEMBER
FNDCHN: MOVE T0,OPNWRD ;LOOK UP THE CHAIN
MOVE T1,CHNDEV
SETZ T2,
OPEN CHN,T0 ;IF NOT THERE, ERROR
JRST NOFILE
HLLZS CHNLK+1 ;CLEAR POSSIBLE JUNK
SETZM CHNLK+2
MOVE T3,CHNPPN ;GET CHAIN PPN
MOVEM T3,CHNLK+3 ;STORE
LOOKUP CHN,CHNLK ;LOOKUP FILE IN USER'S AREA
JRST NOFILE ;ERROR IF NOT THERE
GETCHN: SKIPG T1,CURCHN ;GET CURRENT CHAIN NUMBER
JRST REDCHN ;IF ANY
HLRE T2,OVTAB-1(T1) ;GET LENGTH OF CURRENT OVERLAY
MOVM T2,T2
ADDI T2,OVBEG-1 ;GET HIGHEST ADDRESS IN OVERLAY
HRRZ T3,.JBOPS## ;GET FORMAT CHAIN
MOVEI T3,FMT.DY(T3) ;...
FUNRA0: HRRZ T1,(T3) ;LOCATE FORMAT POINTED TO
JUMPE T1,REDCHN ;DONE
HRRZ T4,1(T1) ;LOAD FORMAT ADDRESS
CAIL T4,OVBEG ;LOWER THAN OVERLAYS?
CAILE T4,(T2) ;OR HIGHER THAN TOP OF OVERLAY?
JRST FUNRA2 ;YES. GET NEXT FORMAT
MOVE T0,(T1) ;LINK FORMATS AROUND OVERLAY
HRRM T0,(T3)
ADDI T1,1 ;SET POINTER FOR DECOR.
HLLZS -1(T1) ;AND CLEAR POINTER
MOVEM T1,CORADR ;STORE ADDRESS OF CORE TO RETURN
PUSH P,16 ;SAVE AN AC
MOVEI 16,ARGBLK ;SET UP ARGUMENT
PUSHJ P,DECOR.## ;RETURN FORMATS CORE TO FOROTS
POP P,16 ;RESTORE AC
JRST FUNRA0 ;LOOP
FUNRA2: HRRZ T3,(T3) ;GET NEXT FORMAT
JRST FUNRA0
REDCHN: MOVE T1,@(16)
JUMPLE T1,BADCHN ;MUST BE POSITIVE
HLRE T2,OVTAB-1(T1) ;GET SIZE OF OVERLAY
JUMPGE T2,BADCHN ;MUST HAVE SOME SIZE!
MOVE T2,OVTAB-1(T1) ;NUMBER OF OVERLAY DESIRED
USETI CHN,(T2)
HRRI T2,OVBEG-1
MOVEI T3,0
INPUT CHN,T2
STATZ CHN,760000
JRST INERR
RELEAS CHN,
MOVEM T1,CURCHN ;REMEMBER CURRENT OVERLAY
MOVSI 5,SAVAC
BLT 5,5 ;RESTORE ALL ACS
GOODBY (1)
CHNSYS: MOVEI T3,WHRNUM ;NUMBER OF PLACES TO LOOK
MOVE T0,[XWD 400000,17];DUMP MODE, PHY ONLY
CHNSY1: MOVE T1,WHRTAB-1(T3) ;GET DEVICE TO TRY
SETZ T2,
OPEN CHN,T0 ;OPEN IT
SOJA T3,NXTDEV ;TRY NEXT DEVICE
HLLZS CHNLK+1 ;SET LOOKUP BLOCK
SETZM CHNLK+2
SETZM CHNLK+3
LOOKUP CHN,CHNLK ;FIND FILE
SOJA T3,NXTDEV ;NOT THERE
MOVEM T1,CHNDEV ;REMEMBER DEVICE
SETZM CHNPPN ;NO PPN
MOVEM T0,OPNWRD ;AND HOW TO OPEN
JRST GETCHN ;GET CHAIN. ALREADY LOOKUP UP
NXTDEV: JUMPLE T3,NOFILE ;ERROR IF NO MORE DEVICES
JRST CHNSY1 ;TRY ANOTHER DEVICE
CHNLK: 0
SIXBIT .CHN.
0
0
WHRTAB: SIXBIT .NEW. ;DEVICE NEW:[1,5]
SIXBIT .OVL. ;DEVICE OVL: (NEW DEVICE FOR CHAINB,OVERLAY)
WHRNUM==.-WHRTAB
CURCHN: 0 ;CURRENT CHAIN IN CORE
CHNDEV: 0 ;DEVICE FOR CHAIN FILE
CHNPPN: 0 ;PPN FOR CHAIN FILE
OPNWRD: BLOCK 1 ;MODE TO OPEN CHAIN DEVICE
CORADR: BLOCK 1
1,,0
ARGBLK: EXP CORADR
CHNBD2: OUTSTR [ASCIZ .
CALL TO CHAIN MUST NOT BE IN THE OVERLAY
.]
EXIT
CHNBD1: OUTSTR [ASCIZ .
CHAIN MUST NOT BE IN THE OVERLAY
.]
EXIT
NOFILE: SETZM CHNDEV ;FORGET WHERE FOUND DEVICE IF LOSE IT
OUTSTR [ASCIZ .
CAN'T FIND CHAIN FILE
.]
EXIT
INERR: OUTSTR [ASCIZ .
ERROR READING OVERLAY
.]
EXIT
BADCHN: OUTSTR [ASCIZ .
INVALID CHAIN NUMBER
.]
EXIT
SAVAC: BLOCK 6 ;AC SAVE AREA
PRGEND
TITLE CORAL CORE ALLOCATION ROUTINES
SUBTTL ALLCOR SUBROUTINE TO ALLOCATE CORE
SEARCH FORPRM
COMMENT %
WRITTEN BY NORM GRANT. W.M.U. MARCH 17, 1977
CALL ALLCOR(MAX,IERR,IREL,S(1))
WHERE MAX: TOTAL NUMBER OF WORDS OF STORAGE TO BE ALLOCATED.
IERR: ERROR CODE.
0 OK
-1 INSUFFICIENT ROOM OR ILLEGAL ARGUMENT
1 WARNING! CAN'T GET MUCH BIGGER
IREL: SUBSCRIPT ON SINGLE PRECISION ARRAY S SUCH THAT S(IREL)
IS FIRST LOCATION IN ALLOCATED CORE.
OTHER ARRAYS (BEYOND FIRST) ARE AT S(IREL+LENGTH1),
S(IREL+LENGTH1+LENGTH2),ETC.
S: A ONE ELEMENT SINGLE PRECISION ARAY WHICH ALL
ALLOCATED CORE IS TO BE ADDRESSED RELATIVE TO.
THE WARNING(IERR=1) WILL ONLY BE GIVEN IF DOING ALLOCATION VIA CORE UUO.
ON PAGING SYSTEMS (VM) ALLOCATION WILL BE DONE BY PAGE. UUOS ABOVE THE
HIGH SEGMENT, SO THAT THE OBJECT TIME SYSTEM MAY BE SHARED. THIS REQUIRES A
CHANGE TO FOROTS (ALSO FORFUN AND FORPRM) SO THAT THE CBC FUNCTION
TRYING TO REDUCE CORE DOESN'T ZAP OUR NON-CONTIGUOUS PAGES, AND NEITHER DOES QMANGR.
NOTE THAT GALAXY QMANGR STILL WILL ZAP OUR NON-CONTIGUUOUS PAGES SINCE IT
DOES A CORE UUO EVEN WHEN TOLD NOT TO.
THIS PATCH IS SHOWN ON THE NEXT TWO PAGES FOR FOROTS VERSION 4B.
AFTER INSTALLATION OF THE PATCH, IT WILL BE NECESSARY TO REASSEMBLE
FORPRM.MAC, FORINI.MAC, FOROTS.MAC, AND FORFUN.MAC. IT WILL ALSO BE
NECESSARY TO FUDGE FORINI,FOROTS, AND FORFUN INTO FORLIB, AND RELOAD
FOROTS.SHR. THIS PROCEDURE WILL HAVE NO EFFECT ON EXISTING SAVE FILES,
UNLESS THE ADDITIONAL SIZE SHOULD MAKE THEM TOO LARGE TO RUN.
%
IFDEF PAG.TB,<FTPAGE==-1> ;IF THEY PATCHED FORPRM, ASSUME WANT PAGE. UUOS
IFNDEF FTPAGE,<FTPAGE==0> ;OTHERWISE, ASSUME DON'T WISH TO DO PAGE. UUOS
COMMENT %
File 1) DSKB:FORPRM.ORG[10,7] created: 0000 20-MAY-1976
File 2) DSKB:FORPRM.MAC[10,7] created: 0925 20-APR-1977
1)13 LOW.SZ==ZZ. ;SIZE OF THE STATIC LOW SEGMENT
****
2)13 STATIC(PAG.TB,20) ;WORDS FOR FORFUN TO DO PAGE. UUOS
2) LOW.SZ==ZZ. ;SIZE OF THE STATIC LOW SEGMENT
**************
File 1) DSKB:FORFUN.ORG[10,7] created: 0000 19-MAY-1976
File 2) DSKB:FORFUN.MAC[10,7] created: 0932 20-APR-1977
1)16 MOVEI P1,-1(T2) ;[311] LAST WORD WE NEED
1) CORE P1, ;[311]
1) JRST FUNST0 ;[311] NO CHANGE IF WE FAILED
1) CAMLE T2,.JBREL## ;[311] INCASE WE GAVE IT ALL AWAY
1) JRST FUNCB1 ;[311] JUST CLEAR PREVIOUS
****
2)16 IFN <KA10-CPU>,< ;IF NOT A KA10
2) MOVE T3,[XWD 4,T4] ;CHECK FOR EXISTENCE OF PAGE. UUO
2) MOVEI T4,1 ;BY GETTING A WORD OF WORKING SET TABLE
2) PAGE. T3, ;DO CALL
2) JRST FUNCB3 ;DOES NOT EXIST. NOT PAGING SYSTEM
2) MOVEI P1,776(T2) ;GET FIRST UNWANTED PAGE
2) LSH P1,-^D9
2) HRRZ T3,.JBREL## ;GET LAST UNWANTED PAGE
2) LSH T3,-^D9
2) TLO P1,(1B0) ;SET DELETING PAGES BIT IN P1
2) RETAGN: MOVSI T5,-17 ;MAX PAGES TO DO AT ONE TIME
2) HRRI T5,PAG.TB(P4) ;WHERE TO STORE WORDS
2) SETZM PAG.TB(P4) ;START WITH ZERO PAGES
2) RETMOR: CAIGE T3,(P1) ;FINISHED?
2) JRST RETDON ;YES. DO FINAL PAGE. UUO
2) MOVEM P1,1(T5) ;NO. STORE THIS PAGE. (SHOULD BE AT LEAST ONE)
2) AOS PAG.TB(P4) ;AND COUNT IT
2) ADDI P1,1 ;STEP TO NEXT PAGE
2) AOBJN T5,RETMOR ;LOOP FOR MORE PAGES
2) RETDON: MOVEI T5,PAG.TB(P4) ;SET UP UUO ARG
2) HRLI T5,1 ;DELETE PAGES FUNCTION
2) PAGE. T5, ;DO IT
2) JFCL ;IGNORE IT. MAY CAUSE PROBS?
2) CAIL T3,(P1) ;WAS THAT THE END?
2) JRST RETAGN ;NO. DO MORE
2) JRST FUNCB4 ;YES. DONE
2) > ;END IFN <KA10-CPU>
2) FUNCB3: MOVEI P1,-1(T2) ;[311] LAST WORD WE NEED
2) CORE P1, ;[311]
2) JRST FUNST0 ;[311] NO CHANGE IF WE FAILED
2) FUNCB4: CAMLE T2,.JBREL## ;[311] INCASE WE GAVE IT ALL AWAY
2) JRST FUNCB1 ;[311] JUST CLEAR PREVIOUS
**************
File 1) DSKC:FOROTS.CUR[10,6] created: 0000 21-APR-1977
File 2) DSKC:FOROTS.MAC[10,6] created: 1038 12-OCT-1977
1)55 PUSH P,.JBHRL## ;[346] SAVE HIGH SEGMENT LENGTH
****
2)55 ; CLOS.Q+ S.M. #485.25 NDG/ 10-12-77
2) TLO T1,40000 ;TELL QMANGR NOT TO DO ANY CORE SHRINKING
2) PUSH P,.JBHRL## ;[346] SAVE HIGH SEGMENT LENGTH
**************
1)55 PJRST UPDCHN ;[240] UPDATE CHANNEL TABLE
1) QUE.TB: ;TABLE OF QUEUE CODES
****
2)55 PUSHJ P,UPDCHN ;[240] UPDATE CHANNEL TABLE
2) HRRZ T2,.JBFF ;GET WHERE WE THINK CORE ENDS
2) CAML T2,.JBREL ;QMANGR CHANGE?
2) POPJ P, ;NO. OK
2) IFN <KA10-CPU>,< ;IF NOT A KA10
2) MOVE T3,[XWD 4,T4] ;CHECK FOR EXISTENCE OF PAGE. UUO
2) MOVEI T4,1 ;BY GETTING A WORD OF WORKING SET TABLE
2) PAGE. T3, ;DO CALL
2) JRST QUECB3 ;DOES NOT EXIST. NOT PAGING SYSTEM
2) MOVEI P1,776(T2) ;GET FIRST UNWANTED PAGE
2) LSH P1,-^D9
2) HRRZ T3,.JBREL## ;GET LAST UNWANTED PAGE
2) LSH T3,-^D9
2) TLO P1,(1B0) ;SET DELETING PAGES BIT IN P1
2) RETAGN: MOVSI T5,-17 ;MAX PAGES TO DO AT ONE TIME
2) HRRI T5,PAG.TB(P4) ;WHERE TO STORE WORDS
2) SETZM PAG.TB(P4) ;START WITH ZERO PAGES
2) RETMOR: CAIGE T3,(P1) ;FINISHED?
2) JRST RETDON ;YES. DO FINAL PAGE. UUO
2) MOVEM P1,1(T5) ;NO. STORE THIS PAGE. (SHOULD BE AT LEAST ONE)
2) AOS PAG.TB(P4) ;AND COUNT IT
2) ADDI P1,1 ;STEP TO NEXT PAGE
2) AOBJN T5,RETMOR ;LOOP FOR MORE PAGES
2) RETDON: MOVEI T5,PAG.TB(P4) ;SET UP UUO ARG
2) HRLI T5,1 ;DELETE PAGES FUNCTION
2) PAGE. T5, ;DO IT
2) JFCL ;IGNORE IT. MAY CAUSE PROBS?
2) CAIL T3,(P1) ;WAS THAT THE END?
2) JRST RETAGN ;NO. DO MORE
2) POPJ P, ;YES. DONE
2) > ;END IFN <KA10-CPU>
2) QUECB3: MOVEI P1,-1(T2) ;WHERE TO SHRINK BY CORE UUO
2) CORE P1, ;DO IT
2) JFCL ;CAN'T FAIL
2) POPJ P, ;RETURN
2) QUE.TB: ;TABLE OF QUEUE CODES
**************
%
HELLO (ALLCOR) ;ALLCOR ENTRY
SKIPL T1,@0(16) ;MAX NEGATIVE?
CAILE T1,400000 ;OR GREATER THAN 128 K?
JRST NOCORE ;YES. CAN'T DO ANYTHING
SETZM @1(16) ;ASSUME NO ERRORS
IFN <CPU-KA10>&FTPAGE,<
MOVE T1,[XWD 4,T2] ;GET WORKING SET BIT TABLE
MOVEI T2,1
PAGE. T1, ;GET TABLE FROM MONITOR
JRST OLDCOR ;MUST DO OLD WAY. NOT VM SYSTEM
MOVEI T1,377777 ;DO VIA PAGE. CHECK ARG MORE
SKIPE .JBHRL## ;ANY HIGHSEG?
HRRZ T1,.JBHRL## ;GET HIGHEST ADR IN HIGHSEG
ADDI T1,1 ;PLUS ONE IS OUR FIRST ADDRESS
MOVE T2,@0(16) ;GET MAX AGAIN
JUMPE T2,DELALL ;ASKING FOR ZERO?
ADDI T2,-1(T1) ;NO. GET HIGHEST ADDR
LSH T1,-^D9 ;FIRST PAGE NEEDED
LSH T2,-^D9 ;HIGHEST PAGE NEEDED
CAILE T2,776 ;LEAVE ROOM FOR PFH
JRST NOCORE ;NOT ROOM. DO NOTHING
MOVEM T1,LOWPAG# ;STORE LOWEST PAGE
MOVEM T2,HIPAGE# ;HIGHEST PAGE
MOVEI T4,-1(T1) ;MAKE T4 CURRENT HIGHEST PAGE (MAY NOT EXIST)
CHKPAG: MOVEI T3,1(T4) ;SEE IF PAGES REALLY EXISTS
HRLI T3,6 ;.PAGCA FUNCTION
PAGE. T3, ;ASK MONITOR
JRST ENDPAG ;ASSUME T4 IS HIGH PAGE
JUMPL T3,ENDPAG ;DOES PAGE EXIST?
CAIGE T4,775 ;YES. HIGH AS WANT TO LOOK?
AOJA T4,CHKPAG ;LOOP FOR MORE PAGES
ENDPAG: MOVEM T4,CURHGH# ;STORE HIGHEST PAGE
CAMN T4,HIPAGE ;IS IT THE HIGHEST DESIRED ALSO?
JRST NOCHNG ;YES. NOTHING TO DO
CAML T4,HIPAGE ;NO. MORE THAN HE WANTS?
JRST LESPAG ;YES. REDUCE CORE
ADDI T4,1 ;WANTS MORE CORE.
CAMGE T4,LOWPAG ;START ALLOCATING AT
MOVE T4,LOWPAG ;LARGER OF (CURHGH+1), LOWPAG
MOVEM T4,FIRSTP# ;REMEMBER WHERE WE STARTED
SETZM ONDISK# ;START ALLOCATING PAGES IN CORE
CREPAG: SETZM PAGTAB ;ZERO PAGES SO FAR
HRLZI T1,-20 ;AT MOST 16.P PER CALL
CREPG0: HRRZM T4,PAGTAB+1(T1) ;ALWAYS AT LEAST ONE TO ALLOCATE. STORE NUMBER
AOS PAGTAB ;AND COUNT IN TABLE ALSO
ADDI T4,1 ;STEP TO NEXT PAGE
CAMG T4,HIPAGE ;WAS THAT THE LAST?
AOBJN T1,CREPG0 ;NO. DO NEXT IF IT WILL FIT
CREPG1: MOVSI T2,(1B1) ;MUST WE ALLOCATE ON DISK?
SKIPE ONDISK ;???
IORM T2,PAGTAB+1 ;YES. SETTING FOR ONE SETS FOR ALL
MOVE T2,[XWD 1,PAGTAB] ;ALLOCATE PAGES
PAGE. T2, ;FROM MONITOR
JRST CREFAI ;FAILED. ON DISK INSTEAD?
CAMG T4,HIPAGE ;GOT THEM. MORE TO DO?
JRST CREPAG ;YES. START ANOTHER BLOCK
NOCHNG: MOVE T3,LOWPAG ;WHERE ALLOCATED CORE STARTS
LSH T3,^D9 ;IN WORDS
JRST WHRCOR ;TELL WHERE IS AND LEAVE
CREFAI: SKIPE ONDISK ;ALREADY TRYING DISK?
JRST UNCRPG ;YES. GIVE BACK ANY WE ALLOCATED AND GIVE ERROR
SETOM ONDISK ;NO. TRY PUTTING SOME ON DISK
JRST CREPG1 ;TRY THE ALLOCATION AGAIN. SAME PAGES
UNCRPG: SETOM @1(16) ;THIS WILL BE AN ERROR ON RETURN
HRRZ T1,PAGTAB+1 ;GET FIRST PAGE IN BLOCK THAT FAILED
CAMG T1,FIRSTP ;ABOVE FIRST THAT TRIED FOR?
JRST NOCORE ;NO. WE NEVER GRABBED ANY
SUBI T1,1 ;LAST PAGE TO RETURN
EXCH T1,CURHGH ;GOES INTO CURHGH
MOVEM T1,HIPAGE ;AND OLD HIGHEST GOES INTO DESIRED HIGHEST
JRST DELPAG ;DEALLOCATE IT
LESPAG: SETZM @1(16) ;DEALLOCATING PAGES IS ALWAYS OK
DELPAG: MOVE T4,HIPAGE ;START DELETING AT HIPAGE DESIRE PLUS ONE
AOS T4 ;PLUS ONE
MOVSI T3,(1B0) ;DELETEING PAGES BIT
DELPG0: SETZM PAGTAB ;START WITH ZERO COUNT
MOVSI T1,-20 ;AT MOST 16.P PER CALL
DELPG1: MOVEM T4,PAGTAB+1(T1) ;STORE COMMAND. MUST BE AT LEAST ONE
AOS PAGTAB ;COUNT IT TOO
IORM T3,PAGTAB+1(T1) ;SET DELETE BIT
ADDI T4,1 ;STEP TO NEXT PAGE
CAMG T4,CURHGH ;WAS THAT LAST ONE?
AOBJN T1,DELPG1 ;DO NEXT PAGE IF IT WILL FIT
DELPG2: MOVE T2,[XWD 1,PAGTAB] ;DELETE THE PAGES
PAGE. T2, ;FROM OUR IMAGE
JFCL ;IGNORE FAILURE
CAMG T4,CURHGH ;WAS THAT END OF IT
JRST DELPG0 ;NO. START ANOTHER BLOCK
SKIPE @1(16) ;DID WE HAVE ERROR
JRST NOCORE ;YES. ON ALLOCATION
JRST NOCHNG ;NO ERROR. RETURN ADDRESS
DELALL: HRRZ T1,.JBREL## ;GET CURRENT HIGHEST IN CONTIGUOUS LOWSEG
CORE T1, ;CUT TO JUST THAT
JFCL ;IF POSSIBLE
SETZB T3,@1(16) ;NO ERRORS
JRST WHRCR1 ;AND AN OFFSET OF 1 = S(1)
PAGTAB: BLOCK 21 ;ROOM FOR HEADER WORD AND 16P = 8K
>;END IFE <CPU-KA10>!FTPAGE
; HERE TO DO ALLOCATION BY CORE UUO IN HIGH SEGMENT
OLDCOR: SKIPE .JBHRL## ;ANY HIGH SEGMENT?
JRST GOTHI ;YES. DON'T MAKE ONE
HRRZ T2,.JBREL## ;WHERE DOES LOW SEG END?
ADDI T2,1 ;PLUS ONE
CAIGE T2,400000 ;BELOW 400000?
MOVEI T2,400000 ;YES. START OUR HIGHSEG AT 400000
MOVS T2,T2 ;...
CORE T2, ;MAKE HIGHSEG
JRST NOCORE ;CAN'T?
MOVEI T2,10 ;RELATIVE LENGTH OF INITIAL HIGHSEG
HRLM T2,.JBHRL##
GOTHI: PUSHJ P,CLRUWP ;WRITE ENABLE HIGHSEG
MOVE T1,@0(16) ;GET MAX
HRRZ T2,.JBREL## ;FIGURE OUT HIGH SEG ORIGIN
TRNN T2,400000 ;OVER 400000?
MOVEI T2,377777 ;NO. ASSUME ORIGIN IS 400000
MOVE T3,[XWD -2,100] ;GET ORIGIN FROM .GTUPM
GETTAB T3, ;IN MONITOR
HRLI T3,1(T2) ;ASSUME LOW PLUS ONE
HLRZ T3,T3 ;GET ORIGIN IN RIGHT
HLRZ T2,.JBHRL## ;GET RELATIVE LENGTH
ADDI T3,0(T2) ;ADD TO ORIGIN
ADDI T1,-1(T3) ;AND ADD THAT TO MAX -1
TLNE T1,-1 ;EXCEED ADDRESS SPACE?
JRST NOCORE ;YES. NO CAN DO
MOVS T2,T1 ;MAKE CORE WORD
ADDI T1,^D512 ;ALSO TRY FOR EXTRA PAGE
MOVSS T1 ;CORE WORD FOR THAT
TRNN T1,-1 ;EXCEED ADDRESS SPACE?
CORE T1, ;NO. GET CORE
AOS @1(16) ;CAN'T. WARNING
CORE T2, ;GET RIGHT AMOUNT
JRST NOCORE ;THAT NEITHER
WHRCOR: SUBI T3,@3(16) ;CALCULATE OFFSET INTO S
WHRCR1: ADDI T3,1 ;SUBSCRIPT CALC IS BASE-1+SUBSCRIPT
MOVEM T3,@2(16) ;RETURN IT
GOODBY 4
NOCORE: SETOM @1(16) ;ERROR RETURN
GOODBY 4
SUBTTL CLRUWP CLEAR HISEG WRITE PROTECTION
COMMENT %
WRITTEN BY NORM GRANT. WMU. JANUARY 22, 1974
USAGE CALL CLRUWP
PURPOSE CLEAR USER WRITE PROTECTION ON HIGH SEGMENT
%
HELLO (CLRUWP) ;CLRUWP ENTRY
SETZ 0,
SETUWP 0,
JRST .+2
GOODBY
OUTSTR [ASCIZ/
Cannot write-enable high segment data area.
/]
EXIT
PRGEND
TITLE CORE MANIPULATION FOR LOW SEGS VIA FOROTS
SEARCH FORPRM
COMMENT %
USAGE CALL GTCORE(WORDS,BASE,OFFSET,ERROR,RESERVE)
WHERE WORDS - IS NUMBER OF WORDS OF CORE TO GET
BASE - IS ARRAY RELATIVE TO WHICH ADDRESS IS TO BE RETURNED
OFFSET - IS ADDRESS OF CORE RELATIVE TO BASE
ERROR - ERROR CODE
0 = OK
-1 = INSUFFICIENT CORE
1 = CANNOT OBTAIN REQUESTED RESERVE CORE
RESERVE - NUMBER OF WORDS TO RESERVE FOR LATER
CALL LSCORE(BASE,OFFSET)
WHERE BASE AND OFFSET HAVE SAME MEANING AS ABOVE.
THIS ROUTINE MUST BE CALLED TO RETURN CORE BEFORE IT CAN BE REUSED.
NOTE: GTCORE DOES NOT FUNCTION PROPERLY WITH LINK-10 OVERLAYS
IN MOST CASES. SEE FORLIB.MAN FOR MORE COMMENTS
%
XWD -1,0
M1: Z 2,AMT# ;TO ALLOCATE CORE
XWD -1,0
M2: Z 2,[-1] ;TO ALLOCATE ALL OF CORE
XWD -1,0
M3: Z 2,ADR# ;TO RETURN CORE
HELLO (GTCORE)
SETOM GETTNG# ;GETTING CORE. DO NOT DELETE FORMATS ON RETURN
MOVEM 16,SAVE16#
PUSH P,P4 ;SAVE P4
MOVE P4,.JBOPS## ;GET BASE OF OTS
SETZM @2(16) ;CLEAR OFFSET
SETZM @3(16) ;CLEAR ERROR
SKIPLE T1,@0(16) ;MUST BE POSITIVE
TLNE T1,-1 ;MORE THAN 18 BITS?
JRST NOCORE ;YES. NO WAY
MOVEM T1,SAVESZ# ;SAVE THE SIZE FOR LATER
SETZM RSVSW# ;FLAG RESERVE ARG ABSENT
SETZM RSVADR# ;FLAG NO RESERVE CORE YET
IFN F40LIB,<
TLNN 16,-1 ;F10 CALL
JRST NOTF40 ;YES
HLRZ 0,4(16) ;F40 CALL
TRZ 0,740 ;CLEAR AC FIELD
CAIE 0,(JUMP) ;IS IT AN ARG?
JRST RSVNOT ;NO
JRST RSVYES ;YES
NOTF40:>
HLRE 0,-1(16)
MOVN 0,0 ;CHANGE SIGN
CAIGE 0,5 ;AT LEAST FIVE ARGS?
JRST RSVNOT ;NO.
RSVYES: MOVE 0,@4(16) ;GET AMOUNT OF RESERVE
JUMPLE 0,RSVNOT ;OK IF NONE
SETOM RSVSW ;ASKED FOR RESERVE
TLNN 0,-1 ;MORE THAN 18 BITS?
PUSHJ P,GETCOR ;GET THE RESERVE CORE
JRST NORESV ;NO RESERVE
MOVEM 1,RSVADR ;SAVE RESERVE ADR
RSVNOT: PUSHJ P,DEFRAG ;FIND LARGEST POSSIBLE PIECE
MOVE 1,ADR ;WHERE IS IT?
HLRZ 0,-1(1) ;HOW BIG?
CAMG 0,SAVESZ ;BIG ENOUGH FOR REQUEST AND OVERHEAD WORD?
JRST GETOWN ;NO
MOVE 0,SAVESZ ;YES. GET SIZE BACK
PUSHJ P,GETCOR ;GET CORE FROM FOROTS
JRST CORERR ;CAN'T GET IT
SETADR: MOVE 16,SAVE16 ;GET ARG LIST BACK
SUBI 1,@1(16) ;SUBTRACT BASE FROM ADDRESS
ADDI 1,1 ;FORTRAN PASSES BASE-1+OFFSET
MOVEM 1,@2(16) ;STORE AS OFFSET
RETRSV: SKIPN RSVSW ;RESERVE ARG GIVEN?
JRST GTRET ;NO. RETURN
MOVE 0,RSVADR ;YES. GET ADDRESS ALLOCATED
JUMPLE 0,GTRET ;NONE. RETURN
PUSHJ P,GIVCOR ;GIVE CORE BACK TO FOROTS
GTRET: MOVE 16,SAVE16 ;GET ARG LIST BACK
POP P,P4 ;RESTORE P4
GOODBY 400004 ;RETURN
CORERR: SKIPLE T1,RSVADR ;DID USER WANT A RESERVE?
JRST CORER1 ;NO. (OR WE COUDN'T GET IT)
MOVE 16,SAVE16 ;GET ARG LIST BACK
SETO 0, ;ERROR IS -1
EXCH 0,@3(16) ;REPLACE ANY OLD ERROR AND REMEMBER
JUMPE 0,RETRSV ;IF NO PREVIOUS ERROR, RETURN ANY RESERVE
JRST GTRET ;ELSE JUST RETURN
CORER1: MOVEM T1,ADR ;STORE ADDRESS
PUSHJ P,RETADR ;RETURN THE CORE
SETZM RSVADR ;DON'T HAVE IT ANYMORE
NORESV: MOVE 16,SAVE16 ;GET ARGS BACK
MOVEI 0,1 ;NO RESERVE ERROR
MOVEM 0,@3(16)
JRST RSVNOT ;NOW FIND REAL CORE
NOCORE: SETOM @3(16) ;COMPLETE FAILURE
JRST GTRET ;RETURN
HELLO (LSCORE)
SETZM GETTNG# ;RETURNING CORE FROM PROGRAM. RETURN FORMATS
;AND ETC. SO CAN TRY TO SHRINK
PUSH P,P4 ;SAVE P4
MOVE P4,.JBOPS## ;GET OTS WORD
MOVEI 1,@(16) ;GET ARG WORD
ADD 1,@1(16) ;PLUS OFFSET
SUBI 1,1 ;MINUS THE FUDGE FACTOR FROM FORTRAN
HLRZ 2,.JBSA## ;CHECK AGAINST LOWER CORE
CAIGE 1,1(2) ;INCLUDING LINK WORD
JRST ILCORE ;TO LOW
HLRZ 2,-1(1) ;AND CHECK UPPER END
ADDI 2,-2(1) ;GET EXACT UPPER ADDRESS
TLNN 2,-1 ;NEGATIVE?
CAMLE 2,.JBREL## ;OR GREATER THAN .JBREL?
JRST ILCORE ;YES. ILLEGAL
MOVE 0,1 ;CALL GIVCOR
MOVEM 16,SAVE16#
PUSHJ P,GIVCOR ;GIVE IT BACK
MOVE 16,SAVE16
LSRET: POP P,P4 ;RESTORE P4
GOODBY (2)
ILCORE: OUTSTR [ASCIZ/
Attempting to return core at illegal address in LSCORE
/]
HALT LSRET
GETCOR: MOVEM 0,AMT ;ALLOCATE CORE
PUSHJ P,DEFRAG ;DEFRAGMENT CORE FIRST AND ALWAYS
MOVEI 16,M1
PUSHJ P,ALCOR.## ;GET IT FROM FOROTS
JUMPL 0,GIVCOR ;IF ERROR, TRY TO SHRINK CORE
MOVE 1,0 ;RETURN ADDRESS IN AC 1
MOVE 0,AMT ;RETURN AMOUNT IN ZERO
CPOPJ1: AOS (P) ;SKIP RETURN
CPOPJ: POPJ P, ;RETURN
GETBIG: MOVEI 16,M2 ;GET LARGEST POSSIBLE CHUNK
PUSHJ P,ALCOR.## ;FROM FOROTS
MOVEM 0,ADR ;STORE ADRRESS
POPJ P, ;RETURN
DEFRAG: PUSHJ P,GETBIG ;GET LARGEST POSSIBLE PIECE
JRST RETADR ;AND RETURN IT TO FOROTS (DEFRAGMENTS CORE)
FNDHGH: SETZ T1, ;ASSUME ZERO HIGHEST
MOVEI T2,FRE.DY(P4) ;GET ADDRESS OF FIRST BLOCK
MOVE T3,T2 ;SAVE AS PREVIOUS
FNDHG1: MOVE T4,T3 ;SAVE PREVIOUS
HRRZ T3,(T3) ;GET ADDRESS OF BLOCK
JUMPE T3,CPOPJ ;RETURN IF NONE
CAILE T1,(T3) ;IS NEW ADDRESS HIGHER
JRST FNDHG1 ;NO. LOOP
MOVEI T1,(T3) ;YES. REMEMBER
MOVE T2,T4 ;AND REMEMBER PREVIOUS
JRST FNDHG1 ;LOOP
GETOWN: SETZM GOTHGH# ;ASSUME WILL NOT FIND BLOCK AT TOP
PUSHJ P,FNDHGH ;TRY TO FIND BLOCK AT TOP OF CORE
JUMPE T1,GETOW1 ;NO CORE BLOCKS AT ALL
HLRZ T3,(T1) ;GET SIZE OF HIGHEST BLOCK
ADDI T3,-1(T1) ;GET HIGHEST ADDRESS IN BLOCK
CAME T3,.JBREL## ;TOP OF CORE?
JRST GETOW1 ;NO.
SETOM GOTHGH ;YES. REMEMBER
HRRZ T3,(T1) ;GET ADDRESS OF NEXT
HRRM T3,(T2) ;LINK FROM PREVIOUS
HLLZS (T1) ;CLEAR FORWARD LINK
JRST GETOW2 ;STORE ADDRESS OF BLOCK AS LOWEST FREE
GETOW1: MOVE T1,.JBFF## ;GET ADDRESS OF FIRST FREE WORD
GETOW2: MOVEM T1,SAVLOW# ;STORE THAT
ADD T1,SAVESZ ;PLUS SIZE IS OUR HIGHEST
CORE T1, ;TRY TO GRAB CORE
JRST OWNERR ;DIDN'T GET IT. FAIL
HRRZ T3,.JBREL## ;GOT IT
MOVE T1,.JBFF## ;GET OLD FIRST FREE
SUBI T3,-1(T1) ;GET SIZE OF CHUNK
ADDB T3,.JBFF## ;AND UPDATE .JBFF
SUB T3,SAVESZ ;GET ADR OF LOWEST WORD FOR USER
MOVEM T3,SAVUSR# ;SAVE IT
MOVE T2,SAVESZ ;GET SIZE TO STORE
ADDI T2,1 ;INCLUDING OVERHEAD
HRLZM T2,-1(T3) ;STORE IN BLOCK
SUB T3,SAVLOW ;FIND SIZE OF REMAINDER
SOJLE T3,GETOWX ;MUST BE POSITIVE TO RETURN
HRLZM T3,@SAVLOW ;STORE SIZE
AOS T1,SAVLOW ;GET ADDRESS
MOVEM T1,ADR ;AND STORE IT
PUSHJ P,RETADR ;RETURN TO FOROTS
GETOWX: MOVE 1,SAVUSR ;GET THE ADDRESS OF THE BLOCK BACK
JRST SETADR ;SET UP THE OFFSET AND RETURN TO USER
OWNERR: AOS T1,SAVLOW ;GET LOWEST PLUS ONE
MOVEM T1,ADR ;STORE IT
SKIPE GOTHGH ;GOT IT FROM FOROTS?
PUSHJ P,RETADR ;YES. RETURN IT TO FOROTS
JRST CORERR ;GIVE CORE ERROR
GIVCOR::MOVEM 0,ADR ;DEALLOCATE CORE
PUSHJ P,RETADR ;RETURN THE CORE
SKIPE GETTNG ;IF JUST GETTING CORE, SKIP FORMATS
JRST SHRINK ;AND COMPRESS CORE
GVCOR1: PUSHJ P,DEFRAG ;DEFRAGMENT THE CORE
SETZM FRAGED# ;AND SAY ITS NOT FRAGMENTED
PUSHJ P,FNDHGH ;FIND HIGHEST BLOCK OF CORE
JUMPE T1,CPOPJ ;IF NONE (IMPOSSIBLE) RETURN
HLRZ T3,(T1) ;GET SIZE OF HIGHEST BLOCK
ADDI T3,-1(T1) ;GET HIGHEST ADDRESS OF BLOCK
CAMN T3,.JBREL## ;TOP OF CORE?
JRST SHRINK ;YES. SHRINK THE CORE IF WORTH IT
SKIPE GETTNG ;WORTH LOOKING AT FORMATS?
POPJ P, ;NO. RETURN
MOVEM T1,CURHGH# ;SAVE ADDRESS OF HIGHEST BLOCK
HLRZ T1,FMT.DY(P4) ;GET ADDRESS OF FORMAT ENCODING BLOCK
CAMG T1,CURHGH ;ABOVE HIGHEST?
JRST GVCOR2 ;NO. CONTINUE
HRRZS FMT.DY(P4) ;YES. DELETE IT
ADDI T1,1 ;SET ADDRESS THE WAY FOROTS EXPECTS
MOVEM T1,ADR ;AND RETURN THE CORE
PUSHJ P,RETADR ;TO FOROTS
SETOM FRAGED ;THE CORE IS NOW FRAGMENTED
GVCOR2: MOVEI T1,FMT.DY(P4) ;NOW LOOK AT THE ENCODED FORMATS
GVCOR3: HRRZ T1,(T1) ;GET NEXT ONE
JUMPE T1,GVCOR4 ;NO MORE
CAMG T1,CURHGH ;ABOVE HIGHEST BLOCK
JRST GVCOR3 ;NO. LOOK AT NEXT
HRRZ T1,FMT.DY(P4) ;GET THE ADDRESS OF FIRST ENCODED FORMAT
ADDI T1,1 ;PLUS ONE FOR FOROTS
MOVEM T1,ADR ;STORE ADDRESS
HLLZS FMT.DY(P4) ;DELETE THE ENCODED FORMAT LIST
PUSHJ P,RETADR ;RETURN THE CORE TO FOROTS
JRST GVCOR1 ;CORE IS NOW FRAGMENTED, SO TRY AGAIN
GVCOR4: SKIPE FRAGED ;IS CORE FRAGMENTED?
JRST GVCOR1 ;YES
POPJ P, ;NO
SHRINK: HRRZ T3,(T1) ;GET ADDRESS OF NEXT BLOCK
HRRM T3,(T2) ;STORE IN PREVIOUS AS LINK
HLLZS (T1) ;ZERO POINTER
ADDI T1,1 ;CHANGE POINTER TO WAY FOROTS EXPECTS
MOVEM T1,ADR ;STORE FOR LATER
TROE T1,777 ;ROUND ADDRESS UP TO PAGE
ADDI T1,1000 ;EXTRA PAGE
CAML T1,.JBREL## ;WORTH DELETING?
JRST RETADR ;NO. RETURN THE BLOCK
CORE T1, ;RETURN SOME CORE
HALT . ;OOPS?
HRRZ T3,.JBREL## ;GET NEW HIGHEST
ADDI T3,1 ;NEW .JBFF
MOVEM T3,.JBFF##
MOVE T1,ADR ;GET THE BLOCK ADDRESS BACK
SUBI T3,-1(T1) ;COMPUTE SIZE
HRLM T3,-1(T1) ;AND STORE IT
RETADR: MOVEI 16,M3 ;RETURN IT
PUSHJ P,DECOR.## ;VIA FOROTS
POPJ P,
END