Trailing-Edge
-
PDP-10 Archives
-
BB-4157E-BM
-
fortran-compiler/comman.mac
There are 8 other files named comman.mac in the archive. Click here to see a list.
TITLE FTNCMD - COMMAND SCANNER INTERFACE FOR FORTRAN COMPILER
SUBTTL /DCE/EGM/EDS/TFV
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) 1972,1981 BY DIGITAL EQUIPMENT CORPORATION
;AUTHOR: Dave Eklund
INTERN COMMAV
COMMAV= BYTE (3)0(9)6(6)0(18)^D113 ; Version Date: 28-Sep-81
TWOSEG
SUBTTL Revision History
Comment \
***** Begin Revision History *****
***** Begin Version 5B *****
-- 656 25246 PROTECTION FAILURES NOT REPORTED, (DCE)
-- 704 26390 FIX DEFAULT BUFFER SIZE (IF DEVSIZ FAILS)
-- 723 ----- ADD /NOWARN SELECTIVITY, (DCE)
***** Begin Version 6 *****
-- 760 TFV 1-Jan-80 -----
Make /KA and /KI switchs errors.
100 762 EGM 22-Apr-80 -----
Move Revision History to REVHST.MAC
101 767 DCE 20-May-80 -----
Rewrite the bulk of the Command Scanner module.
In particular, make feature testing cleaner.
Fix various problems with /GFL and add /F77 (future).
Merge as much of the TOPS-10 and TOPS-20 code as possible.
102 1001 EGM 30-Jun-80 -----
Replace SEARCH of C with UUOSYM,MACTEN. Replace LINK command file
references to SCAN, WILD, and HELPER with MACRO .REQUESTs.
103 1043 EGM 19-Jan-81 20-15466
Add CAO (Consecutive arith ops illegal) to nowarn keyword table
104 1047 EGM 22-Jan-81 Q10-05323
Add support for TOPS-10 execute only.
105 1053 EDS 11-Feb-81 -----
Make FORTRA a global symbol.
106 1061 DCE 9-Apr-81 -----
Add PSR (Pound sign in Random access illegal) to noward table
107 1065 EGM 7-May-81 Q10-05053
Replace M.XXXX SCAN macros with FORTRAN specific ones. Do not
attempt to handle all the cases, or 10 type message standard.
109 1115 EGM 31-Jul-81 --------
Rework /NOWARN for expandability, and efficiency.
110 1117 EGM 26-Aug-81
Add additional TOPS-10 EXO support code to allow lifting fixed high seg
origin restrictions.
111 1121 EGM 9-Sep-81 --------
Add code to get GETSEG parameters from GETTABs, and store path info.
Also update several comments concerning initialization.
113 1133 TFV 28-Sep-18 ------
Add /STATISTICS flag for in-house performance measurement. It is
disabled in the released V6.
***** End Revision History *****
\
PAGE
SUBTTL REQUIRED UNIVERSAL FILES
ENTRY NXTFIL ;ONLY USED IN MAIN.BLI
SEARCH FTTENX ;ASSEMBLY TIME SWITCHES
IFN FTTENX,< SEARCH MONSYM >
SEARCH UUOSYM,MACTEN,SCNMAC ;[1001]
SEARCH GFOPDF ;GFLOATING OPCODES
IFN FTTENX,< .REQUEST SYS:SCAN ;[1001]
.REQUEST SYS:HELPER> ;[1001]
IFE FTTENX,< .REQUEST REL:SCAN ;[1001]
.REQUEST REL:WILD ;[1001]
.REQUEST REL:HELPER> ;[1001]
IF2,<
IFE FTTENX, <PRINTX ASSEMBLING FORTRAN-10 COMMAN>
IFN FTTENX, <PRINTX ASSEMBLING FORTRAN-20 COMMAN>
>
PAGE
SUBTTL SYMBOLIC DEFINITIONS
RELOC 400000
;AC'S USED BY COMMAND SCANNER
F=0 ;FLAGS
T1=1 ;TEMP
T2=2 ; ..
T3=3 ; ..
T4=4 ; ..
P1=5 ;PRESERVED AC
P2=6 ; ..
N=7 ;NUMBER AC
C=10 ;CHARACTER AC
VREG=15 ;BLIS10 VALUE RETURN REG
FREG=16 ;STACK FRAME POINTER
P=17 ;PUSH DOWN POINTER
;I/O CHANNELS
BIN==1 ;REL FILE OUTPUT
LST==2 ;LISTING FILE OUTPUT
SRC==3 ;SOURCE FILE INPUT
ICL==4 ;INCLUDE FILE INPUT
;OFFSETS INTO CHNLTBL
TBLMAX==^D10
JFN==0
HDR==3
PNT==4
CNT==5
;FLAG BITS IN F (SEE IOFLG.BLI BEFORE CHANGING THESE BITS)
SW.OPT==1B35 ;GLOBAL OPTIMIZE
SW.NET==1B34 ;NO ERRORS ON TTY
SW.MAC==1B33 ;MACRO CODE
SW.IDS==1B32 ;INCLUDE DEBUG STATEMENTS
SW.EXP==1B31 ;EXPAND
SW.DEB==1B30 ;DEBUG
SW.CRF==1B29 ;CREF
EOCS==1B28 ;END OF COMMAND STRING
LSTFLG==1B25 ;LISTING FILE BEING MADE
SW.KAX==1B24 ;KA-10 FLAG
RELFLG==1B22 ;REL FILE BEING MADE
SW.MAP==1B16 ;LINE NUMBER/OCTAL LOCATION MAP
SW.ERR==1B14 ;FATAL ERRORS DURING COMPILE
SW.OCS==1B13 ;ONLY CHECK SYNTAX
COMKA==1B12 ;COMPILING ON A KA-10
SW.PHO==1B10 ;PEEP HOLE OPTIMIZE
SW.BOU==1B5 ;ARRAY BOUNDS CHECKING SWITCH
SW.NOW==1B2 ;DON'T PRINT WARNING MESSAGES
TTYDEV==1B1 ;LISTING ON TTY:
PAGE
EXTERN FLAGS2 ;SECONDARY FLAG REGISTER (TTYINP,GFMCOK, ETC.)
EXTERN F2 ;USER SETTABLE SWITCHES (GFL, F77, ETC.)
EXTERN DEBGSW
;FLAG BITS IN FLAGS2 (SEE IOFLG.BLI BEFORE CHANGING THESE BITS)
TTYINP==1B0 ;INPUT DEVICE IS A TTY
GFMCOK==1B1 ;GFLOATING MICROCODE PRESENT
;FLAG BITS IN F2 (SEE IOFLG.BLI BEFORE CHANGING THESE BITS)
;THIS FLAG WORD IS RESERVED FOR USER SETTABLE SWITCHES
SW.GFL==1B0 ;Switch for /GFLOATING DP
SW.F77==1B1 ;F77 SELECTED
SW.STA==1B2 ;[1113] /STATISTICS
IFN FTTENX,<
; OPENF BITS
INBYT==440000 ;NON-TTY INPUT BYTE SIZE
BINBYT==440000 ;BINARY BYTE SIZE
LSTBYT==070000 ;LISTING BYTE SIZE
TTYBYT==070000 ;TTY INPUT BYTE SIZE
READ==200000 ;READABLE
WRITEE==100000 ;WRITEABLE
TTCODE==600012 ;TTY: DEVICE CODE
DSKCOD==600000 ;DSK: DEVICE CODE
; DEFAULT GTJFN TABLE FOR LISTING
LSTTAB: GJ%FOU ;FLAGS,VERSION DEFAULT
XWD 377777,377777 ;NO JFN'S
0 ;DEVICE
0 ;DIRECTORY
0 ;FILENAME
XWD -1,[ASCIZ /LST/] ;EXTENSION
0 ;PROTECTION
0 ;ACCOUNT
; DEFAULT GTJFN TABLE FOR BINARY OUTPUT FILE
BINTAB: GJ%FOU ;FLAGS,DEFAULT VERSION
XWD 377777,377777 ;NO JFN'S
0 ;DEVICE
0 ;DIRECTORY
0 ;FILE NAME
XWD -1,[ASCIZ /REL/] ;EXTENSION
0 ;PROTECTION
0 ;ACCOUNT
; DEFAULT TABLE FOR SOURCE INPUT
SRCTAB: GJ%OLD!GJ%IFG ;FLAGS,VERSION DEFAULT
XWD 377777,377777 ;NO JFN'S
0 ;DEV
0 ;DIRECTORY
0 ;FILE NAME
XWD -1,[ASCIZ /FOR/] ;EXTENSION
0 ;PROTECTION
0 ;ACCOUNT
; DEFAULT TABLE FOR INCLUDE INPUT
ICLTAB: GJ%OLD ;FLAGS,VERSION DEFAULT
XWD 377777,377777 ;NO JFN'S
0 ;DEV
0 ;DIRECTORY
0 ;FILE NAME
XWD -1,[ASCIZ /FOR/] ;EXTENSION
0 ;PROTECTION
0 ;ACCOUNT
> ;END TOPS-20 ONLY
PAGE
SUBTTL Compiler Switch Definitions and Defaults
;DEFAULTS FOR SWITCH SETTINGS - ALL CURRENTLY "OFF"
DM ADV,1,0,1
DM BAK,1,0,1
DM BOU,1,0,1
DM BUG,377777,0,1
DM CRF,1,0,1
DM DEB,1,0,1
DM EXP,1,0,1
DM GFL,1,0,1
DM F77,1,0,1
DM INC,1,0,1
DM MAC,1,0,1
DM NOE,1,0,1
DM WEO,1,0,1
DM ZER,1,0,1
DM OPT,1,0,1
DM OCS,1,0,1
DM NOW,1,0,1
DM MAP,1,0,1
DM STA,1,0,1 ;[1133] statistics switch
ND PDLLEN,^D500 + ^D600 ;LENGTH OF PDL
;NOTE THE ADDITION OF 600 OF SPACE TO PDLLEN!!!
;SEE DECLARATION POOLSIZ IN FIRST.BLI
;THIS SPACE WILL ACTUALLY BE OCCUPIED BY
;THE GLOBAL VECTORS STK AND POOL SO THAT
;MORE SPACE FOR THE STACK CAN BE MADE AVAILABLE
;TO HIGHLY RECURSIVE OPERATIONS
;THAT MAY OCCUR IN THE COMPILER
;DEFAULT FLAG SETTINGS (FOR F)
INDADF: EXP <<AD.MAP>_<43-^L<SW.MAP>>> !
<<AD.CRF>_<43-^L<SW.CRF>>> !
<<AD.DEB>_<43-^L<SW.DEB>>> !
<<AD.EXP>_<43-^L<SW.EXP>>> !
<<AD.INC>_<43-^L<SW.IDS>>> !
<<AD.MAC>_<43-^L<SW.MAC>>> !
<<AD.NOE>_<43-^L<SW.NET>>>
;DEFAULT SWITCH SETTINGS FOR F2
INDAD2: EXP <<AD.F77>_<43-^L<SW.F77>>> !
<<AD.GFL>_<43-^L<SW.GFL>>> !
<<AD.STA>_<43-^L<SW.STA>>> ;[1133] /STATISTICS
DEFINE RESETUUO <CALLI 0>
DEFINE RESETJSYS <JSYS 147>
DEFINE RESET <PRINTX ?DO NOT USE RESET - USE RESETUUO OR RESETJSYS>
PAGE
SUBTTL Compiler Switches
DEFINE SWTCHS,<
SP ADVANCE,FAREA+F.ADV,.SWDEC##,ADV
SP BACKSPACE,FAREA+F.BACK,.SWDEC##,BAK
;SP BOUNDS,<POINTR(SAVEF,SW.BOU)>,.SWDEC##,BOU
SP BUGOUT,<POINT 18,BUGINT,35>,.SWOCT##,BUG
SP CROSSREF,<POINTR(SAVEF,SW.CRF)>,.SWDEC##,CRF
SL DEBUG,DEBGSD,BUGK,-1,FS.OBV
SP EXPAND,<POINTR(SAVEF,SW.EXP)>,.SWDEC##,EXP
SN *GFLOATING,<POINTR(SAVE2,SW.GFL)> ;ALLOW /NOGFL
;SN *F77,<POINTR(SAVE2,SW.F77)> ;ALLOW /NOF77
;SS F66,<POINTR(SAVE2,SW.F77)>,0 ;SAME AS /NOF77
SP KA10,<POINTR(SAVEF,SW.KAX)>,KA10SW ;[760] /KA is fatal error
SP KI10,<POINTR(SAVEF,SW.KAX)>,KI10SW ;[760] /KI is obsolete
SP INCLUDE,<POINTR(SAVEF,SW.IDS)>,.SWDEC##,INC
SP *MACROCODE,<POINTR(SAVEF,SW.MAC)>,.SWDEC##,MAC
SP *LNMAP,<POINTR(SAVEF,SW.MAP)>,.SWDEC##,MAP
SP NOERRORS,<POINTR(SAVEF,SW.NET)>,.SWDEC##,NOE
SL NOWARNING,<777700,,NOWARN>,NOW,-1 ;[1115] NOWARN SWITCH AND PROCESSOR
SP *OPTIMIZE,<POINTR(SAVEF,SW.OPT)>,.SWDEC##,OPT
;SN *STATISTICS,<POINTR(SAVE2,SW.STA)> ;[1133] ALLOW /NOSTA
SP *SYNTAX,<POINTR(SAVEF,SW.OCS)>,.SWDEC##,OCS
SP TAPEND,FAREA+F.WEOF,.SWDEC##,WEO
SP ZERO,FAREA+F.DTZR,.SWDEC##,ZER
>
PAGE
;[1115]Keywords that can be used with the /NOWARN switch. Exclusive
;[1115] of ALL and NONE (must be keywords 1 and 2), the rest represent the
;[1115] 3 letter error message mnuemonics for errors defined in ERROUT.BLI.
;[1115] Always add new keywords to the end of the macro.
RELOC ;[1115] Retain in low seg
NWKTB:: ;[1115] Global handle on the table
KEYS NOW,<
ALL,NONE,ZMT,FNA,DIS,MVC,AGA,CUO,NED,LID,DIM,WOP,
VNI,RDI,CTR,CAI,IFL,ICD,SOD,ICC,XCR,ICS,FMR,VND,
NOD,PPS,DXB,VAI,IDN,PAV,SID,IUA,CAO,PSR> ;[1115]
NWKTBC==:.-NWKTB ;[1115] Global keyword count
NWWDCT==<<NWKTBC-1>/^D36>+1 ;[1115] Words needed for bits
RELOC ;[1115] Back to high seg
KEYS BUGK,<DIMENSIONS,LABELS,INDEX,TRACE,BOUNDS>
XALL
DOSCAN(FORT)
SALL
PAGE
SUBTTL Error macros
; Miscellaneous error macros
; These parallel the macros used by SCAN to handle errors
; including the type ahead clearing and re-prompt.
; They use several SCAN typeout routines.
; General Fatal error - continues
; TEXT = Error message text, includes prefix
DEFINE F.FAIL (TEXT) ,<
SKPINL
JFCL
OUTSTR [ASCIZ \
?'TEXT
\]
CLRBFI
JRST FORTR2
>
; Fatal error with decimal value typeout - continues
; TEXT = Error message text
; NUM = Decimal number to append to text
DEFINE F.FAID (TEXT,NUM) ,<
SKPINL
JFCL
OUTSTR [ASCIZ \
?'TEXT\]
OUTSTR [ASCIZ / /]
PUSHJ P,.TDECW##
OUTSTR [ASCIZ /
/]
CLRBFI
JRST FORTR2
>
; Fatal error with octal value and filespec typeout - continues
; TEXT = Error message text
; NUM = Octal number to append to text
; FSPEC = Pointer to file spec to append to text
DEFINE F.FAIF (TEXT,NUM,FSPEC) ,<
SKPINL
JFCL
OUTSTR [ASCIZ \
?'TEXT\]
OUTSTR [ASCIZ / /]
MOVE T1,NUM
JUMPL T1,.+3
PUSHJ P,.TOCTW##
OUTSTR [ASCIZ / /]
MOVE T1,FSPEC
PUSHJ P,.TFBLK##
OUTSTR [ASCIZ /
/]
CLRBFI
JRST FORTR2
>
PAGE
SUBTTL TRAP handling routines
;
; Subroutine to initialize for APR trapping
;
; SET UP TRAP FOR
;
; AP.POV PUSHDOWN OVERFLOW
; AP.ABK ADDRESS BREAK (FUTURE)
; AP.ILM MEMORY PROTECTION VIOLATION
; AP.NXM NON-EXISTENT MEMORY
;
APRINI: MOVEI T1,APRTRP ;LOCATE TRAP ROUTINE
MOVEM T1,.JBAPR## ;TELL THE MONITOR WHERE TRAP OCCURS
MOVEI T1,AP.POV!AP.ABK!AP.ILM!AP.NXM ;SET CONDITIONS
APRENB T1, ;ENABLE TRAPS
POPJ P,
PAGE
SUBTTL GFLOATING Microcode test
;
; Subroutine to test for the presence of GFLOATING microcode
;
; Notice that the way that one tests for the microcode is quite
; different for the two different types of monitors.
; For TOPS-10, we need to set up an interrupt block to trap the
; error, while for TOPS-20 we basically need only to attempt
; a typical GFLOATING instruction and directly trap the error
; return which would indicate the microcode is not present.
; The result of this routine is that the bit GFMCOK will be
; set (or reset) to zero if the GFLOATING microcode is
; available and -1 if not.
;
GFLTST: SETZM T4 ;ASSUME MICROCODE NOT PRESENT
IFE FTTENX,<
MOVEI T1,INTBLK ;GET ADDRESS OF INTERRUPT BLOCK
EXCH T1,.JBINT ;SET UP FOR TRAPPING FAILURE OURSELVES
SETZM INTBLK+2 ;MUST ZERO THIS OLD PC
> ;ALL SET FOR TOPS-10 NOW
GFAD T2,T2 ;TRY A TYPICAL GFLOATING INSTRUCTION
IFN FTTENX,< ERJMP INTDON > ;SIMPLE FOR TOPS-20!
MOVX T4,GFMCOK ;YES, THE MICROCODE IS PRESENT.
INTDON: IORM T4,FLAGS2 ;SET UP THE GFMCOK BIT
IFE FTTENX,< EXCH T1,.JBINT > ;PUT INTERRUPT TRAPPING BACK FOR TOPS-10
POPJ P, ;AND RETURN IN ANY CASE
IFE FTTENX,<
RELOC
INTBLK: XWD 4,INTDON ;LENGTH, NEW PC
EXP ER.MSG+ER.EIJ ;NO MESSAGE, TRAP FATAL ERRORS
EXP 0 ;OLD PC
EXP 0 ;ERROR BITS
RELOC
> ;HARDER FOR TOPS-10!
PAGE
SUBTTL Interface to SCAN
;
; Subroutine to initialize SCAN
;
SINIT: MOVE T1,[2,,[EXP 0
XWD CCLSW##,'FOR']]
PUSHJ P,.ISCAN## ; FIRE UP SCAN
POPJ P,
;
; Subroutine to process SWITCH.INI switches
;
PSWINI: MOVE T1,[4,,[IOWD FORTL,FORTN
XWD FORTD,FORTM
XWD 0,FORTP
EXP -1]]
PUSHJ P,.OSCAN## ;SCAN SWITCH.INI FILE
POPJ P,
;
; Subroutine to scan one command line
;
SLINE: MOVE T1,[11,,[IOWD FORTL,FORTN
XWD FORTD,FORTM
XWD 0,FORTP
EXP -1
XWD CLRALL,CLRFIL
XWD ALLIN,ALLOUT
XWD MEMSTK,APPSTK
XWD CLRSTK,1B18
XWD 0]] ;[1115] Let SCAN process switches
PUSHJ P,.TSCAN## ;SCAN ONE COMMAND LINE
POPJ P,
PAGE
SUBTTL Compiler Initialization
;Here is where it all begins. One enters the compiler at label
;FORTRA or one instruction down for CCL entry. At this point
;[1121]one cannot depend upon the stack being set up.
;[1121]For the TOPS-10 multi segment version, the full RUN
;[1121]directory path, and the high seg origin must be
;[1121]saved away for later use by the GETSEGs and high
;[1121]segment entry code.
MRP0:: PORTAL .+1 ;[1121] NORMAL Execute only entry
FORTRA:: ;[1053]
TDZA T1,T1 ;FLAG AS NORMAL ENTRY
MOVEI T1,1 ;FLAG AS CCL ENTRY
MOVEM T1,CCLSW## ;SAVE CCL SWITCH
IFE FTTENX,<
SKIPE T1,GETSBL## ;HAVE WE BEEN HERE BEFORE?
JRST FORTR1 ;YES MUST BE DOING ^C START
MOVEM 7,GETSBL##+4 ;[1121]Save old RUN PPN
MOVEM 11,GETSBL## ;[1121]And device
MOVSI T2,-5 ;[1121]Max of 5 SFDs
FOR.I1: HRROI T1,.GTRS0(T2) ;[1121]Get SFD name
GETTAB T1, ;[1121]
JRST FOR.I2 ;[1121]Failed - assume done
JUMPE T1,FOR.I2 ;[1121]End - really done
MOVEM T1,GETSPA##+3(T2) ;[1121]Save in PATH block
AOBJN T2,FOR.I1 ;[1121]Loop for all
FOR.I2: SETZM GETSPA##+3(T2) ;[1121]Terminate list
HRROI T1,.GTRDI ;[1121]Get RUN PPN
GETTAB T1, ;[1121]
JRST FOR.I3 ;[1121]Failed - use old value
JUMPE T1,FOR.I3 ;[1121]Also if not available
MOVEM T1,GETSPA##+2 ;[1121]Save in full path block
SKIPE GETSPA##+3 ;[1121]If any SFDs
MOVEI T1,GETSPA## ;[1121]Get PATH pointer
MOVEM T1,GETSBL##+4 ;[1121]Save PPN or path pointer
FOR.I3: HRROI T1,.GTRDV ;[1121]Get RUN device
GETTAB T1, ;[1121]
JRST FOR.I4 ;[1121]Failed - use old value
JUMPE T1,FOR.I4 ;[1121]Also if not available
MOVEM T1,GETSBL## ;[1121]Save in GETSEG block
FOR.I4: MOVE T1,[-2,,.GTUPM] ;[1121]Get high seg origin
GETTAB T1, ;[1117]From table
MOVSI T1,400000 ;[1117]Must have hiseg - use default origin
LSH T1,-^D18 ;[1117]Position
TRZ T1,777 ;[1117]No extra bits
MOVEM T1,HSGORG## ;[1117]And save
> ;End of TOPS-10 code
FORTR1: JUMPPT (T1,CP166,KA10) ;CANNOT RUN ON PDP-6 OR KA10
MOVE P,[IOWD PDLLEN,STACK##] ;SET UP THE STACK
HRRZI FREG,(P) ;LIFE IS BLISS
PUSHJ P,GFLTST ;TEST FOR GFLOATING MICROCODE
PUSHJ P,SINIT ;INITIALIZE SCAN
FORTR2: MOVE T2,[FIRZER,,FIRZER+1] ;CLEAR LOCAL STORAGE
SETZM FIRZER ; ..
BLT T2,LASZER ; ..
RESETUUO ;RESET ACTIVE I/O
MOVE T1,.JBFF## ;START OF CORE
CORE T1, ;REMOVE CRUFT FROM PREVIOUS JOBS
JFCL ;DO NOT CARE IF IT FAILS
PUSHJ P,APRINI ;INITIALIZE APR TRAPPING
PAGE
SUBTTL Command Scanner
COMND:
PUSHJ P,SLINE ;PRINT "*" AND SCAN NEXT COMMAND LINE
PUSHJ P,NOWSAV ;[1115] SAVE COMMAND LINE NOWARN VALUES
PUSHJ P,PSWINI ;PROCESS SWITCH.INI FILE
PUSHJ P,NOWMRG ;[1115] MERGE COMMAND LINE/SWITCH.INI NOWARNS
PUSHJ P,ABSDEF ;FILL IN ABSENT DEFAULTS
MOVE T1,F2 ;GET SWITCHES
TXNN T1,SW.GFL ;WAS /GFL REQUESTED?
JRST GFLOK ;NO, WE ARE ALL SET TO GO!
MOVE T1,FLAGS2 ;GET RESULT OF MICROCODE TEST
TXNN T1,GFMCOK ;IS GFL MICROCODE PRESENT?
JRST GFLBAD ;NO, TOO BAD - FATAL ERROR
GFLOK:
EXTERN RTIME ;[1133] runtime for this program unit
EXTERN CTIME ;[1133] time of day for connect time
IFE FTTENX,< ;[1133] TOPS-10 code
MOVEI T1,0 ;[1133] get time for this job
RUNTIM T1, ;[1133] get runtime
MOVEM T1,RTIME ;[1133] save it
MSTIME T1, ;[1133] get current time
MOVEM T1,CTIME ;[1133] save it
> ;[1133] end TOPS-10 code
IFN FTTENX,< ;[1133] TOPS-20 code
MOVEI T1,.FHSLF ;[1133] get time for this job
RUNTM ;[1133] get runtime, current time
MOVEM T1,RTIME ;[1133] save runtime
MOVEM T3,CTIME ;[1133] save current time
> ;[1133] end TOPS-20 code
IFE FTTENX,< ;TOPS-20 CODE IS ALL DIFFERENT...
SKIPN T1,FINPTR ;CHECK FOR NO INPUT FILES
JRST FORTR1 ;NO INPUT FILES
PUSHJ P,GETSIZ ;CALCULATE MAXIMUM BUFFER CORE REQUIREMENTS
PUSHJ P,NXTFIL ;GET THE NEXT FILE
JRST FORTR1 ;NO INPUT FILES GIVEN
MOVE T1,LBLOCK+.RBALC;GET THE NUMBER OF BLOCKS ALLOCATED
MOVEM T1,LBLOCK+.RBEST; AND ESTIMATE THAT AS THE SIZE OF
SETZM LBLOCK+.RBALC ; EACH OUTPUT FILE.
TXNN F,SW.OCS ;SYNTAX ONLY? IF SO LEAVE .REL ALONE
SKIPN T2,RELSPC+F.DEV ;IS THERE A REL DEVICE
JRST NOREL ;NONE TRY LISTING
MOVE T2,RELSPC+F.MOD ;CHECK FOR NUL DEVICE AND NAME
TXNN T2,FX.NDV ;NO SKIP MEANS DEVICE THERE
JRST ISREL
SKIPN RELSPC+F.NAME ;NO SKIP MEANS DEVICE THERE
JRST NOREL ;NO NAME SPECIFIED
ISREL:
MOVE T2,RELSPC+F.DEV ;SET UP OPEN BLK
TXO F,RELFLG ;LIGHT THE REL FILE BIT FOR OUTMOD
MOVEI P1,RELSPC ;POINTER TO FILESPEC
PUSHJ P,MTMODE ;SET UP MODE FOR MAG TAPE
ADDX T1,.IOBIN ;BINARY MODE
MOVSI T3,BINHDR ;HEADER POINTER
OPEN BIN,T1 ;OPEN THE DEVICE
JRST OPNERR ;CAN NOT DO IT!!!
PUSHJ P,SETENT ;SET UP FOR ENTER
JRST ERRST ;FILE NAME ERROR
MOVEI T1,BIN
DEVCHR T1,
TXNN T1,DV.DTA ;IS DEVICE A DECTAPE
JRST REL1 ;NO
ENTER BIN,LBLOCK+2
JRST UUOERR
JRST REL2
REL1:
ENTER BIN,LBLOCK ;ENTER IN UFD
JRST UUOERR
REL2:
OUTBUF BIN,0 ;SET UP O/P BUFFER
NOREL:
SKIPN T2,LSTSPC+F.DEV ;IS THERE A LISTING DEVICE
JRST NOLST ;NONE TODAY
MOVE T2,LSTSPC+F.MOD ;SAME AS FOR .REL FILE
TXNN T2,FX.NDV
JRST ISLST
SKIPN LSTSPC+F.NAME
JRST NOLST ;NO LISTING IF ZERO
ISLST:
MOVE T2,LSTSPC+F.DEV ;SET UP OPEN BLK
; MOVE T3,LSTSPC+F.MOD
; JRST NOLST
TXO F,LSTFLG ;FLAG THAT A LISTING IS NEEDED
MOVEI P1,LSTSPC ;LISTING SPEC POINTER
MOVE T3,LSTSPC+F.MOD ;GET MODIFIERS
TXNE F,SW.CRF ;CREF ?
TXNN T3,FX.NUL ;NUL EXTENSION?
JRST NOCREF ;NOT CREF OR EXTENSION ALREADY SPECIFIED
; MOVE T3,LSTSPC+F.EXT
; JUMPL T3,NOCREF ;SKIP IF EXPLICIT EXTENSION
MOVEI T3,'CRF'
HRLM T3,F.EXT(P1) ;STORE CRF EXTENSION IN FILESPEC AREA
NOCREF:
PUSHJ P,MTMODE ;SET T1 FOR MAG TAPE MODE
ADDX T1,.IOASC ;ASCII MODE
MOVSI T3,LSTHDR ;POINTER TO BUFFER HEADER
OPEN LST,T1 ;OPEN THE DEVICE
JRST OPNERR ;CAN NOT OPEN DEVICE
PUSHJ P,SETENT ;SET UP FOR ENTER
JRST ERRST ;FILE NAME ERROR
MOVEI T1,LST ;SKIP RETURN OK
DEVCHR T1,
TXNE T1,DV.TTA
TXO F,TTYDEV ;SET BIT ON IF LST DEVICE IS TTY
TXNN T1,DV.DTA ;IS DEVICE A DECTAPE
JRST LST1 ;NO
ENTER LST,LBLOCK+2
JRST UUOERR
JRST LST2
LST1:
ENTER LST,LBLOCK ;ENTER THE FILE
JRST UUOERR
LST2:
MOVE T1,F.NAME(P1) ;GET LISTING FILENAME
MOVEM T1,CHNLTB##+20 ;STORE FOR USE IN PHASE1
OUTBUF LST,0 ;SET UP O/P LST BUFFER
NOLST: MOVEI T1,[ASCIZ /%FTNNOF No output files given
/]
TXNN F,RELFLG!LSTFLG!SW.OCS ;ANY OUTPUT REQUESTED?
PUSHJ P,.TSTRG## ;NO--GIVE THE WARNING
> ;END TOPS-10 ONLY
PAGE
IFN FTTENX,< ;HERE IS THE TOPS-20 SPECIFIC CODE
SKIPN T1,FINPTR ;CHECK FOR NO INPUT FILES
JRST FORTR1 ;NO INPUT FILES
SUBI T1,F.LEN ;INITIALIZE CURRENT INPUT POINTER
MOVEM T1,CINPTR ;SAVE
PUSHJ P,NEWJFN ;GET THE NEXT FILE
JRST FORTR1 ;NO INPUT FILES GIVEN
SKIPN T2,RELSPC+F.DEV ;IS THERE A REL DEVICE
JRST NOREL ;NONE TRY LISTING
MOVE T2,RELSPC+F.MOD ;CHECK FOR NUL DEVICE AND NAME
TXNN T2,FX.NDV ;NO SKIP MEANS DEVICE THERE
JRST ISREL
SKIPN RELSPC+F.NAME ;NO SKIP MEANS DEVICE THERE
JRST NOREL ;NO NAME SPECIFIED
ISREL:
TXO F,RELFLG ;LIGHT THE REL FILE BIT FOR OUTMOD
MOVEI P1,RELSPC ;POINTER TO FILESPEC
PUSHJ P,MTMODE ;SET UP MODE FOR MAG TAPE
PUSHJ P,XFILCV ;CONVERT REL SPEC BACK TO ASCII
MOVE T2,[POINT 7,FILSPC] ;POINTER TO NEW SPEC
HRRZI T1,BINTAB ;LONG GTJFN FOR OUTPUT
GTJFN
JRST FILERR ;PROBLEMS
MOVEM T1,BINJFN ;OK - SAVE JFN
HRRZ T1,T1 ;ZERO LEFT
MOVE T2,[XWD BINBYT,WRITEE] ;OPEN FOR WRITE
OPENF
JRST FILERR ;PROBLEMS
NOREL:
SKIPN T2,LSTSPC+F.DEV ;IS THERE A LISTING DEVICE
JRST NOLST ;NONE TODAY
MOVE T2,LSTSPC+F.MOD ;SAME AS FOR .REL FILE
TXNN T2,FX.NDV
JRST ISLST
SKIPN LSTSPC+F.NAME
JRST NOLST ;NO LISTING IF ZERO
ISLST:
TXO F,LSTFLG ;FLAG THAT A LISTING IS NEEDED
MOVEI P1,LSTSPC ;LISTING SPEC POINTER
MOVE T3,LSTSPC+F.MOD ;GET MODIFIERS
TXNE F,SW.CRF ;CREF ?
TXNN T3,FX.NUL ;NUL EXTENSION?
JRST NOCREF ;NOT CREF OR EXTENSION ALREADY SPECIFIED
MOVEI T3,'CRF'
HRLM T3,F.EXT(P1) ;STORE CRF EXTENSION IN FILESPEC AREA
NOCREF:
PUSHJ P,MTMODE ;SET T1 FOR MAG TAPE MODE
PUSHJ P,XFILCV ;CONVERT LST SPEC BACK TO ASCII
MOVE T2,[POINT 7,FILSPC] ;POINTER TO NEW SPEC
HRRZI T1,LSTTAB ;LONG GTJFN FOR OUTPUT
GTJFN
JRST FILERR ;PROBLEMS
MOVEM T1,LSTJFN ;OK - SAVE JFN
HRRZ T1,T1 ;ZERO LEFT
MOVE T2,[XWD LSTBYT,WRITEE] ;OPEN FOR WRITE
OPENF
JRST FILERR ;PROBLEMS
;CONTROLLING TERMINAL?
HRRZ T1,LSTJFN ;GET JFN
DVCHR ;CHARACTERISTICS
HLRZ T1,T1 ;GET DEVICE TYPE
CAIE T1,TTCODE ;IS IT A TERMINAL
JRST NOTTY ;NO
HRRZ T3,T3 ;SAVE TERMINAL NUMBER
PUSH P,T3
GJINF ;CONTROLING INFORMATION
POP P,T3 ;GET TERMINAL NUMBER BACK
CAMN T4,T3 ;COMPARE TO CONROLLING TERMINAL NUMBER
TXO F,TTYDEV ;NOTE LST = CONTROLLING TTY:
NOTTY:
MOVE T1,F.NAME(P1) ;GET LISTING FILENAME
MOVEM T1,CHNLTB##+20 ;STORE FOR USE IN PHASE1
NOLST: MOVEI T1,[ASCIZ /%FTNNOF No output files given
/]
TXNN F,RELFLG!LSTFLG!SW.OCS ;ANY OUTPUT REQUESTED?
PUSHJ P,.TSTRG## ;NO--GIVE THE WARNING
> ;END TOPS-20 ONLY
;TOPS-10 AND TOPS-20 MERGE HERE
LOOP:
SKIPN T1,CCLSW
JRST BYNAM
MOVEI T1,[ASCIZ /FORTRAN: /]
PUSHJ P,.TSTRG##
SKIPE T1,CHNLTB##+32 ;GET FILE NAME IF ANY
PUSHJ P,.TSIXN## ;TYPE AS SIXBIT
PUSHJ P,.TCRLF## ;GIVE AN EOL
BYNAM:
MOVE T1,DEBGSD ;MOVE LOCAL TO GLOBAL - MACRO BUG
MOVEM T1,DEBGSW##
MOVE T1,BUGINT
MOVEM T1,BUGOUT## ;INTERMEDIATE OUTPUT REQUEST SWITCHWES
SETZM SEGINCORE## ;ARGUMENT TO PHASE CONTROL
PUSHJ P,PHAZCONTROL## ;GET THE NEXT PHASE
PORTAL .+1 ;[1047] Execute only re-entry
LOOPDN:
IFN FTTENX,< PUSHJ P,CLOSUP## > ;CLOSE EVERYTHING
IFE FTTENX,<
CLOSE LST, ;CLOSE LISTING FILE
CLOSE SRC, ;CLOSE SOURCE FILE
TXNE F,SW.ERR ;ANY FATAL ERRORS?
CLOSE BIN,40 ;YES - DISCARD .REL
RELEASE BIN, ;WILL DO CLOSE IF NEEDED
> ;END TOPS-10 ONLY
JRST FORTR2 ;INITIALIZE AND LOOK FOR NEXT COMMAND
PAGE
SUBTTL SUBROUTINES CALLED FROM .TSCAN
;SUBROUTINE TO CLEAR ALL ANSWERS
CLRALL: SETZM SAVEF ;ERASE OLD SWITCHES
SETZM SAVEFM ;MASK WORD TOO
SETZM SAVE2 ;MORE OF THE SAME
SETZM SAVE2M ;MASK WORD TOO
PUSHJ P,NOWCLR ;[1115] DEFAULT THE NOWARN DATA
SKIPA T2,[LSTCLR] ;THE WHOLE THING
;SUBROUTINE TO CLEAR FILE ANSWERS
CLRFIL: MOVEI T2,FAREA+F.LEN ;JUST CLEAR F AREA
MOVE T1,[FIRZER,,FIRZER+1] ;CLEAR FROM FIRZER
SETZM FIRZER ; ..
BLT T1,(T2) ; TO THE END
POPJ P, ; ..
;SUBROUTINE TO ALLOCATE AN OUTPUT AREA
ALLOUT: AOS T3,OUTCNT ;T3 = COUNT OF OUPUT FILES
MOVE T1,[EXP RELSPC,LSTSPC]-1(T3) ;T1 = ADDRESS OF SPEC
MOVEI T2,F.SLEN ;T2 = LENGTH OF SPEC
CAIG T3,2 ;TOO MANY SPECS?
POPJ P, ;NO--ALL DONE
F.FAIL (<FTNTOF More than 2 output files are not allowed>) ;[1065]
;SUBROUTINE TO ALLOCATE AN INPUT AREA
ALLIN: SKIPE T1,LINPTR ;ANY LAST INPUT SPEC?
JRST ALLIN1 ;YES--MAKE ANOTHER
MOVE T1,.JBFF## ;FIRST INPUT SPEC GOES HERE
MOVEM T1,FINPTR ;SAVE FOR LATER
SUBI T1,F.LEN ;FIX UP SO FIRST SPEC IS CORRECT
MOVEM T1,LINPTR ;SAVE AWAY
ALLIN1: MOVEI T2,<F.LEN*2>(T1);ADDRESS OF NEXT SPEC
CAMGE T2,.JBREL## ;WILL IT FIT?
JRST ALLIN2 ;YES--CONTINUE
CORE T2, ;NO--EXPAND CORE
JRST E.NCF ;NO CORE--YOU LOOSE
ALLIN2: MOVEI T1,F.LEN ;LENGTH OF SPEC
ADDM T1,.JBFF## ;UPDATE JOBFF
ADDB T1,LINPTR ;UPDATE T1 AND POINTER
MOVEI T2,F.SLEN ;AMOUNT SCAN KNOWS ABOUT
POPJ P, ;RETURN
;SUBROUTINE TO CLEAR STICKEY DEFAULTS
CLRSTK: SETZM PAREA ;ALL THE STICKEY DEFAULTS
MOVE T1,[PAREA,,PAREA+1] ; ..
BLT T1,PAREA+F.LEN-1; ARE IN THE PAREA
POPJ P,
;[1115] SUBROUTINE TO DEFAULT NOWARN DATA ANSWERS
NOWCLR: SETZM NWBITS ;[1115] CLEAR THE KEYWORD DATA
MOVE T1,[NWBITS,,NWBITS+1] ;[1115] AND THE MASKS
BLT T1,<NWMASK+NWWDCT-1> ;[1115]
POPJ P, ;[1115] DONE
;[1115] SUBROUTINE TO PROCESS THE NOWARN SWITCH KEYWORDS.
;[1115] OPTIONS ARE ALWAYS APPLIED, IN THE ORDER GIVEN
;[1115] EXACTLY AS SCAN OR-BIT-VALUES.
NOWARN: SKIPN N ;[1115] /NOWARN: OR /NOWARN:0?
MOVEI N,2 ;[1115] MAKE IT NONE
CAIE N,-1 ;[1115] WAS IT JUST /NOWARN
CAIN N,1 ;[1115] OR /NOWARN:ALL?
JRST NW.ALL ;[1115] YES - SET ALL BITS ON
CAIN N,2 ;[1115] /NOWARN:NONE?
JRST NW.NON ;[1115] YEP - CLEAR ALL BITS
MOVEI T1,-1(N) ;[1115] DETERMINE CORRECT WORD
IDIVI T1,^D36 ;[1115] AND POSITION TO SET
MOVEI T3,1 ;[1115] GET BIT TO SHIFT
LSH T3,(T2) ;[1115] SHIFT TO PROPER POSITION
IORM T3,NWBITS(T1) ;[1115] SET NOWARN OPTION
IORM T3,NWMASK(T1) ;[1115] AND MASK BIT
JRST NW.DON ;[1115] LEAVE
NW.NON: SETZ T1, ;[1115] CLEAR ALL BITS
SKIPA ;[1115] CHECK FURTHER
NW.ALL: SETO T1, ;[1115] SET ALL BITS
MOVSI T2,-NWWDCT ;[1115] SETUP FOR LOOP
NW.SET: MOVEM T1,NWBITS(T2) ;[1115] STORE VALUE
SETOM NWMASK(T2) ;[1115] SET MASK
AOBJN T2,NW.SET ;[1115] SET THEM ALL
NW.DON: AOS (P) ;[1115] WE STORED THE VALUE
POPJ P, ;[1115] BACK TO SCAN
;[1115] SUBROUTINE TO SETUP FOR SWITCH.INI PROCESSING
NOWSAV: MOVE T1,[NWBITS,,NWSAVB] ;[1115] MOVE COMMAND LINE DATA AND
BLT T1,<NWSAVM+NWWDCT-1> ;[1115] MASKS TO SAVE AREA
PUSHJ P,NOWCLR ;[1115] DEFAULT NOWARN ANSWERS
POPJ P, ;[1115] RETURN TO PROCESS SWITCH.INI
;[1115] SUBROUTINE TO MERGE COMMAND LINE/SWITCH.INI NOWARN ANSWERS
NOWMRG: MOVSI T1,-NWWDCT ;[1115] SETUP FOR LOOP
MOVE T3,[SW.NOW] ;[1115] GET NOWARN INDICATOR
NW.UPD: MOVE T2,NWSAVM(T1) ;[1115] GET MASK BITS FROM COMMAND LINE
ANDCAM T2,NWBITS(T1) ;[1115] CANNOT BE OVERRIDEN BY SWITCH.INI
IORM T2,NWMASK(T1) ;[1115] UPDATE MASK
MOVE T2,NWSAVB(T1) ;[1115] GET COMMAND LINE KEYWORDS
IORM T2,NWBITS(T1) ;[1115] UPDATE NOWARN KEYWORD SETTINGS
SKIPE NWBITS(T1) ;[1115] ANY OPTIONS REQUESTED?
IORM T3,SAVEF ;[1115] MAKE SURE NOWARN IS INDICATED
AOBJN T1,NW.UPD ;[1115] LOOP FOR ALL WORDS
POPJ P, ;[1115] DONE
XALL
DEFINE MEM(A),<
IRP A,<
SKIPE T1,FAREA+F.'A ;IS A SPECIFIED?
MOVEM T1,PAREA+F.'A ;YES--REMEMBER A
>>
;SUBROUTINE TO MEMORIZE STICKEY DEFAULTS
MEMSTK: MEM (<ADV,BACK,WEOF,REW,DTZR>)
POPJ P,
DEFINE APPLY(A),<
IRP A,<
MOVE T1,PAREA+F.'A ;PICK UP STICKEY DEFAULT FOR A
SKIPN FAREA+F.'A ;IS A LOCAL OVER RIDE PRESENT
MOVEM T1,FAREA+F.'A ;NO--APPLY THE DEFAULT
>>
;SUBROUTINE TO APPLY STICKEY DEFAULTS
APPSTK: APPLY (<ADV,BACK,WEOF,REW,DTZR>)
POPJ P,
SALL
IFE FTTENX,<
PAGE
SUBTTL SUBROUTINES FOR COMMAND SCANNING
;SUBROUTINE TO APPLY ABSENT DEFAULTS
ABSDEF: SETCM F,SAVEFM ;T1 GETS A 1 BIT FOR EVERY BIT IN F
; WHICH WAS NOT EXPLICITLY SPECIFIED
; BY THE USER.
AND F,INDADF ;AND WITH THE DEFAULTS.
IORB F,SAVEF ;OR IN THE SELECTED BITS.
SETCM T1,SAVE2M ;GET THOSE SWITCHES NOT REQUESTED
AND T1,INDAD2 ;PICK UP DEFAULTS FOR THEM
IORB T1,SAVE2 ;OR IN THE SELECTED SWITCHES
MOVEM T1,F2 ;PUT OUT IN THE FLAG REGISTER
MOVEI T1,RELSPC ;POINT AT REL FILE
HRLOI T2,'REL' ;DEFAULT EXTENSION
PUSHJ P,DEFEXT ;FILL IN DEFAULT
MOVEI T1,LSTSPC ;POINT TO LISTING FILE SPEC
HRLOI T2,'LST' ;DEFAULT EXTENSION
PUSHJ P,DEFEXT ;FILL IN DEFAULT
MOVE T1,FINPTR ;POINT TO FIRST INPUT SPEC
ABSDF1: HRLOI T2,'FOR' ;DEFAULT EXTENSION
PUSHJ P,DEFEXT ;GO DEFAULT IT
MOVX T3,FX.PRT ;[656] BE SURE TO NOTICE
IORM T3,F.MODM(T1) ;[656] THE /OKPROT BIT
CAMN T1,LINPTR ;LAST INPUT POINTER
POPJ P, ;YES--ALL SET UP
ADDI T1,F.LEN ;POINT TO NEXT SPEC
JRST ABSDF1 ;LOOP FOR NEXT SPEC
;SUBROUTINE TO FILL IN A DEFAULT EXTENSION
;CALL WITH:
; T1 = FILE SPEC POINTER (PRESERVED)
; T2 = EXTENSION
; PUSHJ P,DEFEXT
; RETURN HERE
DEFEXT: HLRZ T3,F.EXT(T1) ;GET EXTENSION
JUMPN T3,.POPJ## ;ALL DONE IF IT WAS GIVEN
HRRE T3,F.EXT(T1) ;EXPLICITLY NULL
AOJE T3,.POPJ## ;JUMP IF YES
MOVEM T2,F.EXT(T1) ;NO--SET UP DEFAULT
POPJ P, ; RETURN
PAGE
SUBTTL LOOKUP/ENTER SUBROUTINES
;SUBROUTINE TO RETURN THE NEXT FILE TO BE READ BY FORTRAN.
;IT RETURNS WITH THE EOCS BIT SET IN F. IF THIS IS THE
; LAST SPEC IN THE COMMAND STRING. IT SKIP RETURNS IF A
; FILE SPEC HAS BEEN FOUND.
;CALL WITH:
; PUSHJ P,NXTFIL
; NOTHING FOUND
; SPEC POINTER IN P1
NXTFIL: PORTAL .+1 ;[1047] Execute only entry
MOVE T1,[4,,[XWD FINPTR,LINPTR ;[1047]
XWD OBLOCK,LBLOCK
XWD F.LEN,.RBALC
EXP 1B0+<SRC>B17+LKTEMP]]
PUSHJ P,.LKWLD## ;SCAN THE DISK OR TAPE
POPJ P, ;NON-SKIP WHEN DONE
MOVE P1,LKTEMP ;POINTER TO CURRENT SPEC
CAMN P1,LINPTR ;SAME AS LAST SPEC
SKIPE .WLDFL## ; AND NO WILD CARDS?
TXZA F,EOCS ;NO--MAY BE MORE
TXO F,EOCS ;YES--THIS IS THE LAST SPEC.
PUSHJ P,OPENIN ;OPEN THE INPUT FILE
MOVE T1,F.NAME(P1) ;GET SRC FILENAME
MOVEM T1,CHNLTBL##+32 ;PUT IN TABLE TO BE LOOKED
; AT BY LISTING HEADER
MOVE T1,F.EXT(P1) ;EXTENSION
MOVEM T1,CHNLTBL+33 ;EXTENSION FIELD FOR SRC
;ROUTINE IN CLASS
JRST .POPJ1## ;SKIP RETURN
;SUBROUTINE TO OPEN THE INPUT FILE
;CALL WITH:
; P1 = FILE SPEC POINTER
; PUSHJ P,OPENIN
; RETURN HERE
OPENIN: HRRZI T1,SRCHDR ;BUFFER HEADER
MOVEM T1,OBLOCK+2 ;STORE IN OPEN BLOCK
OPEN SRC,OBLOCK ;OPEN THE DEVICE
JRST OPNER1 ;OPEN ERROR
MOVEI T1,SRC
DEVCHR T1,
MOVE T2,FLAGS2## ;SECONDARY FLAG REGISTER
TXNE T1,DV.TTY ;IS DEVICE A TTY
TXOA T2,TTYINP ;YES
TXZ T2,TTYINP ;NO
MOVEM T2,FLAGS2## ;SAVE IT
PUSH P,LBLOCK+.RBPPN ;SAVE .RBPPN OVER LOOKUP
TXNN T1,DV.DTA ;IS DEVICE DECTAPE
JRST OPEN1 ;NO
LOOKUP SRC,LBLOCK+2 ;DO DIFFERENT LOOKUP
JRST OPNER2
JRST OPEN2
OPEN1:
LOOKUP SRC,LBLOCK ;LOOKUP THE FILE
JRST OPNER2 ;NO CAN DO
OPEN2:
POP P,LBLOCK+.RBPPN ;RESTORE .RBPPN TO WHAT USER SAID
MOVE T2,OBLOCK ;T2 GETS THE DEVICE NAME
PJRST MTAOP ;POSITION MAG TAPE
OPNER1:
PUSHJ P,E.DFO##
ERRST: ;ERROR ENTRY
SKIPE T1,CCLSW
JRST COMND
JRST FORTR1 ;LOOP BACK
OPNER2:
POP P,LBLOCK+.RBPPN ;RESTORE .RBPPN FROM LOOKUP ERROR
HRRZ T1,LBLOCK+.RBEXT
JUMPN T1,OPNE2A ;EXPLICIT EXTENSION FILE LOOKUP ERROR
MOVX T1,FX.NUL ;NULL EXT MASK
TDNN T1,F.MOD(P1) ;WAS NULL EXTENSION INPUT?
JRST OPNE2A ;NO
ANDCAM T1,F.MOD(P1) ;YES,TURN OFF THAT BIT TO AVOID ALOOP
HRRZS LBLOCK+.RBEXT ;ZERO THE EXTENSION FIELD IN LOOKUP BLOCK
JRST OPENIN ;TRY AGAIN WITH NULL EXTENSION
OPNE2A:
PUSHJ P,E.DFL## ;TRY AGAIN AFTER ERROR MESSAGE
SKIPE T1,CCLSW
JRST COMND
JRST FORTR1 ;LOOP BACK
; SUBROUTINE TO CALCULATE THE MAX CORE REQUIREMENTS FOR THE LIST
; OF INPUT FILES. CHECK THE
; LIST OF FILES AND SAVE THE REQUIREMENTS OF THE LARGEST.
; CALL WITH:
; PUSHJ GETSIZ
; RETURN HERE
GETSIZ:MOVE T1,FINPTR ;FIRST FILE AREA
SETZM BGSTBF## ;CLEAR LARGEST SAVE LOCATION
GETSI2: ;SET UP ARG BLOCK
MOVEI T2,0 ;STATUS
MOVE T3,F.DEV(T1) ;DEVICE NAME
MOVEI T4,T2 ;ARG BLOCK ADDRESS
DEVSIZ T4, ;GET DEFAULT NUMBER AND SIZE OF BUFFERS
MOVE T4,[2,,203] ;[704] ASSUME OLD MONITOR - 2 DSK BUFFERS
JUMPLE T4,GETSI1 ;IGNORE ANY ERRORS
;SOMEONE ELSE WILL CATCH THEM
HLRZ T3,T4 ;MOVE NUMBER OF BUFFERS
HRRZ T4,T4 ;ZERO T4<LEFT>
IMUL T4,T3 ;TOTAL SIZE
CAMLE T4,BGSTBF## ;IS THIS LARGEST SO FAR?
MOVEM T4,BGSTBF## ;YES - SAVE IT
GETSI1:
CAMN T1,LINPTR ;ARE WE DONE?
POPJ P, ;YES
ADDI T1,F.LEN ;NO - DO NEXT ONE
JRST GETSI2
;SUBROUTINE TO SET UP FOR AN ENTER
;CALL WITH:
; P1 = FILE SPEC POINTER
; PUSHJ P,SETENT
; RETURN HERE
SETENT: PUSHJ P,MTAOP ;POSITION THE TAPE
SETZM LBLOCK+.RBPPN
SETZM LBLOCK+.RBSIZ
SETZM LBLOCK+.RBVER
SETZM LBLOCK+.RBSPL
SETZM LBLOCK+.RBALC
MOVE T1,F.NAME(P1) ;PICK UP FILE NAME
MOVE T2,F.NAMM(P1) ;PICK UP FILE NAME MASK
AOJN T2,E.WILD ;CAN NOT BE WILD
MOVEM T1,LBLOCK+.RBNAM;STORE THE FILE NAME
HRRE T2,F.EXT(P1) ;GET THE EXTION MASK
AOJN T2,E.WILD ;MUST BE ALL SPECIFIED
HLLZ T2,F.EXT(P1) ;PICK UP THE EXTENSION
MOVEM T2,LBLOCK+.RBEXT;STORE FOR THE ENTER
LDB T1,[<POINTR(F.MOD(P1),FX.PRO)>] ;GET THE PROTECTION
ROT T1,-^D9 ;PUT IN THE LEFT 9 BITS
MOVEM T1,LBLOCK+.RBPRV;STORE FOR THE ENTER
MOVX T1,FX.DIR ;DIRECTORY SPECIFIED?
TDNN T1,.FXMOD(P1) ; ??
JRST .POPJ1## ;NO--ALL DONE
MOVE T2,F.DIRM(P1) ;IS PPN WILD?
AOJN T2,E.WILD ;YES == ERROR
MOVE T1,F.DIR(P1) ;PICK UP PPN
MOVEM T1,LBLOCK+.RBPPN;STORE FOR THE MOMENT
SKIPN F.DIR+2(P1) ;NEED ANY SFD'S TODAY
JRST .POPJ1## ;NO--ALL DONE
MOVEI T2,PATH ;YES--POINT ENTER TO PATH
MOVEM T2,LBLOCK+.RBPPN; ..
ADDI T2,2 ;SKIP PAST SWITCHES
MOVEM T1,(T2) ;STORE PPN
MOVEI T1,F.DIR+2(P1) ;POINT TO SFD LIST
SETEN1: MOVE T3,1(T1) ;IS SFD WILD?
AOJN T3,E.WILD ;YES == ERROR
MOVE T3,(T1) ;PICK UP SFD
MOVEM T3,1(T2) ;STORE IN PATH
ADDI T1,2 ;SKIP TO NEXT SFD
SKIPE (T1) ;IS IT THERE??
AOJA T2,SETEN1 ;YES--LOOP OVER IT
SETZM 2(T2) ;NO--END THE LIST
JRST .POPJ1##
;SUBROUTINE TO PERFORM MAG TAPE OPERATIONS
;CALL WITH:
; MOVEI P1,FILE-SPEC-POINTER
; PUSHJ P,MTAOP
; RETURN HERE WITH TAPE POSITIONED
MTAOP: POPJ P, ;NULL FOR NOW
;SUBROUTINE TO SET UP T1 AS A MODE WORD FOR MAG TAPES
;CALL WITH:
; MOVEI P1,FILE-SPEC-POINTER
; PUSHJ P,MTAOP
; RETURN HERE WITH T1 SET UP
MTMODE: SETZM T1 ;START WITH A CLEAN SLATE
POPJ P, ;RETURN
> ;End of TOPS-10 code
PAGE
SUBTTL ERROR CONDITIONS
CP166: OUTSTR [ASCIZ /?FTNPD6 FORTRAN will not run on a PDP-6
/]
CLRBFI
EXIT ;Totally fatal
KA10: OUTSTR [ASCIZ /?FTNKA FORTRAN will not run on a KA
/]
CLRBFI
EXIT ;Totally fatal
GFLBAD: OUTSTR [ASCIZ \?FTNGFM /GFL requires GFLOATING microcode
\]
CLRBFI
JRST FORTR2 ;TRY ANOTHER COMMAND LINE
KA10SW: OUTSTR [ASCIZ \?FTNKAS FORTRAN can not compile for a KA
\]
CLRBFI
JRST FORTR2 ;TRY ANOTHER COMMAND LINE
KI10SW: OUTSTR [ASCIZ \%FTNKIS Obsolete switch /KI
\]
POPJ P, ;Return to scan - ignore the stitch
E.NCF: MOVEI N,1(T2)
F.FAID (<FTNNCF Not enough core for file specs. Total K needed=>,N);[1065]
IFE FTTENX,<
UUOERR: HRRZ T2,LBLOCK+.RBEXT
HRRZ N,P1
SETZM LKTEMP ;CLEAR .LKWLD STATE
CAIN T2,2
JRST EER02
CAIN T2,6
JRST EER06
CAIN T2,14
JRST EER14
F.FAIF (<FTNETF ENTER failure>,T2,N) ;[1065]
EER02: F.FAIF (<FTNPRF Protection failure>,T2,N) ;[1065]
EER06: F.FAIF (<FTNRDE RIB or directory error>,T2,N) ;[1065]
EER14: F.FAIF (<FTNQEF Quota exceeded or disk full>,T2,N) ;[1065]
OPNERR: MOVEM T2,.WILDZ## ;COPY DEVICE NAME TO FSTR IN WILD
JRST OPNER1 ;GIVE ERROR MESSAGE
E.WILD: MOVE N,P1
MOVE T1,F.DEV(P1) ;GET DEVICE NAME
DEVTYP T1, ;GET THE DEVICE TYPE
HALT . ;CAN ONLY FAIL IF THERE IS A BUG IN FORTRAN
; SINCE FOROTS NEEDS THIS CALLI IT MUST EXIST
TXNN T1,TY.INT ;IF INTERACTIVE, ALWAYS OK
TXNN T1,TY.MAN ;LOOKUP/ENTER MANDATORY?
JRST .POPJ1## ;NO--IGNORE BAD FILE NAME
SETOM T2 ;YES--GIVE ERROR MESSAGE
SETZM LKTEMP ;CLEAR .LKWLD STATE
F.FAIF (<FTNNWD Incorrect use of * or ? in>,T2,N) ;[1065]
; FOR ERROR MESSAGES.
XLIST ;Literals
LIT:: LIT
> ;END TOPS-10 ONLY
LIST
PAGE
SUBTTL Resident low core routines and data
RELOC ;IMPURE CODE
; CORE UUO FAILURE ROUTINE IS LOW SEGMENT RESIDENT (CALLED FROM CORMAN AND GETCOR)
CORERR:: ;HERE WHEN CORE UUO FAILS
MOVEM T1,APRSV1 ;STORE T1
MOVEM T2,APRSV2 ;STORE T2
SOS T1,0(P) ;WHERE WERE WE CALLED FROM
HRRZM T1,.JBTPC## ;STORE ADDRESS
MOVEI T2,CORTXT ;LOCATE MESSAGE
JRST APRTR4 ;FINISH MESSAGE
CORTXT: ASCIZ \?FTNUCE User Core Exceeded\
; APR TRAP ROUTINE IS LOW-SEGMENT RESIDENT
; TEXT FOR APR TRAP ROUTINE
APRNXM: ASCIZ \Illegal Memory Reference\
APRPOV: ASCIZ \Stack exhausted\
APRILM: ASCIZ \Memory Protection Violation\
APRABK: ASCIZ \Address Break\
APRTX0: ASCIZ \
?Internal Compiler Error
?\
APRTX1: ASCIZ \ at location \
APRTX2: ASCIZ \ in Phase \
APRTX3: ASCIZ \
?while processing statement \
APRPN1: POINT 3,.JBTPC##,17 ;USEFUL BYTE POINTER
APRPN2: POINT 6,GETSBL##+1 ;[1047] USEFUL BYTE POINTER
APRIOR: ASCII \00000\ ;MAKE A NUMBER
APRTRP: JRSTF @.+1 ;CLEAR FIRST PART DONE
0,,.+1 ;CLEAR APR FLAGS
TTCALL 3,APRTX0 ;PREFACE MESSAGE
MOVEM T1,APRSV1 ;SAVE A REGISTER
MOVEM T2,APRSV2 ;SAVE A REGISTER
MOVEI T2,APRNXM ;ASSUME ILL MEM REF
MOVE T1,.JBCNI## ;TEST ERROR
TRNE T1,AP.POV ;PDL OVERFLOW?
MOVEI T2,APRPOV ;LOCATE MESSAGE
TRNE T1,AP.ABK ;ADDRESS BREAK
MOVEI T2,APRABK ;LOCATE MESSAGE
TRNE T1,AP.ILM ;MEMORY PROTECTION
MOVEI T2,APRILM ;LOCATE MESSAGE
APRTR4: TTCALL 3,0(T2) ;TYPE MESSAGE
TTCALL 3,APRTX1 ;CONTINUE
MOVE T2,APRPN1 ;LOAD POINTER
APRTR1: ILDB T1,T2 ;TYPE ADDRESS
MOVEI T1,"0"(T1) ;TYPE ADDRESS
TTCALL 1,T1 ;TYPE DIGIT
TLNE T2,770000 ;TYPE 6 DIGITS
JRST APRTR1 ;TYPE 6 DIGITS
SKIPN .JBHRL## ;HIGH SEGMENT?
JRST APRTR2 ;NO
TTCALL 3,APRTX2 ;CONTINUE
MOVE T2,APRPN2 ;TYPE SEGMENT NAME
APRTR3: ILDB T1,T2 ;LOAD BYTE
MOVEI T1," "(T1) ;TO ASCII
TTCALL 1,T1 ;TYPE BYTE
TLNE T2,770000 ;TYPE 6 CHARACTER
JRST APRTR3 ;TYPE 6 CHARACTER
APRTR2: TTCALL 3,APRTX3 ;CONTINUE
MOVE T1,ISN## ;GET STATEMENT #
MOVEM T3,APRSV3 ;SAVE A REGISTER
IDIVI T1,^D10 ;BREAK DOWN
LSHC T2,-7 ;STORE
IDIVI T1,^D10 ;BREAK DOWN
LSHC T2,-7 ;STORE
IDIVI T1,^D10 ;BREAK DOWN
LSHC T2,-7 ;STORE
IDIVI T1,^D10 ;BREAK DOWN
LSHC T2,^D29 ;BUILD NUMBER
LSHC T1,^D29 ;BUILD NUMBER
IOR T1,APRIOR ;CONVERT TO ASCII
MOVSI T2,(BYTE (7)15,12) ;FINISH MESSAGE
TTCALL 3,T1 ;FINISH MESSAGE
MOVE T1,APRSV1 ;RESTORE AC
MOVE T2,APRSV2 ;RESTORE AC
MOVE T3,APRSV3 ;RESTORE AC
EXIT 1, ;DONE
APRSV1: BLOCK 1
APRSV2: BLOCK 1
APRSV3: BLOCK 1
PAGE
SUBTTL File specification area definitions
;CCLSW: BLOCK 1 ;0 IF NORMAL START, 1 IF CCL START (NOW IN GLOBAL.BLI)
FIRZER:! ;FIRST LOCATION TO ZERO
FAREA: PHASE 0
F.DEV:! BLOCK 1 ;DEVICE NAME
F.NAME:!BLOCK 1 ;FILE NAME
F.NAMM:!BLOCK 1 ;FILE NAME MASK
F.EXT:! BLOCK 1 ;EXTENSION
F.MOD:! BLOCK 1 ;MOD WORD
F.MODM:!BLOCK 1 ;MOD MASKS
F.DIR:! BLOCK 1 ;PPN
F.DIRM:!BLOCK 1 ;DIRECTORY MASK
BLOCK 12 ;SPACE FOR SFD BIWORDS
F.SLEN==.-F.DEV ;SIZE OF THE BLOCK SCAN KNOWS ABOUT
F.ADV:! BLOCK 1 ;NUMBER OF FILES TO ADVANCE TAPE
F.BACK:!BLOCK 1 ;NUMBER OF FILES TO BACKSPACE TAPE
F.WEOF:!BLOCK 1 ;WRITE AN END OF FILE
F.REW:! BLOCK 1 ;REWIND THE TAPE
F.DTZR:!BLOCK 1 ;ZERO THE DTA DIRECTORY
DEPHASE
F.LEN=.-FAREA ;SIZE OF THE FAREA
;AREA TO REMEMBER STICKEY SWITCHES
PAREA: BLOCK F.LEN ;STICKEY SPEC BLOCK
;OTHER FILE SPECIFICATION STORAGE
RELSPC: BLOCK F.LEN ;AREA FOR REL FILE SPEC
LSTSPC: BLOCK F.LEN ;AREA FOR LIST FILE SPEC
FINPTR: BLOCK 1 ;POINTRER TO FIRST INPUT SPEC
LINPTR: BLOCK 1 ;POINTER TO LAST INPUT SPEC
CINPTR: BLOCK 1 ;CURRENT SPEC POINTER
OUTCNT: BLOCK 1 ;NUMBER OF OUTPUT FILE SPECS
LSTCLR==.-1 ;LAST WORD TO ZERO ON A *
; THE FOLLOWING FOUR WORDS ARE TO HOLD SETTABLE SWITCH VALUES
SAVEF: BLOCK 1 ;HOLDS F WHILE IN SCAN SO .SWDPB DOES NOT
; HARM T1.
SAVEFM: BLOCK 1 ;MASKS FOR STORED FLAGS
SAVE2: BLOCK 1 ;SECOND FLAG WORD FOR SWITCHES
SAVE2M: BLOCK 1 ;SECOND MASK WORD FOR STORED FLAGS
;[1115] DATA FOR PROCESSING /NOWARN, AND RELATED KEYWORDS
NWBITS:: BLOCK NWWDCT ;[1115] NOWARN BITS
NWMASK: BLOCK NWWDCT ;[1115] NOWARN CONFLICT MASK BITS
NWSAVB: BLOCK NWWDCT ;[1115] NOWARN COMMAND BITS SAVE AREA
NWSAVM: BLOCK NWWDCT ;[1115] NOWARN COMMAND MASK SAVE AREA
DEBGSD: BLOCK 1 ;LOCAL HOLDER OF DEBUG SWITCHES
BUGINT: BLOCK 1 ;HOLDS INTERNAL OUTPUT SWITCHES
;LOCATIONS IN GLOBAL USED BY INOUT BUT SET UP HERE
DEFINE BUFHDR(A,B),<
IRP A,<
IRP B,<
A'B=CHNLTBL##+<<A-1>*TBLMAX>+B
>>>
IFE FTTENX < BUFHDR (<BIN,LST,SRC>,<HDR,PNT,CNT>) >
IFN FTTENX < BUFHDR (<BIN,LST,SRC,ICL>,<JFN,HDR,PNT,CNT>) >
IFE FTTENX <
;UUO BLOCKS
LBLOCK: BLOCK .RBALC+1 ;FOR LOOKUPS
OBLOCK: BLOCK 3 ;FOR OPENS
LKTEMP: BLOCK 1 ;FOR WILD
PATH: BLOCK 1 ;FOR PATH. UUO
> ;END OF LOCAL TOPS10 STORAGE
IFN FTTENX <
FILSPC: BLOCK 10 ;BUILD AREA FOR FILE SPEC
ICLEST: BLOCK 24 ;STORE AREA FOR INCLUDE FILE ERROR MESSAGE
> ;END OF LOCAL TOPS20 STORAGE
LASZER==.-1
IFN FTTENX,<
PAGE
SUBTTL SUBROUTINES FOR COMMAND SCANNING
;SUBROUTINE TO APPLY ABSENT DEFAULTS
RELOC
ABSDEF: SETCM F,SAVEFM ;T1 GETS A 1 BIT FOR EVERY BIT IN F
; WHICH WAS NOT EXPLICITLY SPECIFIED
; BY THE USER.
AND F,INDADF ;AND WITH THE DEFAULTS.
IORB F,SAVEF ;OR IN THE SELECTED BITS.
SETCM T1,SAVE2M ;GET THOSE SWITCHES NOT REQUESTED
AND T1,INDAD2 ;PICK UP DEFAULTS FOR THEM
IORB T1,SAVE2 ;OR IN THE SELECTED SWITCHES
MOVEM T1,F2 ;PUT OUT IN THE FLAG REGISTER
POPJ P, ;--ALL SET UP
PAGE
SUBTTL LOOKUP/ENTER SUBROUTINES
;SUBROUTINE TO RETURN THE NEXT FILE TO BE READ BY FORTRAN.
;IT RETURNS WITH THE EOCS BIT SET IN F. IF THIS IS THE
; LAST SPEC IN THE COMMAND STRING. IT SKIP RETURNS IF A
; FILE SPEC HAS BEEN FOUND.
;CALL WITH:
; PUSHJ P,NXTFIL
; NOTHING FOUND
; SPEC POINTER IN P1
NXTFIL:
MOVE T1,SRCJFN ;GET JFN
GNJFN ;SEE IF THERE IS ANOTHER FILE HERE
JRST NEWJFN ;NO MORE
JRST OPNSRC ;GOT ONE
;GET 1ST JFN FOR FILE
NEWJFN:
MOVE P1,CINPTR ;GET CURRENT SPEC POINTER
CAMN P1,LINPTR ;ARE WE DONE
POPJ P, ;YES - NONSKIP RETURN
ADDI P1,F.LEN ;UPDATE POINTER
MOVEM P1,CINPTR ;SAVE IT
PUSHJ P,XFILCV ;CONVERT SPEC BACK TO ASCII
HRRZI T1,SRCTAB ;SRC LONG JFN TABLE
MOVE T2,[POINT 7,FILSPC] ;NEW FILE SPEC
GTJFN
JRST SRCNUL ;TRY WITHOUT DEFAULT OF "FOR"
NOTFOR:
MOVEM T1,SRCJFN ;SAVE JFN
;WHAT SORT OF DEVICE DO WE HAVE
OPNSRC:
HRRZ T1,T1 ;ZERO LEFT
DVCHR
MOVE T3,FLAGS2## ;PREPARE TO SET TTY BIT
HLRZ T1,T1 ;GET DEVICE CODE
CAIN T1,TTCODE ;IS IT TTY?
JRST TTYSRC ;YES
;SRC NOT TTY:
TXZ T3,TTYINP ;NOTE NOT TTY:
MOVE T2,[XWD INBYT,READ] ;SET UP FOR OPEN
JRST GOTSRC
;TTY:
TTYSRC:
TXO T3,TTYINP ;NOTE TTY:
MOVE T2,[XWD TTYBYT,READ!WRITEE] ;SET UP FOR OPEN
;OPEN THE FILE
GOTSRC:
MOVEM T3,FLAGS2## ;SAVE THOSE FLAGS
HRRZ T1,SRCJFN ;GET JFN
OPENF
JRST FILERR ;PROBLEMS
MOVE T1,F.NAME(P1) ;SAVE FILE NAME FOR
MOVEM T1,CHNLTBL##+32 ; THE COMPILER
MOVE T1,F.EXT(P1) ; AND EXTENSION
MOVEM T1,CHNLTBL##+33
TXZ F,EOCS ;CLEAR END INPUT BIT
JRST .POPJ1## ;GOT FILE - SKIP RETURN
;TRY SRC WITHOUT "FOR"
SRCNUL:
MOVE T1,[GJ%SHT!GJ%OLD!GJ%IFG] ;FLAGS
MOVE T2,[POINT 7,FILSPC] ;ASCII FILE SPEC
GTJFN
JRST FILERR ;GIVE IT UP
JRST NOTFOR ;GOT IT WITH "NUL"
;SUBROUTINE TO CONVERT FILE SPEC BLOCK
;POINTED TO BY P1 INTO AN ASCII STRING
; AND PUT IT IN FILSPC
;CALL WITH
; P1 - SPEC POINTER
; PUSHJ XFILCV
; RETURN HERE
XFILCV:
MOVE T1,[ASCIZ /DSK:/] ;DEFAULT DEVICE
MOVEM T1,FILSPC ; FOR PPNST
MOVE T3,[POINT 7,FILSPC,27] ;PTR TO AFTER DEFAULT DEV:
SKIPN T2,F.DEV(P1) ;GET DEVICE NAME
JRST NODEV ;NONE THERE
SETZM T1,FILSPC ;CLEAR DEFAULT DEVICE
MOVE T3,[POINT 7,FILSPC] ;INITIAL POINTER
PUSHJ P,X6.7CV ;CONVERT
MOVEI T1,":" ;PUT IN COLON
IDPB T1,T3
NODEV:
MOVX T2,FX.DIR ;
TDNN T2,.FXMOD(P1) ;IS THERE A PPN?
JRST NOPPN ;NO
MOVE T2,F.DIRM(P1) ;IS PPN WILD?
AOJN T2,E.WILD ;YES == ERROR
MOVE T1,[POINT 7,FILSPC] ;PUT ANSWER HERE
MOVE T2,F.DIR(P1) ;GET PPN
MOVE T4,T3 ;SAVE PTR TO AFTER DEV: FOR DIRST
MOVE T3,T1 ;POINT TO DEV:
PPNST ;PPN TO DIRECTORY
ERJMP CHK1B ;DIDN'T WORK: CHECK FOR 1B
PPNOK: ;
MOVE T3,T1 ;T3 IS OUR FILE SPEC PTR
NOPPN: ;
SKIPN T2,F.NAME(P1) ;FILE NAME
JRST NONAM ;NOPE
PUSHJ P,X6.7CV ;CONVERT IT
NONAM:
HLLZS F.EXT(P1) ;CLEAR RIGHT HALF
SKIPE T2,F.EXT(P1) ;EXTENSION
JRST DODOT ;YES
MOVX T1,FX.NUL ;NULL EXT MASK
TDNE T1,F.MOD(P1) ;EXPLICITLY NULL?
JRST NULEXT ;NO
DODOT: MOVEI T1,"." ;PUT DOT IN
IDPB T1,T3
CAIE T2, ;DID WE HAVE A NAME
PUSHJ P,X6.7CV ;YES CONVERT
NULEXT:
MOVEI T1,0 ;NULL TERMINATOR
IDPB T1,T3
POPJ P, ;RETURN
;PPNST FAILED: IF IT FAILED BECAUSE THE JSYS WAS UNDEFINED,
; THEN WE MUST BE RUNNING ON VERSION 1B MONITOR AND CAN USE
; DIRST TO CONVERT THE PPN TO A DIRECTORY
CHK1B: ;
HRRZI T1,400000 ;GET PROCESS HANDLE
GETER ;WHY DID PPNST FAIL?
HRRZ T2,T2 ;REMOVE PROCESS HANDLE
CAIE T2,ILINS2 ;IS PPNST JSYS DEFINED?
JRST FILERR ;YES == VERSION 2 ERROR
HLRZ T2,F.DIR(P1) ;CHECK PROJECT #
CAIE T2,4 ;IS PROJ # = 4?
JRST PPN4ER ;NO == ERROR
HRRZ T2,F.DIR(P1) ;GET PROG # = DIRECTORY #
MOVE T1,T4 ;GET PTR TO AFTER DEV: SAVED ABOVE
MOVEI T3,"<" ;
IDPB T3,T1 ;PUT IN PUNCTUATION
DIRST ;PROG # TO DIRECTORY
JRST FILERR ;PPN ERROR
MOVEI T3,">" ;
IDPB T3,T1 ;PUT IN PUNCTUATION
JRST PPNOK ;
;ROUTINE TO CONVERT 6BIT TO 7BIT
;CALL WITH
; T3 = BYTE POINTER OF DESTINATION
; T2 = 6BIT NAME
; PUSHJ P,X6.7CV
; RETURN HERE
X6.7CV:
SETZM T1 ;CLEAR CHARACTER REG
LSHC T1,6 ;GET CHAR
CAIN T1,
POPJ P, ;DONE
ADDI T1," " ; TO 7BIT
IDPB T1,T3 ;STORE IT
JRST X6.7CV ;DO MORE
;ROUTINE TO PROCESS FILE ERRORS
; JRST FILERR
FILERR:
MOVE T1,[-1,,FLEHDR] ;MESSAGE HEADER
PSOUT ;TYPE IT
HRRZI T1,101 ;PRIMARY OUTPUT JFN
HRLOI T2,400000 ;CURRENT FORK,CURRENT ERROR
SETZM T3
ERSTR
JRST ERRERR ;UNKNOWN ERROR
JRST ERRERR ;PROBLEM
MOVE T1,[-1,,CRLFST] ;ADD CRLF
PSOUT
JRST ERRST ;TAKE IT FROM THE TOP
;ERROR HANDLING ERROR
ERRERR:
MOVE T1,[POINT 7,UNKFLE]
PSOUT
JRST ERRST ;RESTART
UNKFLE: ASCIZ /FILE ERROR - UNKNOWN
/
CRLFST: ASCIZ /
/
FLEHDR: ASCIZ /?FTNFER / ;ERROR MESSAGE PREFIX
;ROUTINE TO PROCESS WILD PPN ERRORS
E.WILD: MOVE T1,[POINT 7,WLDERR] ;GET ERROR MESSAGE
PSOUT ;DISPLAY IT
JRST ERRST ;GET OUT
WLDERR: ASCIZ /?FTNNWD Incorrect use of * or % in ppn
/
;PROJECT # MUST = 4 FOR DIRST JSYS ON TOPS-20 V1B
PPN4ER: ;
MOVE T1,[POINT 7,PRJERR] ;GET ERROR MESSAGE
PSOUT ;DISPLAY IT
JRST ERRST ;GET OUT
PRJERR: ASCIZ /?FTNPN4 Project number must be 4 in ppn
/
ERRST: ;ERROR ENTRY
SKIPE T1,CCLSW
JRST COMND
JRST FORTR1 ;LOOP BACK
;SUBROUTINE TO OPEN INCLUDE FILES
;CHECK TO SEE THAT THEY ARE DISK
;CALL WITH
; ICLPTR = ASCIII FILE SPEC POINTER
; PUSHJ P,OPNICL
; RETURN HERE
; VREG = 0 - OK
; OR
; VREG = ASCII ERROR STRING MESSAGE POINTER
OPNICL::
PUSH P,T1
PUSH P,T2
PUSH P,T3
HRRZI T1,ICLTAB ;LONG GTJFN INCLUDE FILE TABLE
MOVE T2,ICLPTR ;SPEC POINTER
GTJFN
JRST ICLNUL ;TRY WITHOUT DEFAULT "FOR"
NULX: MOVEM T1,ICLJFN ;SAVE JFN
MOVEM T2,ICLPTR ;SAVE POINTER TO LOOK FOR SWITCHES
;CHECK FOR DSK:
HRRZ T1,T1 ;ZERO LEFT
DVCHR
HLRZ T1,T1 ;GET DEVICE CODE
CAIE T1,DSKCOD ;DSK:?
JRST NOTDSK ;NO
HRRZ T1,ICLJFN ;GET JFN AGAIN
MOVE T2,[XWD INBYT,READ] ;SETUP FOR OPEN
OPENF
JRST ICLERR ;PROBLEMS
MOVEI VREG,0 ;GOOD RETURN
ICLRET: POP P,T3
POP P,T2
POP P,T1
POPJ P,
;TRY WITHOUT DEFAULT "FOR"
ICLNUL: MOVE T1,[GJ%SHT!GJ%OLD] ;FLAGS
MOVE T2,ICLPTR## ;FILE SPEC POINTER
GTJFN
JRST ICLERR ;DIDN'T HELP
JRST NULX ;OK GOT IT
NOTDSK: MOVE VREG,[POINT 7,NODSK] ;NOT DSK MESSAGE
JRST ICLRET
NODSK: ASCIZ /DEVICE MUST BE DISK/
ICLERR:
MOVE T1,[POINT 7,ICLEST] ;MESSAGE STORE AREA
HRLOI T2,400000 ;CURRENT FORK,CURRENT ERROR
HRLZI T3,-^D100 ;MESSAGE LIMIT
ERSTR
JRST ICLERR ;UNKNOWN
JRST ICLERR ;PROBLEM
MOVE VREG,[POINT 7,ICLEST] ;MESSAGE POINTER
JRST ICLRET
ICLEER: MOVE VREG,[POINT 7,UNKFLE] ;UNKNOWN ERROR
JRST ICLRET
;ROUTINE TO CLOSE THE ICL FILE
;CALL WITH
; PUSHJ P,CLOICL
; RETURN HERE
CLOICL::
PUSH P,T1
HRRZ T1,ICLJFN ;GET JFN
CLOSF
JFCL 0,0
POP P,T1
POPJ P,
;SUBROUTINE TO PERFORM MAG TAPE OPERATIONS
;CALL WITH:
; MOVEI P1,FILE-SPEC-POINTER
; PUSHJ P,MTAOP
; RETURN HERE WITH TAPE POSITIONED
MTAOP: POPJ P, ;NULL FOR NOW
;SUBROUTINE TO SET UP T1 AS A MODE WORD FOR MAG TAPES
;CALL WITH:
; MOVEI P1,FILE-SPEC-POINTER
; PUSHJ P,MTAOP
; RETURN HERE WITH T1 SET UP
MTMODE: SETZM T1 ;START WITH A CLEAN SLATE
POPJ P, ;RETURN
XLIST ;Literals
LIT:: LIT
LIST
> ;END TOPS-20 COMMAND PROCESSOR
END FORTRAN