Trailing-Edge
-
PDP-10 Archives
-
CFS_TSU04_19910205_1of1
-
update/cblsrc/cobscn.mac
There are 8 other files named cobscn.mac in the archive. Click here to see a list.
; UPD ID= 1518 on 2/2/84 at 3:33 PM by RMEYERS
TITLE COBSCN - The COBOL-20 Specific Command Scanner
SUBTTL David M. Nixon
SEARCH COPYRT
SALL
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1983, 1986
ENTRY COBOL
SUBTTL Revision History
Comment \
***** Begin Revision History *****
;MJC 15-JAN-86 [1625] Set up .JBREN to proint to COBLAR:
;MJC 21-JUN-85 [1601] Remove FORTRAN edit numbers
\
SEARCH P
SEARCH JOBDAT,MONSYM,MACSYM
ENTRY RESTRT ;Restart compilation (REENTER)
ENTRY REDO ;Restart compilation (START)
;Globals defined in CMND20
EXTERN CNTIDX
EXTERN SRCIDX
EXTERN SRCFIL
EXTERN CMD ;COMND% JSYS in CMND20
EXTERN USRERR ;Command not completed
EXTERN MONERR ;Error return
EXTERN SCANSW ;Read SWITCH.INI
EXTERN CONFIRM ;COMND% function to confirm a command
EXTERN ATMBUF ;Atom buffer for COMND% JSYS
EXTERN STATE ;COMND% JSYS state block
EXTERN GETDEF ;Get the default filename
EXTERN CJFNBK
EXTERN CMDSOU
EXTERN DEFFIL
EXTERN ERRPFX
EXTERN JOBNUM
EXTERN LSTTYP
EXTERN SRCGJB
EXTERN BINGJB
EXTERN LSTGJB
EXTERN FLAG10 ;-1 if TOPS-10 style command
EXTERN .HELP ;Handle TOPS-10 /H command
EXTERN .ECHOOP ;/ECHO-OPTION switch action
EXTERN .NEW ;/Z = Get back to TOPS-20 scanner
EXTERN .NOOPTION ;/NOOPTION switch action
EXTERN .OPTION ;/OPTION: switch action
EXTERN .COBSW ;-1 to signal called bt Cobol
EXTERN .OLDSW ;Use TOPS-10 style command scanner
;Global defined in COBOLA
EXTERN COBOLA ;Entry point to phase "A"
EXTERN SETIMP ;Clear the impure area
;Globals used by CMND20
INTERN COMSW,OCOMSW
INTERN DOCOMPILE
INTERN INITFL
INTERN PROMPT ;Language prompt string
INTERN PRANAM ;Process arg name used by EXEC
INTERN PRBFIL ;File name used for CCL command
INTERN DEFOFL ;Default output file name
INTERN LNGWPF ;Warning prefix
INTERN LNGFPF ;Fatal prefix
INTERN LNGCMD ;Command error message
INTERN LNGPSC ;...
INTERN HLPSTR ;HELP file on device HLP:
INTERN HLPSYS ;HELP file on device SYS:
INTERN LNGNAM ;Name of compiler
INTERN LNGTYP ;Default type of source file
INTERN ONFLG ;The flags that must be turned on
INTERN OFFFLG ;The flags that must be turned off
INTERN SONFLG ;Holds ON flags from command line during SWITCH.INI processing.
INTERN SOFFLG ;Holds OFF flags from command line during SWITCH.INI processing.
INTERN .NOLIST
;Globals used by rest of the compiler
INTERN ASYSAV
INTERN ASYCNT
INTERN IOWLIT
INTERN LIBSPC
INTERN LIBOSP
INTERN NORELS
INTERN NXTFIL ;Opens next source file for compiler
INTERN OPNLIB ;Open the library file for the compiler
INTERN OPNLIT ;Open the literal file for the compiler
INTERN OPNOVR ;Open overlay file for segmentation
INTERN PUTAS1,PUTAS2,PUTAS3
INTERN PUTGEN
INTERN PUTGN1
INTERN PUTBIN
INTERN PUTLST
INTERN RITASY ;Write last partial buffers of AS1, AS2, and AS3 files
INTERN RITNAM
INTERN RITERA
INTERN RITCPY
INTERN RITCRF
INTERN RITLIT ;Write out LITFIL buffer
INTERN RITOVD ;Write out the directory of the overlay file
INTERN GETSRB ;GET NEXT SOURCE BUFFER
INTERN GETGEN ;GET TWO WORDS
INTERN SETGEN ;SET UP GENFIL FOR INPUT
INTERN SETNAM
INTERN SETSEG ;SET UP GENFIL TO READ NEXT SECTION
INTERN GETASY ;GET A WORD
INTERN SETASY ;SET UP ASYFIL FOR INPUT
INTERN SETAS2 ;Set up to create a new AS2 file for optimizer
INTERN RENAS2 ;Rename AS2 file back
INTERN GETCPY ;GET A WORD
INTERN SETCPY ;SET UP CPYFIL FOR INPUT
INTERN GETCRF
INTERN SETCRF
INTERN GETERA ;GET A WORD
INTERN SETERA ;SET UP ERAFIL FOR INPUT
INTERN GETLIT
INTERN SETLIT ;Set up LITFIL for input
INTERN SFPLIB ;Set file pointer of library file
INTERN GETLBA ;Get library buffer
INTERN CLSAS1 ;CLOSE AS1FIL
INTERN CLSAS2
INTERN CLSAS3
INTERN CLSERA
INTERN CLSCPY
INTERN CLSCRF
INTERN CLSGEN
INTERN CLSLIB
INTERN CLSLIT
INTERN CLZSRC
INTERN CLZBIN
INTERN CLZLST
INTERN CLZLIB
INTERN DELALL ;DELETE ALL TEMP FILES
INTERN RITSF1,RITSF2,RITSF3 ;Write out buffer
INTERN SETSF1,SETSF2,SETSF3
INTERN CLSSF1,CLSSF2,CLSSF3
INTERN GETSF1,GETSF2,GETSF3 ;Read next buffer
INTERN OPNSF1,OPNSF2,OPNSF3
INTERN OPNSF ;Get a JFN for CREF temp files
INTERN DELSF ;Delete the CREF temp files
INTERN OPNDMP ;Open dump file from COBOLK
INTERN DMPOUT ;Write a character to the dump file
INTERN CLZDMP ;Close the dump file and release JFN
INTERN SETTFI ;Open any of the temp files for input in COBOLK
INTERN GETTFI ;Read the above temp file
IFN DBMS,<
INTERN OPNDBC ;Open DBC file for input
INTERN OPNDBD ;Open DB1 file for input
INTERN PUTDBC ;Write to DBC file
INTERN PUTDBD ;Write to DB1 file
INTERN SETDBS ;Open DBC for input
INTERN DBGTF. ;Open DB1 for input
INTERN GETDBS ;Get next input buffer of DBMS INVOKE file
INTERN CLSDBC ;Close DBC file but keep JFN
INTERN CLSDBD ;Close DB1 file but keep JFN
INTERN CLZDBS ;Close DBC or DB1 file and don't release JFN
INTERN DBCPTR ;Initial buffer address and size
INTERN DBDPTR ;Initial buffer address and size
>
EXTERN CCLSW ;Contains 0 or 1, the start address offset used
; to start COBOL
EXTERN OJPPSZ ;Size of OTS pushdown stack set by /STACK:
EXTERN AS7482 ;ANSI standard either 74 or 82
EXTERN COBXSW ;Same for COBOLG
EXTERN ABRTSW ;-1 if /ABORT seen
EXTERN CREFSW ;-1 if /CREF seen
EXTERN DEBSW ;-1 if /DEBUG seen
EXTERN DEFDSP ;Default display mode, either 6,7 or 9
EXTERN OPTSW ;-1 if /OPTIMIZE seen
EXTERN PRODSW ;-1 if /PRODUCTION-MODE seen
EXTERN QUIKSW ;-1 if /QUICK-MODE seen
EXTERN SLASHJ ;-1 if main program switch seen
EXTERN SUBPRG ;-1 if subprogram switch seen
EXTERN SEENRU ;-1 if /U seen, +1 if /R seen
EXTERN RENSW ;-1 if /R seen
EXTERN FLGSW ;FIPS flagger mask
IFN DEBUG,<
EXTERN CORESW ;Holds /TRACE: and /KILL: masks
EXTERN TRACFL
>
EXTERN GENWRD
EXTERN PROGST
EXTERN PROLOC
EXTERN KILL
SALL
CMDTRC==0 ;Turn on tracing
BUFSIZ==^D96 ;Length (words) of command line buffer
ATMBLN==^D34 ;Length (words) of atom buffer
MAXFILES==^D20 ;Maximum number of sources files in one command
TMPLEN==200 ;Length of the PRARG block
TAKLEN==^D10 ;Nesting depth of TAKE files
TWOSEG %HISEG
.COPYRIGHT ;Put standard copyright statement in REL file
;AC'S USED BY COMMAND SCANNER
F==0 ;Known as FLGREG by the compiler.
SW==0 ;Used as a flag register by rest of the compiler.
R0==0 ;Used by DBMS code
T1==1 ;TEMP
T2==2 ; ..
T3==3 ; ..
T4==4 ; ..
T5==5 ; ..
T6==6 ; ..
P1==7 ;PRESERVED AC
P2==10 ; ..
P3==11 ; ..
P4==12 ;
P5==13 ;
P6==14 ;
VREG=15 ;BLIS10 VALUE RETURN REG
; FREG=16 ;BLIS10 FRAME POINTER
SREG=17 ;BLIS10 STACK POINTER
OPDEF PJRST [JRST] ;PUSHJ and POPJ
OPDEF NOOP [TRN] ;Fastest No-op in machine
.NODDT PJRST,NOOP
DEFINE TRACE(S)<
IFN CMDTRC,<
PUSH SREG,T1
HRROI T1,[ASCIZ \
Got to 'S
\]
PSOUT%
POP SREG,T1>
>
FRMTTY==0 ;Command input comes from terminal
FRMPRA==1 ;Command input comes from PRARGs
FRMTAK==2 ;Command input comes from /TAKE file
FRMSWI==3 ;Command input comes from SWITCH.INI
FRMTEN==4 ;Command input is under TOPS-10 compatibility
SUBTTL Flag Mask Definitions
;Global flags are in LHS of SW. Do not change these values they are defined in P.MAC.
;The RHS of SW if used during command scanning to hold useful flags.
;Flags that correspond to switch setting are stored in ONFLG and OFFFLG.
;The RHS of ONFLG is the same as the RHS of SW for convenience.
;The flags in ONFLG and OFFFLG are converted to LHS of SW or full word switches
;just before compilation starts.
;Flag word offsets
$F==0 ;Flags to put in SW or separate full words
$FC==1 ;Flags to put in CORESW
$FD==2 ;Flags to put in DEFDSP
$FX==3 ;Flags to put in COBXSW
$FL==4 ;Flags to put in FLGSW (flagger switches)
$FS==5 ;Stack size
NUMFLGS==6 ;Length of switch block
;Flags in ONFLG+$F and OFFFLG+$F
SW.ABO==1B0 ;Abort (exit) on fatal errors
SW.AFS==1B1 ;ANSI-FORMAT (card sequenced)
SW.CRF==1B2 ;CREF wanted
SW.ERA==1B3 ;Print errors on terminal
SW.NOC==1B4 ;Don't list library file in listing
SW.MAC==1B6 ;/MACHINE-CODE wanted
SW.MAP==1B7 ;Data map wanted
SW.MAI==1B8 ;Main progran
SW.SUB==1B9 ;Sub-program
SW.OPT==1B10 ;Optimize
SW.PRD==1B11 ;Production mode
SW.QIK==1B12 ;Quick mode
SW.OCS==1B13 ;Only Check Syntax
SW.ONE==1B14 ;One-seg
SW.TWO==1B15 ;Two-seg
RELFLG==1B22 ;REL file wanted
LSTFLG==1B25 ;LIST file wanted
TTYINP==1B30 ;INPUT DEVICE IS A TTY
;Values in ONFLG+$FD and OFFFLG+$FD
;%US.D6==1 ;DISPLAY-6 (defined in P.MAC)
;%US.D7==2 ;DISPLAY-7 (defined in P.MAC)
;%US.EB==3 ;DISPLAY-9 (defined in P.MAC)
;Flags in ONFLG+$FX and OFFFLG+$FX
SW.A82==SW.A82 ;1B16 ;ANS-82 syntax wanted (defined in INTERM)
SW.A74==SW.A74 ;1B17 ;ANS-74 syntax wanted (defined in INTERM)
SUBTTL Low Segment Data Area
LOC 124 ;[1625] Point at .JBREN
EXP COBLAR ;[1625] Set up the REENTER address
RELOC 0
APRSV1: BLOCK 1
APRSV2: BLOCK 1
APRSV3: BLOCK 1
LIBTYP: BLOCK ATMBLN ;Holds user's typescript of value to /LIBRARY
COBSTK: BLOCK 1 ;Used to restore the stack pointer
ONFLG: BLOCK NUMFLGS ;The flags that must be turned on
OFFFLG: BLOCK NUMFLGS ;The flags that must be turned off
SONFLG: BLOCK NUMFLGS ;Holds ON flags from command line
;during SWITCH.INI processing.
SOFFLG: BLOCK NUMFLGS ;Holds OFF flags from command line
;during SWITCH.INI processing.
XJBFF: BLOCK 1 ; Holds .JBFF across compiles
XJBREL: BLOCK 1 ; Holds .JBREL across compiles
DEFINE IOLIST (A,B,C,D,E)<
EXTERN A'JFN,A'BH
>
IOFILE
DEFINE IOLIST (A,B,C,D,E)< A'BLN==B
A'BFR: BLOCK A'BLN>
IOFILE
TMPGJB: BLOCK .GJJFN+1 ;Default GTJFN block for temp files
LIBGJB: BLOCK .GJJFN+1 ;Default GTJFN block for LIBRARY files
TMPSPC: BLOCK 2 ;Temp file name
ASCJOB: BLOCK 1 ;ASCII job number right justified
ASYSAV: BLOCK 1 ;Save JFN of AS1FIL during phase G
ASYCNT: BLOCK 1 ;Which ASY phase G is currently working on
NORELSW: BLOCK 1 ;-1 if REL file is not to be produced
LIBSPC: BLOCK ^D40 ;CPYLIB filespec
LIBOSP: BLOCK ^D40 ;Old CPYLIB filespec
IOWLIT: BLOCK 2 ;IOWD for dump mode write of LITFIL
RELOC 400000
SUBTTL Constants
PROMPT: ASCIZ \COBOL>\ ;Prompt pointer
PRANAM: 'NCO' ;Process arg name used by EXEC
PRBFIL: ASCIZ \/TAKE:000NCO.TMP;T
\
DEFOFL: ASCIZ /COBOL-OUTPUT/
LNGFPF: ASCIZ /?CBL/ ;Fatal prefix
LNGWPF: ASCIZ /%CBL/ ;Warning prefix
LNGCMD: ASCIZ /CBLCMD / ;Command error message
LNGPSC: ASCIZ /CBLCMD "+", switch, or confirm required -- /
HLPSTR: ASCIZ /HLP:COBOL.HLP/ ;HELP string on HLP:
HLPSYS: ASCIZ /SYS:COBOL.HLP/ ;HELP string on SYS:
LNGNAM: ASCIZ /COBOL/ ;Name of compiler
LNGTYP: ASCIZ /CBL/ ;Default type of source file
SUBTTL Start up code
$COPYRIGHT ;Put standard copyright statement into EXE file
COBOL: JRST COMTTY ;Normal entry point
JRST COMDSK ;CCL entry point
JRST COBLAR ;Restart
;Here to go to COBOLA to continue compilation after command scanning.
RETCOB: MOVEM PP,COBSTK ;Store pointer
JRST COBOLA ;And go to COBOLA
;Restart due to START console command
REDO: SETZ SW,
;Restart due to REENTER console command.
;Also used by COBOLG, COBOLK, and QUITS.
RESTRT: TSWF FECOM ;Any more commands?
HALTF% ;No
AND SW,[EXP FDSKC] ;Turn off all flags except CCL flag
MOVE PP,COBSTK ;Restore stack pointer
POPJ PP, ;Return to scanner
;Set up to get commands from disk
COMDSK: MOVX SW,FDSKC ;Clear flags, set "commands from disk"
MOVEI TA,1
MOVEM TA,CCLSW
JRST COBLAS
COMTTY: SETZB SW,CCLSW## ;Clear flags and signal normal entry point
;Start a new compilation
COBLAR: TSWF FDSKC ;INPUT COMMAND FROM TTY?
JRST COBLAS ;NO
COBLAS: RESET%
GETNM ; Get the name of the program
MOVE T2,T1 ; Private name is name returned by GETNM%
MOVE T1,[SIXBIT \COBOL\] ;System name
SETSN% ;Let's tell the Monitor!
NOOP ;Failure return, we don't care!
SETOM .COBSW ;Signal called by Cobol
MOVEI T1,.LNSJB ;Job-wide logical name
HRROI T2,[ASCIZ /COBOL-SCANNER/]
MOVE T3,[POINT 7,.OLDSW]
LNMST%
JRST NOLNM ;No logical name
MOVE T3,.OLDSW ;Get name
SETZM .OLDSW ;Assume off
CAME T3,[ASCIZ /OLD/]
CAMN T3,[ASCIZ /old/]
SETOM .OLDSW ;Use TOPS-10 command scanner
NOLNM: MOVEI T1,.FHSLF ;This process's compatibility vector
SETO T2, ;Do not allow UUOs
SCVEC%
MOVE PP,[SPSIZE##,,SPLIST##-1] ;Set up stack
PUSHJ PP,APRINI ;Initialize interupt system
;Save initial values of .JBFF and .JBREL
MOVE T1,.JBFF ; Save value of .JBFF across compile
MOVE T2,.JBREL ; Save value of .JBREL across compile
DMOVEM T1,XJBFF ;
;Zero all of free memory between .JBFF and .JBREL just to be sure
CAIG T1,(T2)
SETZM (T1)
AOS T1
HRL T1,.JBFF
CAMLE T2,.JBFF
BLT T1,(T2)
PUSHJ PP,SETIMP ;Initialize Cobol specific stuff
JRST CMND20## ;Continue in language independant code
SUBTTL TRAP handling routines
;
; Subroutine to initialize for 'APR' trapping
;
; SET UP TRAPS FOR
;
; TOPS-10 TOPS-20
; AP.POV .ICPOV PUSHDOWN OVERFLOW
; AP.NXM .ICNXP NON-EXISTENT MEMORY
; AP.ILM .ICIRD MEMORY PROTECTION VIOLATION
; .ICIWR (READ & WRITE)
;
APRINI:
MOVEI T1, .FHSLF ; OWN FORK
CIS% ; CLEAR INTERUPT SYSTEM
MOVE T2, [LEVTAB,,CHNTAB] ; ADDR OF LEVEL TAB & CHAN TAB
SIR% ; SET INTERUPT ADDRESSES
EIR% ; ENABLE INTERUPT SYSTEM
MOVE T2, .JBREL ; END OF CORE (REFERENCES PG 0)
ORI T2, 777 ; END OF PAGE-IFY
MOVEI T3, 1777 ; START AT END OF PAGE 1
APR.1: CAMLE T3, T2 ; DONE YET?
JRST APR.2 ; YES, ACTIVATE INTERUPTS
SKIP (T3) ; NO, REFERENCE THIS PAGE
ADDI T3, 1000 ; BUMP UP 1 PAGE
JRST APR.1
APR.2: MOVE T2,[CHNMSK] ; ARM PROPER CHANNELS
AIC% ; ENABLE INTERUPT CHANNELS
POPJ SREG, ;
; Blocks for TOPS-20 interupt system
; Note: all interupts happen at level 1
LEVTAB: LEV1PC ; ADDR OF LEVEL 1 PC
LEV2PC ; ADDR OF LEVEL 2 PC
LEV3PC ; ADDR OF LEVEL 3 PC
RELOC ; TO THE LOWSEG
LEV1PC: BLOCK 1 ; LEVEL 1 PC
LEV2PC: BLOCK 1 ; LEVEL 2 PC
LEV3PC: BLOCK 1 ; LEVEL 3 PC
RELOC ; BACK TO PURE STORAGE
CHNMSK==1B<.ICPOV>!1B<.ICIRD>!1B<.ICIWR>!1B<.ICNXP> ; CHANNEL MASK
CHNTAB: PHASE 0 ; *** BEWARE! ***
; The value of "." is now the current offset into the table
; instead of .-CHNTAB so you are allways <n>-. words away from
; entry <n> instead of <n>-<.-CHNTAB>
BLOCK .ICPOV-. ; (0-8)
1,,POVTRP ; (9) PDL OVERFLOW
BLOCK .ICILI-. ; (10-14)
1,,ILITRP ; (15) ILL INST
1,,IRDTRP ; (16) ILL MEM READ
1,,IWRTRP ; (17) ILL MEM WRITE
BLOCK .ICNXP-. ; (18-21)
1,,NXPTRP ; (22) NON-EXISTENT PAGE
BLOCK ^D35-. ; (23-35)
DEPHASE ; *** END OF PHASE 0 ***
SUBTTL CORE UUO Simulation Routines
; NEW /PLB
; Simulate CORE UUO for TOPS-20
CORUUO::
PUSH SREG, T1
PUSH SREG, T2
MOVEI T1, %HISEG ;GET HI-SEGMENT ORIGIN
CAMG T1, -3(P) ;LARGER THEN REQUESTED CORE BREAK?
PUSHJ SREG, CORERR ;'FRAID SO
MOVEI T1, .FHSLF ;THIS PROCESS
MOVEI T2, 1B<.ICNXP> ;NON-EXISTENT PAGE TRAP
DIC% ;DEACTIVATE
MOVE T2, -3(P) ;GET DESIRED LOW SEGMENT BREAK
ORI T2, 777 ;END-OF-PAGE-IFY
MOVE T1, .JBREL ;GET CURRENT END OF CORE
CAMG T2, T1 ;CUTTING BACK????
JRST CORE.1 ;YES
AOJ T1, ;BUMP UP FROM END OF LAST PAGE
SETZM (T1) ;ZERO FIRST WORD
HRL T1, T1 ;PREPARE FOR BLT
BLT T1, (T2) ;SMEAR THE ZEROS
CORE.1: MOVEM T2, .JBREL ;STORE AS NEW END
MOVEI T1, .FHSLF ;OUR FORK
MOVEI T2, 1B<.ICNXP> ;NXP INTERUPT CONDITION
AIC% ;ACTIVATE CHANNEL
POP SREG, T2
POP SREG, T1
POPJ SREG,
; Core UUO failure routine is low segment resident (called from
; CORMAN and GETCOR).
CORERR:: ;HERE WHEN CORE UUO FAILS
DMOVEM T1,APRSV1 ;STORE T1, T2
MOVEM T3,APRSV3 ; STORE T3
SOS T1,0(P) ;WHERE WERE WE CALLED FROM
HRRZM T1,.JBTPC ;STORE ADDRESS
HRROI T2,[ASCIZ \?CBLUCE User Core Exceeded\] ;LOCATE MESSAGE
JRST APRTR4 ;FINISH MESSAGE
SUBTTL Misc. Error Utility Routines
;APR TRAP ROUTINE
NXPTRP: DMOVEM T1, APRSV1 ; SAVE REGS T1 & T2
MOVEI T1, .FHSLF ; US
GTRPW% ; GET TRAP WORD
JUMPE T1, NXP.0 ; NO ERROR ?
HRRZ T2,T1 ;Get location
CAMG T2,.JBREL ;Under top of low seg?
JRST NOTRAP ;Yes, return to user
CAIGE T2,%HISEG ;In high seg?
JRST NXP.1 ;No, give error for sure
HRRZ T2,.JBHRL ;Get top of high seg
CAIGE T2,(T1) ;Is it above top?
JRST NXP.1 ;Yes, give error
NOTRAP: DMOVE T1, APRSV1 ; GET REGS BACK
DEBRK% ; RETURN FROM TRAP
; FALL THRU ON ERROR
DMOVEM T1, APRSV1 ; SAVE REGS T1 & T2
NXP.0: HRROI T2,[ASCIZ \Unknown trap error\]
JRST ICEERR ;Report it
NXP.1: HRROI T2, [ASCIZ \Illegal Memory Reference\] ; GENERIC NXM
TLNE T1, (PF%WRT) ; PAGE FAIL ON WRITE?
HRROI T2, [ASCIZ \Non-existent memory write\]
JRST ICEERR ;Report it
ILITRP: DMOVEM T1, APRSV1 ;Save regs T1 & T2
HRROI T2, [ASCIZ \Illegal instruction\]
JRST ICEERR ;Report it
IRDTRP: DMOVEM T1, APRSV1 ;Save regs T1 & T2
HRROI T2, [ASCIZ \Illegal memory read\]
JRST ICEERR ;Report it
IWRTRP: DMOVEM T1, APRSV1 ;Save regs T1 & T2
HRROI T2, [ASCIZ \Illegal memory write\]
JRST ICEERR ;Report it
POVTRP: DMOVEM T1, APRSV1 ;Save regs T1 & T2
HRROI T2,[ASCIZ \Stack exhausted\] ;PDL OVERFLOW
ICEERR: MOVEM T3, APRSV3 ;Save T3 also
HRROI T1,[ASCIZ \
?CBLICE Internal Compiler Error
?\]
PSOUT%
APRTR4: HRRO T1,T2 ;GET ERROR STRING
PSOUT%
HRROI T1,[ASCIZ \ at location \]
PSOUT%
MOVEI T1,.PRIOU ;TO TERMINAL
HRRZ T2,LEV1PC ;TRAP PC
MOVE T3,[NO%OOV!NO%LFL!NO%ZRO!FLD(6,NO%COL)!10] ;LPAD W/ ZERO , SIX OITS
NOUT%
NOOP ;OVERFLOW?
HRROI T1,[ASCIZ \ in Phase \]
PSOUT%
MOVE T1,PHASEN## ;Get phase #
PBOUT%
HRROI T1,CRLF
PSOUT%
APRTR2: DMOVE T1,APRSV1 ; RESTORE REGS
MOVE T3,APRSV3 ; FOR CRASH
JRST KILL
CRLF: ASCIZ /
/
SUBTTL Initialize the Flag Areas
INITFL: SETZM ONFLG ;Clear the first word of flags
MOVE T1,[XWD ONFLG,ONFLG+1] ;Clear "must be ON or OFF" flags
BLT T1,ONFLG+2*NUMFLGS-1
POPJ PP,
SUBTTL DOCOMPILE -- Call the COBOL Compiler
DOCOMPILE:
PUSH SREG,P1 ;Save old value of P1
PUSH SREG,P2 ;Save old value of P2
MOVE T1,[ONFLG,,SONFLG] ;Move command line flags to save area
BLT T1,SONFLG+2*NUMFLGS-1
MOVE T1,[ONFLG,,ONFLG+1]
SETZM ONFLG ;Clear "must be ON" and "must be OFF" flags
BLT T1,ONFLG+2*NUMFLGS-1
PUSHJ SREG,SCANSW ;Get switches for SWITCH.INI
;Resolve the switch settings
MOVE T1,DEFFLG ;Get the default value of switch words
SKIPE FLAG10 ;Was command scanned as a TOPS-10 command?
IOR T1,DEF10 ;Yes, add in -10 defaults
ANDCM T1,OFFFLG ;Turn off flags that must be off
IOR T1,ONFLG ;Turn on flags that must be on
ANDCM T1,SOFFLG ;Turn off flags that must be off
IOR T1,SONFLG ;Turn on flags that must be on
MOVEM T1,ONFLG ;Store final on state
SKIPN T2,SONFLG+$FS ;Get stack size from command line
MOVE T2,ONFLG+$FS ;Or from SWITCH.INI
MOVEM T2,OJPPSZ ;Save it
SKIPN T2,SONFLG+$FX ;Get which ANSI standard from command line
MOVE T2,ONFLG+$FX ;Or from SWITCH.INI
IORM T2,COBXSW ;Save it
TXNE T2,SW.A74 ;Want ANS-74?
SETOM AS7482 ;Yes
TXNE T2,SW.A82 ;Want ANS-8x?
AOS AS7482 ;Yes
SKIPN T2,SONFLG+$FD ;Get default display mode from command line
MOVE T2,ONFLG+$FD ;Or from SWITCH.INI
MOVEM T2,DEFDSP ;Save it
SKIPN T2,SONFLG+$FL ;Get FIPS flagger bits from command line
MOVE T2,ONFLG+$FL ;Or from SWITCH.INI
JUMPE T2,SET$FC ;No flags to set
TLNE T2,-1 ;Is it flags we don't want?
JRST [HLRZ T2,T2 ;Yes, get in RHS first
TRNE T2,%LV.L ;Now turn on all included FIPS flags
TROA T2,%LV.LI ;Low implies Low-intermediate etc.
TRNE T2,%LV.LI
TROA T2,%LV.HI
TRNE T2,%LV.HI
TRO T2,%LV.H
SETCAM T2,FLGSW ;Compliment it
JRST SET$FC]
TRNE T2,%LV.H ;Now turn all included FIPS flags
TROA T2,%LV.HI ;High implies High-intermediate etc.
TRNE T2,%LV.HI
TRO T2,%LV.LI
TRO T2,%LV.L ;Always turn on Low-level
MOVEM T2,FLGSW ;Save it
SET$FC:
IFN DEBUG,<
MOVE T2,SONFLG+$FC ;Get /KILL and /TRACE masks from command line
TLNN T2,-1 ;/KILL seen?
HLL T2,ONFLG+$FL ;No get from SWITCH.INI
TRNN T2,-1 ;/TRACE seen?
HRR T2,ONFLG+$FL ;No get from SWITCH.INI
MOVEM T2,CORESW ;Save it
TRNE T2,-1 ;Want tracing?
SETOM TRACFL ;Yes
>
;Now turn on or off the approprite bits in LHS of SW and set the full word switches.
HRR SW,T1 ;Set bits in SW to speed up testing
TXO SW,FTERA+FREENT ;Default is two-seg code and list errors
TXNN T1,SW.ERA ;Want to print errors?
TXZ SW,FTERA ;No
TXNE T1,SW.CRF ;Seen /CREF?
SETOM CREFSW ;Yes, turn on CREF switch
TXNE T1,SW.AFS ;/ANSI-FORMAT seen?
TXO SW,FSEQ ;Yes, turn on sequence # switch
TXNE T1,SW.NOC ;Don't want library listed?
SETOM NOCPYL## ;Yes, set the flag
TXNE T1,SW.MAC ;Want macro expansion?
TXO SW,FOBJEC ;Yes, turn on permanent switch
TXNE T1,SW.MAI ;Main program switch seen?
SETOM SLASHJ ;Yes, generate start address no matter what
TXNE T1,SW.SUB ;Sub-program switch seen?
SETOM SUBPRG ;Yes, do not generate start address
TXNE T1,SW.MAP ;Want Data Division map?
TXO SW,FMAP ;Yes, turn on Data Division map wanted
TXNE T1,SW.OCS ;Syntax check only?
TXO SW,FFATAL ;Yes, prevent code generation
TXNE T1,SW.ONE ;Explicit one-seg wanted?
JRST [SWOFF FREENT ;Turn off /TWOSEG
SETOM SEENRU ;Set flag to -1
JRST .+1]
TXNE T1,SW.TWO ;Explicit two-seg wanted?
JRST [SETOM RENSW## ;Set flag for COBOLG, leave FREENT on
AOS SEENRU## ;Set flag to +1
JRST .+1]
TXNE T1,SW.OPT!SW.QIK ;Want to optimize code?
SETOM OPTSW ;Yes
TXNE T1,SW.PRD!SW.QIK ;Want production mode code?
SETOM PRODSW ;Yes
TXNE T1,SW.QIK ;Want benchmark speed code?
SETOM QUIKSW ;Yes, no bounds checking etc
TXNE T1,SW.ABO ;/ABORT seen?
SETOM ABRTSW ;Yes
TXNE T1,SW.OCS ;Is /SYNTAX specified?
TXZ SW,RELFLG ;Yes--Turn off /OBJECT flag
TXNN SW,LSTFLG ;Listing wanted?
TXO SW,FNOLST ;No, turn on nolist flag
TXNN SW,RELFLG ;Want REL FILE?
SETOM NORELSW ;No
;Now open the Rel and List files, also the scratch files
PUSHJ SREG,OPNSCR ;Open the initial scratch files
TXNN F,RELFLG ;Is a object file required?
JRST RELOBJ ;No--See if an object file JFN must be released
SKIPL T1,BINJFN ;Do we have an object file JFN?
JRST OPNOBJ ;Yes--Now ready to open file
HRRZI T1,BINGJB ;Get pointer to arg block for GTJFN
HRROI T2,DEFFIL ;The default name block will be the filespec
GTJFN% ;Get a JFN on the object file
ERJMP MONERR ;
HRRZM T1,BINJFN ;Store JFN of object file
OPNOBJ: MOVX T2,OF%WR ;Open file for writing, ASCII 36 bit bytes
OPENF%
ERJMP MONERR ;Problems
JRST GETLST
RELOBJ: SKIPGE T1,BINJFN ;Get JFN of object file
JRST GETLST ;No JFN of object file
RLJFN% ;Release JFN
ERJMP MONERR
SETOM BINJFN ;Mark JFN as released
GETLST: TXNN SW,LSTFLG ;Is any list file specified?
SKIPGE T1,LSTJFN ;Get JFN of list file
JRST GETL2 ;No JFN for list file
RLJFN% ;Release JFN
ERJMP MONERR
SETOM LSTJFN ;Mark list file as having no JFN
GETL2: TXNN SW,LSTFLG ;Is list flag set?
JRST GETLIB ;Yes--Don't have to get a list file JFN
SKIPL T1,LSTJFN ;Do we have an listing file JFN?
JRST OPNLST ;Yes--Now ready to open list file
HRRZI T1,LSTGJB ;Set up for GTJFN%
SKIPE LSTTYP ;Does the original typescript from /LIST exist?
SKIPA T2,[POINT 7,LSTTYP] ;Yes--Use it as filespec
HRROI T2,DEFFIL ;No--Use default file as filespec
GTJFN% ;Get list file JFN
ERJMP MONERR
HRRZM T1,LSTJFN ;Store list file JFN
OPNLST: MOVX T2,FLD(7,OF%BSZ)+OF%WR ;Open file for writing, 7 bit bytes
OPENF%
ERJMP MONERR ;Problems
SKIPE CREFSW ;Seen /CREF?
PUSHJ PP,OPNCRF ;Yes, open CRF temp file
MOVE T1,LSTJFN ;Get JFN of list file
DVCHR% ;Get characteristics of listing file
LDB T1,[POINTR(T1,DV%TYP)] ;Get device type
CAIE T1,.DVTTY ;Is it a terminal?
JRST GETLIB ;No--Don't need to do anything
HRRZ P1,T3 ;Save number of job that owns the terminal
GJINF% ;Get this job's job number
CAMN P1,T4 ;Are the job numbers the same?
TXO SW,FLTTY ;Yes--Set the list file goes to our TTY flag
GETLIB: SKIPG T1,LIBJFN ;Any library file?
JRST LDSOU ;No
DVCHR% ;Get characteristics
LDB T1,[POINTR(T1,DV%TYP)]
CAIE T1,.DVDSK ;Must be a disk
JRST NOTDSK ;So give error
MOVE T1,LIBJFN
MOVX T2,OF%RD ;Read 36 bits
OPENF%
ERJMP MONERR
SETZM LIBBH+1 ;Force buffer setup on first read
SETZM LIBBH+2
LDSOU:
SETOM CNTIDX ;No source file is currently open
PUSHJ SREG,NXTFIL ;Open the first source file
HALTF% ;Error return--can not happen!
SKIPN CCLSW ;Was COBOL entered at CCL start address
JRST CALCBL ;No--Load list file entry in CHNLTBL
HRROI T1,[ASCIZ \COBOL: \] ; No square bracket
PSOUT% ;Tell the user who we are
REPEAT 0,< ;This is done by COBOLB
HRROI T1,ATMBUF
PSOUT% ;Print name of first source file
HRROI T1,[ASCIZ \
\] ; No square bracket
PSOUT%
>
CALCBL: PUSHJ P,RETCOB ;Call COBOLA back
PUSHJ SREG,CLZALL ;Close all files
DMOVE T1,XJBFF ; Restore value of .JBFF
MOVEM T1,.JBFF ;
MOVEM T2,.JBREL ; Restore value of .JBREL
SKIPE ABRTSW## ;Was /ABORT specified?
TXNN SW,FFATAL ;Yes, was there fatal errors during compile?
JRST RETCOM ;No--Return from this compilation
HRROI T1,[ASCIZ \[Exit due to /ABORT]
\]
PSOUT%
HALTF%
RETCOM: PUSHJ PP,SETIMP ;Clear the impure area of compiler
POP SREG,P2 ;Restore P2
POP SREG,P1 ;Restore P1
POPJ SREG, ;Return
DEF10: EXP LSTFLG ;TOPS-10 default is to generate LST file
DEFFLG:
IFE DEBUG,<
EXP RELFLG!SW.ERA ;Default is to generate REL file and print errors
>
IFN DEBUG,<
EXP RELFLG!SW.ERA!LSTFLG!SW.MAC ;Plus listing with macro-code
>
SUBTTL SWITCH ACTION ROUTINES
.ABORT:
TRACE <.ABORT>
MOVX T1,SW.ABO ;Get the flag
IORM T1,ONFLG ;Turn on flags that must be on
ANDCAM T1,OFFFLG ;Turn off flags that must be off
JRST OKRET
.ANSI:
TRACE <.ANSI:>
MOVX T1,SW.AFS ;Flag that says card sequenced input
IORM T1,ONFLG ;Turn on the card seq flag
ANDCAM T1,OFFFLG ;Turn off the no card seq flag
JRST OKRET
.C74:
TRACE <.C74>
MOVX T1,SW.A74 ;Get flag
JRST .C748x
.C8x:
TRACE <.C8X>
MOVX T1,SW.A82 ;Get flag
.C748x: IORM T1,ONFLG+$FX
ANDCAM T1,OFFFLG+$FX
TXC T1,SW.A74!SW.A82 ;Do reverse for opposite switch
ANDCAM T1,ONFLG+$FX
IORM T1,OFFFLG+$FX
JRST OKRET
.CROSS:
TRACE <.CROSS>
MOVX T1,SW.CRF!LSTFLG ;Get the flags
IORM T1,ONFLG ;Turn on flags that must be on
ANDCAM T1,OFFFLG ;Turn off flags that must be off
JRST OKRET
.DEBUG:
TRACE <.DEBUG>
SETOM DEBSW
JRST OKRET
.DISP9:
TRACE <.DISP9>
HRROI T1,%US.EB ;Turn on EBCDIC mode
MOVEM T1,ONFLG+$FD ;In flags that must be on
JRST OKRET
.DISPLAY:
TRACE <.DISPLAY:>
MOVEI T2,DIS.KY ;Look for a keyword (single letter only)
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return, command not completed
HRRO T1,(T2) ;Get mode flag
MOVEM T1,ONFLG+$FD ;Turn on flags that must be on
JRST OKRET
.ERRORS:
TRACE <.ERRORS>
MOVX T1,SW.ERA ;Get the flag
IORM T1,ONFLG ;Turn on flags that must be on
ANDCAM T1,OFFFLG ;Turn off flags that must be off
JRST OKRET
.FLAGA:
TRACE <.FLAGA:>
HRROS OFFFLG+$FL ;Turn off all FLAG-IF flags
MOVEI T2,FLG.K1 ;Look for a keyword
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return, command not completed
SETZ VREG, ;Assume that nothing unusual happens
CAIN T3,FLG.K1 ;Was a keyword found?
PJRST PRSFLA ;Yes--go process keyword
CAIE T3,FLG.K3 ;Was a open paren found?
JRST USRERR ;No, something wrong
GETFLA: MOVEI T2,FLG.K2 ;Look for only a keyword
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
PUSHJ SREG,PRSFLA ;Process this keyword
HRROI T4,[ASCIZ \CBLCMD Comma or ")" required -- \]
MOVEM T4,ERRPFX ;Store error message prefix
MOVEI T2,COMMA. ;Look for a "," or a ")"
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
HRROI T4,[ASCIZ \CBLCMD \]
MOVEM T4,ERRPFX ;Store error message prefix
CAIN T3,COMMA. ;Was a comma found?
JRST GETFLA ;Yes--get next keyword
JRST OKRET ;Signal that next switch was not scanned
PRSFLA: HRRZ T2,(T2) ;Get keyword mask
IORM T2,ONFLG+$FL ;Turn on flags that must be on
POPJ SREG, ;Return
.FLAGI:
TRACE <.FLAGI:>
HLLOS OFFFLG+$FL ;Turn off all FLAG-ALLBUT flags
MOVEI T2,FLG.K1 ;Look for a keyword
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return, command not completed
SETZ VREG, ;Assume that nothing unusual happens
CAIN T3,FLG.K1 ;Was a keyword found?
PJRST PRSFLI ;Yes--go process keyword
CAIE T3,FLG.K3 ;Was a open paren found?
JRST USRERR ;No, something wrong
GETFLI: MOVEI T2,FLG.K2 ;Look for only a keyword
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
PUSHJ SREG,PRSFLI ;Process this keyword
HRROI T4,[ASCIZ \CBLCMD Comma or ")" required -- \]
MOVEM T4,ERRPFX ;Store error message prefix
MOVEI T2,COMMA. ;Look for a "," or a ")"
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
HRROI T4,[ASCIZ \CBLCMD \]
MOVEM T4,ERRPFX ;Store error message prefix
CAIN T3,COMMA. ;Was a comma found?
JRST GETFLI ;Yes--get next keyword
JRST OKRET ;Signal that next switch was not scanned
PRSFLI: HRLZ T2,(T2) ;Get keyword mask into LHS
IORM T2,ONFLG+$FL ;Turn on flags that must be on
POPJ SREG, ;Return
;Here for old TOPS-10 /Y switch
.FLAGY:
TRACE <.FLAGY:>
SKIPN .OLDSW ;Old style scanner?
JRST .FLAGA ;No, just lazy typist
MOVEI T2,YSW.K1 ;Look for a keyword
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return, command not completed
SETZ VREG, ;Assume that nothing unusual happens
CAIN T3,YSW.K2 ;Was a hyphen found?
JRST .FLAGZ ;Yes, this is /FLAG-IF:
HRROS OFFFLG+$FL ;Turn off all /FLAG-IF flags
CAIE T3,YSW.K1 ;Was a keyword found?
JRST USRERR ;No, something wrong
PUSHJ SREG,PRSFLY ;Yes, go process keyword
GETFLY: MOVEI T2,YSW.K3 ;Look for another letter, or end of switch
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
CAIE T3,YSW.K3 ;Did we find a letter?
POPJ SREG, ;No, switch is finished
PUSHJ SREG,PRSFLY ;Process this keyword
JRST GETFLY ;Get next letter
HRROI T4,[ASCIZ \CBLCMD Comma or ")" required -- \]
MOVEM T4,ERRPFX ;Store error message prefix
MOVEI T2,COMMA. ;Look for a "," or a ")"
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
HRROI T4,[ASCIZ \CBLCMD \]
MOVEM T4,ERRPFX ;Store error message prefix
CAIN T3,COMMA. ;Was a comma found?
JRST GETFLA ;Yes--get next keyword
JRST OKRET ;Signal that next switch was not scanned
PRSFLY: HRRZ T2,(T2) ;Get keyword mask
IORM T2,ONFLG+$FL ;Turn on flags that must be on
POPJ SREG, ;Return
.FLAGZ: HLLOS OFFFLG+$FL ;Turn off all FLAG-ALLBUT flags
GETFLZ: MOVEI T2,YSW.K3 ;Look for another letter, or end of switch
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
CAIE T3,YSW.K3 ;Did we find a letter?
POPJ SREG, ;No, switch is finished
PUSHJ SREG,PRSFLY ;Process this keyword
JRST GETFLZ
PRSFLZ: HRLZ T2,(T2) ;Get keyword mask
IORM T2,ONFLG+$FL ;Turn on flags that must be on
POPJ SREG, ;Return
.LIBRARY:
TRACE <.LIBRARY:>
SKIPG T1,LIBJFN ;Get the possibly old library file JFN
JRST NEWLIB ;If no old JFN, then try and get new JFN
RLJFN% ;Release old JFN
ERJMP MONERR
SETOM LIBJFN ;Mark JFN as unused
MOVE T1,STATE+.CMFLG ;Get flags returned by the COMND% JSYS
TXNN T1,CM%SWT ;Was switch terminated with a colon?
JRST OKRET ;No--return
NEWLIB: MOVX T1,GJ%OLD+GJ%XTN
MOVEM T1,CJFNBK+.GJGEN ;Set default flags
HRROI T1,[ASCIZ \DSK\]
MOVEM T1,CJFNBK+.GJDEV ;Set default device
HRROI T1,[ASCIZ \LIBARY\]
MOVEM T1,CJFNBK+.GJNAM ;Set default name
HRROI T1,[ASCIZ \LIB\] ;Default extension is .LIB
MOVEM T1,CJFNBK+.GJEXT ;Set default extension
MOVEI T2,LBFIL ;Look for a filename
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
HRRZM T2,LIBJFN ;Store the new library file JFN
LIBCPY: MOVE T1,[POINT 7,ATMBUF]
MOVE T2,[POINT 7,LIBTYP]
LIBLP: ILDB T3,T1 ;Copy what the user typed . . .
IDPB T3,T2 ;. . . into the area to hold his typescript
JUMPN T3,LIBLP ;Copy until null byte is found
JRST OKRET ;Get next switch
LBFIL: FLDDB. (.CMFIL,CM%SDH,,<filespec of library file>)
.LIST:
TRACE <.LIST:>
MOVX T1,LSTFLG ;Get flag that says a list file is being made
IORM T1,ONFLG ;Turn on flag that says a list file is made
ANDCAM T1,OFFFLG ;Turn off the no list file flag
HLRZ T1,CMDSOU ;Get source from which this switch came
CAIN T1,FRMSWI ;Did this switch come from SWITCH.INI
JRST OKRET ;Yes--Return since /LIST in SWITCH.INI can
;not take a value.
MOVE T1,STATE+.CMFLG ;Get flags returnd by the COMND% JSYS
TXNN T1,CM%SWT ;Was switch terminated with a colon?
JRST OKRET ;No--return
SKIPG T1,LSTJFN ;Get the possibly old listing file JFN
JRST NEWLST ;If no old JFN, then try and get new JFN
RLJFN% ;Release old JFN
ERJMP MONERR
SETOM LSTJFN ;Mark JFN as unused
NEWLST: MOVX T1,GJ%FOU+GJ%XTN
MOVEM T1,CJFNBK+.GJGEN ;Set default flags
HRROI T1,[ASCIZ \DSK\]
MOVEM T1,CJFNBK+.GJDEV ;Set default device
PUSHJ SREG,GETDEF ;Get default filename text into DEFFIL
HRROI T1,DEFFIL ;Get pointer to default text
MOVEM T1,CJFNBK+.GJNAM ;Set default name
HRROI T1,[ASCIZ \LST\] ;Default extension is .LST
MOVEM T1,CJFNBK+.GJEXT ;Set default extension
MOVEI T2,LFIL ;Look for a filename
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
HRRZM T2,LSTJFN ;Store the new listing file JFN
LSTCPY: MOVE T1,[POINT 7,ATMBUF]
MOVE T2,[POINT 7,LSTTYP]
LSTLP: ILDB T3,T1 ;Copy what the user typed . . .
IDPB T3,T2 ;. . . into the area to hold his typescript
JUMPN T3,LSTLP ;Copy until null byte is found
JRST OKRET ;Get next switch
LFIL: FLDDB. (.CMFIL,CM%SDH,,<filespec of list file>)
.MACHINE:
TRACE <.MACHINE>
MOVX T1,SW.MAC ;Get the flag
IORM T1,ONFLG ;Turn on flags that must be on
ANDCAM T1,OFFFLG ;Turn off flags that must be off
JRST OKRET
.MAIN:
TRACE <.MAIN>
MOVE T1,ONFLG ;Get flags
TXNE T1,SW.SUB ;Have we already seen /SUB?
JRST BADIJ ;GIVE ERROR MESSAGE
MOVX T1,SW.MAI ;Get the flag
IORM T1,ONFLG ;Turn on flags that must be on
ANDCAM T1,OFFFLG ;Turn off flags that must be off
JRST OKRET
BADIJ: HRROI T1,[ASCIZ \?Switches /MAIN-PROGRAM and /SUBPROGRAM are mutually exclusive.\]
PSOUT%
POPJ PP,
.MAP:
TRACE <.MAP>
MOVX T1,SW.MAP ;Get the flag
IORM T1,ONFLG ;Turn on flags that must be on
ANDCAM T1,OFFFLG ;Turn off flags that must be off
JRST OKRET
.NOABORT:
TRACE <.NOABORT>
MOVX T1,SW.ABO ;Get the flag
ANDCAM T1,ONFLG ;Turn off flags that must be off
IORM T1,OFFFLG ;Turn on flags that must be on
JRST OKRET
.NOCOPY:
TRACE <.NOCOPY>
MOVX T1,SW.NOC ;Get the flag
IORM T1,ONFLG ;Turn on flags that must be on
ANDCAM T1,OFFFLG ;Turn off flags that must be off
JRST OKRET
.NOCROSS:
TRACE <.NOCROSS>
MOVX T1,SW.CRF ;Get the flags
ANDCAM T1,ONFLG ;Turn off flags that must be off
IORM T1,OFFFLG ;Turn on flags that must be on
JRST OKRET
.NOERRORS:
TRACE <.NOERRORS>
MOVX T1,SW.ERA ;Get the flag
ANDCAM T1,ONFLG ;Turn off flags that must be off
IORM T1,OFFFLG ;Turn on flags that must be on
JRST OKRET
.NOOBJECT:
TRACE <.NOOBJECT>
MOVX T1,RELFLG ;Get the flag
ANDCAM T1,ONFLG ;Turn off flags that must be off
IORM T1,OFFFLG ;Turn on flags that must be on
JRST OKRET
.NOSYNTAX:
TRACE <.NOSYNTAX>
MOVX T1,SW.OCS ;Get the flag
ANDCAM T1,ONFLG ;Turn off flags that must be off
IORM T1,OFFFLG ;Turn on flags that must be on
JRST OKRET
.NODEBUG:
TRACE <.NODEBUG>
SETZM DEBSW ;Turn off debugging module
JRST OKRET ;Go get next switch
.NOLIST:
TRACE <.NOLIST>
MOVX T1,LSTFLG ;Get flag that says a list file is being made
ANDCAM T1,ONFLG ;Turn off flag that says a list file is made
IORM T1,OFFFLG ;Turn on the no list file flag
TXZ SW,FOBJEC!FMAP ;Turn of possible list type flags
JRST .NOCROSS ;No cref either
.NOMACHINE:
TRACE <.NOMACHINE>
MOVX T1,SW.MAC ;Get the flag
ANDCAM T1,ONFLG ;Turn off flags that must be off
IORM T1,OFFFLG ;Turn on flags that must be on
JRST OKRET
.NOPTIMIZE:
TRACE <.NOPTIMIZE>
MOVX T1,SW.OPT ;Get the flag
ANDCAM T1,ONFLG ;Turn off flags that must be off
IORM T1,OFFFLG ;Turn on flags that must be on
JRST OKRET
.OBJECT:
TRACE <.OBJECT:>
MOVX T1,RELFLG ;Get flag that says a .REL file is being made
IORM T1,ONFLG ;Turn on flag that says a .REL file is made
ANDCAM T1,OFFFLG ;Turn off the no .REL file flag
HLRZ T1,CMDSOU ;Get source from which this switch came
CAIN T1,FRMSWI ;Did this switch come from SWITCH.INI
JRST OKRET ;Yes--Return since /OBJECT doesn't take a
;value in SWITCH.INI
MOVE T1,STATE+.CMFLG ;Get flags returned by the COMND% JSYS
TXNN T1,CM%SWT ;Was switch terminated with a colon?
JRST OKRET ;No--return
SKIPGE T1,BINJFN ;Get the possibly old object file JFN
JRST NEWOBJ ;If no old JFN, then try and get new object JFN
RLJFN% ;Release old JFN
ERJMP MONERR
SETOM BINJFN
NEWOBJ: MOVX T1,GJ%FOU+GJ%XTN
MOVEM T1,CJFNBK+.GJGEN ;Set default flags
HRROI T1,[ASCIZ \DSK\]
MOVEM T1,CJFNBK+.GJDEV ;Set default device
PUSHJ SREG,GETDEF ;Get default filename into DEFFIL
HRROI T1,DEFFIL ;Get pointer to default filename
MOVEM T1,CJFNBK+.GJNAM ;Set default name
HRROI T1,[ASCIZ \REL\]
MOVEM T1,CJFNBK+.GJEXT ;Set default extension
MOVEI T2,OBFIL ;Look for a filename
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
HRRZM T2,BINJFN ;Store the new object file JFN
JRST OKRET ;Get next switch
OBFIL: FLDDB. (.CMFIL,CM%SDH,,<filespec of object file>)
.ONESEG:
TRACE <.ONESEG>
MOVE T1,ONFLG ;Get switches that are on
TXNE T1,SW.TWO ;Have we already seen /TWO?
JRST BADRU ;Yes, give error message
MOVX T1,SW.ONE ;Get the flag
IORM T1,ONFLG ;Turn on flags that must be on
ANDCAM T1,OFFFLG ;Turn off flags that must be off
JRST OKRET
BADRU: HRROI T1,[ASCIZ \?Switches /TWO-SEGMENT and /ONE-SEGMENT are mutually exclusive.\]
PSOUT%
POPJ PP,
.OPTIMIZE:
TRACE <.OPTIMIZE>
MOVX T1,SW.OPT ;Get the flag
IORM T1,ONFLG ;Turn on flags that must be on
ANDCAM T1,OFFFLG ;Turn off flags that must be off
OKRET: SETZ VREG, ;Signal that next switch has not been scanned
POPJ SREG, ;Get next switch
.PROD:
TRACE <.PROD>
MOVX T1,SW.PRD ;Get the flag
IORM T1,ONFLG ;Turn on flags that must be on
ANDCAM T1,OFFFLG ;Turn off flags that must be off
JRST OKRET
.QUICK:
TRACE <.QUICK>
MOVX T1,SW.QIK ;Get the flag
IORM T1,ONFLG ;Turn on flags that must be on
ANDCAM T1,OFFFLG ;Turn off flags that must be off
JRST OKRET
.REWIND:
TRACE <.REWIND>
HRROI T1,[ASCIZ \?/W is not supported.
\]
PSOUT%
POPJ PP,
.STACK:
TRACE <.STACK>
MOVEI T2,[FLDDB.(.CMNUM,CM%SDH,^D8,<octal number>)] ;Look for a number
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
MOVEM T2,ONFLG+$FS ;Store size
JRST OKRET ;Get next switch
.SYNTAX:
TRACE <.SYNTAX>
MOVX T1,SW.OCS ;Get the flag
IORM T1,ONFLG ;Turn on flags that must be on
ANDCAM T1,OFFFLG ;Turn off flags that must be off
JRST OKRET
.SUBPROGRAM:
TRACE <SUBPROGRAM>
MOVE T1,ONFLG ;Get flags
TXNE T1,SW.MAI ;Have we already seen /MAIN?
JRST BADIJ ;Yes, give error
MOVX T1,SW.SUB ;Get the flag
IORM T1,ONFLG ;Turn on flags that must be on
ANDCAM T1,OFFFLG ;Turn off flags that must be off
JRST OKRET
.TWOSEG:
TRACE <.TWOSEG>
MOVE T1,ONFLG ;Get switches that are on
TXNE T1,SW.ONE ;Have we already seen /ONE?
JRST BADRU ;Yes, give error message
MOVX T1,SW.TWO ;Get the flag
IORM T1,ONFLG ;Turn on flags that must be on
ANDCAM T1,OFFFLG ;Turn off flags that must be off
JRST OKRET
.VERSION:
TRACE <.VERSION>
MOVEI T2,VER.KY ;Look for 74 or 8x
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return, command not completed
HRLZ T1,(T2) ;Get flag
JRST .C748x ;Store in memory
IFN DEBUG,<
.KILL:
TRACE <.KILL:>
MOVEI T2,KIL.KY ;Look for a keyword (single letter only)
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return, command not completed
HRLZ T2,(T2) ;Get keyword mask
HLLM T2,ONFLG+$FC ;Turn on flags that must be on
JRST OKRET
.RANGE:
TRACE <.RANGE>
MOVEI T2,[FLDDB.(.CMNUM,CM%SDH,^D10,<initial decimal line number>)] ;Look for a number
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
MOVEM T2,TRCLN1## ;Store starting line number
MOVEI T2,[FLDDB. (.CMCMA)]
PUSHJ SREG,CMD ;Parse a comma
JRST USRERR ;EOF return, command not completed
MOVEI T2,[FLDDB.(.CMNUM,CM%SDH,^D10,<final decimal line number>)] ;Look for a number
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
MOVEM T2,TRCLN2## ;Store ending line number
JRST OKRET ;Get next switch
.TRACE:
TRACE <.TRACE>
MOVEI T2,TR.K1 ;Look for a keyword, "(", or confirm
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return, command not completed
SETZ VREG, ;Assume that nothing unusual happens
CAIN T3,TR.K1 ;Was a keyword found?
PJRST PRSTR1 ;Yes--go process keyword
CAIN T3,TR.K3 ;Was a open paren found?
JRST GETTR1 ;Yes--go get a list of keywords
MOVEI T1,TRACEA ;Use default of /TRACE:ALL
HRRM T1,ONFLG+$FC ;Store results
CAIN T3,COMPSW ;Was a switch found?
SKIPA VREG,[-1] ;Yes--Signal that next switch has been scanned
MOVEI VREG,1 ;Must have a carriage return--signal confirm
POPJ SREG, ;Return
GETTR1: MOVEI T2,TR.K2 ;Look for only a keyword
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
PUSHJ SREG,PRSTR1 ;Process this keyword
HRROI T4,[ASCIZ \CBLCMD Comma or ")" required -- \]
MOVEM T4,ERRPFX ;Store error message prefix
MOVEI T2,COMMA. ;Look for a "," or a ")"
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
HRROI T4,[ASCIZ \CBLCMD \]
MOVEM T4,ERRPFX ;Store error message prefix
CAIN T3,COMMA. ;Was a comma found?
JRST GETTR1 ;Yes--get next keyword
JRST OKRET ;Signal that next switch was not scanned
PRSTR1: HRRZ T2,(T2) ;Get keyword mask
HRRM T2,ONFLG+$FC ;Turn on flags that must be on
POPJ SREG, ;Return
>
SUBTTL Function block for the COMND% JSYS
ABBRIV==CM%FW ! CM%INV ! CM%ABR
INVIS==CM%FW ! CM%INV
DEFINE TBL(STRING,FLAGS,ACTION)<
IFE FLAGS, <XWD [ASCIZ \'STRING\],ACTION>
IFN FLAGS, <XWD [EXP FLAGS
ASCIZ \'STRING\],ACTION>
>
IFE DEBUG,<DEFINE DTBL(STRING,FLAGS,ACTION)<>>
IFN DEBUG,<SYN TBL,DTBL>
COMPSW: FLDDB. (.CMSWI,0,COMSW,<a compilation switch,>,,CONFIRM)
COMMA.: FLDDB. (.CMCMA,CM%SDH,,<"," or ")">,,LEFTP)
LEFTP: FLDDB. (.CMTOK,CM%SDH,<POINT 7,[ASCIZ \)\]>)
VER.KY: FLDDB. (.CMKEY,0,VERTBL,<compiler standard,>)
DIS.KY: FLDDB. (.CMKEY,0,DISTBL,<default display mode,>)
FLG.K1: FLDDB. (.CMKEY,0,FLGTBL,<a flagger option,>,,FLG.K3)
FLG.K2: FLDDB. (.CMKEY,0,FLGTBL)
FLG.K3: FLDDB. (.CMTOK,CM%SDH,<POINT 7,[ASCIZ \(\]>,<"(" followed by a list of flagger options>)
YSW.K1: FLDDB. (.CMKEY,0,YSWTBL,<a flagger option,>,,YSW.K3)
YSW.K2: FLDDB. (.CMTOK,CM%SDH,<POINT 7,[ASCIZ \-\]>,<"-" followed by a list of flagger options>)
YSW.K3: FLDDB. (.CMKEY,0,YSWTBL)
IFN DEBUG,<
TR.K1: FLDDB. (.CMKEY,0,TRATBL,<a trace option,>,,TR.K3)
TR.K2: FLDDB. (.CMKEY,0,TRATBL)
TR.K3: FLDDB. (.CMTOK,CM%SDH,<POINT 7,[ASCIZ \(\]>,<"(" followed by a list of trace options>)
KIL.KY: FLDDB. (.CMKEY,0,KILTBL,<after compiler phase,>)
>
SUBTTL Compilation Switch Table
COMSW: XWD COMSWL,COMSWL ;Count of number of entries
TBL <A>,INVIS,[.MACHINE] ;/A=/MAC in TOPS-10 command scanner
TBL <ABORT>,,[.ABORT]
TBL <ANSI-FORMAT>,,[.ANSI]
TBL <BINARY:>,,[.OBJECT]
TBL <C>,ABBRIV,XXC ;/C in TOPS-10 command scanner
TBL <C74>,,[.C74]
TBL <C8>,,[.C8X]
TBL <CR>,ABBRIV,XXC
TBL <CREF>,INVIS,[.CROSS]
TBL <CRO>,ABBRIV,XXC
TBL <CROS>,ABBRIV,XXC
TBL <CROSS>,ABBRIV,XXC
XXC: TBL <CROSS-REFERENCE>,,[.CROSS]
TBL <CROSSREFERENCE>,INVIS,[.CROSS]
TBL <D>,INVIS,[.STACK] ;/D=/STACK in TOPS-10 command scanner
TBL <DEBUG>,,[.DEBUG]
TBL <DISPLAY:>,,[.DISPLAY]
TBL <E>,INVIS,[.SYNTAX] ;/E=/SYNTAX in TOPS-10 command scanner
TBL <ECHO-OPTION>,,[.ECHOOP]
TBL <ERRORS>,,[.ERRORS]
TBL <FLAG-ALLBUT:>,,[.FLAGA]
TBL <FLAG-IF:>,,[.FLAGI]
;; TBL <G>,INVIS,[.NOCOPY] ;/G =/NOCOPY in TOPS-10 command scanner
TBL <I>,INVIS,[.SUBPROGRAM] ;/I=/SUBPROG in TOPS-10 command scanner
TBL <J>,INVIS,[.MAIN] ;/J=/MAINPROG in TOPS-10 command scanner
DTBL <KILL:>,,[.KILL]
TBL <L>,ABBRIV,XXLIB ;/L=/LIB in TOPS-10 command scanner
TBL <LI>,ABBRIV,XXL
XXLIB: TBL <LIBRARY:>,,[.LIBRARY]
XXL: TBL <LISTING:>,,[.LIST]
TBL <M>,ABBRIV,XXMAP ;/M=/MAP in TOPS-10 command scanner
TBL <MA>,ABBRIV,XXM
TBL <MAC>,ABBRIV,XXM
XXM: TBL <MACHINE-CODE>,,[.MACHINE]
TBL <MACRO>,INVIS,[.MACHINE]
TBL <MAIN-PROGRAM>,,[.MAIN]
XXMAP: TBL <MAP>,,[.MAP]
TBL <N>,INVIS,[.NOERRORS] ;/N=/NOERRORS in TOPS-10 command scanner
TBL <NOABORT>,,[.NOABORT]
TBL <NOBINARY>,,[.NOOBJECT]
TBL <NOC>,ABBRIV,XXNOC
;; TBL <NOCOPY>,,[.NOCOPY]
TBL <NOCR>,ABBRIV,XXNOC
TBL <NOCREF>,INVIS,[.NOCROSS]
TBL <NOCRO>,ABBRIV,XXNOC
TBL <NOCROS>,ABBRIV,XXNOC
TBL <NOCROSS>,ABBRIV,XXNOC
XXNOC: TBL <NOCROSS-REFERENCE>,,[.NOCROSS]
TBL <NOCROSSREFERENCE>,INVIS,[.NOCROSS]
TBL <NODEBUG>,,[.NODEBUG]
TBL <NOERRORS>,,[.NOERRORS]
TBL <NOLISTING>,,[.NOLIST]
TBL <NOM>,ABBRIV,XXNOM
TBL <NOMA>,ABBRIV,XXNOM
TBL <NOMAC>,ABBRIV,XXNOM
XXNOM: TBL <NOMACHINE-CODE>,,[.NOMACHINE]
TBL <NOMACRO>,INVIS,[.NOMACHINE]
TBL <NOOBJECT>,INVIS,[.NOOBJECT]
TBL <NOOPT>,ABBRIV,XXNOOPT
TBL <NOOPTIMIZE>,,[.NOPTIMIZE]
XXNOOPT:TBL <NOOPTION>,,[.NOOPTION]
TBL <NOS>,ABBRIV,XXNOS
XXNOS: TBL <NOSYNTAX>,,[.NOSYNTAX]
TBL <O>,ABBRIV,XXOP ;/O=/OPT in TOPS-10 command scanner
TBL <OBJECT:>,INVIS,[.OBJECT]
TBL <ONE-SEGMENT>,,[.ONESEG]
TBL <OP>,ABBRIV,XXOP
TBL <OPT>,ABBRIV,XXOP
XXOP: TBL <OPTIMIZE>,,[.OPTIMIZE]
TBL <OPTION:>,,[.OPTION]
TBL <PRODUCTION-MODE>,,[.PROD] ;/P in TOPS-10 command scanner
TBL <QUICK-MODE>,,[.QUICK] ;/Q in TOPS-10 command scanner
TBL <R>,INVIS,[.TWOSEG] ;/R=/TWO-SEG in TOPS-10 command scanner
DTBL <RANGE:>,,[.RANGE] ;Line number range for /TRACE
; TBL <REWIND>,,[.REWIND]
TBL <S>,INVIS,[.ANSI] ;/S=/ANSI-FORMAT in TOPS-10 command scanner
TBL <STACK:>,,[.STACK]
TBL <SUBPROGRAM>,,[.SUBPROGRAM]
TBL <SYNTAX>,,[.SYNTAX]
DTBL <T>,ABBRIV,XXTR ;/T=/TRACE in TOPS-10 command scanner
XXTR: DTBL <TRACE:>,,[.TRACE]
TBL <TWO-SEGMENT>,,[.TWOSEG]
TBL <U>,INVIS,[.ONESEG] ;/U=/ONE-SEG in TOPS-10 command scanner
XXV: TBL <VERSION:>,,[EXP .VERSION] ;/V=/VERSION in TOPS-10 commans scanner
TBL <W>,INVIS,[.REWIND] ;/W=/REWIND in TOPS-10 command scanner
TBL <X>,INVIS,[.DISP9] ;/X=/DISPLAY:9 in TOPS-10 command scanner
TBL <Y:>,INVIS,[.FLAGY] ;/Y=/FLAG-ALLBUT in TOPS-10 command scaner
COMSWL==.-COMSW-1
SUBTTL Compilation Switch Table for TOPS-10 only
OCOMSW: XWD OCMSWL,OCMSWL ;Count of number of entries
TBL <A>,,[.MACHINE] ;/A=/MAC in TOPS-10 command scanner
TBL <B>,,[.DEBUG] ;/B=/DEBUG in TOPS-10 command scanner
TBL <C>,,[.CROSS] ;/C in TOPS-10 command scanner
TBL <D>,,[.STACK] ;/D=/STACK in TOPS-10 command scanner
TBL <E>,,[.SYNTAX] ;/E=/SYNTAX in TOPS-10 command scanner
DTBL <F:>,,[.KILL] ;/F =/K near enough
;; TBL <G>,,[.NOCOPY] ;/G =/NOCOPY in TOPS-10 command scanner
TBL <H>,,[.HELP] ;/H = HELP verb in TOPS-10 command scanner
TBL <I>,,[.SUBPROGRAM] ;/I=/SUBPROG in TOPS-10 command scanner
TBL <J>,,[.MAIN] ;/J=/MAINPROG in TOPS-10 command scanner
DTBL <K:>,,[.KILL] ;/K
TBL <L>,,[.LIBRARY] ;/L=/LIB in TOPS-10 command scanner
TBL <M>,,[.MAP] ;/M=/MAP in TOPS-10 command scanner
TBL <N>,,[.NOERRORS] ;/N=/NOERRORS in TOPS-10 command scanner
TBL <O>,,[.OPTIMIZE] ;/O=/OPT in TOPS-10 command scanner
TBL <P>,,[.PROD] ;/P in TOPS-10 command scanner
TBL <Q>,,[.QUICK] ;/Q in TOPS-10 command scanner
TBL <R>,,[.TWOSEG] ;/R=/TWO-SEG in TOPS-10 command scanner
TBL <S>,,[.ANSI] ;/S=/ANSI-FORMAT in TOPS-10 command scanner
DTBL <T>,,[.TRACE] ;/T=/TRACE in TOPS-10 command scanner
TBL <U>,,[.ONESEG] ;/U=/ONE-SEG in TOPS-10 command scanner
TBL <V:>,,[EXP .VERSION] ;/V=/VERSION in TOPS-10 commans scanner
TBL <W>,,[.REWIND] ;/W=/REWIND in TOPS-10 command scanner
TBL <X>,,[.DISP9] ;/X=/DISPLAY:9 in TOPS-10 command scanner
TBL <Y:>,,[.FLAGY] ;/Y=/FLAG-* in TOPS-10 command scaner
TBL <Z>,,[.NEW] ;/Z = Get back to TOPS-20 command scanner
OCMSWL==.-OCOMSW-1
SUBTTL Switch tables
VERTBL: XWD 2,2
TBL <74>,,<(SW.A74)>
TBL <8x>,,<(SW.A82)>
DISTBL: XWD 3,3
TBL <6>,,%US.D6
TBL <7>,,%US.D7
TBL <9>,,%US.EB
FLGTBL: XWD FLGLEN,FLGLEN
TBL <1>,INVIS,FLG.L
TBL <2>,INVIS,FLG.LI
TBL <3>,INVIS,FLG.HI
TBL <4>,INVIS,FLG.H
TBL <68-COBOL>,,%LV.68
TBL <8x-COBOL>,,%LV.8
TBL <DBMS-SYNTAX>,,%LV.DB
FLG.HI: TBL <HIGH-INTERMEDIATE-LEVEL>,,%LV.HI
FLG.H: TBL <HIGH-LEVEL>,,%LV.H
TBL <IBM-COMPATIBILITY>,,%LV.IB
FLG.LI: TBL <LOW-INTERMEDIATE-LEVEL>,,%LV.LI
FLG.L: TBL <LOW-LEVEL>,,%LV.L
TBL <NON-STANDARD-SYNTAX>,,%LV.NS
TBL <REPORT-WRITER-SYNTAX>,,%LV.RP
TBL <VAX-COMPATIBILITY>,,%LV.VX
FLGLEN==.-FLGTBL-1
YSWTBL: XWD YSWLEN,YSWLEN
TBL <1>,,%LV.L
TBL <2>,,%LV.LI
TBL <3>,,%LV.HI
TBL <4>,,%LV.H
TBL <6>,,%LV.68
TBL <8>,,%LV.8
TBL <D>,,%LV.DB
TBL <I>,,%LV.IB
TBL <N>,,%LV.NS
TBL <R>,,%LV.RP
TBL <V>,,%LV.VX
YSWLEN==.-YSWTBL-1
SUBTTL DEBUG Options, /KILL: /TRACE:
KILTBL: XWD KILLEN,KILLEN
DTBL <A>,,%KILLA
DTBL <B>,,%KILLB
DTBL <C>,,%KILLC
DTBL <D>,,%KILLD
DTBL <E>,,%KILLE
DTBL <F>,,%KILLF
DTBL <G>,,%KILLG
KILLEN==.-KILTBL-1
TRATBL: XWD TRALEN,TRALEN
DTBL <ALL>,,TRACEA
DTBL <DATA-DIVISION>,,TRACED
DTBL <ENVIRONMENT-DIVISION>,,TRACEE
DTBL <IDENTIFICATION-DIVISION>,,TRACEI
DTBL <PROCEDURE-DIVISION>,,TRACEP
TRALEN==.-TRATBL-1
SUBTTL Open initial scratch files for the compiler
;Set up the long form GTJFN default blocks for input, output, temp and library files.
;Then open the scratch files that will be required later.
OPNSCR:
;Get ASCII job number
GJINF% ;GET INFO FROM MONITOR
MOVE T1,T3 ;GET A COPY
IDIVI T1,^D100
IDIVI T2,^D10
LSH T1,2*7
LSH T2,7
ADD T1,T2
ADD T1,T3
ADD T1,["000"]
LSH T1,2*7+1 ;Left justify
MOVEM T1,ASCJOB ;SAVE ASCII JOB NUMBER
;Set up the default GTJFN blocks
MOVX T1,GJ%FOU!GJ%TMP
MOVE T2,[.NULIO,,.NULIO]
DMOVEM T1,TMPGJB
MOVX T1,GJ%FOU
DMOVEM T1,BINGJB
DMOVEM T1,LSTGJB
MOVX T1,GJ%OLD
DMOVEM T1,SRCGJB
DMOVEM T1,LIBGJB
MOVEI T1,[ASCIZ /DSK:/]
HRROM T1,SRCGJB+.GJDEV
HRROM T1,BINGJB+.GJDEV
HRROM T1,LSTGJB+.GJDEV
HRROM T1,TMPGJB+.GJDEV
HRROM T1,LIBGJB+.GJDEV
HRROI T1,TMPSPC ;File name is stored here
HRROI T2,[ASCIZ /TMP/]
DMOVEM T1,TMPGJB+.GJNAM
HRROI T1,[ASCIZ /LIBARY/]
HRROI T2,[ASCIZ /LIB/]
DMOVEM T1,LIBGJB+.GJNAM
HRROI T2,[ASCIZ /REL/]
MOVEM T2,BINGJB+.GJEXT
HRROI T2,[ASCIZ /LST/]
MOVEM T2,LSTGJB+.GJEXT
HRROI T2,[ASCIZ /CBL/]
MOVEM T2,SRCGJB+.GJEXT
MOVE T1,ASCJOB ;Get job number
MOVE T2,[ASCIZ / ;T/] ;Finish prototype name
DMOVEM T1,TMPSPC
;Now open the initial temp files i.e. those always required.
MOVE T1,["NAM"] ;NAMTAB
PUSHJ PP,OPNTMP
HRRZM T1,NAMJFN ;Store jfn
SETZM NAMBH+1 ;Force buffer fill on first write
SETZM NAMBH+2
MOVX T2,OF%WR ;Write 36 bit bytes
PUSH PP,T1 ;Incase of error
OPENF%
JRST OPNERR
POP PP,T1 ;Clear stack
MOVE T1,["ERA"] ;Error file
PUSHJ PP,OPNTMP
HRRZM T1,ERAJFN ;Store jfn
SETZM ERABH+1 ;Force buffer fill on first write
SETZM ERABH+2
MOVX T2,OF%WR ;Write 36 bit bytes
PUSH PP,T1 ;Incase of error
OPENF%
JRST OPNERR
POP PP,T1 ;Clear stack
MOVE T1,["GEN"] ;GENFIL
PUSHJ PP,OPNTMP
HRRZM T1,GENJFN ;Store jfn
SETZM GENBH+1 ;Force buffer fill on first write
SETZM GENBH+2
MOVX T2,OF%WR ;Write 36 bit bytes
PUSH PP,T1 ;Incase of error
OPENF%
JRST OPNERR
POP PP,T1 ;Clear stack
MOVE T1,["CPY"] ;CPYFIL copy of source
PUSHJ PP,OPNTMP
HRRZM T1,CPYJFN ;Store jfn
SETZM CPYBH+1 ;Force buffer fill on first write
SETZM CPYBH+2
MOVX T2,OF%WR ;Write 36 bit bytes
PUSH PP,T1 ;Incase of error
OPENF%
JRST OPNERR
POP PP,T1 ;Clear stack
MOVE T1,["AS1"] ;ASCII name right justified
PUSHJ PP,OPNTMP ;Get JFN
HRRZM T1,AS1JFN ;Store jfn
SETZM AS1BH+1 ;Force buffer fill on first write
SETZM AS1BH+2
MOVX T2,OF%WR ;Write 36 bit bytes
PUSH PP,T1 ;Incase of error
OPENF%
JRST OPNERR
POP PP,T1 ;Clear stack
MOVE T1,["AS2"] ;ASCII name right justified
PUSHJ PP,OPNTMP ;Get JFN
HRRZM T1,AS2JFN ;Store jfn
SETZM AS2BH+1 ;Force buffer fill on first write
SETZM AS2BH+2
MOVX T2,OF%WR ;Write 36 bit bytes
PUSH PP,T1 ;Incase of error
OPENF%
JRST OPNERR
POP PP,T1 ;Clear stack
POPJ PP,
SUBTTL Open CREF temp files when required
;Note SF3 is not OPENed yet, only the JFN is obtained.
OPNSF: PUSH PP,T1
PUSH PP,T2
MOVE T1,["SF1"]
PUSHJ PP,OPNTMP
HRRZM T1,SF1JFN ;Store JFN
SETZM SF1BH+1 ;Force buffer fill on first write
SETZM SF1BH+2
MOVX T2,OF%WR ;Write 36 bits
PUSH PP,T1 ;Incase of error
OPENF%
JRST OPNERR
POP PP,T1 ;Clear stack
MOVE T1,["SF2"]
PUSHJ PP,OPNTMP
HRRZM T1,SF2JFN ;Store JFN
SETZM SF2BH+1 ;Force buffer fill on first write
SETZM SF2BH+2
MOVX T2,OF%WR ;Write 36 bits
PUSH PP,T1 ;Incase of error
OPENF%
JRST OPNERR
POP PP,T1 ;Clear stack
MOVE T1,["SF3"]
PUSHJ PP,OPNTMP
HRRZM T1,SF3JFN ;Store JFN for when it becomes output file later
SETZM SF3BH+1 ;Force buffer fill on first write
SETZM SF3BH+2
JRST T2RET
SUBTTL OPNTMP - Open temp files for compiler
;Enter with 3 char file name right justified in T1
OPNTMP: IDIVI T1,200 ;First 2 chars in T1, 3rd in T2
DPB T1,[POINT 14,TMPSPC,34]
DPB T2,[POINT 7,TMPSPC+1,6]
MOVEI T1,TMPGJB ;Point to block
HRROI T2,TMPSPC ;File name string
GTJFN%
TRNA ;Failed
POPJ PP,
MOVX T1,GJ%OFG ;Parse only
IORM T1,TMPGJB ;So we can give error message
MOVEI T1,TMPGJB ;Point to block
GTJFN% ;Try again
SETZ T1, ;No JFN on failure
JRST GJFERR ;Give meaningful error message
SUBTTL NXTFIL -- Open Next Source File
;***********************************************************************
; This routine is called by the compiler to open the next source file.
;***********************************************************************
NXTFIL:
AOS T4,CNTIDX ;Get index into list of source file to open
CAMLE T4,SRCIDX ;Have all the files been opened?
POPJ PP, ;Yes--Take failure return
PUSH PP,P1 ;Save P1
PUSH PP,P2 ;Save P2
MOVE P1,SRCFIL(T4) ;Get JFN of source file
MOVE T1,P1 ;Get JFN of source file
MOVEM T1,SRCJFN ;Save it for SIN%
DVCHR% ;Get characteristics of source file
ERJMP MONERR
LDB T1,[POINTR(T1,DV%TYP)] ;Get device type
CAIE T1,.DVTTY ;Is it a terminal?
JRST NOTTTY ;No--Don't need to do anything
TXO SW,TTYINP ;Set TTY input flag
MOVX T2,FLD(7,OF%BSZ)+OF%RD+OF%WR ;Byte size is 7, allow read&write
JRST OPNSOU ;Open the source file
NOTTTY: TXZ SW,TTYINP ;Clear TTY input bit
MOVX T2,OF%RD ;Open file for writing, ASCII 36 bit bytes
OPNSOU: MOVE T1,P1 ;Get JFN of next source file
OPENF%
ERJMP [MOVE T1,XJBFF ; Restore value of .JBFF
MOVEM T1,.JBFF ;
MOVE T1,XJBREL ; Restore value of .JBREL
MOVEM T1,.JBREL ;
JRST MONERR]
TXZ SW,FECOM ;Clear end of command string flag
POP PP,P2 ;Restore P2
POP PP,P1 ;Restore P1
AOS (PP)
POPJ PP, ;Take success return
SUBTTL OPNLIB -- Open the CPYLIB File for the Compiler
;SUBROUTINE TO OPEN CPYLIB FILES
;CHECK TO SEE THAT THEY ARE DISK
;CALL WITH
; LIBSPC = ASCII FILE SPEC POINTER
; PUSHJ PP,OPNLIB
; RETURN HERE
; VREG = 0 - OK
OPNLIB: PUSH PP,T1
PUSH PP,T2
PUSH PP,T3
SKIPLE LIBJFN ;IS FILE ALREADY OPEN?
PUSHJ PP,CLZLIB ;YES, CLOSE IT FIRST
SKIPN LIBSPC ;DO WE HAVE A FILE SPEC?
JRST DEFLIB ;NO, USE "LIBARY.LIB"
MOVEI T1,LIBGJB ;LONG GTJFN% BLOCK
MOVE T2,[POINT 7,LIBSPC] ;SPEC POINTER
GTJFN%
JRST [SETZM LIBJFN ;Zero out JFN to trigger GETITM's rtn
JRST T3RET] ; to proceed without library file
HRRZM T1,LIBJFN ;SAVE JFN
;CHECK FOR DSK:
HRRZ T1,T1 ;ZERO LEFT
DVCHR%
ERJMP MONERR
LDB T1,[POINTR(T1,DV%TYP)] ;Get device type
CAIE T1,.DVDSK ;Is it a disk?
JRST NOTDSK ;NO
HRRZ T1,LIBJFN ;GET JFN AGAIN
MOVX T2,OF%RD ;Read, ASCII, 36 bit bytes
PUSH PP,T1 ;Incase of error
OPENF%
JRST OPNERR
POP PP,T1 ;Clear stack
MOVEI VREG,0 ;GOOD RETURN
MOVE T1,[LIBSPC,,LIBOSP]
BLT T1,LIBOSP+^D39 ;COPY SPEC FOR COMPARE
JRST T3RET
NOTDSK: HRROI T1,[ASCIZ \?Library device must be disk
\]
PSOUT%
AOJA VREG,T3RET
DEFLIB: MOVX T1,GJ%OLD!GJ%SHT
HRROI T2,[ASCIZ /LIBARY.LIB/]
GTJFN% ;Try for default
JRST [SETZM LIBJFN ;Zero out JFN to trigger GETITM's
JRST T3RET] ; rtn for proceeding without .LIB file
HRRZM T1,LIBJFN ;Save JFN
MOVX T2,OF%RD ;Read, ASCII, 36 bit bytes
PUSH PP,T1 ;Incase of error
OPENF%
JRST OPNERR
POP PP,T1 ;Clear stack
JRST T3RET
;Set file pointer of library file
;Enter with required word in TE
SFPLIB: PUSH PP,T1
PUSH PP,T2
MOVE T1,LIBJFN
MOVE T2,TE
SFPTR%
HALT ;SHOULD NEVER HAPPEN
POP PP,T2
POP PP,T1
POPJ PP,
;Get buffer from library file
GETLBA: PUSH PP,T1 ;Save accs
PUSH PP,T2
PUSH PP,T3
MOVE T1,LIBJFN ;Get JFN
DMOVE T2,LIBPTR ;Setup TOPS-10 style buffer header
DMOVEM T2,LIBBH+1 ;So I/O works same way
DMOVE T2,LIBIOW ;Get byte pointer and size
SIN%
ERJMP [MOVEI T1,.FHSLF
GETER%
NOOP
HRRZ T2,T2 ;Error only
MOVE T1,LIBJFN
CAIE T2,IOX4 ;End of File?
JRST GETERR ;No
IMULI T3,5 ;Convert to bytes
ADDB T3,LIBBH+2 ;Adjust count
JRST .+1]
JRST T3RET ;OK, restore
SUBTTL OPNAS3 -- Open AS3 temp file for the compiler
OPNAS3: PUSH PP,T1 ;Save some accs
PUSH PP,T2
MOVE T1,["AS3"] ;ASCII name right justified
PUSHJ PP,OPNTMP ;Get JFN
HRRZM T1,AS3JFN ;Store jfn
SETZM AS3BH+1 ;Force buffer fill on first write
SETZM AS3BH+2
MOVX T2,OF%WR ;Write 36 bit bytes
PUSH PP,T1 ;Incase of error
OPENF%
JRST OPNERR
JT2RET: POP PP,T1 ;Clear stack
JRST T2RET
SUBTTL OPNLIT -- Open Literal temp file for the compiler
;NOTE, I/O is done in DUMP mode
OPNLIT: PUSH PP,T1 ;Save some accs
PUSH PP,T2
MOVE T1,["LIT"] ;ASCII name right justified
PUSHJ PP,OPNTMP ;Get JFN
HRRZM T1,LITJFN ;Store jfn
SETZM LITBH+1 ;Force buffer fill on first write
SETZM LITBH+2
MOVE T2,[FLD(.GSDMP,OF%MOD)+OF%WR] ;Write 36 bit bytes in dump mode
PUSH PP,T1 ;Incase of error
OPENF%
JRST OPNERR
JRST JT2RET
SUBTTL OPNOVR -- Open segmentation overlay file
;It uses same buffers as binary file
OPNOVR: PUSH PP,T1 ;Save some accs
PUSH PP,T2
PUSH PP,T3
MOVE T1,BINJFN
DVCHR%
ERJMP MONERR
LDB T1,[POINTR(T1,DV%TYP)] ;Get device type
MOVE T3,[FLD(.JSAOF,JS%DIR)+FLD(.JSAOF,JS%NAM)+JS%PAF] ;We want <dir>name for sure
CAIN T1,.DVDSK ;Is it a disk?
TXO T3,FLD(.JSAOF,JS%DIR) ;Yes, use it also
HRROI T1,LIBSPC ;Get string to store part of spec
MOVE T2,BINJFN ;Get the JFN
JFNS% ;Get the name
ERJMP MONERR
PUSHJ PP,PUTBN1 ;Finish off binary output
PUSHJ PP,CLZBIN ;And release JFN
HRROI T1,[ASCIZ /OVR/]
MOVEM T1,BINGJB+.GJEXT ;Change default extension
MOVEI T1,BINGJB ;Default dsk:.ovr
MOVE T2,[POINT 7,LIBSPC] ;Rest of string
GTJFN%
JRST [MOVX T1,GJ%OFG ;Parse only
IORM T1,BINGJB ;So we can give error message
MOVEI T1,BINGJB ;Point to block
GTJFN% ;Try again
SETZ T1, ;No JFN on failure
JRST GJFERR] ;Give meaningful error message
HRRZM T1,BINJFN ;Store jfn
SETZM BINBH+1 ;Force buffer fill on first write
SETZM BINBH+2
MOVX T2,OF%WR ;Write 36 bit bytes
PUSH PP,T1 ;Incase of error
OPENF%
JRST OPNERR
POP PP,T1 ;Clear stack
JRST T3RET
;Write out the directory of the overlay file
RITOVD: PUSH PP,T1
PUSH PP,T2
PUSH PP,T3
MOVE T1,BINJFN
RFPTR% ;Find out where we are in file
JRST MONERR
PUSH PP,T2 ;Save it
MOVE T1,BINJFN
SETZ T2, ;Set back to first byte
SFPTR%
JRST MONERR
MOVE T1,BINJFN
HRRZ T2,LITLOC## ;Where directory is stored
HRLI T2,(POINT ^D36,)
MOVNI T3,^D256
SOUT%
ERJMP PUTERR
MOVE T1,BINJFN
POP PP,T2 ;Set back to original position
SFPTR%
JRST MONERR
JRST T3RET
SUBTTL OPNCRF -- Open CREF temp file for the compiler
OPNCRF: PUSH PP,T1 ;Save some accs
PUSH PP,T2
MOVE T1,["CRF"] ;ASCII name right justified
PUSHJ PP,OPNTMP ;Get JFN
HRRZM T1,CRFJFN ;Store jfn
SETZM CRFBH+1 ;Force buffer fill on first write
SETZM CRFBH+2
MOVX T2,OF%WR ;Write 36 bit bytes
PUSH PP,T1 ;Incase of error
OPENF%
JRST OPNERR
JRST JT2RET
SUBTTL OPNDMP -- Open dump file for COBOLK
OPNDMP: PUSH PP,T1 ;Save some accs
PUSH PP,T2
PUSH PP,T3
SETZM LIBSPC ;In case no name
SKIPN T2,SRCJFN## ;Get name of source file
JRST OPNDMZ
HRROI T1,LIBSPC ;Place to hold name
MOVX T3,FLD(.JSAOF,JS%NAM) ;We want name only
JFNS% ;Get the name
ERJMP MONERR
OPNDMZ: MOVEI T1,"CB"
MOVEI T2,"L" ;Use <jobnumber>CBL as default name
DPB T1,[POINT 14,TMPSPC,34]
DPB T2,[POINT 7,TMPSPC+1,6]
HRROI T1,TMPSPC
MOVEM T1,BINGJB+.GJNAM ;Set default name
HRROI T1,[ASCIZ /DMP/]
MOVEM T1,BINGJB+.GJEXT ;Change default extension
MOVEI T1,BINGJB ;Default dsk:.dmp
MOVE T2,[POINT 7,LIBSPC] ;Rest of string
GTJFN%
JRST [MOVX T1,GJ%OFG ;Parse only
IORM T1,BINGJB ;So we can give error message
MOVEI T1,BINGJB ;Point to block
GTJFN% ;Try again
SETZ T1, ;No JFN on failure
JRST GJFERR] ;Give meaningful error message
HRRZM T1,DMPJFN ;Store jfn
SETZM DMPBH+1 ;Force buffer fill on first write
SETZM DMPBH+2
MOVX T2,FLD(7,OF%BSZ)+OF%WR ;Open file for writing, 7 bit bytes
PUSH PP,T1 ;Incase of error
OPENF%
JRST OPNERR
POP PP,T1 ;Clear stack
JRST T3RET
;Write an ASCII character to the dump file
DMPOUT: SOSG DMPBH+2
PUSHJ PP,DMPO2
SKIPN TYPFLG## ;Typeout flag on?
JRST DMPO1 ;No
EXCH T1,CH
PBOUT% ;Yes, type char too
EXCH T1,CH
DMPO1: IDPB CH,DMPBH+1
POPJ PP,
DMPO2: PUSH PP,T1 ;Save accs
PUSH PP,T2
PUSH PP,T3
MOVE T1,DMPBH+1 ;First time its zero
SKIPLE T3,DMPBH+2 ;Partial buffer to output?
JUMPN T1,DMPO4 ;Yes, not first time and word count positive
DMOVE T2,DMPPTR ;Get byte pointer and size
DMOVEM T2,DMPBH+1 ;Reset TOPS-10 style buffer header
JUMPE T1,RITER1 ;Just like TOPS-10 dummy output
MOVE T1,DMPJFN ;Get JFN
DMOVE T2,DMPIOW ;Get byte pointer and size
DMPO3: SOUT%
ERJMP PUTERR ;Failed
JRST T3RET ;OK, restore
DMPO4: SUBI T3,1 ;Byte count is 1 behind byte pointer
DMOVE T1,DMPPTR ;Get byte pointer and size
DMOVEM T1,DMPBH+1 ;Reset TOPS-10 style buffer header
MOVE T1,DMPJFN ;Get JFN
MOVE T2,DMPIOW ;Output byte pointer
ADD T3,DMPIOW+1 ;Output count
JRST DMPO3
;Read a word from temp file pointed to by TFIJFN
;Uses same buffers as CRF file
EXTERN TFIJFN,TFIBH
SYN CRFPTR,TFIPTR
SYN CRFIOW,TFIIOW
WD==10 ;Word from "GETDSK" for COBOLK
SETTFI: PUSH PP,T1 ;Save some accs
PUSH PP,T2
PUSHJ PP,CLSTFI ;Close it first
HRRZ T1,TFIJFN
MOVX T2,OF%RD ;Read 36 bit bytes
PUSH PP,T1 ;Incase of error
OPENF%
JRST OPNERR
SETZM TFIBH+1 ;Set count zero so we will fill buffer on next read
SETZM TFIBH+2
JRST JT2RET
GETTFI: SOSG TFIBH+2
PUSHJ PP,GETTF1
ILDB WD,TFIBH+1
AOS (PP) ;Skip return
POPJ PP,
GETTF1: PUSH PP,T1 ;Save accs
PUSH PP,T2
PUSH PP,T3
MOVE T1,TFIJFN ;Get JFN
DMOVE T2,TFIPTR ;Setup TOPS-10 style buffer header
DMOVEM T2,TFIBH+1 ;So I/O works same way
DMOVE T2,TFIIOW ;Get byte pointer and size
SIN%
ERJMP [MOVEI T1,.FHSLF
GETER%
NOOP
HRRZ T2,T2 ;Error only
MOVE T1,TFIJFN
CAIE T2,IOX4 ;End of File?
JRST GETERR ;No
ADDB T3,TFIBH+2 ;Adjust count
JUMPN T3,T3RET ;OK, got partial buffer
POP PP,T3 ;EOF, restore accs
POP PP,T2
POP PP,T1
POP PP,(PP) ;Pop off top return
POPJ PP,] ;Return to caller's caller
JRST T3RET
;WRITE OUTPUT TO SCRATCH FILES
PUTAS1: SOSG AS1BH+2 ;BUFFER FULL?
PUSHJ PP,PUTS1A ;YES--EMPTY IT
IDPB CH,AS1BH+1 ;PUT WORD INTO BUFFER
POPJ PP,
PUTS1A: PUSH PP,T1 ;Save accs
PUSH PP,T2
PUSH PP,T3
MOVE T1,AS1BH+1 ;First time its zero
SKIPLE T3,AS1BH+2 ;Partial buffer to output?
JUMPN T1,PUTS1B ;Yes, not first time and word count positive
DMOVE T2,AS1PTR ;Get byte pointer and size
DMOVEM T2,AS1BH+1 ;Reset TOPS-10 style buffer header
JUMPE T1,RITER1 ;Just like TOPS-10 dummy output
MOVE T1,AS1JFN ;Get JFN
DMOVE T2,AS1IOW ;Get byte pointer and size
PUTS1C: SOUT%
ERJMP PUTERR ;Failed
JRST T3RET ;OK, restore
PUTS1B: SUBI T3,1 ;Byte count is 1 behind byte pointer
DMOVE T1,AS1PTR ;Get byte pointer and size
DMOVEM T1,AS1BH+1 ;Reset TOPS-10 style buffer header
MOVE T1,AS1JFN ;Get JFN
MOVE T2,AS1IOW ;Output byte pointer
ADD T3,AS1IOW+1 ;Output count
JRST PUTS1C ;Output it
PUTAS2: SOSG AS2BH+2 ;BUFFER FULL?
PUSHJ PP,PUTS2A ;YES--EMPTY IT
IDPB CH,AS2BH+1 ;PUT WORD INTO BUFFER
POPJ PP,
PUTS2A: PUSH PP,T1 ;Save accs
PUSH PP,T2
PUSH PP,T3
MOVE T1,AS2BH+1 ;First time its zero
SKIPLE T3,AS2BH+2 ;Partial buffer to output?
JUMPN T1,PUTS2B ;Yes, not first time and word count positive
DMOVE T2,AS2PTR ;Get byte pointer and size
DMOVEM T2,AS2BH+1 ;Reset TOPS-10 style buffer header
JUMPE T1,RITER1 ;Just like TOPS-10 dummy output
MOVE T1,AS2JFN ;Get JFN
DMOVE T2,AS2IOW ;Get byte pointer and size
JRST PUTS1C
PUTS2B: SUBI T3,1 ;Byte count is 1 behind byte pointer
DMOVE T1,AS2PTR ;Get byte pointer and size
DMOVEM T1,AS2BH+1 ;Reset TOPS-10 style buffer header
MOVE T1,AS2JFN ;Get JFN
MOVE T2,AS2IOW ;Output byte pointer
ADD T3,AS2IOW+1 ;Output count
JRST PUTS1C ;Output it
PUTAS3: SOSG AS3BH+2 ;BUFFER FULL?
PUSHJ PP,PUTS3A ;YES--EMPTY IT
IDPB CH,AS3BH+1 ;PUT WORD INTO BUFFER
POPJ PP,
PUTS3A: SKIPN AS3JFN ;Is file open?
PUSHJ PP,OPNAS3 ;Not yet, go do it
PUSH PP,T1 ;Save accs
PUSH PP,T2
PUSH PP,T3
MOVE T1,AS3BH+1 ;First time its zero
SKIPLE T3,AS3BH+2 ;Partial buffer to output?
JUMPN T1,PUTS3B ;Yes, not first time and word count positive
DMOVE T2,AS3PTR ;Get byte pointer and size
DMOVEM T2,AS3BH+1 ;Reset TOPS-10 style buffer header
JUMPE T1,RITER1 ;Just like TOPS-10 dummy output
MOVE T1,AS3JFN ;Get JFN
DMOVE T2,AS3IOW ;Get byte pointer and size
JRST PUTS1C
PUTS3B: SUBI T3,1 ;Byte count is 1 behind byte pointer
DMOVE T1,AS3PTR ;Get byte pointer and size
DMOVEM T1,AS3BH+1 ;Reset TOPS-10 style buffer header
MOVE T1,AS3JFN ;Get JFN
MOVE T2,AS3IOW ;Output byte pointer
ADD T3,AS3IOW+1 ;Output count
JRST PUTS1C ;Output it
;Write output (two words) to GENFIL
PUTGEN: AOS GENWRD ;BUMP WORD COUNT
SOSG GENBH+2 ;IS BUFFER FULL?
PUSHJ PP,PUTGN1 ;YES--GET ANOTHER BUFFER
IDPB TA,GENBH+1 ;MOVE ONE WORD
SOSG GENBH+2 ;IS BUFFER FULL NOW?
PUSHJ PP,PUTGN1 ;YES--GET ANOTHER
IDPB TB,GENBH+1 ;MOVE SECOND WORD
POPJ PP,
PUTGN1: PUSH PP,T1 ;Save accs
PUSH PP,T2
PUSH PP,T3
MOVE T1,GENBH+1 ;First time its zero
SKIPLE T3,GENBH+2 ;Partial buffer to output?
JUMPN T1,PUTGN2 ;Yes, not first time and word count positive
DMOVE T2,GENPTR ;Get byte pointer and size
DMOVEM T2,GENBH+1 ;Reset TOPS-10 style buffer header
JUMPE T1,RITER1 ;Just like TOPS-10 dummy output
MOVE T1,GENJFN ;Get JFN
DMOVE T2,GENIOW ;Get byte pointer and size
PUTGN3: SOUT%
ERJMP PUTERR ;Failed
JRST T3RET ;OK, restore
PUTGN2: SUBI T3,1 ;Byte count is 1 behind byte pointer
DMOVE T1,GENPTR ;Get byte pointer and size
DMOVEM T1,GENBH+1 ;Reset TOPS-10 style buffer header
MOVE T1,GENJFN ;Get JFN
MOVE T2,GENIOW ;Output byte pointer
ADD T3,GENIOW+1 ;Output count
JRST PUTGN3 ;Output it
;PUT A CHARACTER OUT ONTO LSTFIL
PUTLST: TSWF FNOLST ;ANY LISTING FILE?
POPJ PP, ;NO--RETURN
SOSG LSTBH+2
PUSHJ PP,PUTLS1
IDPB CH,LSTBH+1
POPJ PP,
;BUFFER IS FULL - WRITE IT OUT
PUTLS1: PUSH PP,T1 ;Save accs
PUSH PP,T2
PUSH PP,T3
MOVE T1,LSTBH+1 ;First time its zero
SKIPLE T3,LSTBH+2 ;Partial buffer to output?
JUMPN T1,PUTLS2 ;Yes, not first time and word count positive
DMOVE T2,LSTPTR ;Get byte pointer and size
DMOVEM T2,LSTBH+1 ;Reset TOPS-10 style buffer header
JUMPE T1,RITER1 ;Just like TOPS-10 dummy output
MOVE T1,LSTJFN ;Get JFN
DMOVE T2,LSTIOW ;Get byte pointer and size
PUTLS3: SOUT%
ERJMP PUTERR ;Failed
JRST T3RET ;OK, restore
PUTLS2: SUBI T3,1 ;Byte count is 1 behind byte pointer
DMOVE T1,LSTPTR ;Get byte pointer and size
DMOVEM T1,LSTBH+1 ;Reset TOPS-10 style buffer header
MOVE T1,LSTJFN ;Get JFN
MOVE T2,LSTIOW ;Output byte pointer
ADD T3,LSTIOW+1 ;Output count
JRST PUTLS3 ;Output it
;Write out word to binary file
PUTBIN: SKIPN BINJFN ;Are we writing a binary file?
POPJ PP, ;No, forget it
SOSG BINBH+2 ;Yes, is the buffer full?
PUSHJ PP,PUTBN1 ;Yes, empty it
IDPB CH,BINBH+1 ;No, put word in buffer
POPJ PP,
PUTBN1: PUSH PP,T1 ;Save accs
PUSH PP,T2
PUSH PP,T3
MOVE T1,BINBH+1 ;First time its zero
SKIPLE T3,BINBH+2 ;Partial buffer to output?
JUMPN T1,PUTBN2 ;Yes, not first time and word count positive
DMOVE T2,BINPTR ;Get byte pointer and size
DMOVEM T2,BINBH+1 ;Reset TOPS-10 style buffer header
JUMPE T1,RITER1 ;Just like TOPS-10 dummy output
MOVE T1,BINJFN ;Get JFN
DMOVE T2,BINIOW ;Get byte pointer and size
PUTBN3: SOUT%
ERJMP PUTERR ;Failed
JRST T3RET ;OK, restore
;Note, because of the way that the SOSG loop is done the count is off by one
;and we cannot tell an unused buffer from one with 1 word used by the count.
;We must look at the byte pointer to be sure. Otherwise an extra word will be written.
PUTBN2: SUBI T3,1 ;Byte count is 1 behind byte pointer
DMOVE T1,BINPTR ;Get byte pointer and size
CAMN T1,BINBH+1 ;Is the buffer really empty?
JRST T3RET ;Yes, see note above.
DMOVEM T1,BINBH+1 ;Reset TOPS-10 style buffer header
MOVE T1,BINJFN ;Get JFN
MOVE T2,BINIOW ;Output byte pointer
ADD T3,BINIOW+1 ;Output count
JRST PUTBN3 ;Output it
;Write out last partial files
RITASY: PUSHJ PP,PUTS1A ;Write out last partial buffer
PUSHJ PP,PUTS2A ;Write out last partial buffer
SKIPLE AS3JFN ;If AS3 file open
PUSHJ PP,PUTS3A ;Write out last partial buffer
POPJ PP,
;Write out NAMTAB to NAMFIL
RITNAM: PUSH PP,T1 ;Save accs
PUSH PP,T2
PUSH PP,T3
MOVE T1,NAMJFN ;Get JFN
DMOVE T2,NAMIOL## ;Byte ptr and count
SOUT%
ERJMP [HRROI T1,[ASCIZ "%Couldn't write NAMTAB, compilation continuing without maps or object listing
"]
PSOUT%
SWOFF FMAP!FOBJEC
JRST .+1]
HRRZ T1,NAMJFN
TXO T1,CO%NRJ ;Keep JFN
CLOSF%
ERJMP .+1
JRST T3RET ;OK, restore
;Read back NAMTAB
SETNAM: PUSH PP,T1 ;Save accs
PUSH PP,T2
PUSH PP,T3
HRRZ T1,NAMJFN ;Get JFN
MOVX T2,OF%RD ;Read 36 bit bytes
PUSH PP,T1 ;Incase of error
OPENF%
JRST OPNERR
POP PP,T1 ;Clear stack
MOVE T1,NAMJFN ;Get JFN
DMOVE T2,NAMIOL## ;Byte ptr and count
SIN%
ERJMP [MOVEI T1,.FHSLF
GETER%
NOOP
HRRZ T2,T2 ;Error only
MOVE T1,NAMJFN
CAIE T2,IOX4 ;End of File?
JRST GETERR ;No
SUB T3,NAMIOL+1 ;See if we read them all
JUMPN T3,GETERR ;No, something wrong
JRST .+1]
JRST T3SRET ;OK skip return
;Write out a diagnostic to ERAFIL
RITERA: PUSH PP,T1 ;Save accs
PUSH PP,T2
PUSH PP,T3
MOVE T1,ERABH+1 ;First time its zero
SKIPLE T3,ERABH+2 ;Partial buffer to output?
JUMPN T1,RITERB ;Yes, not first time and word count positive
DMOVE T2,ERAPTR ;Get byte pointer and size
DMOVEM T2,ERABH+1 ;Reset TOPS-10 style buffer header
JUMPE T1,RITER1 ;Just like TOPS-10 dummy output
MOVE T1,ERAJFN ;Get JFN
DMOVE T2,ERAIOW ;Get byte pointer and size
RITERC: SOUT%
ERJMP PUTERR ;Failed
RITER1: JRST T3RET ;OK, restore
RITERB: SUBI T3,1 ;Byte count is 1 behind byte pointer
DMOVE T1,ERAPTR ;Get byte pointer and size
DMOVEM T1,ERABH+1 ;Reset TOPS-10 style buffer header
MOVE T1,ERAJFN ;Get JFN
MOVE T2,ERAIOW ;Output byte pointer
ADD T3,ERAIOW+1 ;Output count
JRST RITERC ;Output it
;Write out source to CPYFIL
RITCPY: PUSH PP,T1 ;Save accs
PUSH PP,T2
PUSH PP,T3
MOVE T1,CPYBH+1 ;First time its zero
SKIPLE T3,CPYBH+2 ;Partial buffer to output?
JUMPN T1,RITCP1 ;Yes, not first time and word count positive
DMOVE T2,CPYPTR ;Get byte pointer and size
DMOVEM T2,CPYBH+1 ;Reset TOPS-10 style buffer header
JUMPE T1,RITCP3 ;Just like TOPS-10 dummy output
MOVE T1,CPYJFN ;Get JFN
DMOVE T2,CPYIOW ;Get byte pointer and size
RITCP2: SOUT%
ERJMP PUTERR ;Failed
RITCP3: SETZM CPYBFR ;Zero first word
MOVE T1,[CPYBFR,,CPYBFR+1]
BLT T1,CPYBFR+CPYBLN-1 ;Zero all buffer
JRST T3RET ;OK, restore
RITCP1: SOS T2,T3 ;Byte count is 1 behind byte pointer
IDIVI T2,5 ;Get size in words
MOVE T3,T2 ; into T3
DMOVE T1,CPYPTR ;Get byte pointer and size
DMOVEM T1,CPYBH+1 ;Reset TOPS-10 style buffer header
MOVE T1,CPYJFN ;Get JFN
MOVE T2,CPYIOW ;Output byte pointer
ADD T3,CPYIOW+1 ;Output count
JRST RITCP2 ;Output it
;Write out source to CRFFIL
RITCRF: PUSH PP,T1 ;Save accs
PUSH PP,T2
PUSH PP,T3
MOVE T1,CRFBH+1 ;First time its zero
SKIPLE T3,CRFBH+2 ;Partial buffer to output?
JUMPN T1,RITCR2 ;Yes, not first time and word count positive
DMOVE T2,CRFPTR ;Get byte pointer and size
DMOVEM T2,CRFBH+1 ;Reset TOPS-10 style buffer header
JUMPE T1,RITER1 ;Just like TOPS-10 dummy output
MOVE T1,CRFJFN ;Get JFN
DMOVE T2,CRFIOW ;Get byte pointer and size
RITCR3: SOUT%
ERJMP PUTERR ;Failed
JRST T3RET ;OK, restore
RITCR2: SUBI T3,1 ;Byte count is 1 behind byte pointer
DMOVE T1,CRFPTR ;Get byte pointer and size
DMOVEM T1,CRFBH+1 ;Reset TOPS-10 style buffer header
MOVE T1,CRFJFN ;Get JFN
MOVE T2,CRFIOW ;Output byte pointer
ADD T3,CRFIOW+1 ;Output count
JRST RITCR3 ;Output it
;Write out lieral table to LITFIL
;NOTE, this is different from other cases.
;Write is done in dump mode.
RITLIT: PUSH PP,T1 ;Save accs
PUSH PP,T2
MOVE T1,LITJFN ;Get JFN
MOVEI T2,IOWLIT ;Get IOWD
DUMPO%
JRST PUTERR ;Failed
JRST T2RET ;OK, restore
;Get another buffer from source file
;Gives skip return if more data in new buffer.
GETSRB: PUSH PP,T1 ;Save accs
PUSH PP,T2
PUSH PP,T3
DMOVE T2,SRCPTR ;Get byte pointer and size
DMOVEM T2,SRCBH+1 ;Reset TOPS-10 style buffer header
MOVE T1,SRCJFN ;Get JFN
DMOVE T2,SRCIOW ;Get byte pointer and size
SIN%
ERJMP [MOVEI T1,.FHSLF
GETER%
NOOP
HRRZ T2,T2 ;Error only
MOVE T1,SRCJFN
CAIE T2,IOX4 ;End of File?
JRST GETERR ;No
IMULI T3,5 ;Convert to bytes
ADDB T3,SRCBH+2 ;Adjust count
JUMPE T3,EOFRET ;Return EOF as buffer is empty
JRST T3SRET]
T3SRET: POP PP,T3 ;OK, restore
POP PP,T2
POP PP,T1
AOS (PP)
POPJ PP,
EOFRET: POP PP,T3 ;Restore
POP PP,T2
POP PP,T1
POPJ PP, ;EOF return
GETASY: SOSG AS1BH+2
PUSHJ PP,GETASA
ILDB CH,AS1BH+1
POPJ PP,
GETASA: PUSH PP,T1 ;Save accs
PUSH PP,T2
PUSH PP,T3
MOVE T1,AS1JFN ;Get JFN
DMOVE T2,AS1PTR ;Setup TOPS-10 style buffer header
DMOVEM T2,AS1BH+1 ;So I/O works same way
DMOVE T2,AS1IOW ;Get byte pointer and size
SIN%
ERJMP [MOVEI T1,.FHSLF
GETER%
NOOP
HRRZ T2,T2 ;Error only
MOVE T1,AS1JFN
CAIE T2,IOX4 ;End of File?
JRST GETERR ;No
ADDB T3,AS1BH+2 ;Adjust count
JRST .+1]
JRST T3RET ;OK, restore
;All three ASY files are read back using the same buffer area
;Not at the same time of course.
SETASY: PUSH PP,T1 ;Save some accs
PUSH PP,T2
HRRZ T1,AS1JFN ;Get jfn
MOVX T2,OF%RD ;Read 36 bit bytes
PUSH PP,T1 ;Incase of error
OPENF%
JRST OPNERR
SETZM AS1BH+1 ;Force buffer fill on first read
SETZM AS1BH+2
JRST JT2RET
;Set up AS2 file for optimizer.
;Use name AS4 for now and later raname it back it AS2.
SETAS2: PUSH PP,T1
PUSH PP,T2
MOVE T1,["AS4"] ;Temp name
PUSHJ PP,OPNTMP
HRRZM T1,AS2JFN ;SAVE JFN
SETZM AS2BH+1 ;Force buffer fill on first write
SETZM AS2BH+2
MOVX T2,OF%WR ;Write 36 bit bytes
OPENF%
JRST MONERR ;Problems
JRST T2RET
RENAS2: PUSH PP,T1
PUSH PP,T2
PUSHJ PP,CLSAS1
PUSHJ PP,PUTS2A ;WRITE OUT THE PARTIAL BUFFER
PUSHJ PP,CLSAS2
MOVE T1,AS2JFN ;File we want
MOVE T2,AS1JFN ;File spec we want
RNAMF%
JRST MONERR
MOVEM T2,AS2JFN ;Store new JFN
SETZM AS1JFN ;Clear old JFN
JRST T2RET
;Read a word from CPYFIL
GETCPY: SOSG CPYBH+2
PUSHJ PP,GETCPA
ILDB CH,CPYBH+1
POPJ PP,
SETCPY: PUSH PP,T1 ;Save some accs
PUSH PP,T2
HRRZ T1,CPYJFN ;Get jfn
MOVX T2,OF%RD ;Read 36 bit bytes
PUSH PP,T1 ;Incase of error
OPENF%
JRST OPNERR
SETZM CPYBH+1 ;Force buffer fill on first read
SETZM CPYBH+2
JRST JT2RET
GETCPA: PUSH PP,T1 ;Save accs
PUSH PP,T2
PUSH PP,T3
MOVE T1,CPYJFN ;Get JFN
DMOVE T2,CPYPTR ;Setup TOPS-10 style buffer header
DMOVEM T2,CPYBH+1 ;So I/O works same way
DMOVE T2,CPYIOW ;Get byte pointer and size
SIN%
ERJMP [MOVEI T1,.FHSLF
GETER%
NOOP
HRRZ T2,T2 ;Error only
MOVE T1,CPYJFN
CAIE T2,IOX4 ;End of File?
JRST GETERR ;No
IMULI T3,5 ;Convert to bytes
ADDB T3,CPYBH+2 ;Adjust count
JRST .+1]
JRST T3RET ;OK, restore
;Open the CRF file
SETCRF: PUSH PP,T1 ;Save some accs
PUSH PP,T2
HRRZ T1,CRFJFN ;Get JFN
MOVX T2,OF%RD ;Read 36 bit bytes
PUSH PP,T1 ;Incase of error
OPENF%
JRST OPNERR
SETZM CRFBH+1 ;Set count zero so we will fill buffer on next read
SETZM CRFBH+2
JRST JT2RET
;Read a word from CRFFIL
;Returns:
; +1 if EOF
; +2 if not
GETCRF: SOSG CRFBH+2
PUSHJ PP,GETCRA
ILDB CH,CRFBH+1
AOS (PP) ;Skip return if not eof
POPJ PP,
GETCRA: PUSH PP,T1 ;Save accs
PUSH PP,T2
PUSH PP,T3
MOVE T1,CRFJFN ;Get JFN
DMOVE T2,CRFPTR ;Setup TOPS-10 style buffer header
DMOVEM T2,CRFBH+1 ;So I/O works same way
DMOVE T2,CRFIOW ;Get byte pointer and size
SIN%
ERJMP [MOVEI T1,.FHSLF
GETER%
NOOP
HRRZ T2,T2 ;Error only
MOVE T1,CRFJFN
CAIE T2,IOX4 ;End of File?
JRST GETERR ;No
ADDB T3,CRFBH+2 ;Adjust count
SKIPN T3 ;OK
SOS -4(PP) ;EOF, give non-skip return
JRST .+1]
JRST T3RET ;OK, restore
;Read a word from ERAFIL
SETERA: PUSH PP,T1 ;Save some accs
PUSH PP,T2
HRRZ T1,ERAJFN ;Get jfn
MOVX T2,OF%RD ;Read 36 bit bytes
PUSH PP,T1 ;Incase of error
OPENF%
JRST OPNERR
SETZM ERABH+1 ;Set count zero so we will fill buffer on next read
SETZM ERABH+2
JRST JT2RET
GETERA: SOSG ERABH+2
PUSHJ PP,GETER1
ILDB DW,ERABH+1
POPJ PP,
GETER1: PUSH PP,T1 ;Save accs
PUSH PP,T2
PUSH PP,T3
GETER2: MOVE T1,ERAJFN ;Get JFN
DMOVE T2,ERAPTR ;Setup TOPS-10 style buffer header
DMOVEM T2,ERABH+1 ;So I/O works same way
DMOVE T2,ERAIOW ;Get byte pointer and size
SIN%
ERJMP [MOVEI T1,.FHSLF
GETER%
NOOP
HRRZ T2,T2 ;Error only
MOVE T1,ERAJFN
CAIE T2,IOX4 ;End of File?
JRST GETERR ;No
ADDB T3,ERABH+2 ;Adjust count
JRST .+1]
T3RET: POP PP,T3 ;OK, restore
T2RET: POP PP,T2
T1RET: POP PP,T1
POPJ PP,
;Read a word from LITFIL
;NOTE, I/O is done in DUMP mode
SETLIT: PUSH PP,T1 ;Save some accs
PUSH PP,T2
PUSH PP,T3
HRRZ T1,LITJFN ;Get jfn
MOVE T2,[FLD(.GSDMP,OF%MOD)+OF%RD] ;Read 36 bit bytes in dump mode
PUSH PP,T1 ;Incase of error
OPENF%
JRST OPNERR
SETZM LITBH+1 ;Set count zero so we will fill buffer on next read
SETZM LITBH+2
POP PP,T1 ;Clear stack
JRST T3RET ;Return
GETLIT: PUSH PP,T1 ;Save accs
PUSH PP,T2
MOVE T1,LITJFN ;Get JFN
MOVEI T2,IOWLIT ;Get IOWD
DUMPI%
JRST GETLT1 ;Failed
JRST T2RET ;OK, restore
GETLT1: PUSH PP,T3 ;Save extra acc
MOVEI T1,.FHSLF
GETER%
NOOP
HRRZ T2,T2 ;Error only
MOVE T1,LITJFN
CAIE T2,IOX4 ;End of File?
JRST GETERR ;No
JRST T3RET ;OK?
OPNSF1: PUSH PP,T1 ;Save some accs
PUSH PP,T2
HRRZ T1,SF1JFN ;Get jfn
MOVX T2,OF%WR ;Write 36 bit bytes
PUSH PP,T1 ;Incase of error
OPENF%
JRST OPNERR
SETZM SF1BH+1 ;Set count zero so we will fill buffer on next write
SETZM SF1BH+2
JRST JT2RET
OPNSF2: PUSH PP,T1 ;Save some accs
PUSH PP,T2
HRRZ T1,SF2JFN ;Get jfn
MOVX T2,OF%WR ;Write 36 bit bytes
PUSH PP,T1 ;Incase of error
OPENF%
JRST OPNERR
SETZM SF2BH+1 ;Set count zero so we will fill buffer on next write
SETZM SF2BH+2
JRST JT2RET
OPNSF3: PUSH PP,T1 ;Save some accs
PUSH PP,T2
HRRZ T1,SF3JFN ;Get jfn
MOVX T2,OF%WR ;Write 36 bit bytes
PUSH PP,T1 ;Incase of error
OPENF%
JRST OPNERR
SETZM SF3BH+1 ;Set count zero so we will fill buffer on next write
SETZM SF3BH+2
JRST JT2RET
SETSF1: PUSH PP,T1 ;Save some accs
PUSH PP,T2
HRRZ T1,SF1JFN ;Get jfn
MOVX T2,OF%RD ;Read 36 bit bytes
PUSH PP,T1 ;Incase of error
OPENF%
JRST OPNERR
SETZM SF1BH+1 ;Set count zero so we will fill buffer on next read
SETZM SF1BH+2
JRST JT2RET
SETSF2: PUSH PP,T1 ;Save some accs
PUSH PP,T2
HRRZ T1,SF2JFN ;Get jfn
MOVX T2,OF%RD ;Read 36 bit bytes
PUSH PP,T1 ;Incase of error
OPENF%
JRST OPNERR
SETZM SF2BH+1 ;Set count zero so we will fill buffer on next read
SETZM SF2BH+2
JRST JT2RET
SETSF3: PUSH PP,T1 ;Save some accs
PUSH PP,T2
HRRZ T1,SF3JFN ;Get jfn
MOVX T2,OF%RD ;Read 36 bit bytes
PUSH PP,T1 ;Incase of error
OPENF%
JRST OPNERR
SETZM SF3BH+1 ;Set count zero so we will fill buffer on next read
SETZM SF3BH+2
JRST JT2RET
GETSF1: PUSH PP,T1 ;Save accs
PUSH PP,T2
PUSH PP,T3
DMOVE T2,SF1PTR ;Get byte pointer and size
DMOVEM T2,SF1BH+1 ;Reset TOPS-10 style buffer header
MOVE T1,SF1JFN ;Get JFN
DMOVE T2,SF1IOW ;Get byte pointer and size
SIN%
ERJMP [MOVEI T1,.FHSLF
GETER%
NOOP
HRRZ T2,T2 ;Error only
MOVE T1,SF1JFN
CAIE T2,IOX4 ;End of File?
JRST GETERR ;No
ADDB T3,SF1BH+2 ;Adjust count
JRST .+1]
JRST T3RET ;OK, restore
GETSF2: PUSH PP,T1 ;Save accs
PUSH PP,T2
PUSH PP,T3
DMOVE T2,SF2PTR ;Get byte pointer and size
DMOVEM T2,SF2BH+1 ;Reset TOPS-10 style buffer header
MOVE T1,SF2JFN ;Get JFN
DMOVE T2,SF2IOW ;Get byte pointer and size
SIN%
ERJMP [MOVEI T1,.FHSLF
GETER%
NOOP
HRRZ T2,T2 ;Error only
MOVE T1,SF2JFN
CAIE T2,IOX4 ;End of File?
JRST GETERR ;No
ADDB T3,SF2BH+2 ;Adjust count
JRST .+1]
JRST T3RET ;OK, restore
GETSF3: PUSH PP,T1 ;Save accs
PUSH PP,T2
PUSH PP,T3
DMOVE T2,SF3PTR ;Get byte pointer and size
DMOVEM T2,SF3BH+1 ;Reset TOPS-10 style buffer header
MOVE T1,SF3JFN ;Get JFN
DMOVE T2,SF3IOW ;Get byte pointer and size
SIN%
ERJMP [MOVEI T1,.FHSLF
GETER%
NOOP
HRRZ T2,T2 ;Error only
MOVE T1,SF3JFN
CAIE T2,IOX4 ;End of File?
JRST GETERR ;No
ADDB T3,SF3BH+2 ;Adjust count
JRST .+1]
JRST T3RET ;OK, restore
;Write out buffer to CREF file
RITSF1: PUSH PP,T1 ;Save accs
PUSH PP,T2
PUSH PP,T3
MOVE T1,SF1BH+1 ;First time its zero
SKIPLE T3,SF1BH+2 ;Partial buffer to output?
JUMPN T1,RITSFB ;Yes, not first time and word count positive
DMOVE T2,SF1PTR ;Get byte pointer and size
DMOVEM T2,SF1BH+1 ;Reset TOPS-10 style buffer header
JUMPE T1,T3RET ;Just like TOPS-10 dummy output
MOVE T1,SF1JFN ;Get JFN
DMOVE T2,SF1IOW ;Get byte pointer and size
RITSFA: SOUT%
ERJMP PUTERR ;Failed
JRST T3RET ;OK, restore
RITSFB: SUBI T3,1 ;Byte count is 1 behind byte pointer
DMOVE T1,SF1PTR ;Get byte pointer and size
DMOVEM T1,SF1BH+1 ;Reset TOPS-10 style buffer header
MOVE T1,SF1JFN ;Get JFN
MOVE T2,SF1IOW ;Output byte pointer
ADD T3,SF1IOW+1 ;Output count
JRST RITSFA ;Output it
RITSF2: PUSH PP,T1 ;Save accs
PUSH PP,T2
PUSH PP,T3
MOVE T1,SF2BH+1 ;First time its zero
SKIPLE T3,SF2BH+2 ;Partial buffer to output?
JUMPN T1,RITSFC ;Yes, not first time and word count positive
DMOVE T2,SF2PTR ;Get byte pointer and size
DMOVEM T2,SF2BH+1 ;Reset TOPS-10 style buffer header
JUMPE T1,T3RET ;Just like TOPS-10 dummy output
MOVE T1,SF2JFN ;Get JFN
DMOVE T2,SF2IOW ;Get byte pointer and size
JRST RITSFA ;Common output
RITSFC: SUBI T3,1 ;Byte count is 1 behind byte pointer
DMOVE T1,SF2PTR ;Get byte pointer and size
DMOVEM T1,SF2BH+1 ;Reset TOPS-10 style buffer header
MOVE T1,SF2JFN ;Get JFN
MOVE T2,SF2IOW ;Output byte pointer
ADD T3,SF2IOW+1 ;Output count
JRST RITSFA ;Output it
RITSF3: PUSH PP,T1 ;Save accs
PUSH PP,T2
PUSH PP,T3
MOVE T1,SF3BH+1 ;First time its zero
SKIPLE T3,SF3BH+2 ;Partial buffer to output?
JUMPN T1,RITSFD ;Yes, not first time and word count positive
DMOVE T2,SF3PTR ;Get byte pointer and size
DMOVEM T2,SF3BH+1 ;Reset TOPS-10 style buffer header
JUMPE T1,T3RET ;Just like TOPS-10 dummy output
MOVE T1,SF3JFN ;Get JFN
DMOVE T2,SF3IOW ;Get byte pointer and size
JRST RITSFA ;Common output
RITSFD: SUBI T3,1 ;Byte count is 1 behind byte pointer
DMOVE T1,SF3PTR ;Get byte pointer and size
DMOVEM T1,SF3BH+1 ;Reset TOPS-10 style buffer header
MOVE T1,SF3JFN ;Get JFN
MOVE T2,SF3IOW ;Output byte pointer
ADD T3,SF3IOW+1 ;Output count
JRST RITSFA ;Output it
GETGEN: AOS GENWRD ;BUMP WORD COUNTER
SOSG GENBH+2
PUSHJ PP,GETGN2
ILDB W1,GENBH+1
SOSG GENBH+2
PUSHJ PP,GETGN2
ILDB W2,GENBH+1
POPJ PP,
GETGN2: PUSH PP,T1 ;Save accs
PUSH PP,T2
PUSH PP,T3
MOVE T1,GENJFN ;Get JFN
DMOVE T2,GENPTR ;Setup TOPS-10 style buffer header
DMOVEM T2,GENBH+1 ;So I/O works same way
DMOVE T2,GENIOW ;Get byte pointer and size
SIN%
ERJMP [MOVEI T1,.FHSLF
GETER%
NOOP
HRRZ T2,T2 ;Error only
MOVE T1,GENJFN
CAIE T2,IOX4 ;End of File?
JRST GETERR ;No
ADDB T3,GENBH+2 ;Adjust count
JRST .+1]
JRST T3RET ;OK, restore
;SET UP GENFIL FOR INPUT
SETGEN: PUSH PP,T1 ;Save some accs
PUSH PP,T2
PUSH PP,T3
HRRZ T1,GENJFN ;Get JFN
MOVX T2,OF%RD ;Read 36 bit bytes
PUSH PP,T1 ;Incase of error
OPENF%
JRST OPNERR
SETZM GENBH+1 ;Force first read
SETZM GENBH+2
POP PP,T1 ;Clear stack
POP PP,T3
POP PP,T2
POP PP,T1
HLRZ TA,PROGST
MOVEM TA,GENWRD
CAIN TA,100
POPJ PP,
JRST SETSG1
;SET UP GENFIL TO READ NEXT SECTION.
;ENTER WITH RH OF TA POINTING TO A PROTAB ENTRY
SETSEG: ANDI TA,77777
ADD TA,PROLOC
HLRZ TA,1(TA)
CAMN TA,GENWRD
POPJ PP,
MOVEM TA,GENWRD
SETSG1: PUSH PP,T1
PUSH PP,T2
LSH TA,1 ;Convert to words
MOVE T1,GENJFN
MOVE T2,TA ;Get byte number
TRZ T2,177 ;Set on buffer boundary
SUBI T2,200
SFPTR% ;Set on buffer we want
JRST MONERR
PUSHJ PP,GETGN2 ;Read in the buffer
ANDI TA,177 ;Get word count into buffer
ADDM TA,GENBH+1
SUBI TA,1
MOVNS TA
ADDM TA,GENBH+2
JRST T2RET
;CLOSE TEMP FILES BUT KEEP JFN OPEN
CLSAS1: PUSH PP,T1
HRRZ T1,AS1JFN
CLSTMP: JUMPE T1,CLSRET ;Not open
TXO T1,CO%NRJ ;Don't release JFN
CLOSF%
ERJMP .+1
CLSRET: POP PP,T1
POPJ PP,
CLSAS2: PUSH PP,T1
HRRZ T1,AS2JFN
JRST CLSTMP
CLSAS3: PUSH PP,T1
HRRZ T1,AS3JFN
JRST CLSTMP
CLSCPY: PUSH PP,T1
HRRZ T1,CPYJFN
JRST CLSTMP
CLSERA: PUSH PP,T1
HRRZ T1,ERAJFN
JRST CLSTMP
CLSCRF: PUSH PP,T1
HRRZ T1,CRFJFN
JRST CLSTMP
CLSGEN: PUSH PP,T1
HRRZ T1,GENJFN
JRST CLSTMP
CLSLIB: PUSH PP,T1
HRRZ T1,LIBJFN
JRST CLSTMP
CLSLIT: PUSH PP,T1
HRRZ T1,LITJFN
JRST CLSTMP
CLSSF1: PUSH PP,T1
HRRZ T1,SF1JFN
JRST CLSTMP
CLSSF2: PUSH PP,T1
HRRZ T1,SF2JFN
JRST CLSTMP
CLSSF3: PUSH PP,T1
HRRZ T1,SF3JFN
JRST CLSTMP
CLSTFI: PUSH PP,T1
HRRZ T1,TFIJFN
JRST CLSTMP
;CLOSE FILE AND RELEASE JFN
;Close all files in case we missed some
CLZALL: PUSHJ PP,CLZSRC ;Close source
PUSHJ PP,CLZBIN ;Rel file
PUSHJ PP,CLZLST ;List file
PUSHJ PP,CLZDMP ;Dump file
POPJ PP,
CLZBIN: SKIPLE BINJFN ;If bin file open
PUSHJ PP,PUTBN1 ;Write out last partial buffer
PUSH PP,T1
HRRZ T1,BINJFN
IFE DEBUG,<
TSWF FFATAL ;If any fatal errors, don't create
TXO T1,CZ%ABT ; a new .REL, leave any old one
>; END DEBUG
SETZM BINJFN
CLZFIL: JUMPE T1,CLSRET ;Not open
CLOSF%
ERJMP .+1
POP PP,T1
POPJ PP,
CLZSRC: PUSH PP,T1
HRRZ T1,SRCJFN
SETZM SRCJFN
JRST CLZFIL
CLZLST: SKIPLE LSTJFN ;If list file open
PUSHJ PP,PUTLS1 ;Write out last partial buffer
PUSH PP,T1
HRRZ T1,LSTJFN
SETZM LSTJFN
JRST CLZFIL
CLZDMP: SKIPLE DMPJFN ;If dump file open
PUSHJ PP,DMPO2 ;Write out last partial buffer
PUSH PP,T1
HRRZ T1,DMPJFN
SETZM DMPJFN
JRST CLZFIL
CLZLIB: PUSH PP,T1
HRRZ T1,LIBJFN
SETZM LIBJFN
JRST CLZFIL
;DELETE ALL TEMP FILES AT END OF COMPILATION
DELALL: PUSH PP,T1
PUSH PP,T2
MOVSI T2,-LENJFN ;NO. OF JFN'S TO RELEASE
DELAL1: SKIPN T1,@XXXJFN(T2)
JRST DELAL2
TXO T1,CO%NRJ ;Keep JFN
CLOSF%
NOOP ;Probably already closed
HRRZ T1,@XXXJFN(T2)
DELF%
NOOP
DELAL2: AOBJN T2,DELAL1
JRST T2RET
;DELETE CREF TEMP FILES
DELSF: PUSH PP,T1
PUSH PP,T2
MOVSI T2,-3 ;NO. OF JFN'S TO RELEASE
DELSF1: SKIPN T1,SFJFN##(T2)
JRST DELSF2
TXO T1,CO%NRJ ;Keep JFN
CLOSF%
NOOP ;Probably already closed
HRRZ T1,SFJFN(T2)
DELF%
NOOP
DELSF2: AOBJN T2,DELSF1
JRST T2RET
;SUBTTL DBMS routines
IFN DBMS,<
;Used by Phase C
OPNDBC: PUSH PP,T1
PUSH PP,T2
MOVE T1,["DBC"]
PUSHJ PP,OPNTMP ;Get JFN for invoke file
HRRZM T1,DBCJFN ;Save it
MOVX T2,FLD(7,OF%BSZ)+OF%WR ;Write 7 bits
PUSH PP,T1 ;Incase of error
OPENF%
JRST OPNERR
SETZM DBCBH+1 ;Force buffer fill on first read
SETZM DBCBH+2
JRST JT2RET
;Used by Phase D
OPNDBD: PUSH PP,T1
PUSH PP,T2
MOVE T1,["DB1"]
PUSHJ PP,OPNTMP ;Get JFN for invoke file
HRRZM T1,DBDJFN ;Save it
MOVX T2,FLD(7,OF%BSZ)+OF%WR ;Write 7 bits
PUSH PP,T1 ;Incase of error
OPENF%
JRST OPNERR
SETZM DBDBH+1 ;Force buffer fill on first read
SETZM DBDBH+2
JRST JT2RET
;Routines to write the INVOKE files
;Note, that these routines are called with the count of characters written R0.
;The buffer headers are not kept current.
PUTDBC: PUSH PP,T1 ;Save accs
PUSH PP,T2
PUSH PP,T3
MOVN T3,R0 ;Get actual count of characters to output
DMOVE T1,DBCPTR ;Get byte pointer and size
DMOVEM T1,DBCBH+1 ;Reset TOPS-10 style buffer header
JUMPE T3,RITER1 ;Just like TOPS-10 dummy output
MOVE T1,DBCJFN ;Get JFN
MOVE T2,DBCIOW ;Output byte pointer
SOUT%
ERJMP PUTERR ;Failed
JRST T3RET ;OK, restore
PUTDBD: PUSH PP,T1 ;Save accs
PUSH PP,T2
PUSH PP,T3
MOVN T3,R0 ;Get actual count of characters to output
DMOVE T1,DBDPTR ;Get byte pointer and size
DMOVEM T1,DBDBH+1 ;Reset TOPS-10 style buffer header
JUMPE T3,RITER1 ;Just like TOPS-10 dummy output
MOVE T1,DBDJFN ;Get JFN
MOVE T2,DBDIOW ;Output byte pointer
SOUT%
ERJMP PUTERR ;Failed
JRST T3RET ;OK, restore
;Used by both Phase C and D to read the INVOKE files
;Both DBC and DB1 files are read back using the same buffer area
;DBC is read back during phase C and DB1 during phase D.
DBGTF.: PUSH PP,T1
MOVE T1,DBDJFN ;Get phase D file
EXCH T1,DBSJFN ;Put in common place
EXCH T1,DBDJFN ;Save DBC's JFN for delete
TRNA
SETDBS: PUSH PP,T1 ;Save some accs
PUSH PP,T2
HRRZ T1,DBSJFN ;Get jfn
MOVX T2,FLD(7,OF%BSZ)+OF%RD ;Read 7 bit bytes
PUSH PP,T1 ;Incase of error
OPENF%
JRST OPNERR
SETZM DBSBH+1 ;Force buffer fill on first read
SETZM DBSBH+2
JRST JT2RET
GETDBS: PUSH PP,T1 ;Save accs
PUSH PP,T2
PUSH PP,T3
MOVE T1,DBSJFN ;Get JFN
DMOVE T2,DBSPTR ;Setup TOPS-10 style buffer header
DMOVEM T2,DBSBH+1 ;So I/O works same way
DMOVE T2,DBSIOW ;Get byte pointer and size
SIN%
ERJMP [MOVEI T1,.FHSLF
GETER%
NOOP
HRRZ T2,T2 ;Error only
MOVE T1,DBCJFN
CAIE T2,IOX4 ;End of File?
JRST GETERR ;No
ADDB T3,DBCBH+2 ;Adjust count
JUMPE T3,EOFRET ;Buffer is empty now
JRST T3SRET]
JRST T3SRET ;OK, restore
CLSDBC: PUSH PP,T1
HRRZ T1,DBCJFN
JRST CLSTMP
CLSDBD: PUSH PP,T1
HRRZ T1,DBDJFN
JRST CLSTMP
CLZDBS: PUSH PP,T1
HRRZ T1,DBSJFN
JRST CLSTMP ;Keep JFN so can delete tmp at end
>
SUBTTL I/O errors
;Error from SOUT%
PUTERR:
;Error from SIN%
GETERR:
;Error from GTJFN%
GJFERR: PUSH PP,T1
;Error from OPENF%
;When called, the JFN has been pushed on the stack.
OPNERR: HRROI T1,[ASCIZ /
?/]
PSOUT%
MOVEI T1,.PRIOU
HRLOI T2,.FHSLF
SETZ T3,
ERSTR%
NOOP
NOOP
HRROI T1,[ASCIZ / - /]
PSOUT%
MOVEI T1,.PRIOU
POP PP,T2
SETZB T3,T4
SKIPE T2 ;Not if zero
JFNS%
ERJMP .+1
HALTF% ;Just give up
SUBTTL TABLE OF BUFFER POINTER AND BUFFER SIZES FOR SIN%/SOUT%
DEFINE IOLIST (A,B,C,D,E)<
A'IOW: POINT C,A'BFR
IFE C-7,< EXP -5*B>
IFE C-^D36,< EXP -B>
>
IOWPTR:! IOFILE
;TABLE OF BUFFER POINTER AND BUFFER SIZES FOR LDB/DPB
DEFINE IOLIST (A,B,C,D,E)<
A'PTR: POINT D,A'BFR
IFE D-7,<A'SIZ: EXP 5*B>
IFE D-^D36,<A'SIZ: EXP B>
>
IOPTR:! IOFILE
;TABLE OF JFN'S
DEFINE IOLIST(A,B,C,D,E)<
IFN E,< EXP A'JFN>>
XXXJFN: IOFILE
LENJFN==.-XXXJFN
IFN DBMS,<
SYN DBCJFN,DBSJFN
SYN DBCBH,DBSBH
SYN DBCPTR,DBSPTR
SYN DBCIOW,DBSIOW
>
END COBOL