Trailing-Edge
-
PDP-10 Archives
-
decuslib20-02
-
decus/20-0068/fortio.mac
There are 7 other files named fortio.mac in the archive. Click here to see a list.
;TITLE FORTIO -- FORTRAN MACHINE LANGUAGE INTERFACE
; KEN SHOEMAKE 12-JUL-72
;ENTRY POINT,LDB,DPB,IBP,ILDB,IDPB ;1
;ENTRY LOC,CON,SETWRD,LSH,RSH,ROT,CODE ;2
;ENTRY CALLI,NOSKIP ;3
;ENTRY SETCOR,SAVREG,RSTREG ;4
;ENTRY ARGCNT,ARGREF,SIXBIT,ASCII ;5 *** MUST FOLLOW THE REST ***
;ENTRY RAD50,RADX50,ASCI50,SIX50 ;6
;ENTRY OPEN,INIT,RENAME,ENTER,LOOKUP,RELEA,CLOSE,IN,OUT ;7
;ENTRY INPUT,OUTPUT,STATO,STATZ,GETCHA ;7
;ENTRY INBUF,OUTBUF,GETSTS,SETSTS,MTAPE,UGETF,USETI,USETO;8
;ENTRY INCHRW,OUTCHR,INCHRS,OUTSTR,INCHWL,INCHSL,GETLCH ;9
;ENTRY SETLCH,RESCAN,CLRBFI,CLRBFO,SKPINC,SKPINL,IONEOU ;9
TITLE FIO1 -- FORTRAN - MACHINE LANGUAGE INTERFACE
ENTRY POINT,LDB,DPB,IBP,ILDB,IDPB
EXTERNAL ARGCNT
POINT:: 0 ;INTVAR=POINT(SIZE,ADDR(,BIT)), AS IN MACRO
JSA 16,ARGCNT ;GET THE NUMBER OF ARGUMENTS
MOVEM ARGS.# ;SAVE COUNT
HRLZ @(16) ;GET SIZE OF BYTES
LSH 6 ;MOVE TO PROPER POSITION
MOVE 1,ARGS. ;CHECK THE NUMBER OF ARGS.
CAIGE 1,3 ;IS THIRD ARGUMENT THERE ?
SKIPA 1,[1] ;NO, USE THE BIT TO THE LEFT OF BIT 0
MOVN 1,@2(16) ;GET NEGATIVE OF BIT POSITION ...
ADDI 1,43 ;ADD 35 FOR NO. OF PROPER BIT POINTER
DPB 1,[POINT 6,0,5] ;STUFF IT INTO THE POINTER
HRR 1(16) ;GET ADDRESS OF FIRST WORD INTO POINTER
ADD 16,ARGS. ;WANT TO SKIP ARGUMENTS
JRA 16,(16) ;RETURN WITH POINTER IN REGISTER 0
LDB:: 0 ;INTVAR=LDB(IPTR)
LDB @(16) ;GET BYTE
JRA 16,1(16) ;RETURN
DPB:: 0 ;INTVAR=DPB(IBYTE,IPTR) -- RETURNS IBYTE
MOVE @(16) ;GET BYTE
DPB @1(16) ;PUT BYTE IN WORD
JRA 16,2(16) ;RETURN
IBP:: 0 ;INTVAR=IBP(IPTR)
IBP @(16) ;INCREMENT POINTER
MOVE @(16) ;GET POINTER
JRA 16,1(16) ;RETURN
ILDB:: 0 ;INTVAR=ILDB(IPTR)
ILDB @(16) ;INCREMENT POINTER, GET BYTE
JRA 16,1(16) ;RETURN
IDPB:: 0 ;INTVAR=IDPB(IBYTE,IPTR)
MOVE @(16) ;GET BYTE
IDPB @1(16) ;INCREMENT POINTER,PUT BYTE IN WORD
JRA 16,2(16) ;RETURN
PRGEND ;END OF SET
TITLE FIO2 -- FORTRAN - MACHINE LANGUAGE INTERFACE
ENTRY LOC,CON,SETWRD,LSH,RSH,ROT,CODE
LOC:: 0 ;INTVAR=LOC(VRBLE)
MOVEI @(16) ;RETURNS ADDRESS OF ARGUMENT
JRA 16,1(16) ;RETURN WITH RESULT IN REGISTER 0
CON:: 0 ;INTVAR=CON(LOCATION)
MOVE 1,@(16) ;GET LOCATION
MOVE (1) ;GET CONTENTS OF LOCATION
JRA 16,1(16) ;RETURN WITH CONTENTS IN REGISTER 0
SETWRD::0 ;INTVAR=SETWRD(VAL,LOCATION) -- RETURNS VAL
MOVE @(16) ;GET VALUE
MOVE 1,@1(16) ;GET LOCATION
MOVEM (1) ;STORE VALUE IN LOCATION
JRA 16,2(16) ;RETURN
LSH:: 0 ;INTVAR=LSH(IWORD,IAMT)
MOVE 1,@1(16) ;GET NUMBER OF PLACES TO SHIFT
MOVE @(16) ;GET WORD TO BE SHIFTED
LSH (1) ;SHIFT IT
JRA 16,2(16) ;AND RETURN WITH RESULT IN REGISTER 0
RSH:: 0 ;INTVAR=RSH(IWORD,IAMT)
MOVN 1,@1(16) ;GET NUMBER OF PLACES TO SHIFT
JRST .-5 ;GO TO COMMON PART OF ROUTINES
ROT:: 0 ;INTVAR=ROT(IWORD,IAMT)
MOVE 1,@1(16) ;GET NUMBER OF PLACES TO ROTATE WORD
MOVE @(16) ;GET WORD TO BE ROTATED
ROT (1) ;ROTATE IT
JRA 16,2(16) ;AND RETURN RESULT IN REGISTER 0
CODE:: 0 ;INTVAR=CODE(INSTR,ADDRESS)
MOVEM 2,SAVZER# ;SAVE REGISTER 2
MOVS 2,@(16) ;GET INSTRUCTION
HRR 2,@1(16) ;GET ADDRESS
MOVE 1,OLDONE# ;GET PREVIOUS VALUE BACK
SETO ;-1 FOR SKIP RETURN
XCT 2 ;EXECUTE THE INSTRUCTION
SETZ ;ZERO IF NO SKIP
MOVEM 1,OLDONE# ;SAVE VALUE FOR NEXT TIME
MOVE 2,SAVZER# ;RESTORE REGISTER 2
JRA 16,2(16) ;RETURN
PRGEND ;END OF SET
TITLE FIO3 -- FORTRAN - MACHINE LANGUAGE INTERFACE
ENTRY CALLI,NOSKIP
EXTERNAL ARGCNT,SIXBIT
CALLI:: 0 ;CMPXVR=CALLI('NAME'/N(,AC/ARG,ARG2))
JSA 16,ARGCNT ;COUNT THE NUMBER OF ARGS.
MOVEM ARGS.# ;SAVE COUNT
MOVE 1,@(16) ;GET FIRST ARG.
HLRZ 1 ;EXAMINE THE FIRST ARG.
CAIE 0 ;IF LEFT HALF IS ZERO ...
CAIN -1 ;OR -1 ...
JRST NGIVEN ;THEN USE N FOR THE CALLI
MOVE (16) ;ELSE CONVERT NAME TO SIXBIT
HRRM .+2 ;PASS ADDRESS OF NAME
JSA 16,SIXBIT ;TO SIXBIT CONVERTER
JUMP 0 ;FILLED IN
MOVEI 1,CALLQT-CALLS ;LENGTH OF CALL TABLE
CAME CALLS(1) ;SEARCH TABLE OF CALL NAMES
SOJGE 1,.-1 ;UNTIL EXHAUSTED (ASSUME CALLI AC,-1)
NGIVEN: MOVE [2,,ACSAVE] ;SAVE REGISTERS
BLT ACSAVE+15 ;2 - 17
CAIE 1,56 ;IF 'SEEK' ...
CAIN 1,10 ;OR 'WAIT' ...
JRST USE.AC ;THEN USE THE AC SPECIFIED
CAIE 1,12 ;IF 'EXIT' ...
CAIN 1,13 ;OR 'UTPCLR' ...
JRST USE.AC ;THEN USE THE AC SPECIFIED
VGIVEN: HRLI 1,047000 ;ELSE USE AC 0
MOVEM 1,CALLI. ;STASH 'CALLI 0,N'
SETZ ;USE 0 IF NO ARG. SPECIFIED
MOVE 1,ARGS. ;CHECK NO. OF ARGS.
CAIL 1,2 ;IF ARG. FOR 0 SPECIFIED
MOVE @1(16) ;THEN GET IT THERE
CAIL 1,3 ;IF ARG. FOR 1 SPECIFIED
SKIPA 1,@2(16) ;THEN GET IT THERE
SETZ 1, ;ELSE USE 0
CALLIT: SETZM NOSKP.# ;ASSUME A SKIP RETURN
CALLI.: CALLI 0,0 ;FILLED IN
SETOM NOSKP.# ;INDICATE A NO-SKIP (PROBABLY ERROR) RETURN
MOVS 17,[2,,ACSAVE] ;RESTORE REGISTERS 2 ...
BLT 17,17 ;THROUGH 17
ADD 16,ARGS. ;SKIP ARGS.
JRA 16,(16) ;AND RETURN WITH RESULTS IN REGISTERS 0 & 1
USE.AC: HRLI 1,047000 ;SET UP CALLI WITH N
SETZ ;USE AC 0 IF NONE SPECIFIED
MOVE 2,ARGS. ;CHECK NO. OF ARGS.
CAIL 2,2 ;IF ARG. FOR AC SPECIFIED
MOVE @1(16) ;GET AC NUMBER
DPB [POINT 4,1,12] ;AND ADD IT TO CALLI
MOVEM 1,CALLI. ;STASH 'CALLI AC,N'
SETZ ;ZERO REGISTERS 0
SETZ 1, ;AND 1
JRST CALLIT ;THEN GO TO COMMON CODE
NOSKIP::0 ;FOR EXTERNAL REFERENCE
MOVE NOSKP. ;GET LAST NOSKP.
JRA 16,1(16) ;ASSUME CALLED WITH NOSKIP(0)
CALLS: EXP 'RESET ','DDTIN ','SETDDT','DDTOUT','DEVCHR','DDTGT '
EXP 'GETCHR','DDTRL ','WAIT ','CORE ','EXIT ','UTPCLR'
EXP 'DATE ','LOGIN ','APRENB','LOGOUT','SWITCH','REASSI'
EXP 'TIMER ','MSTIME','GETPPN','TRPSET','TRPJEN','RUNTIM'
EXP 'PJOB ','SLEEP ','SETPOV','PEEK ','GETLIN','RUN '
EXP 'SETUWP','REMAP ','GETSEG','GETTAB','SPY ','SETNAM'
EXP 'TMPCOR','DSKCHR','SYSSTR','JOBSTR','STRUUO','SYSPHY'
EXP 'FRECHN','DEVTYP','DEVSTS','DEVPPN','SEEK ','RTTRP '
EXP 'LOCK ','JOBSTS','LOCATE','WHERE ','DEVNAM','CTLJOB'
EXP 'GOBSTR','ACTIVA','DEACTI','HPQ ','HIBER ','WAKE '
EXP 'CHGPPN','SETUUO','DEVGEN','OTHUSR','CHKACC','DEVSIZ'
EXP 'DAEMON','JOBPEK','ATTACH','DAEFIN','FRCUUO','DEVLNM'
EXP 'PATH. ','METER.','MTCHR.','JBSET.','POKE. ','TRMNO.'
EXP 'TRMOP.','RESDV.','UNLOK.'
CALLQT= .-1
ACSAVE: BLOCK 16 ;FOR SAVING REGISTERS 2 - 17 (GETSEG)
PRGEND ;END OF SET
TITLE FIO4 -- FORTRAN - MACHINE LANGUAGE INTERFACE
ENTRY SETCOR,SAVREG,RSTREG
EXTERNAL ARGCNT
SETCOR::0 ;INTVAR=SETCOR(FIRST,LAST(,VALUE))
JSA 16,ARGCNT ;COUNT NUMBER OF ARGS.
MOVEM ARGS.# ;SAVE COUNT
CAIL 3 ;IS 'VALUE' SPECIFIED ?
SKIPA 1,@2(16) ;YES, GET IT IN REGISTER 1
SETZ 1, ;NO, ZERO LOCATIONS
MOVE 1 ;GET VALUE IN REGISTER 0 FOR RETURN
MOVEM @(16) ;SET FIRST LOCATION TO VALUE
MOVE 1,(16) ;GET ADDRESS OF FIRST LOCATION
HRLS 1 ;INTO BOTH HALVES
AOJ 1, ;MAKE BLT WORD 'FIRST,,FIRST+1'
BLT 1,@1(16) ;SET BLOCK TO VALUE
ADD 16,ARGS. ;SKIP ARGS. ON RETURN
JRA 16,(16) ;RETURN WITH 'VALUE' OR 0 IN REGISTER 0
SAVREG::0 ;INTVAR=SAVREG(ARRAY) -- RETURNS 0
MOVEM 16,SAVZER# ;SAVE REGISTER 16
MOVEI 16,@(16) ;GET ADDRESS OF ARRAY INTO REGISTER 16
BLT 16,17(16) ;SAVE REGISTERS 0-17 IN ARRAY - ARRAY+17
MOVE SAVREG ;GET THE CORRECT VALUE FOR REGISTER 16
MOVEM 16(16) ;STUFF IT WHERE IT BELONGS IN THE ARRAY
SETZ 0 ;RETURN 0 IN REGISTER 0
MOVE 16,SAVZER ;RESTORE REGISTER 16 FOR RETURN
JRA 16,1(16) ;RETURN
RSTREG::0 ;INTVAR=SAVREG(ARRAY)
MOVEM 16,RSTREG ;SAVE REGISTER 16 FOR RETURN
MOVSI 17,@(16) ;GET ADDRESS OF ARRAY INTO REGISTER 17
BLT 17,17 ;GET REGISTERS 0-17 FROM ARRAY - ARRAY+17
EXCH 16,RSTREG ;RESTORE REGISTER 16, AND LOOK TO JRA
JRA 16,1(16) ;RETURN C(ARRAY[0]) AS RESULT
PRGEND ;END OF SET
TITLE FIO6 -- FORTRAN - MACHINE LANGUAGE INTERFACE
ENTRY RAD50,RADX50,ASCI50,SIX50
EXTERNAL ARGCNT,SIXBIT,ASCII
RAD50:: 0 ;INTVAR=RAD50('ASCIZ'(,BITS))
MOVE (16) ;FIRST CONVERT 'ASCIZ'
HRRM .+2 ;FROM ASCII TO SIXBIT
JSA 16,SIXBIT ;WITH OUR HANDY SIXBIT ROUTINE
JUMP ;ADDRESS FILLED IN 2 LOCATIONS BACK
JRST .+3 ;SKIP OVER SIXBIT ENTRY
RADX50::0 ;INTVAR=RADX50(SIXBIT(,BITS))
MOVE @(16) ;GET SIXBIT INTO REGISTER 0
MOVEM 2,SAVZER# ;SAVE CONTENTS OF REGISTER 2
MOVEM 2 ;'CAUSE WE'RE PUTTING SIXBIT THERE
JSA 16,ARGCNT ;NOW COUNT THE NUMBER OF ARGS.
MOVEM ARGS.# ;SAVE COUNT
SETZ ;ZERO REGISTER 0 FOR RADIX 50 SYMBOL
RDX50: SETZ 1, ;ZERO REGISTER 1 ...
LSHC 1,6 ;THEN SHIFT THE NEXT CHARACTER INTO 1
JUMPE 1,R50 ;BLANK IS OK
CAIGE 1,20 ;IS CHAR ONE OF: ., %, $ ?
JRST SPCIAL ;COULD BE
CAILE 1,32 ;IS CHAR A LETTER ?
JRST LETTER ;YES, OR ELSE IS GREATER THAN Z
SUBI 1,17 ;MUST BE A NUMBER, CONVERT APPROPRIATELY
R50: IMULI 50 ;MULTIPLY PREVIOUS JUNK ...
ADD 1 ;AND ADD IN NEW CHARACTER
JUMPN 2,RDX50 ;GO BACK FOR MORE
MOVE 2,SAVZER ;RESTORE REGISTER 2
MOVE 1,ARGS. ;CHECK THE NUMBER OF ARGS.
CAIGE 1,2 ;BITS SPECIFIED ?
TRZA 1,17 ;NOPE, ZERO'S GO INTO BITS
MOVE 1,@1(16) ;YES, PUT INTO SYMBOL
DPB 1,[POINT 4,0,3] ;BITS GO INTO 0-3 OF WORD
ADD 16,ARGS. ;WANT TO SKIP ARGS.
JRA 16,(16) ;GOOD DEED FOR THE DAY DONE, NOW RETURN
SPCIAL: CAIE 1,16 ;IS CHAR A . ?
CAIN 1,4 ;OR PERHAPS A $ ?
JRST .+2 ;FAR OUT, IT IS !
MOVEI 1,5 ;ASSUME IT'S A %
ADDI 1,42 ;CONVERT IT PROPERLY
JRST R50 ;NOW GO ADD IT IN
LETTER: CAIL 1,41 ;BETWEEN SIXBIT 41
CAILE 1,72 ;AND SIXBIT 72 ARE LETTERS
JRST .-5 ;OTHERWISE USE %
SUBI 1,26 ;CONVERT TO RADIX 50
JRST R50 ;AND ADD IT IN
ASCI50::0 ;CMPXVR=ASCI50(RADI50,BITS)
MOVEI .+3 ;FOR ADDRESS OF ARGUMENTS
PUSH (16) ;GET RADX50 SYMBOL ADDRESS
PUSH 1(16) ;GET CODE BITS ADDRESS
JSA 16,SIX50 ;NOW CALL RADX50 TO SIXBIT CONVERTER
JUMP 0 ;ADDRESS FILLED IN ABOVE
JUMP 0 ;DITTO
MOVEM SAVZER# ;PUT SIXBIT IN ADDRESS
JSA 16,ASCII ;CALL SIXBIT TO ASCII CONVERTER
JUMP SAVZER# ;ACTUALLY, THE CALLER SHOULD DO THIS
JRA 16,2(16) ;OH WELL, TOO LATE NOW - SO RETURN
SIX50:: 0 ;INTVAR=SIX50(RADI50,BITS)
MOVEM 2,SAVZER# ;WE NEED TO USE THIS REGISTER
MOVEM 3,SAVONE# ;WE ALSO USE THIS ONE
MOVE @(16) ;GET THE SYMBOL
SETZB 1,3 ;ZERO TO GET CODE BITS AND SIXBIT
ROTC 4 ;PUT CODE BITS INTO REGISTER 1
MOVEM 1,@1(16) ;STASH CODE BITS
LSH -4 ;PUT WORD BACK INTO POSITION
CONV50: IDIVI 50 ;UNPACK CHAR. INTO REGISTER 1
SETZ 2, ;ZERO TO GET CHAR. NO.
LSHC 1,-2 ;CHAR. MOD 4
ROT 2,2 ;IN PROPER PLACE
EXCH 1,2 ;SO FINAL SHIFT WORKS
MOVE 2,TAB650(2) ;GET RIGHT WORD
AOJ 1, ;ADD ONE TO INDEX OF CHAR.
IMULI 1,6 ;CALCULATE AMOUNT OF SHIFT
ROT 2,(1) ;ROTATE SIXBIT CHAR. INTO POSITION
LSHC 2,-6 ;APPEND CHAR. TO SIXBIT SYMBOL
JUMPN CONV50 ;LOOP FOR MORE OF SYMBOL
MOVE 3 ;GET SIXBIT SYMBOL INTO REGISTER 0
MOVE 2,SAVZER# ;RESTORE THIS REGISTER
MOVE 3,SAVONE# ;WE ALSO USED THIS ONE
JRA 16,2(16) ;RETURN
TAB650: BYTE (6) 00,20,21,22 ;BLANK,0-2
BYTE (6) 23,24,25,26 ;3-6
BYTE (6) 27,30,31,41 ;7-9,A
BYTE (6) 42,43,44,45 ;B-E
BYTE (6) 46,47,50,51 ;F-I
BYTE (6) 52,53,54,55 ;J-M
BYTE (6) 56,57,60,61 ;N-Q
BYTE (6) 62,63,64,65 ;R-U
BYTE (6) 66,67,70,71 ;V-Y
BYTE (6) 72,16,04,05 ;Z,.,$,%
PRGEND ;END OF SET
TITLE FIO7 -- FORTRAN - MACHINE LANGUAGE INTERFACE
ENTRY OPEN,INIT,RENAME,ENTER,LOOKUP,RELEA,CLOSE,IN,OUT
ENTRY INPUT,OUTPUT,STATO,STATZ,GETCHA
EXTERNAL ARGCNT,SIXBIT
DEFINE PUTCHA(WH),<
MOVE 1,@(16) ;;GET CHANNEL NUMBER
DPB 1,[POINT 4,WH,12];;PUT INTO INSTRUCTION>
OPEN:: 0 ;LGVAR=OPEN(CHANNEL,ARRAY3)
PUTCHA (INS) ;PUT CHANNEL NUMBER INTO UUO INSTRUCTION
SETZ ;ZERO REGISTER 0 FOR NO ERROR RETURN
INS: OPEN @1(16) ;DO OPEN UUO USING ADDRESS OF 3 WORD BLOCK
SETO ;RETURN A -1 (.TRUE.) IF ERROR
JRA 16,2(16) ;RETURN
INIT:: 0 ;LGVAR=INIT(CHAN,STATUS(,'LDEV',OBUF,IBUF))
JSA 16,ARGCNT ;GET THE NUMBER OF ARGUMENTS
MOVEM ARGS.# ;SAVE COUNT
PUTCHA (INST) ;PUT CHANNEL NUMBER INTO OPEN INSTRUCTION
MOVE @1(16) ;GET STATUS WORD
MOVEM ARGBLK ;MOVE TO FIRST WORD OF UUO ARGUMENT BLOCK
MOVSI 'DSK' ;IF DEVICE IS NOT SPECIFIED USE 'DSK'
MOVEM ARGBLK+1 ;STORE IN SECOND WORD OF ARG. BLOCK
SETZM ARGBLK+2 ;ZERO BUFFER SPECIFIER IN CASE OMITTED
MOVE 1,ARGS. ;CHECK NUMBER OF ARGS.
CAIGE 1,3 ;IS THERE REALLY AN ARGUMENT ?
JRST INST-1 ;NO, ONLY CHAN AND STATUS, USE 'DSK'
MOVE 2(16) ;GET ADDRESS OF ASCII DEVICE NAME
HRRM .+2 ;PASS ON TO SIXBIT CONVERTER
JSA 16,SIXBIT ;GET DEVICE NAME IN SIXBIT
JUMP ;ADDRESS FILLED IN 2 INSTRUCTIONS BACK
MOVEM ARGBLK+1 ;MOVE SIXBIT NAME TO SECOND WORD OF BLOCK
MOVE 1,ARGS. ;CHECK NUMBER OF ARGS.
CAIGE 1,4 ;IS THERE REALLY AN ARGUMENT ?
JRST INST-1 ;NO, OBUF & IBUF WEREN'T SPECIFIED
MOVE 3(16) ;GET OBUF ADDRESS
LDB 1,[POINT 7,@,6] ;CHECK CONTENTS OF ADDRESS
CAIE 1,"0" ;IF ARGUMENT WASN'T LITERAL '0' ...
HRLM ARGBLK+2 ;OBUF GOES INTO LEFT HALF-WORD
MOVE 1,ARGS. ;CHECK NUMBER OF ARGS.
CAIGE 1,5 ;IS THERE REALLY AN ARGUMENT ?
JRST INST-1 ;NO, IBUF WASN'T SPECIFIED
MOVE 4(16) ;GET IBUF ADDRESS
LDB 1,[POINT 7,@,6] ;CHECK CONTENTS OF ADDRESS
CAIE 1,"0" ;IF ARGUMENT WASN'T LITERAL '0' ...
HRRM ARGBLK+2 ;IBUF GOES INTO RIGHT HALF-WORD
SETZ ;REGISTER 0 IS 0 (.FALSE.) FOR GOOD RETURN
INST: OPEN ARGBLK ;TRY TO OPEN CHANNEL
SETO ;ERROR RETURNS -1 (.TRUE.) IN REGISTER 0
ADD 16,ARGS. ;WANT TO SKIP ARGUMENTS
JRA 16,(16) ;RETURN
ARGBLK: BLOCK 4 ;ARGUMENT BLOCK FOR INIT,LOOKUP,ETC.
RENAME::0 ;INTVAR=RENAME(CHANNEL,NAME,EXT(,PRJ,PRG))
MOVSI 55000 ;INTVAR=RENAME(CHANNEL,ARRAY)
MOVEM SAVINS# ;SAVE INSTRUCTION
JRST RELUUO ;GO TO COMMON PORTION
ENTER:: 0 ;INTVAR=ENTER(CHANNEL,NAME,EXT(,PRJ,PRG))
MOVSI 77000 ;INTVAR=ENTER(CHANNEL,ARRAY)
MOVEM SAVINS# ;SAVE INSTRUCTION
JRST RELUUO ;COMMON TO RENAME, ENTER AND LOOKUP UUO'S
LOOKUP::0 ;INTVAR=LOOKUP(CHANNEL,NAME,EXT(,PRJ,PRG))
MOVSI 76000 ;INTVAR=LOOKUP(CHANNEL,ARRAY)
MOVEM SAVINS# ;SAVE INSTRUCTION
RELUUO: JSA 16,ARGCNT ;GET THE NUMBER OF ARGUMENTS
MOVEM ARGS.# ;SAVE COUNT
MOVE 1(16) ;GET THE ADDRESS OF THE SECOND ARGUMENT
MOVE 1,ARGS. ;CHECK THE NUMBER OF ARGUMENTS
CAIGE 1,3 ;ARE MORE THAN 2 ARGUMENTS SPECIFIED ?
JRST EXECUT ;NO, CALLED WITH RELINS(CHANNEL,ARRAY)
HRRM NOT6-1 ;YES, CONVERT NAME TO SIXBIT
MOVE @1(16)
TLNN 774000
JRST NOT6 ; EXCEPT MAYBE IF IT IS A PPN
JSA 16,SIXBIT
JUMP ;ADDRESS WAS FILLED IN 2 LOCATIONS AGO
NOT6: MOVEM ARGBLK ;STORE NAME IN 1ST WORD OF SPECS
MOVE 2(16) ;GET THE ADDRESS OF THE EXTENSION
HRRM .+2 ;PASS ADDRESS TO CONVERSION ROUTINE
JSA 16,SIXBIT ;CONVERT TO SIXBIT
JUMP ;ADDRESS WAS FILLED IN 2 LOCATIONS AGO
HLLZM ARGBLK+1 ;STORE EXTENSION IN 2ND WORD OF SPECS
GETPPN ;GET HIS PPN IN REGISTER ZERO
JFCL ;NO DIFFERENCE TO US IF SKIP RETURN
MOVE 1,ARGS. ;CHECK THE NUMBER OF ARGS.
CAIGE 1,4 ;PPN SPECIFIED ?
JRST .+5 ;NO, USE HIS PPN
HRL @3(16) ;GET THE PROJECT NUMBER
MOVE 1,ARGS. ;CHECK THE NUMBER OF ARGS.
CAIL 1,5 ;PROGRAMMER NUMBER SPECIFIED ?
HRR @4(16) ;YES, GET PROGRAMMER NUMBER
MOVEM ARGBLK+3 ;STORE PPN IN 4TH WORD OF SPECS BLOCK
SETZM ARGBLK+2 ;NO INFORMATION HERE
MOVEI ARGBLK
EXECUT: PUTCHA (SAVINS#) ;PUT CHANNEL NUMBER INTO INSTRUCTION
HRRM SAVINS# ;PUT ADDRESS OF ARGUMENTS INTO INSTRUCTION
SETZ ;SET REGISTER 0 TO .FALSE. FOR GOOD RETURN
ADD 16,ARGS. ;WANT TO SKIP ARGUMENTS
INSTR: XCT SAVINS# ;CHANNEL AND ADDRESS ARE FILLED IN
SKIPA 1,SAVINS ;ON ERROR RETURN, WE WANT TO DO MORE
JRA 16,(16) ;RETURN
MOVE (1) ;GET THE 1ST WORD OF THE ARGUMENT BLOCK
JUMPE .+3 ;(0 NAME - MUST HAVE BEEN RENAME)
TLNN -1 ;IS IT A FILE NAME OR A NUMBER ?
ADDI 1,2 ;A NUMBER INDICATES EXTENDED LOOKUP
HRRZ 1(1) ;GET ERROR CODE
AOJ ;ADD 1 TO INSURE NON-ZERO
MOVNS ;NEGATE TO TURN ON SIGN BIT
JRA 16,(16) ;RETURN WITH ERROR CODE IN REGISTER 0
RELEA:: 0 ;INTVAR=RELEA(CHANNEL) -- RETURNS 0
PUTCHA (<.+1>) ;PUT CHANNEL NUMBER INTO UUO
RELEASE ;EXECUTE UUO
SETZ ;RETURN RESULT OF 0 IN REGISTER 0
JRA 16,1(16) ;RETURN TO CALLING PROGRAM
CLOSE:: 0 ;INTVAR=CLOSE(CHANNEL(,ARG)) -- RETURNS 0
JSA 16,ARGCNT ;GET THE NUMBER OF ARGUMENTS
MOVEM ARGS.# ;SAVE COUNT
MOVSI 70000 ;GET CLOSE UUO INTO REGISTER 0
PUTCHA (0) ;ADD THE CHANNEL NUMBER
MOVE 1,ARGS. ;CHECK THE NUMBER OF ARGS.
CAIL 1,2 ;IS THE 2ND ARGUMENT REALLY SPECIFIED ?
HRR @1(16) ;YES, ADD NUMBER TO INSTRUCTION
XCT ;EXECUTE THE CLOSE
SETZ ;RETURN 0 IN REGISTER 0
ADD 16,ARGS. ;WANT TO SKIP ARGUMENTS
JRA 16,(16) ;RETURN TO CALLING PROGRAM
IN:: 0 ;LGVAR=IN(CHANNEL(,LOC(ADDRESS)))
JSA 16,ARGCNT ;GET THE NUMBER OF ARGUMENTS
MOVEM ARGS.# ;SAVE COUNT
MOVSI 56020 ;USE "IN @" INSTRUCTION
JRST INOUT ;GO TO COMMON CODE
OUT:: 0 ;LGVAR=IN(CHANNEL(,LOC(ADDRESS)))
JSA 16,ARGCNT ;GET THE NUMBER OF ARGUMENTS
MOVEM ARGS.# ;SAVE COUNT
MOVSI 57020 ;USE "OUT @" INSTRUCTION
INOUT: MOVE 1,ARGS. ;CHECK THE NO. OF ARGS.
CAIGE 1,2 ;ADDRESS SPECIFIED ?
TLZ 20 ;NO, ZAP INDIRECT BIT
JRST INOUTP+1 ;GO TO EVEN MORE COMMON CODE
INPUT:: 0 ;LGVAR=INPUT(CHANNEL(,ADDRESS))
JSA 16,ARGCNT ;GET THE NUMBER OF ARGUMENTS
MOVEM ARGS.# ;SAVE COUNT
MOVSI 56000 ;USE "IN" INSTRUCTION
JRST INOUTP ;GO TO COMMON CODE
OUTPUT::0 ;LGVAR=OUTPUT(CHANNEL(,ADDRESS))
JSA 16,ARGCNT ;GET THE NUMBER OF ARGUMENTS
MOVEM ARGS.# ;SAVE COUNT
MOVSI 57000 ;USE "OUT" INSTRUCTION
INOUTP: MOVE 1,ARGS. ;CHECK THE NUMBER OF ARGS.
CAIL 1,2 ;ADDRESS SPECIFIED ?
HRR 1(16) ;YES, ADD TO INSTRUCTION
PUTCHA (0) ;PUT CHANNEL NUMBER INTO INSTRUCTION
XCT ;PERFORM UUO
SKIPA 1,[0] ;GOOD RETURN RETURNS 0 IN REGISTER 0
SETO 1, ;ERROR RETURN RETURNS -1 (.TRUE.)
MOVE 1 ;MOVE -1 OR 0 INTO REGISTER 0
ADD 16,ARGS. ;WANT TO SKIP ARGS.
JRA 16,(16) ;RETURN
STATO:: 0 ;LGVAR=STATO(CHANNEL,BITS)
MOVSI 61000 ;STATO UUO
JRST .+3 ;GO TO COMMON CODE
STATZ:: 0 ;LGVAR=STATZ(CHANNEL,BITS)
MOVSI 63000 ;STATZ UUO
PUTCHA (0) ;ADD THE CHANNEL NO. TO THE UUO
HRR @1(16) ;ADD THE BITS TO BE TESTED
MOVEM 1 ;PUTCHA USES 1 SO COULDN'T ASSEMBLE THERE
SETO 0 ;RETURN .TRUE. (-1) IF SKIPPED
XCT 1 ;EXECUTE THE UUO
SETZ 0 ;RETURN .FALSE. (0) IF NO SKIP
JRA 16,2(16) ;RETURN WITH RESULT IN REGISTER 0
GETCHA::0 ;INTVAR=GETCHA(0) - RETURNS -1 IF NONE FREE
MOVEI 17 ;START LOOKING WITH CHANNEL 17
MOVEM 1 ;CHANNEL TO BE TESTED IN REGISTER 0
DEVNAM 1, ;USE THE DEVICE NAME UUO
JRA 16,1(16) ;CHANNEL NOT INITED, I.E., IT'S A FREE ONE
SOJGE .-3 ;GOOD RETURN, CHANNEL INIT'ED SO CONTINUE
JRA 16,1(16) ;NO FREE CHANNELS, RETURN A -1
PRGEND ;END OF SET
TITLE FIO8 -- FORTRAN - MACHINE LANGUAGE INTERFACE
ENTRY INBUF,OUTBUF,GETSTS,SETSTS,MTAPE,UGETF,USETI,USETO
DEFINE PUTCHA(WH),<
MOVE 1,@(16) ;;GET CHANNEL NUMBER
DPB 1,[POINT 4,WH,12];;PUT INTO INSTRUCTION>
INBUF:: 0 ;INTVAR=INBUF(CHAN,NUMBER) -- RETURNS 0
MOVSI 64000 ;PUT INBUF INSTRUCTION IN REGISTER 0
JRST .+3 ;JUMP TO COMMON CODE
OUTBUF::0 ;INTVAR=OUTBUF(CHAN,NUMBER) -- RETURNS 0
MOVSI 65000 ;PUT OUTBUF INSTRUCTION IN REGISTER 0
PUTCHA (0) ;PUT CHANNEL NUMBER INTO INSTRUCTION
HRR @1(16) ;PUT NUMBER OF BUFFERS INTO INSTRUCTION
XCT ;EXECUTE THE INSTRUCTION
SETZ ;AND RETURN A 0 RESULT IF A FUNCTION CALL
JRA 16,2(16) ;RETURN
GETSTS::0 ;INTVAR=GETSTS(CHANNEL)
PUTCHA (<.+1>) ;PUT CHANNEL NUMBER INTO UUO
GETSTS ;GET STATUS WORD IN REGISTER 0
JRA 16,1(16) ;RETURN
SETSTS::0 ;INTVAR=SETSTS(CHANNEL,STATUS)
PUTCHA (<.+3>) ;PUT CHANNEL NUMBER INTO UUO
MOVE @1(16) ;GET STATUS WORD INTO REGISTER 0
HRRM .+1 ;ADD IT TO INSTRUCTION
SETSTS ;SET STATUS WORD
JRA 16,2(16) ;RETURN WITH STATUS WORD IN REGISTER 0
MTAPE:: 0 ;INTVAR=MTAPE(CHANNEL,N)
MOVSI 72000 ;MTAPE UUO
PUTCHA (0) ;ADD THE CHANNEL NO. TO THE UUO
HRR @1(16) ;ADD THE FUNCTION NUMBER
XCT 0 ;EXECUTE MTAPE UUO
SETZ 0 ;RETURN 0 IN REGISTER 0
JRA 16,2(16) ;RETURN
UGETF:: 0 ;INTVAR=UGETF(CHANNEL)
PUTCHA (<.+1>) ;PUT CHANNEL NO. INTO UUO
UGETF ;GET FREE BLOCK NO. IN REGISTER 0
JRA 16,1(16) ;RETURN
USETI:: 0 ;INTVAR=USETI(CHANNEL,IBLKNO) -- RETURNS 0
MOVSI 74000 ;USETI UUO
JRST .+3 ;GO TO COMMON CODE
USETO:: 0 ;INTVAR=USETO(CHANNEL,IBLKNO) -- RETURNS 0
MOVSI 75000 ;USETO UUO
PUTCHA (0) ;ADD THE CHANNEL NO. TO UUO
HRR @1(16) ;ADD BLOCK NUMBER TO INPUT OR OUTPUT NEXT
XCT 0 ;EXECUTE THE UUO
SETZ 0 ;RETURN 0 IN REGISTER 0
JRA 16,2(16) ;RETURN
PRGEND ;END OF SET
TITLE FIO9 -- FORTRAN - MACHINE LANGUAGE INTERFACE
ENTRY INCHRW,OUTCHR,INCHRS,OUTSTR,INCHWL,INCHSL,GETLCH
ENTRY SETLCH,RESCAN,CLRBFI,CLRBFO,SKPINC,SKPINL,IONEOU
EXTERNAL ARGCNT
RETURN: MOVEM SAVZER# ;RETURNS SKIPPING ARGUMENTS
JSA 16,ARGCNT ;COUNT NUMBER OF ARGUMENTS
ADD 16,0 ;SKIP ARGS. ON RETURN
MOVE SAVZER ;RESTORE REGISTER 0
JRA 16,(16) ;RETURN
INCHRW::0 ;ICHAR=INCHRW -- RETURNS RESULT OF INCHRW
TTCALL 0, ;GET A CHARACTER FROM TTY
JRST RETURN ;RETURN WITH RESULT IN REGISTER 0
OUTCHR::0 ;INTVAR=OUTCHR(ICHAR) -- RETURNS 0
TTCALL 1,@(16) ;OUTPUT CHARACTER
SETZ ;RETURN 0 IN REGISTER 0
JRST RETURN ;RETURN
INCHRS::0 ;LGVAR=INCHRS -- RETURNS -1 IF NO SKIP
TTCALL 2, ;GET CHARACTER IN REGISTER 0
SETO ;RETURN .TRUE. IF NO CHARACTER INPUTTED
JRST RETURN ;RETURN
OUTSTR::0 ;INTVAR=OUTSTR('ASCIZ STRING') -- RETURNS 0
TTCALL 3,@(16) ;TYPE OUT ASCIZ STRING (STOP ON NULL)
SETZ ;RETURN 0 IN REGISTER 0
JRST RETURN ;RETURN
INCHWL::0 ;ICHAR=INCHWL -- RETURNS RESULT OF INCHWL
TTCALL 4, ;GET CHARACTER INTO REGISTER 0
JRST RETURN ;RETURN
INCHSL::0 ;LGVAR=INCHSL -- RETURNS -1 IF NO SKIP
TTCALL 5, ;GET NEXT CHARACTER ON LINE
SETO ;NO MORE LINE, RETURN -1
JRST RETURN ;RETURN CHARACTER OR .TRUE. IN REGISTER 0
GETLCH::0 ;INTVAR=GETLCH((LINE))
JSA 16,ARGCNT ;GET THE NUMBER OF ARGS.
MOVEM 1 ;SAVE COUNT
SETO ;IF NO LINE NUMBER USE HIS LINE
SOSL 1 ;CHECK THE NUMBER OF ARGS.
MOVE @(16) ;GET LINE NUMBER IN REGISTER 0
TTCALL 6, ;GET LINE CHARACTERISTICS INTO REGISTER 0
ADD 16,1 ;WANT TO SKIP ARGUMENTS
JRA 16,1(16) ;RETURN
SETLCH::0 ;INTVAR=SETLCH(IWORD) -- RETURNS 0
MOVE @(16) ;GET WORD INTO REGISTER 0
TTCALL 7, ;SET LINE CHARACTERISTICS FROM REGISTER 0
SETZ ;RETURN 0 IN REGISTER 0
JRST RETURN ;RETURN
RESCAN::0 ;INTVAR=RESCAN(IBIT)
HRRZ 1,@(16) ;IBIT USED AS EFFECTIVE ADDRESS
SETO ;RETURN -1 IF NO COMMAND IN BUFFER
TTCALL 10,(1) ;TELL MONITOR TO RESCAN INPUT BUFFER
SETZ ;RETURN 0 IF COMMAND IN BUFFER
JRST RETURN ;RETURN
CLRBFI::0 ;INTVAR=CLRBFI -- RETURNS 0
TTCALL 11, ;CLEAR INPUT BUFFER
SETZ ;RETURN 0 IN REGISTER 0
JRST RETURN ;RETURN
CLRBFO::0 ;INTVAR=CLRBFO -- RETURNS 0
TTCALL 12, ;CLEAR OUTPUT BUFFER
SETZ ;RETURN 0 IN REGISTER 0
JRST RETURN ;RETURN
SKPINC::0 ;LGVAR=SKPINC -- RETURNS -1 IF CHAR. TYPED
SETO ;RETURN -1 IN REGISTER 0 IF NO CHAR.
TTCALL 13, ;HAS A CHARACTER BEEN TYPED ?
SETZ ;NO, RETURN 0
JRST RETURN ;RETURN
SKPINL::0 ;LGVAR=SKPINL -- RETURNS -1 IF LINE TYPED
SETO ;RETURN -1 IN REGISTER 0 IF NO LINE
TTCALL 14, ;IS A LINE AVAILABLE FOR TTY INPUT ?
SETZ ;NO, RETURN 0
JRST RETURN ;RETURN
IONEOU::0 ;INTVAR=IONEOU(ICHAR) -- RETURNS 0
TTCALL 15,@(16) ;SEND THE CHARACTER IN IMAGE MODE
SETZ ;RETURN 0 IN REG
JRST RETURN ;RETURN
PRGEND ;END OF SET
TITLE FIO5 -- FORTRAN - MACHINE LANGUAGE INTERFACE
ENTRY ARGCNT,ARGREF,SIXBIT,ASCII ; *** MUST FOLLOW THE REST ***
ARGCNT::0 ;INTVAR=ARGCNT(0)
HRRZ 1,ARGCNT ;GET ADDRESS OF 1ST ARG., ZERO COUNT
COUNT.: LDB [POINT 9,(1),8] ;LOOK AT OP CODE
JUMPE .+2 ;IF A ZERO THEN IT'S AN IMP ARG.
CAIN 320 ;IF A "JUMP" THEN IT'S A FORTRAN ARG.
AOBJP 1,COUNT. ;IF AN ARG., INCREMENT COUNT AND ADDRESS
HLRZ 1 ;IF NOT AN ARG., PUT COUNT IN REGISTER 0
JRA 16,(16) ;RETURN
ARGREF::0 ;INTVAR=ARGREF(N)
HRRZ 1,ARGREF ;GET START OF ARGUMENT LIST
ADD 1,@(16) ;ADD N TO GET POSITION OF DESIRED ARG.
MOVE 1-1(1) ;GET ADDRESS OF ARG. INTO REGISTER 0
JRA 16,1(16) ;RETURN
SIXBIT::0 ;INTVAR=SIXBIT('ASCIZ.')
MOVSI 440700 ;SETUP POINTER TO GET CHARACTERS
HRR (16)
MOVEM PNTR7#
MOVE [POINT 6,0] ;SETUP POINTER TO STUFF SIXBIT CHARACTERS
MOVEM PNTR6#
SETZ ;ZERO REGISTER 0 FOR ACCUMULATING SIXBIT
GETBYT: ILDB 1,PNTR7 ;GET THE NEXT CHARACTER
SKIPN 1 ;IF A ZERO QUIT
JRA 16,1(16) ;AND RETURN SIXBIT IN REGISTER 0
CAIGE 1,140 ;CONVERT LOWER-CASE CHARACTERS
SUBI 1," " ;CONVERT TO SIXBIT
IDPB 1,PNTR6 ;STUFF CHARACTER IN REGISTER 0
MOVE 1,PNTR6 ;CHECK FOR SIX CHARACTERS PROCESSED
CAME 1,[600,,0]
JRST GETBYT ;MORE TO GO
JRA 16,1(16) ;SIX CHARACTERS -- DONE
ASCII:: 0 ;CMPXVR=ASCII(SIXBIT)
MOVE [POINT 7,ASCII.];SETUP POINTER TO RESULT ARRAY
MOVEM PNTR7#
MOVE 1,@(16) ;GET SIXBIT
SETZM ASCII. ;CLEAR FIRST RESULT WORD
SETZM ASCII.+1 ;CLEAR SECOND RESULT WORD
SETZ ;ZERO REGISTER 0
LSHC 6 ;SHIFT THE NEXT CHARACTER INTO REGISTER 0
ADDI " " ;CONVERT IT TO ASCII
IDPB PNTR7 ;ADD TO RESULT STRING
JUMPN 1,.-4 ;LOOP IF NON-BLANK CHARACTERS LEFT
IDPB 1,PNTR7 ;ASSURE NULL CHARACTER AT THE END
MOVE ASCII. ;GET FIRST WORD INTO REGISTER 0
MOVE 1,ASCII.+1 ;GET SECOND WORD INTO REGISTER 1
JRA 16,1(16) ;AND RETURN
ASCII.: BLOCK 2 ;TEMPORARY STORAGE OF RESULT STRING
END ;END OF FILE