Trailing-Edge
-
PDP-10 Archives
-
bb-4157j-bm_fortran20_v11_16mt9
-
fortran-compiler/cmnd20.mac
There are 12 other files named cmnd20.mac in the archive. Click here to see a list.
TITLE CMND20 - The FORTRAN-20 Command Scanner
SUBTTL Randall Meyers/PLB/CDM/SRM/CKS/MRB/TGS/AlB/AHM/MEM/JB
;COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1982, 1987
;ALL RIGHTS RESERVED.
;
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
;ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
;INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
;COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
;OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
;TRANSFERRED.
;
;THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
;AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
;CORPORATION.
;
;DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
;SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
;AUTHOR: Randall Meyers
INTERN COMMAV
COMMAV= BYTE (3)0(9)11(6)0(18)4561 ; Version Date: 13-Jan-87
SUBTTL Revision History
Comment \
***** Begin Revision History *****
***** Begin Version 7 *****
1535 CDM 29-July-82
Add ACB, AIL to /NOWARN switches.
1563 PLB 18-Jun-82
Implement TTYSTR routine to do a PSOUT% from BLISS and,
EXITUUO routine to simulate CALLI 12
1600 PLB 9-Jul-82
TOPS-20 Native hacks. Supplies routine CORUUO, and PSI support
1602 RVM 14-Jul-82
Implement the TOPS-20 Native Scanner.
1603 RVM 16-Jul-82
Make .DEBUG preserve T2 so that a switch may follow /DEBUG. Remove
square brackets around the CCL "FORTRAN: etc." message. Disable
CONTROL/H recovery under batch, so that an error in a command
will not effect the next command line (otherwise, the next command
tries to hang, waiting for a CONTROL/H).
1611 RVM 6-Aug-82
Many command scanner changes to fix bugs, incorporate suggestions,
and to add features. Major changes: Exit compiler after processing
PRARG block. Rewrite /RUN code. Add /HELP. Rename /OBJECT and
/NOOBJECT to be /BINARY and /NOBINARY. Improve error message maker.
Add /DFLOATING.
1612 PLB 13-August-82
Trap code cleanup for edit 1600
1613 CDM 13-Aug-82
Change /DEBUG:PARAMETERS to /DEBUG:ARGUMENTS
1623 RVM 26-Aug-82
TOPS-20 command scanner: Do a CLZFF% before each command read
from the primary input stream in order close all files and
release all JFNs. This fixes the problem of unreleased JFNs
when a command or compile is aborted due to a catastrophic
error. A consequence of this edit is that the compiler cannot
keep a JFN on SWITCH.INI across compiles.
1631 RVM 1-Sep-82 Q20-03013
If the PRARG block overflows, the EXEC writes out TMP files to
disk. The TOPS-20 command scanner didn't look on disk for its
arguments if it found a null PRARG block.
1632 RVM 1-Sep-82
The TOPS-20 compiler does not reclaim its data area after a
compile. The locations .JBFF and .JBREL were only being set
once when the compiler started, rather than after each compile.
1636 RVM 28-Sep-82
Make /EXTEND and /NOEXTEND invisible, as they are not supported
aspects of the FORTRAN product.
1643 RVM 11-Oct-82
If the EXEC's arguments to the compiler do not exist in a PRARG
block or on disk, then do not complain, just accept commands from
the terminal. Also, add the ;T(emporary) attribute to the filespec
for the disk file which holds the EXEC arguments.
1645 RVM 15-Oct-82
Add the /NOECHO switch to the TOPS-20 command scanner, and change
a nested /TAKE which does not specify /ECHO or /NOECHO to use the
current value of the echo flag.
1652 CDM 20-Oct-82
Add RIM to NOWARN switch.
1654 SRM 21-Oct-82
Increased PDLLEN from 2100 to 2200 to allow FM045.FOR in the
validation tests to work.
1656 CKS 25-Oct-82
Change PLP warning to TSI.
1657 RVM 27-Oct-82
Improve the "Error occured while processing ..." message from
the TOPS-20 command scanner.
1671 RVM 11-Nov-82
The TOPS-20 command scanner had problems when the compiler was
reSTARTed because the COMND% JSYS state block was not being
reset.
1672 RVM 11-Nov-82
The TOPS-20 command scanner complained overmuch if the user's
SWITCH.INI file was offline. The scanner no longer complains
if the switch file is offline. I/O errors while reading the
switch file now produce warning instead of error messages,
and the warnings are now followed by a message stating that
the problem occurred while reading the switch file.
1673 RVM 11-Nov-82
Make the error message about nesting /TAKE commands too deep
a warning message and recover from the error by just ignoring
the errant command and continuing to process the nested /TAKEs
already in process. This has the nice property that the user
can recover by issuing the ignored /TAKE command when prompted
again by the compiler.
1701 RVM 13-Dec-82 Q20-06057
Remove the abbreviation for the /NOOBJECT switch since
that swich will disappear as soon as the EXEC no longer
needs it.
1705 PLB 21-Dec-82
Fix BLT word in CORUUO to zero more than one word.
1711 RVM 7-Jan-83
Make /O mean /OPTIMIZE, just as advertised. Also, have
the compiler to exit if the primary input designator is
invalid (this lets the compiler run as a background fork).
***** End V7 Development *****
1750 MRB 6-May-83
Add FOO to /NOWARN table.
2014 TGS 25-OCT-83 SPR:20-19657
Correct batch parsing so legal TOPS20-style command strings
won't be rejected as illegal TOPS10 commands.
2015 TGS 25-OCT-83 SPR:NONE
If a switch is given after the comma separating the list file
from the object file in a TOPS-10 compatibility command, the
error message "?FTNCMD Comma not given" is returned. (This is
part of edit 2220 in V10).
2032 TGS 10-JAN-84 SPR:NONE
Remove the default "+" which was available after parsing a
source filespec. If the .CMTOK function of the COMND% JSYS
is changed, the default for a .CMTOK field will be parsed
before the confirm. This will mean that the command scanner
sees all command lines ending with a "+", which is illegal.
(Accomplished in V10 by edit 2263)
2044 TGS 6-MAR-84 SPR:20-20007
Fix undeserved "Command too long for internal buffer" error
when there are lots of command strings under batch. Correct
.CMCNT word of the COMND% state block to accurately reflect
the number of free characters. (Accomplished in V10 by 2262)
***** End Revision History *****
***** Begin Version 10 *****
2220 RVM 29-Sep-83
Make the command scanner accept the revised TOPS-20 command
syntax and implement the extend switch. Also, a problem was
fixed that prevented switches from appearing between the comma
and listing filespec in a TOPS-10 command under compatibility
scanning. (This last problem was fixed in V7a as edit 2015.)
2221 RVM 29-Sep-83
Add new feature test FT612 to control debugging with SIX12.
Change how feature tests so that they recieve their default
values if their symbols are not defined.
2242 RVM 12-Dec-83
The /NOEXTEND switch was not using the proper offset into ONFLG
and OFFFLG for the SW.EXT flag. Thus, /NOEXTEND did not cancel
/EXTEND. Also, make /BUGOUT imply /LIST, since this allows code
to be removed from LEXICA (which is almost to big to compile!).
2246 AlB 20-Dec-83
Add the /FLAG and /NOFLAG switches for Compatibility Flagging.
See new routines .FLAG and .NOFLAG
2251 CDM 22-Dec-83
Add new global variable BIGCONCAT to declare the size (50,000
for now) of the largest concatenation allowed as fixed (CONCTF)
or known maximum (CONCTM) in length. If the concatenation is
larger than this, then the concatenation will be dynamic
(CONCTV) so that it will use the character stack.
2262 RVM 5-Jan-83
Fix bug that caused the "Command too long for internal buffer"
message to be given when a great many command strings were
given the compiler under batch. The bug had two causes.
First, edit 1603 disabled CONTROL/H error recovery under batch
by reseting some of the words in the COMND% state block. It
turns out the the .CMINI function would not reset the .CMCNT
word if the state block had been so munged. Second, when
command strings where put into the COMND% buffer "by hand,"
the command scanner would subtract the length of the command
from .CMCNT (the count of free characters in the command
buffer). This is incorrect since .CMCNT is the space left
after the text which has been parsed in the buffer. No text
in the buffer had been parsed yet.
2263 RVM 9-Jan-83
Remove the default "+" which was available after parsing a
source filespec. A Change to the .CMTOK function of the
COMND% JSYS now causes the default for a .CMTOK field to be
parsed before a confirm. This ment that the command scanner
saw all command lines ending with a "+", which is illegal.
(This was fixed in V7a by edit 2032.)
2264 PLB 11-JAN-83
Force OWGBPSECTION to 1 when /EXTEND typed. Zero at REPARSE.
This means the compiler will always output OWGs under /EXTEND.
2265 TFV 12-Jan-84
Increase POOLSIZE to 6000 words so we can compile programs with
large blocks of comment lines. The standard allows unlimited
numbers of comment lines between initial and continuation lines.
2305 AlB 8-Feb-84
Added a slough of entries to the /NOWARN tables. All entries are
for the Compatibility Flagger warnings.
2310 CDM 13-Feb-84
Output type 1131 rel block for PSECT redirection of segments
into psects. The command scanner sets the names for the psects
and the code generator dumps the rel block.
2320 RVM 9-Mar-84
First, change the name of the /FLAG switch to
/FLAG-NON-STANDARD and /NOFLAG to /NOFLAG-NON-STANDARD.
Second, allow the command standard required abbreviations of
/F for /FLAG... and /NOF for /NOFLAG.... Third, add a default
value of "ALL" for /FLAG....
2322 CDM 27-Apr-84
Fix array subscript calculations for /EXTEND to use a full word
to calculate arithmetic. In PROCEQUIV and BLDDIM, check an
array reference against the correct maximum size of an array
declaration /EXTEND. In BLDDIM, call CNSTCM for array
calculations to give underflow/overflow messages for illegal
declarations. Otherwise arrays that are too large may not be
detected since their size will overflow.
Change /FLAG:STANDARD to /FLAG:ANSI and /FLAG:NOSTANDARD to
/FLAG:NOANSI at AlB's request.
2330 AHM 28-Mar-84
Remove all references to the global OWGBPSECTION, since it is
no longer used by the code generator.
2331 RVM 28-Mar-84
Fix a bug in the way that colons at the end of the /EXTEND keywords
were handled. Under the old code, a ? immediately after the colon
in the /EXTEND switch keyword, would produce the wrong help text.
This occured because the CHKCOLON routine would look for something
in the follow set of the switch keyword when it had no colon, and
if that failed, look for a colon. The solution was simple: look
for a colon AND the follow set at the same time.
2343 RVM 18-Apr-84
Implement /EXTEND:COMMON and /EXTEND:NOCOMMON.
2347 RVM 27-Apr-84
Make /EXTEND mean /EXTEND:COMMON rather than /EXTEND:NOCOMMON.
Also, fix two bugs. First, /NOEXTEND was not setting the default
psect for COMMON blocks back to PSDATA. Second, /EXTEND:COMMON
had the side effect of changing the /EXTEND:DATA size to its
default value!
2350 RVM 28-Apr-84
Make the code and psect keywords to /EXTEND invisible for now,
as they are not yet supported.
2415 RVM 7-Jul-84
First, provide some additional help when the user types "?" at
the COMND% JSYS. Second, create an new entry into the error
message maker that allows us to provide some error text rather
than use the ERSTR% JSYS. This improves the reporting of various
semantic errors. Third, echo the command line in error if it is
coming from a indirect command file, regardless of the state of the
echo flag. Fourth, correct a long standing bug that caused the
command scanner not to complain if a TOPS-10 style command didn't
contain any source files.
2416 RVM 8-Jul-84
Make the /EXTEND:COMMON:name(s) switch imply that the default
psect for unnamed COMMON blocks is PSDATA. Likewise, make the
/EXTEND:NOCOMMON:name(s) switch imply that the default psect
for unnamed COMMON blocks is PSLARGE.
2417 RVM 9-Jul-84
Improve upon the rotten error message given when the first thing
in the command line was either a bad keyword or a non-existing
file. The solution was to scan for the old-style action switches
at the same time as all the new stuff, to examine the error that
occured, and to substitute a better error message for the monitor's
bad one using the new SEMERR routine.
2421 RVM 10-Jul-84
Impove the error messages for a command that looks like it starts
out at a keyword command by then goes awry.
2430 CDM 18-Jul-84
Have the compiler complain /FLAG for a variable mentioned more
than once in SAVE statements (SAVE A,B,A - A is mentioned
twice).
2441 RVM 4-Aug-84
Change the way the TOPS-20 command scanner resolves command
line switches and SWITCH.INI switches. This will require less
work in the future to add new flag words.
Module:
CMND20
2442 RVM 4-Aug-84
Make /EXTEND:CODE turn on its bit.
2445 RVM 8-Aug-84
Make /EXTEND:PSECT fill in LONAME and HINAME.
2447 PLB 10-Aug-84
Changes for nested INCLUDE files: Modified OPNICL to return
JFN in VREG, rather than store in CHNLTBL. Removed CLOICL.
2454 RVM 28-Aug-84
Move the definition of DEFLON (the default value for LONAME)
and DEFHIN (the default value for HINAME) from CMND20 into
GLOBAL. Then make OUTMOD use DEFLON and DEFHIN where needed
in the twoseg redirection rel block.
2455 MEM 30-Aug-84
Replace all occurrences of VAX with VMS.
2465 RVM 11-Oct-84
BLISS and CMND20 disagree about which registers are saved across
routine calls. Thus, CMND20 should save and restore all the
preserved registers when calling a BLISS routine.
2470 RVM 19-Oct-84
BIGARY was getting the wrong value if /EXTEND was never seen. This
also had the effect that BIGARY was wrong if /EXTEND:anything-but-data
was given.
2473 CDM 29-Oct-84
Add IMPLICIT NONE for the Military Standard MIL-STD-1753.
2524 JB 13-Mar-85
Add INC to the list of NOWARNs.
***** End V10 Development *****
***** End Revision History *****
***** Begin Version 11 *****
4500 MEM 22-Jan-85
Add warning message mnemonic VKI.
4501 MEM 22-Jan-85
Add warning message mnemonic EIR.
4527 CDM 1-Jan-86
VMS Long symbols phase II. Convert all internal symbols from
one word of Sixbit to [length,,pointer].
4530 MEM 17-Feb-86
Add long symbol support: Add warning message mnemonic EID;
Accept long common block names in /EXTEND switch.
4543 JB 10-Jul-86
Add LDI to the list of NOWARNs.
4544 MEM 7-Aug-86
Add ADV to list of NOWARNs.
4547 RVM 24-Aug-86
Update the version number in the argument to SETSN%. Thus,
the exec command @INFO SUBSYS will display "FTN 11" statistics.
4553 JB 15-OCT-86
Remove edit 4543.
4561 MEM 13-Jan-87
Correct check to see if /GFLOAT was specified on a machine
that does not have gfloating microcode.
ENDV11
\
SEARCH JOBDAT,MONSYM,MACSYM
SEARCH GFOPDF ;Define GFLOATING instructions
EXTERN PHAZCONTROL
EXTERN CLOSUP ;Close everything
EXTERN FNDCOM ;[2343] Find an entry in ECTAB
ENTRY NXTFIL ;Opens next source file for compiler
ENTRY OPNICL ;Open the include file for the compiler
INTERN NWBITS ;The flags of warnings have been suppressed
INTERN NWKTBC ;The number of warning message mnemonics
INTERN NWKTB ;The table of sixbit warning message mnemonics
INTERN MRP0 ;Execute-only entry
INTERN FORTRA ;Start address of FORTRA
EXTERN .HIGH. ;Start of compiler's high segment (Defined by
; a /SET switch to LINK)
EXTERN ISN ;Statement number of line being compiled
EXTERN ICLPTR ;Points to INCLUDE filespec
EXTERN CCLSW ;Contains 0 or 1, the start address offset used
; to start FORTRA
EXTERN STACK ;The stack used by BLISS
EXTERN CTIME ;The current time of day
EXTERN RTIME ;The runtime of this fork
EXTERN DEBGSW ;Holds the debug switches
EXTERN BUGOUT ;Holds BUGOUT mask for debugging the compiler
EXTERN FLAGS2 ;A flag word
EXTERN F2 ;A flag word
EXTERN BIGARY ;[2220] Size of arrays to put in PSLARGE
EXTERN BIGCONCAT ;[2251] The size of the biggest
;[2251] concatenation to allow as a
;[2251] "fixed length" or "known maximum
;[2251] length". Maximum size of non
;[2251] dynamic concatenation.
EXTERN DFCMPS ;[2343] The default psect for COMMON blocks
EXTERN ECTABL ;[2343] Max number of common blocks allowed
;[2343] to be named in /EXTEND
EXTERN ECRECL ;[2343] Length of a entry in ECTAB
EXTERN ECHSHL ;[2343] Length of hash table for list of COMMON
;[2343] named in a /EXTEND switch
EXTERN ECUSED ;[2343] Number of entries in ECTAB
EXTERN ECTAB ;[2343] Table of COMMON blks named in /EXTEND
EXTERN ECHASH ;[2343] Hash Table of COMMON blocks named in
;[2343] /EXTEND switch
EXTERN CHNLTBL ;Holds filenames and JFNs for the compiler
EXTERN SEGINCORE ;Argument to PHAZCONTROL
EXTERN LONAME ;[2310] Name of the low (data) PSECT in SIXBIT
EXTERN HINAME ;[2310] Name of the high (code) PSECT in SIXBIT
EXTERN DEFLON ;[2454] Default for LONAME
EXTERN DEFHIN ;[2454] Default for HINAME
EXTERN VMSIZE ;[2322] Size of virtual memory for this compile
SALL
; Default feature test settings
IFNDEF DEBUG,DEBUG==0 ;[2221] Enables tracing (default off)
IFNDEF FTUS,FTUS==0 ;[2221] DEC in-house features (default off)
IFNDEF FT612,FT612==0 ;[2221] Build in SIX12 debugger (default off)
; Parameters for sizes of various data structures
BUFSIZ==^D96 ;Length (words) of command line buffer
ATMBLN==^D34 ;Length (words) of atom buffer
MAXSYM==^D72 ;[2445] Maximum length is a symbolic name
SYMLEN==<MAXSYM+5>/6 ;[2445] Symbolic name length in words
ATM6SZ==SYMLEN ;[2445] Length (words) of largest SIXBIT atom
MAXCHR==^D32 ;[4530] Maximum number of characters in symbol
;[4530] Only psect names can have size MAXSYM
MAXWD==<MAXCHR+5>/6 ;[4530] Maximum number of words in symbol
SIXBCHARSPERWORD==6 ;[4530] Number of Sixbit characters per word
MAXFILES==^D20 ;Maximum number of sources files in one command
TMPLEN==200 ;Length of the PRARG block
PDLLEN==^D2200+^D6000 ;[2265] Length of PDL
;Note the addition of 600 words to PDLLEN!!! See the
;declaration of 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.
DEFBIGARY==^D10000 ;[2470] Default for /EXTEND:DATA (no value)
PSOOPS==0 ;[2343] "Bad" psect (Also defined in FIRST.BLI)
PSDATA==1 ;[2343] Data psect (Also defined in FIRST.BLI)
PSLARGE==3 ;[2343] Large psect (Also defined in FIRST.BLI)
DEFINE ECPSE2(REG) ;[2343]
< [POINT 2,1('REG),3] > ;/EXTEND:COMMON SWITCH.INI psect
DEFINE ECPSECT(REG) ;[2343]
< [POINT 2,1('REG),1] > ;/EXTEND:COMMON command line psect
TRUE==1 ;[2343] BLISS-10 Truth
TWOSEG 400000
;AC'S USED BY COMMAND SCANNER
F==0 ;Known as FLGREG by the compiler.
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
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
DEFINE TRACE(S)< ;;Does statement label tracing
IFN DEBUG,<
PUSH SREG,T1
HRROI T1,[ASCIZ \
Got to 'S
\]
PSOUT%
POP SREG,T1>
>
SUBTTL Low Segment Data Area
RELOC 0
RUNCOD: ;[1611] This code rewritten
RUNJFN: XWD .FHSLF,.-. ; 0- .-. gets JFN of file to run
EXP -1 ; 1-Throw away pages
XWD .FHSLF,0 ; 2-Of this fork starting at page zero
EXP PM%CNT+1000 ; 3-and going through to the last page
PMAP% ; 4-Throw away pages
MOVE 1,0 ; 5-Get JFN of file to run
GET% ; 6-Map its pages
RESET% ; 7-Reset the world
RUNSTO: MOVEM 15,.JBERR ;10-Store old value of .JBERR
MOVEI 1,.FHSLF ;11-This fork
MOVE 2,14 ;12-Get value of start address offset
SFRKV% ;13-Start this fork
RUNOFF: EXP .-. ;14- .-. gets start address offset
RUNERR: EXP .-. ;15- .-. gets old value of .JBERR
ICLEST: BLOCK 24 ;STORE AREA FOR INCLUDE FILE ERROR MESSAGE
APRSV1: BLOCK 1
APRSV2: BLOCK 1
APRSV3: BLOCK 1
; DEFAULT TABLE FOR INCLUDE INPUT
ICLTAB: GJ%OLD ;FLAGS,VERSION DEFAULT
XWD .NULIO,.NULIO ;NO JFN'S
0 ;DEV
0 ;DIRECTORY
0 ;FILE NAME
XWD -1,[ASCIZ \FOR\] ;EXTENSION
0 ;PROTECTION
0 ;ACCOUNT
;State block for COMND% JSYS
STATE: XWD 0,0 ;Flags,,Reparse address
XWD .PRIIN,.PRIOU ;Input JFN,,Output JFN
EXP 0 ;Pointer to Command Prompt
POINT 7,BUFF ;Pointer to command buffer
POINT 7,BUFF ;Pointer to next text to parse
EXP 5*BUFSIZ ;# of Chars unused in buffer
EXP 0 ;# of Chars unparsed in buffer
POINT 7,ATMBUF ;Pointer to atom buffer
EXP 5*ATMBLN ;# of chars in atom buffer
EXP CJFNBK ;Pointer to GTJFN% block
;Copy of the ACs returned by the COMND JSYS
CMDFLG: BLOCK 1 ;[2220] Flags in left half (AC1)
CMDDAT: BLOCK 1 ;[2220] Data obtained (AC2)
CMDUSD: BLOCK 1 ;[2220] Descriptor used (AC3)
LKAHD: BLOCK 1 ;[2220] Flag nonzero means next symbol scanned
DEFEXT: BLOCK 1 ;[2220] Pointer to table of default file
;[2220] extensions to be used by COMND% JSYS
FOLLOW: BLOCK 1 ;[2220] Follow set (used by CHKCOLON)
BUFF: BLOCK BUFSIZ ;Command buffer for COMND% JSYS
COMBUF: BLOCK MAXWD ;[4530] Buffer for long common block naem
ATMBUF: BLOCK ATMBLN ;Atom buffer for COMND% JSYS
DEFFIL: BLOCK ATMBLN ;Holds default filename for /LIST & /OBJECT
LSTTYP: BLOCK ATMBLN ;Holds user's typescript if he gives value to
;/LIST
INIFIL: BLOCK ^D19 ;Holds filename of SWITCH.INI file
CMDSOU: BLOCK 1 ;Source code,,Optional JFN of COMND% input
ERRPFX: BLOCK 1 ;Pointer to prefix of error message line
ERRTXT: BLOCK 1 ;[2415] Pointer to error text used by SEMERR
OLDSTK: BLOCK 1 ;Used to restore the stack pointer
CJFNBK: BLOCK .GJATR+1 ;Block for GTJFN%
PRAFIL: ASCIZ \/TAKE:000NFO.TMP;T
\ ;[1643] Used to read EXEC args if PRARG fails
INCFIL: BLOCK 1 ;JFN of include file
RELFIL: BLOCK 1 ;JFN of object file
LSTFIL: BLOCK 1 ;JFN of list file
CNTIDX: BLOCK 1 ;Index in FORFIL to currently open source file
FORIDX: BLOCK 1 ;Index to get last source file JFN in FORFIL
FORFIL: BLOCK MAXFILES ;JFN's of source files
JOBNUM: BLOCK 1 ;[1631] Job number
XJBFF: BLOCK 1 ;[1632] Holds .JBFF across compiles
XJBREL: BLOCK 1 ;[1632] Holds .JBREL across compiles
BATCH: BLOCK 1 ;Flag: Is this a batch job?
TDEPTH: BLOCK 1 ;Level of nesting of /TAKE: files
ECHOFLG:BLOCK 1 ;Flag: Is command to be echoed?
OPTECHO:BLOCK 1 ;Flag: Are option lines from SWITCH.INI echoed?
NOPTION:BLOCK 1 ;Flag: Has /NOOPTION been seen?
OPTION: BLOCK 10 ;Storage for option string--stores 39 chars
PERIOD: BLOCK 1 ;[2343] Flag: Has a period been seen in this
;[2343] COMMON block name? (Used by CVTCOM)
ARGBLK: BLOCK TMPLEN ;Area to hold Process Args
SIXATM: BLOCK ATM6SZ ;[2445] Hold Sixbit atoms produced by CVT76
COLON: FLDDB. (.CMTOK,CM%SDH,<POINT 7,[ASCIZ \:\]>,a ":" followed by value of the keyword) ;[2331] Modified at runtime to chain to follow set
EP.CL: FLDDB. (.CMTOK,CM%SDH,<POINT 7,[ASCIZ \:\]>,a ":" followed by name of the code psect) ;[2445] Modified at runtime to chain to follow set
;++
;
; To add a new flag word to the command scanner, you must do the following:
;
; 1. Add the name of the flag word to the EXTERN list.
;
; 2. Add an XX entry to the FLGTBL list below. The first argument
; to the XX macro is the name of the flag word being set. The
; second argument is the default value for that word.
;
; The FLGTBL macro, when it expands, will define an offset into the ONFLG
; and OFFFLG tables to be used in action routine for a switch to build up
; the value to be set in the flag work by the command scanner. When it is
; time to compile a file, the RESFLG routine will be caller, and it will do
; all the processing necessary to assign the final value to the flag word.
;
;--
DEFINE FLGTBL(LIST)< ;;[2441] Macro to expand flag word tables
NUMFLGS==0 ;;[2441] NUMFLGS is the number of flag words
DEFINE XX(ONE,TWO)< ;;[2441] Expand FLGNAM table
EXP ONE ;;[2441] Pointer to flag word to update
$'ONE==NUMFLGS ;;[2441] Symbolic offset into ONFLG/OFFFLG
NUMFLGS==NUMFLGS+1 ;;[2441] Count number of Flag words
> ;;[2441]
FLGNAM: LIST ;;[2441] Table of pointers to the flag words
DEFINE XX(ONE,TWO)< ;;[2441] Expand DEFFLG table
EXP TWO ;;[2441] Default values for flag words
> ;;[2441]
DEFFLG: LIST ;;[2441] Table of default values for flag words
> ;;[2441]
FLGTBL < ;[2441] Create this table
XX (F, RELFLG) ;Default for F switch word
XX (F2, SW.F77) ;Default for F2 switch word
XX (FLAGS2, 0) ;Default for FLAG2 switch word
XX (DEBGSW, 0) ;Default for DEBGSW switch word
XX (BUGOUT, 0) ;Default for BUGOUT switch word
XX (BIGARY, <1_^D30>-1) ;[2470] Default for BIGARY <set by /EXTEND>
XX (DFCMPS, PSDATA) ;[2343] Default for DEFCOMPSECT <set by /EXT>
XX (BIGCONCAT, ^D50000) ;[2251] Default for BIGCONCAT
> ;[2441] Create this table
; !! DO NOT SEPERATE ONFLG, OFFLG, SONFLG, SOFFFLG !!
; !! THEY MUST BE CONTIGUOUS !!
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.
; !! DO NOT SEPERATE ONHIN, ONLON, OFFHIN, OFFLON, SONHIN, !!
; !! and SONLON, SOFFHI, SOFFLON !!
; !! THEY MUST BE CONTIGUOUS !!
ONHIN: BLOCK SYMLEN+1 ;[2445] Like ONFLG, but only for HINAME
ONLON: BLOCK SYMLEN+1 ;[2445] Like ONFLG, but only for LONAME
OFFHIN: BLOCK SYMLEN+1 ;[2445] Like OFFFLG, but only for HINAME
OFFLON: BLOCK SYMLEN+1 ;[2445] Like OFFFLG, but only for LONAME
SONHIN: BLOCK SYMLEN+1 ;[2445] Like SONFLG, but only for HINAME
SONLON: BLOCK SYMLEN+1 ;[2445] Like SONFLG, but only for LONAME
SOFFHI: BLOCK SYMLEN+1 ;[2445] Like SOFFFLG, but only for HINAME
SOFFLO: BLOCK SYMLEN+1 ;[2445] Like SOFFFLG, but only for LONAME
SUBTTL Compiler Initialization
RELOC 400000
MRP0: ;Label used by PHAZCONTROL, becomes starts address
FORTRA: TDZA VREG,VREG ;Flag as normal entry
MOVEI VREG,1 ;Flag as CCL entry
MOVEM VREG,CCLSW ;Save the CCL switch
RESET%
GETNM% ;[1612] Get the name of the program
MOVE T2,T1 ;[1612] Private name is name returned by GETNM%
MOVE T1,[SIXBIT \FTN 11\] ;[4547] System name
SETSN% ;Let's tell the Monitor!
NOOP ;Failure return, we don't care!
MOVEI T1,.FHSLF ;This process's compatibility vector
SETO T2, ;Do not allow UUOs
SCVEC%
HLRZ T1,.JBSA ;Get first free low-segment start address
HRRM T1,.JBFF ;"Deallocate" core
HRRM T1,.JBREL ;"Deallocate" core
MOVE SREG,[IOWD PDLLEN,STACK] ;Set up the stack
HRRZI FREG,(SREG) ;LIFE IS BLISS
IFN FT612,< ;[2221] Are we being built for debugging?
;[2221] Yes - force the debugger to be loaded
;[2221] and called upon startup
.REQUIRE DUMP ;[2221] Dump routines
.REQUIRE DSUB ;[2221] More dump routines
.REQUIRE DSTATE ;[2221] Yet more dump routines
.REQUIRE DEXPR ;[2221] Still more dump routines
.REQUEST SIX12 ;[2221] Debugger (finally)
MOVE VREG,CCLSW ;[2221] Get back the value of the CCL switch
PUSHJ SREG,SIX36## ;[2221] ENABLE . . .
MOVEM VREG,CCLSW ;[2221] Save the CCL switch
;[2221] (Can be set by "RETURN n" in SIX12)
PUSHJ SREG,DUMPINIT## ;[2221] . . . SW/REG
> ; End of IFN FT612 ;[2221] End of SIX12 initialization code
PUSHJ SREG,APRINI ;Initialize interrupt system
SETZM ECHOFLG ;[1645] Assume that commands are not echoed
SETZM STATE+.CMFLG ;[1671] No reparse address or flags
MOVE T1,[XWD .PRIIN,.PRIOU] ;[1671] JFNs for command input, output
MOVEM T1,STATE+.CMIOJ ;[1671] Restore JFNs
MOVE T1,[POINT 7,BUFF] ;[1671] Pointer to command buffer
MOVEM T1,STATE+.CMBFP ;[1671]
MOVEM T1,STATE+.CMPTR ;[1671]
MOVX T1,5*BUFSIZ ;[1671] # Chars unused in buffer
MOVEM T1,STATE+.CMCNT ;[1671]
SETZM STATE+.CMINC ;[1671] # Chars unparsed in buffer
;**********************************************************************
;
; Test for the presence of the gfloating microcode. This code will
; turn on or off the GFMCOK flag in the default word for FLAGS2.
;
;**********************************************************************
SETZB T2,T3 ;Clear T2 & T3 so we can do a GFAD on it
SETZ T4, ;Clear T4 to assume don't have gfloating ucode
GFAD T2,T2 ;Do a typical gfloating instruction
ERJMP INTDON ;Oh, no! No gfloating microcode!
MOVX T4,GFMCOK ;Yes, we have the gfloating microcode
INTDON: IORM T4,DEFFLG+$FLAGS2 ;Set GFMCOK flag in the defaults for FLAGS2
SUBTTL Get Name of SWITCH.INI file
;**********************************************************************
;
; Get name of the user's SWITCH.INI file.
;
;**********************************************************************
;Rewritten edit 1623
SETO T1, ;Get info about this job
MOVE T2,[XWD -<.JILNO+1>,BUFF] ;-Length,,address
MOVEI T3,.JIJNO ;First thing that we are interested in
GETJI%
ERCAL UNXERR ;Failure return
MOVE T1,BUFF+.JIJNO ;[1631] Get job number
MOVEM T1,JOBNUM ;[1631] Store
MOVE T1,BUFF+.JIBAT ;Get batch flag
MOVEM T1,BATCH ;Store
HRROI T1,INIFIL ;Area to receive name of switch file
MOVE T2,BUFF+.JILNO ;Get number of logged-in directory
DIRST%
ERCAL UNXERR ;Failure return
MOVEI P1,^D11 ;Source is ten characters
MOVE P2,[POINT 7,[ASCIZ \SWITCH.INI\]] ;Source byte pointer
SETZB P3,P6 ;No second word in byte pointers
MOVEI P4,^D11 ;Destination to receive ten characters
MOVE P5,T1 ;Destination Byte pointer
EXTEND P1,[MOVSLJ ;Copy the string
0]
NOOP
SUBTTL Process Fork Argument from the EXEC
;**********************************************************************
;
; Read and process the proccess arguments set up by the EXEC. The
; EXEC sets up the process arguments when it calls FORTRA to do
; a COMPILE, EXECUTE, etc. EXEC command.
;
;**********************************************************************
SKIPN CCLSW ;Was FORTRA started at the CCL entry point?
JRST MAIN ;No--Don't try to get process arguments
MOVE T1,[XWD .PRARD,.FHSLF] ;Read arguments for this fork
MOVEI T2,ARGBLK ;Area in which to get arguments
MOVEI T3,TMPLEN ;Length of area to hold text
PRARG%
SKIPG T1,ARGBLK ;Get number of "files" in TMPCOR
JRST DSKTMP ;[1631] Get arguments from file on disk
LOOP: MOVE T2,ARGBLK(T1) ;Get displacement of file in TMPCOR
HLRZ T3,ARGBLK(T2) ;Get header of first file
CAIN T3,(SIXBIT \NFO\) ;Have we got the file we want?
JRST FOUND ;Yes--process it
SOJG T1,LOOP
JRST MAIN
FOUND: HRRZ P1,ARGBLK(T2) ;Get length (in words) of TMP file
IMULI P1,5 ;Get length (in characters) of TMP file
MOVEI P2,ARGBLK+1(T2) ;Get address of string in TMP file
HRLI P2,(POINT 7,0,-1) ;Make into a byte pointer
SL2: HRLZI T1,FRMPRA ;The command stream is the process arguments
MOVE T2,[XWD .NULIO,.NULIO] ;COMND% will not have to do I/O
HRROI T3,[ASCIZ \FORTRAN>\] ;Prompt pointer
PUSHJ SREG,CMDINI ;Init COMND% JSYS and its state block
MOVEI P3,BUFSIZ*5 ;[2262] Get length of receiving area
MOVE T1,STATE+.CMPTR ;Get byte pointer to command buffer
L2: ILDB T2,P2 ;Get a character from TMP file
IDPB T2,T1 ;Deposit in command buffer
SOJE P1,GOTSTR ;Jump if no more text in TMP file
CAIN T2,.CHLFD ;Was character linefeed?
SOJA P3,GOTSTR ;Yes--Got the command string
SOJGE P3,L2 ;If room still in command buffer, loop
HRROI T1,[ASCIZ \FTNCMD Command passed by EXEC is too long
\]
ESOUT%
JRST MAIN
GOTSTR: SETZM TDEPTH ;No take files nested here!
SUBI P3,BUFSIZ*5 ;[2262] Get the number of unparsed characters
MOVNM P3,STATE+.CMINC ;[2262] Store number of unparsed chars
PUSHJ SREG,SCAN20 ;Scan the command line
MOVE T1,P2 ;Get copy of pointer to text in TMP file
ILDB T2,T1 ;Get next character
JUMPE T2,PFAHLT ;[1611]If char is null, then got end of command
JUMPN P1,SL2 ;Continue processing if more text
PFAHLT: HALTF% ;[1611] Through processing fork arguments
JRST MAIN ;[1631] User typed "CONTINUE" ...
SUBTTL Process TMP file on DSK:
;[1631] This routine added by RVM
DSKTMP: HRLZI T1,FRMPRA ;The command stream is the process arguments
MOVE T2,[XWD .NULIO,.NULIO] ;COMND% will not have to do I/O
HRROI T3,[ASCIZ \FORTRAN>\] ;Prompt pointer
PUSHJ SREG,CMDINI ;Init COMND% JSYS and its state block
MOVE T1,JOBNUM ;Get job number
IDIVI T1,^D100 ;Get hundreds digit
MOVE T3,T1 ;Store hundreds digit
MOVE T1,T2 ;Get remainder of job number
IDIVI T1,^D10 ;Get tens and ones digits
LSH T3,7 ;Make room for tens digit
ADD T3,T1 ;Add in tens digit
LSH T3,7 ;Make room for ones digit
ADD T3,T2 ;Add in ones digit
LSH T3,^D8 ;Position in order to form filename
ADDM T3,PRAFIL+1 ;Form filename of TMP file
MOVX T1,GJ%SHT+GJ%OLD+GJ%TMP ;[1643] An existing TMP file
MOVE T2,[POINT 7,PRAFIL+1,6] ;[1643] Filename is in PRAFIL
GTJFN% ;[1643] Get a JFN to see if file exists
ERJMP MAIN ;[1643] Can't read file--get commands from tty
MOVE T1,[XWD PRAFIL,BUFF] ;From PRAFIL to BUFF
BLT T1,BUFF+4 ;[1643] Move the command string+null byte
SETZM TDEPTH ;No take files nested here (yet)!
MOVEI T1,^D20 ;[1643] Number of characters in command
MOVEM T1,STATE+.CMINC ;Store number of unparsed chars in state block
PUSHJ SREG,SCAN20 ;Scan the command line
MOVX T1,.FHSLF+CZ%NIF+CZ%ABT ;Abort I/O for this process
CLZFF% ;Close open files and release all JFNs
MOVX T1,GJ%SHT+GJ%OLD+GJ%TMP ;[1643] Get a JFN on an old TMP file
MOVE T2,[POINT 7,PRAFIL+1,6] ;Filename pointer
GTJFN%
ERCAL UNXERR ;Unexpected error
HRRZ T1,T1 ;Zero left half of T1
DELF% ;Delete the TMP file
ERCAL UNXERR ;Unexpected error
HALTF% ;Done
SUBTTL Main Command Loop of the Compiler
;**********************************************************************
;
; This is the main command loop of the compiler. It is responsable
; for calling SCAN20 or SCAN10 to process a command line input from
; the terminal.
;
;**********************************************************************
MAIN:
SKIPE BATCH ;Are we running under batch?
JRST GOTBAT ;Yes--Might have to do -10 compatability stuff
NOTBAT: MOVX T1,.FHSLF+CZ%NIF+CZ%ABT ;[1623] Abort I/O for this process
CLZFF% ;[1623] Close open files and release all JFNs
SETZM TDEPTH ;No take files are nested here!
HRLZI T1,FRMTTY ;COMND% input comes from terminal
MOVE T2,[XWD .PRIIN,.PRIOU] ;Input from terminal,,ouput to terminal
HRROI T3,[ASCIZ \FORTRAN>\] ;Prompt pointer
PUSHJ SREG,CMDINI ;Init COMND% JSYS and its state block
PUSHJ SREG,SCAN20 ;Scan a TOPS-20 command line
JRST NOTBAT
GOTBAT: MOVX T1,.FHSLF+CZ%NIF+CZ%ABT ;[1623] Abort I/O for this process
CLZFF% ;[1623] Close open files and release all JFNs
MOVEI T1,"*" ;The batch prompt
PBOUT%
SETZM TDEPTH ;No take files are nested here!
MOVEI T1,BUFSIZ*5 ;[2262] Get size of buffer
MOVEM T1,STATE+.CMCNT ;[2262] Store number of chars free in buffer
SETZM STATE+.CMINC ;[2262] No characters left unparsed
MOVE T2,[POINT 7,BUFF] ;[2262] Point to the COMND% JSYS buffer
MOVEM T2,STATE+.CMPTR ;[1603] Disable CONTROL/H feature under batch
SETZ P1, ;No charaters read Yet
BATLP: PBIN% ;Get a character
AOJ P1, ;Got another character
CAILE P1,BUFSIZ*5 ;Have we exceeded the size of the buffer?
JRST CMDOVL ;Yes--Buffer overflowed!
IDPB T1,T2 ;Store character in COMND%'s buffer
;[2014]
CAIN T1,"=" ;[2014] Is this character an equal sign?
JRST TOPS10 ;[2014] Yes--Got a TOPS-10 command
CAIE T1,"+" ;Is this character an plus sign?
CAIN T1,"?" ;Is this character a question mark?
JRST TOPS20 ;Yes--Got a TOPS-20 command
CAIE T1,.CHCNF ;Is this character a CONTROL/F?
CAIN T1,.CHESC ;Is this character an escape?
JRST TOPS20 ;Yes--Got a TOPS-20 command
CAIE T1,.CHCNV ;Is this character a CONTROL/V?
CAIN T1,.CHLFD ;Is this character a linefeed?
JRST TOPS20 ;Yes--Got a TOPS-20 command
CAIE T1,.CHFFD ;Is this character a form feed?
JRST BATLP ;No--Go get another character
TOPS20: HRLZI T1,FRMTTY ;COMND% input comes from terminal
MOVE T2,[XWD .PRIIN,.NULIO] ;Input from terminal,,ouput to nowhere
HRROI T3,[ASCIZ \FORTRAN>\] ;Prompt pointer
PUSHJ SREG,CMDINI ;Init COMND% JSYS and its state block
MOVEM P1,STATE+.CMINC ;Store number of unparsed characters
PUSHJ SREG,SCAN20 ;Scan a TOPS-20 command line
JRST GOTBAT
TOPS10: MOVSI T1,FRMTEN ;COMND% input processed under -10 compatibility
MOVE T2,[XWD .PRIIN,.NULIO] ;Input from terminal,,ouput to nowhere
HRROI T3,[ASCIZ \*\] ;Prompt pointer
PUSHJ SREG,CMDINI ;Init COMND% JSYS and its state block
MOVEM P1,STATE+.CMINC ;Store number of unparsed characters
PUSHJ SREG,SCAN10 ;Scan a TOPS-10 command line
JRST GOTBAT
CMDOVL: HRROI T1,[ASCIZ \FTNCMD Command too big for internal buffer
\]
ESOUT%
JRST GOTBAT
SUBTTL UNXERR -- Unexpected JSYS error
;************************************************************************
; This rouine is used when an unexpected JSYS error occurs
; Added by edit 1623.
;************************************************************************
UNXERR: HRROI T1,[ASCIZ \FTNCMD Unexpected JSYS error at PC \]
ESOUT%
MOVEI T1,.PRIOU ;Output to primary output stream
HRRZ T2,(SREG) ;Get the return address from the PC
SOJ T2, ;Back the PC over the call
MOVX T3,NO%ZRO+FLD(6,NO%COL)+FLD(^D8,NO%RDX) ;6 col. octal #
NOUT% ;Output number
NOOP ;Pretty bad if this fails
HRROI T1,[ASCIZ \
\]
PSOUT%
HALTF% ;Halt this fork
POPJ SREG, ;Brave person typed "CONTINUE"--so return
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 FORFIL of source file to open
CAMLE T4,FORIDX ;Have all the files been opened?
POPJ SREG, ;Yes--Take failure return
PUSH SREG,P1 ;Save P1
PUSH SREG,P2 ;Save P2
MOVE P1,FORFIL(T4) ;Get JFN of list file
MOVE T1,P1 ;Get JFN of list file
DVCHR% ;Get characteristics of source file
LDB T1,[POINTR(T1,DV%TYP)] ;Get device type
MOVX T3,TTYINP ;Get bit that indicates TTY input
CAIE T1,.DVTTY ;Is it a terminal?
JRST NOTTTY ;No--Don't need to do anything
IORM T3,FLAGS2 ;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: ANDCAM T3,FLAGS2 ;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 ;[1632] Restore value of .JBFF
MOVEM T1,.JBFF ;[1632]
MOVE T1,XJBREL ;[1632] Restore value of .JBREL
MOVEM T1,.JBREL ;[1632]
JRST MONERR]
MOVEI P2,CHNLTBL+^D20 ;Get address of the source file CHNLTBL entry
PUSHJ SREG,LDCHNL ;Load CHNLTBL entry of object file
TXZ F,EOCS ;Clear end of command string flag
POP SREG,P2 ;Restore P2
POP SREG,P1 ;Restore P1
AOS (SREG)
POPJ SREG, ;Take success return
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 ;[1600] OWN FORK
CIS% ;[1600] CLEAR INTERUPT SYSTEM
MOVE T2, [LEVTAB,,CHNTAB] ;[1600] ADDR OF LEVEL TAB & CHAN TAB
SIR% ;[1600] SET INTERUPT ADDRESSES
EIR% ;[1600] ENABLE INTERUPT SYSTEM
MOVE T2, .JBREL ;[1600] END OF CORE (REFERENCES PG 0)
ORI T2, 777 ;[1612] END OF PAGE-IFY
MOVEI T3, 1777 ;[1600] START AT END OF PAGE 1
APR.1: CAMLE T3, T2 ;[1612] DONE YET?
JRST APR.2 ;[1612] YES, ACTIVATE INTERUPTS
SKIP (T3) ;[1612] NO, REFERENCE THIS PAGE
ADDI T3, 1000 ;[1612] BUMP UP 1 PAGE
JRST APR.1
APR.2: MOVE T2,[CHNMSK] ;[1600] ARM PROPER CHANNELS
AIC% ;[1600] ENABLE INTERUPT CHANNELS
POPJ SREG, ;[1600]
; [1600] Blocks for TOPS-20 interupt system
; [1600] Note: all interupts happen at level 1
LEVTAB: LEV1PC ;[1600] ADDR OF LEVEL 1 PC
LEV2PC ;[1600] ADDR OF LEVEL 2 PC
LEV3PC ;[1600] ADDR OF LEVEL 3 PC
RELOC ;[1600] TO THE LOWSEG
LEV1PC: BLOCK 1 ;[1600] LEVEL 1 PC
LEV2PC: BLOCK 1 ;[1600] LEVEL 2 PC
LEV3PC: BLOCK 1 ;[1600] LEVEL 3 PC
RELOC ;[1600] BACK TO PURE STORAGE
CHNMSK==1B<.ICPOV>!1B<.ICIRD>!1B<.ICIWR>!1B<.ICNXP> ;[1600] CHANNEL MASK
CHNTAB: PHASE 0 ;[1600] *** BEWARE! ***
;[1600] The value of "." is now the current offset into the table
;[1600] instead of .-CHNTAB so you are allways <n>-. words away from
;[1600] entry <n> instead of <n>-<.-CHNTAB>
BLOCK .ICPOV-. ;[1600] (0-8)
1,,POVTRP ;[1600] (9) PDL OVERFLOW
BLOCK .ICIRD-. ;[1600] (10-15)
1,,IRDTRP ;[1600] (11) ILL MEM READ
1,,IWRTRP ;[1600] (12) ILL MEM WRITE
BLOCK .ICNXP-. ;[1600] (13-21)
1,,NXPTRP ;[1600] (22) NON-EXISTENT PAGE
BLOCK ^D35-. ;[1600] (23-35)
DEPHASE ;[1600] *** END OF PHASE 0 ***
SUBTTL CORE UUO Simulation Routines
; NEW [1600] /PLB
; Simulate CORE UUO for Twenex
CORUUO::
PUSH SREG, T1
PUSH SREG, T2
MOVEI T1, .HIGH. ;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 OLD CORE
SETZM (T1) ;ZERO FIRST WORD
HRL T1, T1 ;PREPARE FOR BLT
AOJ T1, ;[1705] BUMP RIGHT HALF FOR SMEAR
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,
SUBTTL Misc. Error Utility Routines
; 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 ;[1612] STORE T3
SOS T1,0(P) ;WHERE WERE WE CALLED FROM
HRRZM T1,.JBTPC ;STORE ADDRESS
HRROI T2,[ASCIZ \?FTNUCE User Core Exceeded\] ;LOCATE MESSAGE
JRST APRTR4 ;FINISH MESSAGE
NXPTRP: DMOVEM T1, APRSV1 ;[1600] SAVE REGS
MOVEM T3, APRSV3 ;[1600] T1, T2 & T3
MOVEI T1, .FHSLF ;[1600] US
GTRPW% ;[1600] GET TRAP WORD
JUMPE T1, NXP.1 ;[1600] NO ERROR ?
MOVE T2, .JBREL ;[1600] HIGHEST ALLOWED LOCN
CAIGE T2, (T1) ;[1600] ABOVE TOP ?
JRST NXP.1 ;[1600] YES, INTERNAL ERROR TIME
DMOVE T1, APRSV1 ;[1600] GET REGS BACK
DEBRK% ;[1600] RETURN FROM TRAP
;[1600] FALL THRU ON ERROR
NXP.1: HRROI T2, [ASCIZ \Illegal Memory Reference\] ;[1600] GENERIC NXM
TLNE T1, (PF%WRT) ;[1600] PAGE FAIL ON WRITE?
HRROI T2, [ASCIZ \Non-existent memory write\]
TRNA
IRDTRP: HRROI T2, [ASCIZ \Illegal memory read\]
TRNA
IWRTRP: HRROI T2, [ASCIZ \Illegal memory write\]
TRNA
POVTRP: HRROI T2,[ASCIZ \Stack exhausted\] ;PDL OVERFLOW
HRROI T1,[ASCIZ \
?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%
JFCL ;OVERFLOW?
SKIPN GETSBL##+1 ;IN A PHASE?
JRST APRTR2
HRROI T1,[ASCIZ \ in Phase \]
PSOUT%
MOVE T2,[POINT 6,GETSBL##+1] ;TYPE SEGMENT NAME
APRTR3: ILDB T1,T2 ;LOAD BYTE
MOVEI T1," "(T1) ;TO ASCII
PBOUT% ;[1600] TYPE BYTE
TLNE T2,770000 ;TYPE 6 CHARACTERS
JRST APRTR3
APRTR2: HRROI T1,[ASCIZ \
?while processing statement \]
PSOUT%
MOVEI T1,.PRIOU
MOVE T2,ISN
MOVE T3,[NO%OOV!NO%LFL!NO%ZRO!FLD(5,NO%COL)!^D10] ;LPAD W/ ZERO , 5 DIGITS
NOUT%
JFCL
DMOVE T1,APRSV1 ;[1612] RESTORE REGS
MOVE T3,APRSV3 ;[1612] FOR CRASH
HALTF%
JRST .-1
SUBTTL OPNICL -- Open the INCLUDE File for the Compiler
;SUBROUTINE TO OPEN INCLUDE FILES
;CHECK TO SEE THAT THEY ARE DISK
;CALL WITH
; ICLPTR = ASCIII FILE SPEC POINTER
; PUSHJ SREG,OPNICL
; RETURN HERE
;[2447] ; VREG = 0,,JFN - OK
; OR
; VREG = ASCII ERROR STRING MESSAGE POINTER
OPNICL::
PUSH SREG,T1
PUSH SREG,T2
PUSH SREG,T3
HRRZI T1,ICLTAB ;LONG GTJFN% INCLUDE FILE TABLE
MOVE T2,ICLPTR ;SPEC POINTER
GTJFN%
JRST ICLNUL ;TRY WITHOUT DEFAULT "FOR"
NULX: HRRZM T1,VREG ;[2447] SAVE JFN AS RETURN VALUE
MOVEM T2,ICLPTR ;SAVE POINTER TO LOOK FOR SWITCHES
;CHECK FOR DSK:
HRRZ T1,T1 ;ZERO LEFT
DVCHR%
LDB T1,[POINTR(T1,DV%TYP)] ;Get device type
CAIE T1,.DVDSK ;Is it a disk?
JRST NOTDSK ;NO
MOVE T1,VREG ;[2447] GET JFN AGAIN
MOVX T2,OF%RD ;Read, ASCII, 36 bit bytes
OPENF%
JRST ICLERR ;PROBLEMS
ICLRET: POP SREG,T3
POP SREG,T2
POP SREG,T1
POPJ SREG,
;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" ;[2447]
ICLERR:
MOVE T1,[POINT 7,ICLEST] ;MESSAGE STORE AREA
HRLOI T2,.FHSLF ;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,[ASCIZ \Unknown file error\]] ;UNKNOWN ERROR
JRST ICLRET
SUBTTL Misc. Utility Routines
;SUBROUTINE TO PSOUT% A STRING FROM BLISS
; [1563] /PLB
TTYSTR::
PUSH SREG,T1 ;SAVE AC 1
HRRO T1,-2(P) ;GET -1,,ADDR
PSOUT% ;OUTPUT
POP SREG,T1 ;RESTORE
POPJ SREG,
;SUBROUTINE TO SIMULATE AN EXIT UUO
; [1563] /PLB
EXITUUO::
PUSH SREG,T1 ;SAVE AC 1
HRROI T1, [ASCIZ \
Exit\] ;BE LIKE TOP-10 (ALMOST)
PSOUT% ;STUFF IT
POP SREG,T1 ;RESTORE
HALTF%
JRST .-1
SUBTTL Initialize the Flag Areas
INIT:
SETZM ONFLG ;Clear first word of flags
MOVE T1,[XWD ONFLG,ONFLG+1] ;Clear "must be ON or OFF" flags
BLT T1,ONFLG+2*NUMFLGS-1
SETZM ONHIN ;[2445] Clear first word psect names
MOVE T1,[XWD ONHIN,ONHIN+1] ;[2445] Want to clear rest of blocks
BLT T1,ONHIN+4*<SYMLEN+1>-1
SETZM NWON ;Clear first word of nowarn bits
MOVE T1,[XWD NWON,NWON+1] ;Clear nowarn "must be ON or OFF" bits
BLT T1,NWON+2*NWWDCT-1
POPJ SREG,
SUBTTL RESFLG -- Resolves the SWITCH.INI and Command Line Flags
;++
; FUNCTIONAL DESCRIPTION:
;
; This routine resolves the flags read during SWITCH.INI
; processing and the flags read during normal command line
; processing, and assigns the result to the various flag words
; used by the compiler.
;
; CALLING SEQUENCE:
;
; PUSHJ SREG,RESFLG
;
; INPUT PARAMETERS:
;
; None.
;
; IMPLICIT INPUTS:
;
; NUMFLGS The number of flag words
; ONFLG The flags turned on during SWITCH.INI processing
; OFFFLG The flags turned off during SWITCH.INI processing
; SONFLG The flags turned on during command line processing
; SOFFFLG The flags turned off during command line processing
; DEFFLG The table of default values for the flag words
; FLGNAM The table of pointers to the flag words
; ONHIN The code psect name set during SWITCH.INI processing
; OFFHIN The code psect name set during SWITCH.INI processing
; SONHIN The code psect name set during command line processing
; SOFFHI The code psect name set during command line processing
; DEFHIN The default name of the code psect
; ONLON The data psect name set during SWITCH.INI processing
; OFFLON The data psect name set during SWITCH.INI processing
; SONLON The data psect name set during command line processing
; SOFFLO The data psect name set during command line processing
; DEFLON The default name of the data psect
; ECTAB The table of COMMON blocks named during /EXTEND
; NWON The no warning bits set during SWITCH.INI processing
; SNWOFF The no warning bits cleared during command line proc.
; SNWON The no warning bits set during command line processing
;
; OUTPUT PARAMETERS:
;
; None.
;
; IMPLICIT OUTPUTS:
;
; HINAME The name of the code psect
; LONAME The name of the data psect
; ECTAB The table of COMMON blocks named during /EXTEND
; NWBITS The /NOWARN flags
;
; And, the flag words pointed to by FLGNAM.
;
; FUNCTION VALUE:
;
; None.
;
; SIDE EFFECTS:
;
; None.
;
;--
;[2441] New Routine
; Process normal flags
RESFLG: MOVEI T2,NUMFLGS-1 ;Get the highest index into ONFLG/OFFLG
GFLOOP: MOVE T1,DEFFLG(T2) ;Get the default value of switch word
ANDCM T1,OFFFLG(T2) ;Turn off flags that must be off
IOR T1,ONFLG(T2) ;Turn on flags that must be on
ANDCM T1,SOFFLG(T2) ;Turn off flags that must be off
IOR T1,SONFLG(T2) ;Turn on flags that must be on
MOVEM T1,@FLGNAM(T2) ;Store flag word
SOJGE T2,GFLOOP ;Process all flag words
; Process HINAME
MOVEI T2,SYMLEN ;Get the highest index into ONHIN/OFFHIN
HINL: MOVE T1,DEFHIN(T2) ;Get the default value of switch word
ANDCM T1,OFFHIN(T2) ;Turn off bits that must be off
IOR T1,ONHIN(T2) ;Turn on bits that must be on
ANDCM T1,SOFFHI(T2) ;Turn off bits that must be off
IOR T1,SONHIN(T2) ;Turn on bits that must be on
MOVEM T1,HINAME(T2) ;Store word
SOJGE T2,HINL ;Process all words
; Process LONAME
MOVEI T2,SYMLEN ;Get the highest index into ONLON/OFFLON
LONL: MOVE T1,DEFLON(T2) ;Get the default value of switch word
ANDCM T1,OFFLON(T2) ;Turn off bits that must be off
IOR T1,ONLON(T2) ;Turn on bits that must be on
ANDCM T1,SOFFLO(T2) ;Turn off bits that must be off
IOR T1,SONLON(T2) ;Turn on bits that must be on
MOVEM T1,LONAME(T2) ;Store word
SOJGE T2,LONL ;Process all words
;Make sure that the ECPSECT fields in ECTAB are set correctly. The
;rest of the compiler uses ECPSECT as the psect that the COMMON
;block should be allocated to. But, the command scanner (up until
;this point) uses ECPSECT to store the psect set for the common
;block during "normal" command line processing and ECPSE2 to store
;the psect set for the common block during SWITCH.INI processing.
;So that the rest of the compiler can use ECPSECT as the psect of
;the common block, the value store in ECPSE2 must be moved into
;ECPSECT iff ECPSECT has not been set. (Remember, a value set
;during command line scanning overrules a value set during SWITCH.INI
;scanning.)
MOVE T1,ECUSED ;[2343] Get number of entries in ECTAB
MOVEI VREG,ECTAB ;[2343] Get pointer to table
ECMERG: LDB T2,ECPSECT(VREG);[2343] Get psect of this entry
CAIE T2,PSOOPS ;[2343] Is field PSOOPS?
JRST ECCONT ;[2343] No--Go to end of loop
LDB T2,ECPSE2(VREG) ;[2343] Get psect set by SWITCH.INI
DPB T2,ECPSECT(VREG);[2343] Move the value into the "real" psect
;[2343] field
ECCONT: ADDI VREG,ECRECL ;[2343] Point VREG at next entry in ECTAB
SOJG T1,ECMERG ;[2343] Process rest of ECTAB
;Note that since there is no default mechanism for the
;nowarning bits, and that all the bits are by default
;zero, there is no need to turn off any bits that were
;explicitly turned off by SWITCH.INI.
MOVEI T2,NWWDCT-1 ;Get maximum index into nowarn tables
MRGNW: MOVE T1,NWON(T2) ;Turn on flags that must be on
ANDCM T1,SNWOFF(T2) ;Turn off flags that must be off
IOR T1,SNWON(T2) ;Turn on flags that must be on
MOVEM T1,NWBITS(T2) ;Store nowarning bits
SOJGE T2,MRGNW ;If more nowarn bits, then merge flags
POPJ SREG,
SUBTTL DOCOMPILE -- Call the FORTRAN Compiler
DOCOMPILE:
PUSH SREG,P1 ;Save old value of P1
PUSH SREG,P2 ;Save old value of P2
PUSH SREG,P3 ;[2465] Save P3 Smashed
PUSH SREG,P4 ;[2465] Save P4 By
PUSH SREG,P5 ;[2465] Save P5 PHAZCONTROL
PUSH SREG,P6 ;[2465] Save P6
MOVE T1,[XWD ONFLG,SONFLG] ;Move command line flags to save area
BLT T1,SONFLG+2*NUMFLGS-1 ;Move flags
MOVE T1,[XWD ONHIN,SONHIN] ;[2445] Move psect names to save area
BLT T1,SONHIN+4*<SYMLEN+1>-1 ;[2445] Save names
MOVE T1,[XWD NWON,SNWON] ;Move command line nowarn bits to save area
BLT T1,SNWON+2*NWWDCT-1 ;Move bits
PUSHJ SREG,INIT ;Zero flag areas
PUSHJ SREG,SCANSW ;Get switches for SWITCH.INI
PUSHJ SREG,RESFLG ;[2441] Resolve the flag values
;[2322] Set the size of virtual memory depending on whether /EXTEND
;[2322] is given.
MOVE T1,F2 ;[2322] Copy global flag to register
HRLZI T2,1 ;[2322] assume /NOEXTEND, 1,,0
TXNE T1,SW.EXT ;[2322] Test if /EXTEND was given
MOVX T2,<40,,0> ;[2322] /EXTEND, load 40,,0
MOVEM T2,VMSIZE ;[2322] Save the size away!
;The following table is used by the compiler to hold
;the names and JFNs of active files. Let's clear it
;out for now.
SETZM CHNLTBL ;Zap first word
MOVE T1,[XWD CHNLTBL,CHNLTBL+1] ;Set up for BLT
BLT T1,CHNLTBL+^D40-1 ;Zap the table
MOVE T1,F2 ;[4561] Copy global flag to register
TXNN T1,SW.GFL ;[4561]Did the user specify /GFLOATING?
JRST GETOBJ ;No--Everything is OK
MOVE T1,FLAGS2 ;Get flag word
TXNE T1,GFMCOK ;Does the machine have gfloating microcode?
JRST GETOBJ ;Yes--Everything is OK
HRROI T1,[ASCIZ \FTNGFL /GFLOATING requires GFLOATING microcode.
\]
ESOUT% ;Give error message
JRST RET.ERR ;Take error return
GETOBJ: TXNE F,SW.OCS ;Is /SYNTAX specified?
TXZA F,RELFLG ;Yes--Turn off /OBJECT flag
TXNN F,RELFLG ;Is a object file required?
JRST RELOBJ ;No--See if an object file JFN must be released
SKIPL T1,RELFIL ;Do we have an object file JFN?
JRST OPNOBJ ;Yes--Now ready to open file
SETZM CJFNBK ;Zero first word of GTJFN block
MOVE T1,[XWD CJFNBK,CJFNBK+1] ;Source,,destination
BLT T1,CJFNBK+.GJATR ;Zero GTJFN block
MOVX T1,GJ%FOU
MOVEM T1,CJFNBK+.GJGEN ;Set default flags
MOVE T1,[XWD .NULIO,.NULIO] ;Do no I/O
MOVEM T1,CJFNBK+.GJSRC ;Set up I/O JFNs for GTJFN
HRROI T1,[ASCIZ \DSK\]
MOVEM T1,CJFNBK+.GJDEV ;Set default device
HRROI T1,[ASCIZ \REL\]
MOVEM T1,CJFNBK+.GJEXT ;Set default extension
HRRZI T1,CJFNBK ;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,RELFIL ;Store JFN of object file
OPNOBJ: MOVX T2,OF%WR ;Open file for writing, ASCII 36 bit bytes
OPENF%
ERJMP MONERR ;Problems
MOVE P1,RELFIL ;Get the object file JFN
MOVEI P2,CHNLTBL+^D0 ;Get address of the object file CHNLTBL entry
PUSHJ SREG,LDCHNL ;Load CHNLTBL entry of object file
JRST GETLST
RELOBJ: SKIPGE T1,RELFIL ;Get JFN of object file
JRST GETLST ;No JFN of object file
RLJFN% ;Release JFN
ERJMP MONERR
SETOM RELFIL ;Mark JFN as released
GETLST: TXNN F,SW.CRF ;Is cref specified?
TXNN F,LSTFLG ;Is any list file specified?
SKIPGE T1,LSTFIL ;Get JFN of list file
JRST GETL2 ;No JFN for list file
RLJFN% ;Release JFN
ERJMP MONERR
SETOM LSTFIL ;Mark list file as having no JFN
GETL2: SKIPN BUGOUT ;[2242] Has /BUGOUT been given?
TXNE F,SW.CRF!SW.MAP!SW.MAC!SW.EXP ;Are any flags set that imply /LIST?
TXO F,LSTFLG ;Yes--Make sure list flag is set
TXNN F,LSTFLG ;Is list flag set?
JRST LDSOU ;No--Don't have to get a list file JFN
SKIPL T1,LSTFIL ;Do we have an listing file JFN?
JRST OPNLST ;Yes--Now ready to open list file
SETZM CJFNBK ;Zero first word of GTJFN block
MOVE T1,[XWD CJFNBK,CJFNBK+1] ;Source,,destination
BLT T1,CJFNBK+.GJATR ;Zero GTJFN block
MOVX T1,GJ%FOU
MOVEM T1,CJFNBK+.GJGEN ;Set default flags
MOVE T1,[XWD .NULIO,.NULIO] ;Do no I/O
MOVEM T1,CJFNBK+.GJSRC ;Set up I/O JFNs for GTJFN
HRROI T1,[ASCIZ \DSK\]
MOVEM T1,CJFNBK+.GJDEV ;Set default device
TXNE F,SW.CRF ;Has /CREF been specified?
SKIPA T1,[POINT 7,[ASCIZ \CRF\]] ;Yes--default extension is .CRF
HRROI T1,[ASCIZ \LST\] ;No--default extension is .LST
MOVEM T1,CJFNBK+.GJEXT ;Set default extension
HRRZI T1,CJFNBK ;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,LSTFIL ;Store list file JFN
OPNLST: MOVX T2,FLD(7,OF%BSZ)+OF%WR ;Open file for writing, 7 bit bytes
OPENF%
ERJMP MONERR ;Problems
MOVE P1,LSTFIL ;Get the list file JFN
MOVEI P2,CHNLTBL+^D10 ;Get address of the list file CHNLTBL entry
PUSHJ SREG,LDCHNL ;Load CHNLTBL entry of list file
MOVE T1,LSTFIL ;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 LDSOU ;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 F,TTYDEV ;Yes--Set the list file goes to our TTY flag
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 FORTRAN entered at CCL start address
JRST CALLFTN ;No--Load list file entry in CHNLTBL
HRROI T1,[ASCIZ \FORTRAN: \] ;[1603] No square bracket
PSOUT% ;Tell the user who we are
HRROI T1,ATMBUF
PSOUT% ;Print name of first source file
HRROI T1,[ASCIZ \
\] ;[1603] No square bracket
PSOUT%
CALLFTN:
MOVEI T1,.FHSLF ;Get runtime for this fork
RUNTM% ;Get runtime and current time
MOVEM T1,RTIME ;Save runtime
MOVEM T3,CTIME ;Save current time
MOVE T1,.JBFF ;[1632] Save value of .JBFF across compile
MOVEM T1,XJBFF ;[1632]
MOVE T1,.JBREL ;[1632] Save value of .JBREL across compile
MOVEM T1,XJBREL ;[1632]
SETZM SEGINCORE ;Argument to PHASE CONTROL
PUSHJ SREG,PHAZCONTROL ;Get the next phase
PUSHJ SREG,CLOSUP ;Close all files
MOVE T1,XJBFF ;[1632] Restore value of .JBFF
MOVEM T1,.JBFF ;[1632]
MOVE T1,XJBREL ;[1632] Restore value of .JBREL
MOVEM T1,.JBREL ;[1632]
MOVE T1,FLAGS2 ;Get word of flags
TXNE T1,SW.ABO ;Was /ABORT specified?
TXNN F,SW.ERR ;Was there fatal errors during compile?
JRST RETCOM ;No--Return from this compilation
HRROI T1,[ASCIZ \[Exit due to /ABORT]
\]
PSOUT%
HALTF%
RETCOM: POP SREG,P6 ;[2465] Restore P6 Restore
POP SREG,P5 ;[2465] Restore P5 Regs
POP SREG,P4 ;[2465] Restore P4 Used by
POP SREG,P3 ;[2465] Restore P3 PHAZCONTROL
POP SREG,P2 ;Restore P2
POP SREG,P1 ;Restore P1
POPJ SREG, ;Return
SUBTTL LDCHNL -- Set up an Entry in CHNLTBL
;Set up an entry in CHNLTBL for the compiler.
;Arguments:
; P1 JFN
; P2 Pointer to CHNLTBL entry for this file
;Note that when this file returns, the name of the file in
;the atom buffer.
CHNJFN==0 ;Offset in a CHNLTBL entry for JFN
CHNDEV==1 ;Offset in a CHNLTBL entry for device
CHNNAM==6 ;Offset in a CHNLTBL entry for name
CHNEXT==7 ;Offset in a CHNLTBL entry for extension
LDCHNL: HRRM P1,CHNJFN(P2) ;Store JFN
HRROI T1,ATMBUF ;Get string in atom buffer
MOVE T2,P1 ;Get the JFN
MOVX T3,FLD(.JSAOF,JS%DEV) ;We want the device field
JFNS% ;Get the device name
PUSHJ SREG,CVT76 ;Convert atom buffer to sixbit
MOVE VREG,SIXATM ;[2445] Get the SIXBIT
MOVEM VREG,CHNDEV(P2) ;Store device in channel table
HRROI T1,ATMBUF ;Get string in atom buffer
MOVE T2,P1 ;Get the JFN
MOVX T3,FLD(.JSAOF,JS%TYP) ;We want the extension field
JFNS% ;Get the extension
PUSHJ SREG,CVT76 ;Convert atom buffer to sixbit
MOVE VREG,SIXATM ;[2445] Get the SIXBIT
HLLM VREG,CHNEXT(P2) ;Store in channel table
HRROI T1,ATMBUF ;Get string in atom buffer
MOVE T2,P1 ;Get the JFN
MOVX T3,FLD(.JSAOF,JS%NAM) ;We want the name field
JFNS% ;Get the name
PUSHJ SREG,CVT76 ;Convert atom buffer to sixbit
MOVE VREG,SIXATM ;[2445] Get the SIXBIT
MOVEM VREG,CHNNAM(P2) ;Store in channel table
POPJ SREG, ;Return
SUBTTL CVT76 - Convert ASCII to SIXBIT
;++
; FUNCTIONAL DESCRIPTION:
;
; This routine converts the 7 bit ASCII string in the atom buffer
; to SIXBIT. The conversion stops when 6*ATM6SZ characters have
; been processed or when a null is found in the atom buffer.
;
; CALLING SEQUENCE:
;
; PUSHJ SREG,CVT76
;
; INPUT PARAMETERS:
;
; None.
;
; IMPLICIT INPUTS:
;
; ATMBUF The atom buffer.
;
; OUTPUT PARAMETERS:
;
; None.
;
; IMPLICIT OUTPUTS:
;
; SIXATM The atom buffer converted to sixbit and padded
; with nulls.
;
; FUNCTION VALUE:
;
; Number of words used in SIXATM.
;
; SIDE EFFECTS:
;
; None.
;
;--
;[2445] Routine rewritten to convert more that six characters
CVT76: SETZM SIXATM ;Clear out first word for BLT
MOVE T1,[XWD SIXATM,SIXATM+1] ;Source,,destination
BLT T1,SIXATM+ATM6SZ-1 ;Zero out block
MOVE T1,[POINT 7,ATMBUF] ;7 bit string comes from the atom buffer
MOVE T2,[POINT 6,SIXATM] ;6 bits string goes into SIXATM
MOVEI T4,6*ATM6SZ ;Get number of characters to process
C76LP: ILDB T3,T1 ;Get a seven bit character
JUMPE T3,C76RET ;Return if null encountered
CAIL T3,140 ;Is character lowercase?
SUBI T3,40 ;Yes--Make it uppercase
SUBI T3," "-' ' ;Convert 7 bit to sixbit
IDPB T3,T2 ;Store sixbit character
SOJG T4,C76LP ;Process up to 6 characters
C76RET: MOVEI VREG,6*ATM6SZ+5 ;Get ready ...
SUB VREG,T4 ; ... to find ...
IDIVI VREG,6 ; ... Number of words used in SIXATM
POPJ SREG, ;Return
SUBTTL SCAN20 -- Scan a TOPS-20 Command Line
;**********************************************************************
;
; SCAN20 -- scan and process a TOPS-20 compiler command line.
;
;**********************************************************************
SCAN20:
TRACE <SCAN20:>
PUSH SREG,P1 ;Save P1
PUSH SREG,P2 ;Save P2
PUSH SREG,P3 ;Save P3
PUSH SREG,P4 ;Save P4
PUSH SREG,P5 ;Save P5
PUSH SREG,P6 ;Save P6
PUSH SREG,STATE+.CMFLG ;Save the Reparse address of the COMND% JSYS
PUSH SREG,OLDSTK ;Save old "old stack pointer"
MOVEM SREG,OLDSTK ;Save stack pointer so we can abort
MOVEI T1,REPARSE ;Get address of code to handle a reparse
HRRM T1,STATE+.CMFLG ;Store in state block
JRST GETCOMM
REPARSE:
TRACE <REPARSE>
MOVE SREG,OLDSTK ;Restore the stack pointer
SKIPL T1,RELFIL ;Get JFN of object file (-1 means no JFN)
RLJFN% ;Release JFN
ERJMP MONERR
SKIPL T1,LSTFIL ;Get JFN of list file (-1 means no JFN)
RLJFN% ;Release JFN
ERJMP MONERR
SKIPGE T5,FORIDX ;Get index to JFN of last source file
JRST GETCOMM ;No source file JFN's
RL: MOVE T1,FORFIL(T5) ;Get JFN of next source file
RLJFN% ;Release JFN
ERJMP MONERR
SOJGE T5,RL ;Loop to release rest of source file JFN's
GETCOMM:
TRACE <GETCOMMAND>
PUSHJ SREG,INIT ;Clear flags
SETOM LSTFIL ;Clear JFN of list file
SETOM RELFIL ;Clear JFN of object file
SETOM FORIDX ;No source files have JFN's
SETZM LSTTYP ;Throw away typescript from /LIST:
SETZM OPTECHO ;Don't echo options from SWITCH.INI
SETZM NOPTION ;/NOOPTION has not been seen--read SWITCH.INI
SETZM OPTION ;No option string has been given
SETZM LKAHD ;[2220] Next field not scanned yet
SETZM ECUSED ;[2343] No entries on table of /EXT:COMMON
SETZM ECTAB ;[2343] Clear first word of /EXT:COMMON table
MOVE T1,[XWD ECTAB,ECTAB+1]
BLT T1,ECTAB+2*ECTABL-1 ;[2343] Clear rest of table
SETZM ECHASH ;[2343] Clear first word of /EXT:COM hash table
MOVE T1,[XWD ECHASH,ECHASH+1]
BLT T1,ECHASH+ECHSHL-1 ;[2343] Clear rest of table
MOVX T1,GJ%OLD!GJ%XTN
MOVEM T1,CJFNBK+.GJGEN ;Set default flags for source file
HRROI T1,[ASCIZ \DSK\]
MOVEM T1,CJFNBK+.GJDEV ;Set default device for source file
SETZM CJFNBK+.GJNAM ;Set default name for source file
MOVEI T1,FOREXT ;Setup pointer to table of default extensions
MOVEM T1,DEFEXT ;for source file
HRROI T1,[ASCIZ \FTNCMD \] ;Get pointer to prefix of error messages
MOVEM T1,ERRPFX ;Store error message prefix
MOVEI T1,STA1 ;[2220] Setup follow set for the /EXTEND
MOVEM T1,FOLLOW ;[2220] switch while in STATE1
MOVEI T2,KEYWD ;[2220] Look for a command or a filespec
PUSHJ SREG,ECMD ;[2220] Do COMND% JSYS
JRST RET.EOF ;Got end of file, so return
JRST IMPRER ;[2417] Nothing found, see if we can improve
;[2417] on the monitor error message
CAIN T3,CMFIL0 ;[2220] Was a filename found?
JRST GOTFIL ;[2220] Yes--process a compile command
CAIN T3,CMSWI0 ;[2220] Was a switch found?
JRST GOTSWI ;[2220] Yes--process a compile command
HRRZ T2,(T2) ;[2220] Get action code
JRST (T2) ;[2220] Call routine to process command
IMPRER: MOVX T1,.FHSLF ;[2417] This process's last error
GETER% ;[2417] Get last error in T2
HRRZ T2,T2 ;[2417] Throw away fork handle
CAIE T2,NPXNOM ;[2417] "Does not match switch or keyword"
JRST USRERR ;[2417] Not that error--use monitor message
HRROI T1,[ASCIZ \Does not match switch or keyword, or file not found\] ;[2417]
JRST SEMERR ;[2417] Use better error message
.EXIT:
TRACE <.EXIT>
HRROI T1,[ASCIZ \FTNCMD EXIT command must be confirmed -- \] ;[2421]
MOVEM T1,ERRPFX ;[2421] Store error message prefix
MOVEI T2,CONFIRM ;Wait for confirmation
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
HALTF% ;All done
JRST RET.OK ;[1611] Continue the compiler
.HELP: ;[1611] Routine added
TRACE <.HELP>
HRROI T1,[ASCIZ \FTNCMD HELP command must be confirmed -- \] ;[2421]
MOVEM T1,ERRPFX ;[2421] Store error message prefix
MOVEI T2,CONFIRM ;Wait for confirmation
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
MOVX T1,GJ%OLD+GJ%SHT ;Try logical HLP:
HRROI T2,[ASCIZ \HLP:FORTRA.HLP\]
GTJFN%
TRNA ;Failure return, try next source
JRST HLPOPN ;Success return, Open the file
MOVX T1,GJ%OLD+GJ%SHT+GJ%PHY ;Try physical HLP:
HRROI T2,[ASCIZ \HLP:FORTRA.HLP\]
GTJFN%
TRNA ;Failure return, try next source
JRST HLPOPN ;Success return, Open the file
MOVX T1,GJ%OLD+GJ%SHT ;Try logical SYS:
HRROI T2,[ASCIZ \SYS:FORTRA.HLP\]
GTJFN%
TRNA ;Failure return, try next source
JRST HLPOPN ;Success return, Open the file
MOVX T1,GJ%OLD+GJ%SHT+GJ%PHY ;Try physical SYS:
HRROI T2,[ASCIZ \SYS:FORTRA.HLP\]
GTJFN%
JRST HLPERR ;Failure return, Cannot open the file
HLPOPN: HRRZ T5,T1 ;Save JFN of help file
MOVX T2,FLD(7,OF%BSZ)+OF%RD ;Read the file
OPENF%
JRST HLPERR ;Failure return, tell user
HLPLP: MOVE T1,T5 ;Get JFN of help file
HRROI T2,BUFF ;Area in which to put string
MOVNI T3,BUFSIZ*5 ;Size of string buffer
SIN
ERJMP HLPEOF ;Failure, maybe EOF
SETZ T3, ;Need a zero byte
IDPB T3,T2 ;Mark end of buffer with zero byte
HRROI T1,BUFF ;Point to string in buff
PSOUT%
JRST HLPLP ;Type rest of help file
HLPEOF:
SETZ T3, ;Need a zero byte
IDPB T3,T2 ;Mark end of buffer with zero byte
HRROI T1,BUFF ;Point to string in buff
PSOUT%
MOVE T1,T5 ;Get JFN of help file
CLOSF% ;Close file
NOOP ;Not likely
JRST RET.OK ;Return to caller
HLPERR: HRROI T1,[ASCIZ \%FTNCMD Can't open help file; I'm sorry but I can't help you.
\]
PSOUT%
JRST RET.OK ;Nothing really bad occured, take normal return
;Register Usage:
; P1 JFN of file to run
; P2 Offset to be added to its start address
; P3 Program name in SIXBIT
.RUN: TRACE <.RUN>
MOVEI T2,[FLDDB. (.CMNOI,,<POINT 7,[ASCIZ \program\]>)] ;[2220]
PUSHJ SREG,CMD ;[2220] Look for guide word
JRST USRERR ;[2220] EOF return--command not completed
HRROI T1,[ASCIZ \FTNCMD Filespec required in RUN command -- \] ;[2421]
MOVEM T1,ERRPFX ;[2421] Store error message prefix
MOVX T1,GJ%OLD!GJ%XTN
MOVEM T1,CJFNBK+.GJGEN ;Set default flags
HRROI T1,[ASCIZ \SYS\]
MOVEM T1,CJFNBK+.GJDEV ;Set default device
SETZM CJFNBK+.GJNAM ;Clear default name
MOVEI T1,EXEEXT ;[2220] Get pointer to table of default
MOVEM T1,DEFEXT ;[2220] extensions for the file to be run
MOVEI T2,RUNFIL ;Look for a filename
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
MOVE P1,T2 ;Save JFN of file to run
SETZ P2, ;Assume an offset of zero
HRROI T1,[ASCIZ \FTNCMD \] ;[2421] Get pointer to error prefix
MOVEM T1,ERRPFX ;[2421] Store error message prefix
MOVEI T2,OFFSET ;Look for /OFFSET or confirmation
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
CAIN T3,CONFIRM ;Was command confirmed?
JRST DORUN ;Yes--Run the program
MOVEI P2,1 ;Assume an offset of 1
MOVEI T2,RUNNUM ;Look for a number or confirmation
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
CAIN T3,CONFIRM ;Was command confirmed?
JRST DORUN ;Yes--Run the program
MOVE P2,T2 ;Get new value of offset
MOVEI T2,CONFIRM ;Wait for confirmation
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
DORUN: JUMPL P2,BIGOFF ;Is the offset too small?
CAILE P2,1 ;Is the offset too big?
JRST BIGOFF ;Yes--Complain
;Get name of program in SIXBIT
HRROI T1,ATMBUF ;Get string in atom buffer
MOVE T2,P1 ;Get the JFN
MOVX T3,FLD(.JSAOF,JS%NAM) ;We want the name field
JFNS% ;Get the name
PUSHJ SREG,CVT76 ;Convert atom buffer to sixbit
MOVE P3,SIXATM ;[2445] Store the sixbit program name
;Get the directory of the program file if the file is on disk
MOVE T1,P1 ;Get JFN of file to run
DVCHR%
TXNN T2,DV%MDD ;Does device have multiple directories?
JRST NOTSYS ;No, not disk, so program has no system name
HRROI T1,ATMBUF ;Get string in atom buffer
MOVE T2,P1 ;Get the JFN
MOVX T3,FLD(.JSAOF,JS%DIR) ;We want the directory of file
JFNS% ;Get the directory
;Compare the directory of the program with the system's directory
; of SUBSYS. If the directories are equal, then assume that this
; program has comes from PS:<SUBSYS>.
MOVEI T1,7 ;Number of characters in ASCIZ 'SUBSYS'
MOVE T2,[POINT 7,[ASCIZ \SUBSYS\]]
MOVEI T4,7 ;May not have 7 characters, but who cares
MOVE T5,[POINT 7,ATMBUF] ;Directory of file
EXTEND T1,[CMPSN] ;Is the directory of the file SUBSYS?
SKIPA T1,P3 ;Yes--System name is name of program
NOTSYS: MOVE T1,[SIXBIT \(PRIV)\] ;System name is "(PRIV)"
MOVE T2,P3 ;Private name is name of file
SETSN% ;Tell the monitor
NOOP ;Error return is never taken
MOVEI T1,.FHSLF ;This process
SETZ T2, ;Allow UUOs
SCVEC%
HRRM P1,RUNJFN ;[1611] Store JFN of file to run
HRLZM P2,RUNOFF ;[1611] Store the start address offset
MOVE P3,.JBERR ;[1611] Get this fork's error count
MOVEM P3,RUNERR ;[1611] Store error count for run code
SKIPE .JBERR ;[1611] Is .JBERR zero?
JRST NOFIX ;[1611] Yes--Don't need to patch run code
HRLI T1,(NOOP) ;[1611] Get a No-op instruction
MOVEM T1,RUNSTO ;[1611] Don't save old value of .JBERR
NOFIX: MOVE 17,[XWD RUNCOD,0] ;[1611] Load Run code into the registers
BLT 17,15 ;[1611] Move the code into the registers
JRST 4 ;[1611] .JBERR was zero, just do the run code
BIGOFF: HRROI T1,[ASCIZ \Value of /OFFSET: can not be greater than 1\] ;[2415]
JRST SEMERR ;[2415] Give error message
RUNFIL:
FLDDB. (.CMFIL,CM%SDH,,<filespec of .EXE file to run>)
RUNNUM:
FLDDB. (.CMNUM,CM%SDH,^D8,<offset from start address, must be 0 or 1>,1,CONFIRM)
;Register usage:
; P1 JFN of indirect command file
; P2 Past value of echo switch
.TAKE:
TRACE <.TAKE>
MOVEI T2,[FLDDB. (.CMNOI,,<POINT 7,[ASCIZ \commands from\]>)] ;[2220]
PUSHJ SREG,CMD ;[2220] Look for guide word
JRST USRERR ;[2220] EOF return--command not completed
HRROI T1,[ASCIZ \FTNCMD Filespec required in TAKE command -- \] ;[2421]
MOVEM T1,ERRPFX ;[2421] Store error message prefix
MOVX T1,GJ%OLD+GJ%XTN
MOVEM T1,CJFNBK+.GJGEN ;Set default flags
HRROI T1,[ASCIZ \DSK\]
MOVEM T1,CJFNBK+.GJDEV ;Set default device
SETZ CJFNBK+.GJNAM ;Set default name
MOVEI T1,CMDEXT ;[2220] Get pointer to table of default
MOVEM T1,DEFEXT ;[2220] extensions to use for take file
MOVEI T2,TAKEFIL ;Look for a filename
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
HRRZ P1,T2 ;Save JFN of indirect command file
MOVE P2,ECHOFLG ;[1645] Assume current value of the echo switch
HRROI T1,[ASCIZ \FTNCMD \] ;[2421] Get pointer to error prefix
MOVEM T1,ERRPFX ;[2421] Store error message prefix
MOVEI T2,ECHO ;Look for echo switch or confirmation
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
CAIN T3,CONFIRM ;Was command confirmed?
JRST TAKLVL ;[1673] Yes--Check that this /TAKE is not
; too many levels deep
HRRZ P2,(T2) ;[1645] /ECHO or /NOECHO was given--get new
; value of ECHOFLG from table entry
MOVEI T2,CONFIRM ;Wait for confirmation
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
TAKLVL: AOS T1,TDEPTH ;About to nest another level
CAIG T1,^D10 ;Have we nested more than 10 levels deep?
JRST READF ;[1673] No--It is OK to do the /TAKE
SOS TDEPTH ;[1673] Since we didn't really nest
HRROI T1,[ASCIZ \%FTNCMD /TAKE: commands may not be nested more than ten levels deep
%FTNCMD /TAKE:\] ;[1673]
PSOUT% ;[1673]
MOVEI T1,.PRIOU ;[1673] Output goes to terminal
HRRZ T2,P1 ;[1673] Get optional JFN of source
MOVE T3,[FLD(.JSSSD,JS%DEV)+FLD(.JSSSD,JS%DIR)+FLD(.JSSSD,JS%NAM)+FLD(.JSAOF,JS%TYP)+JS%PAF] ;[1673]
JFNS% ;[1673]
HRROI T1,[ASCIZ \ is ignored
\] ;[1673]
PSOUT% ;[1673]
JRST RET.OK ;[1673] Not an error, since we can recover
READF: EXCH P2,ECHOFLG ;Exchange new and old values of echo flag
MOVE T1,P1 ;JFN of take file
MOVX T2,FLD(7,OF%BSZ)+.GSNRM+OF%RD ;Ascii Chars, normal read access
OPENF%
ERJMP TAKERR
TAKLOOP:
MOVE T1,P1 ;Get JFN of /TAKE file
HRLI T1,FRMTAK ;The input is coming from a take file
HRL T2,P1 ;Input from take file
HRRI T2,.NULIO ;Throw away output
HRROI T3,[ASCIZ \FORTRAN>\] ;Prompt pointer
PUSHJ SREG,CMDINI ;Init COMND% JSYS and its state block
PUSHJ SREG,SCAN20
JUMPE VREG,TAKLOOP ;If no error and not EOF, then loop
MOVEM P2,ECHOFLG ;Restore echo flag to its old value
SOS TDEPTH ;We've come up one level of nesting
HRRZ T1,P1 ;Get JFN of indirect command file
CLOSF% ;Close file
JRST MONERR ;Failure return
JUMPL VREG,RET.OK ;If end of file, then do a normal return
JRST RET.ERR ;Otherwise, pass back that we got an error
TAKERR: HRROI T1,[ASCIZ \?FTNCMD Cannot open /TAKE file \]
PSOUT%
MOVEI T1,.PRIOU ;Output goes to terminal
MOVE T2,P1 ;JFN of /TAKE file
MOVE T3,[FLD(.JSSSD,JS%DEV)+FLD(.JSSSD,JS%DIR)+FLD(.JSSSD,JS%NAM)+FLD(.JSAOF,JS%TYP)+JS%PAF]
JFNS%
HRROI T1,[ASCIZ \ -- \]
PSOUT%
MOVX T1,.PRIOU ;Primary output stream
HRLOI T2,.FHSLF ;This process' most recent error
SETZ T3, ;Write all of message
ERSTR%
JRST UNKERR ;Unknown error return
JRST BADCALL ;Bad call to ERSTR% return
HRROI T1,[ASCIZ \
\]
PSOUT%
JRST RET.ERR ;Take the error return
TAKEFILE:
FLDDB. (.CMFIL,CM%SDH,,<filespec of indirect command file>)
.COMPILE: ;[2220] This rouitne rewritten
SKIPA T1,[POINT 7,[ASCIZ \FTNCMD Filespec or switch should follow COMPILE command -- \]] ;[2421]
STATE1: HRROI T1,[ASCIZ \FTNCMD \] ;Get pointer to prefix of error messages
MOVEM T1,ERRPFX ;Store error message prefix
MOVX T1,GJ%OLD!GJ%XTN
MOVEM T1,CJFNBK+.GJGEN ;Set default flags for the source file
HRROI T1,[ASCIZ \DSK\]
MOVEM T1,CJFNBK+.GJDEV ;Set default device for the source file
SETZM CJFNBK+.GJNAM ;No default name for the source file
MOVEI T1,FOREXT ;Setup pointer to table of default extensions
MOVEM T1,DEFEXT ;for source file
MOVEI T2,STA1 ;Look for a filespec or switch
MOVEM T2,FOLLOW ;Setup follow set for the /EXTEND switch
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
CAIN T3,S1FILE ;Did we get a filespec?
JRST GOTFIL ;Yes--store filename
;Must have got switch
GOTSWI: HRROI T1,[ASCIZ \FTNCMD \] ;Get pointer to prefix of error messages
MOVEM T1,ERRPFX ;Store error message prefix
HRRZ T2,(T2) ;Get action code from selected switch
PUSHJ SREG,@(T2) ;Call the routine to process the switch
JRST STATE1
GOTFIL: AOS T1,FORIDX ;Get index to use to store new source file JFN
CAIL T1,MAXFILES ;Does index still fit in table
JRST TOOMANY ;No--give an error message
HRRZM T2,FORFIL(T1) ;Store JFN of source file
STATE2:
HRROI T4,[ASCIZ \FTNCMD "+", switch, or confirm required -- \]
MOVEM T4,ERRPFX ;Store error message prefix
MOVEI T2,STA2 ;Look for a "+", switch, or confirm
MOVEM T2,FOLLOW ;Setup follow set for the /EXTEND switch
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
CAIN T3,S2PLUS ;Was a "+" found?
JRST STATE1 ;Yes--goto state 1
CAIN T3,CONFIRM ;Was command confirmed?
JRST STATE3 ;Yes--command is done
;Must have got a switch
HRROI T1,[ASCIZ \FTNCMD \] ;Get pointer to prefix of error messages
MOVEM T1,ERRPFX ;Store error message prefix
HRRZ T2,(T2) ;Get action code from selected switch
PUSHJ SREG,@(T2) ;Call the routine to process the switch
JRST STATE2 ;Stay in state 2
STATE3: PUSHJ SREG,GETDEF ;Get the default filename for /LIST and /OBJECT
PUSHJ SREG,DOCOMPILE ;Compile the program
JRST RET.OK ;Return from SCAN20
TOOMANY:
HRROI T1,[ASCIZ \Too many source files\] ;[2415]
JRST SEMERR ;[2415] Give error message
STA1:
S1FILE: FLDDB. (.CMFIL,CM%SDH,,<filespec of source file>,,S1SWIT)
S1SWIT: FLDDB. (.CMSWI,0,COMSW,<a compilation switch,>)
STA2:
S2PLUS: FLDDB. (.CMTOK,CM%SDH,<POINT 7,[ASCIZ \+\]>,<a "+" followed by filespec of the next source file>,,S2SWIT) ;[2263]
S2SWIT: FLDDB. (.CMSWI,0,COMSW,<a compilation switch,>,,CONFIRM)
SUBTTL GETDEF - Setup default filename for list and object files
;++ [2220] Create this routine
; FUNCTIONAL DESCRIPTION:
;
; This routine stores the default name for the listing and object
; files into DEFFIL. The default name is an ASCIZ string, and is
; name of the last source file, or the string "FORTRAN-OUTPUT" if
; no source files have been scanned or if the last source files
; didn't have a name.
;
; CALLING SEQUENCE:
;
; PUSHJ SREG,GETDEF
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; FORIDX The index to the last source file JFN
; FORFIL Table of source file JFNs
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; DEFFIL The ASCIZ default name string
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; None
;
;--
GETDEF: HRROI T1,DEFFIL ;Get pointer to where to store default file
MOVE T2,FORIDX ;Get index to last source file
JUMPL T2,NUL ;Negative index means no source files yet
MOVE T2,FORFIL(T2) ;Get JFN of last source file
MOVX T3,FLD(.JSAOF,JS%NAM) ;Write only the name of the source file
JFNS% ;Convert source JFN to a string
LDB T1,[POINT 7,DEFFIL,6] ;Get first character of file name
JUMPN T1,GDRET ;Everything is fine if filename isn't null
NUL: MOVE T1,[XWD [ASCIZ \FORTRAN-OUTPUT\],DEFFIL]
BLT T1,DEFFIL+3-1 ;Move in the 3 word default string
GDRET: POPJ SREG, ;Return
SUBTTL CLRFLG - Clear bits in a flag word
;++
; FUNCTIONAL DESCRIPTION:
;
; This routine is used to clear some number of bits in a flag
; word. Generally, this routine is called because it was given as
; the routine to process a switch in the COMSW data structure.
;
; CALLING SEQUENCE:
;
; PUSPJ SREG,CLRFLG
;
; INPUT PARAMETERS:
;
; T2 Points to a vector of arguments, where:
; 1(T2) is a mask of what bits in a flag need to be turned off;
; 2(T2) is an index into the ONFLG/OFFFLG vextors which indicate
; which flag word is to have bits turned off.
;
; IMPLICIT INPUTS:
;
; None
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; ONFLG Will have the mashed bits turned off in the entry for
; the flag word.
; OFFFLG Will have the mashed bits turned in in the entry for
; the flag word.
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; None
;
;--
CLRFLG:
TRACE <CLRFLG>
DMOVE T3,1(T2) ;Get into T3 flag mask
;Get into T4 index into ONFLG to pick flag word
ANDCAM T3,ONFLG(T4) ;Turn off bit that might say that flag is true
IORM T3,OFFFLG(T4) ;Turn on bit that says that flag must be false
POPJ SREG, ;Get next switch
SUBTTL SETFLG - Set bits in a flag word
;++
; FUNCTIONAL DESCRIPTION:
;
; This routine is used to set some number of bits in a flag word.
; Generally, this routine is called because it was given as the
; routine to process a switch in the COMSW data structure.
;
; CALLING SEQUENCE:
;
; PUSPJ SREG,SETFLG
;
; INPUT PARAMETERS:
;
; T2 Points to a vector of arguments, where:
; 1(T2) is a mask of what bits in a flag need to be turned on;
; 2(T2) is an index into the ONFLG/OFFFLG vextors which indicate
; which flag word is to have bits turned off.
;
; IMPLICIT INPUTS:
;
; None
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; ONFLG Will have the mashed bits turned off in the entry for
; the flag word.
; OFFFLG Will have the mashed bits turned in in the entry for
; the flag word.
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; None
;
;--
SETFLG:
TRACE <SETFLG>
DMOVE T3,1(T2) ;Get into T3 flag mask
;Get into T4 index into ONFLG to pick flag word
IORM T3,ONFLG(T4) ;Turn on bit that says that flag must be true
ANDCAM T3,OFFFLG(T4) ;Turn off bit that might say that flag is false
POPJ SREG, ;Get next switch
SUBTTL .BUGOUT - Process a /BUGOUT switch
;++
; FUNCTIONAL DESCRIPTION:
;
; This routine is called when a BUGOUT switch is scanned. This
; routine scans for an octal mask that becomes the value of the
; /BUGOUT switch.
;
; CALLING SEQUENCE:
;
; PUSHJ SREG,BUGOUT
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; None
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; ONFLG+$BUGOUT Will be set to the octal mask
; OFFFLG+$BUGOUT Will be set to the complement of the mask
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; An octal number is scanned with the COMND% JSYS
;
;--
.BUGOUT:
TRACE <.BUGOUT:>
MOVEI T2,[FLDDB.(.CMNUM,CM%SDH,^D8,<octal mask>)] ;Look for a number
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
MOVEM T2,ONFLG+$BUGOUT ;Will need to turn on these bits
SETCAM T2,OFFFLG+$BUGOUT ;Will need to turn off these bits
POPJ SREG, ;Get next switch
SUBTTL .DEBUG - Process the /DEBUG switch
;++
; FUNCTIONAL DESCRIPTION:
;
; This routine sets the flag bits to show that a debug switch was
; seen. If the switch ends with a colon, either a debug keyword
; or a list of debug keywords enclosed in parentheses is scanned.
; Each debug keyword has associated with it a mask which will
; control which debug bits are set or cleared.
;
; CALLING SEQUENCE:
;
; PUSHJ SREG,.DEBUG
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; STATE+.CMFLG The flags returned by the COMND% JSYS when the
; /DEBUG switch was scanned.
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; ONFLG+$DEBGSW Set to show which debug bits are to be turned on
; OFFFLG+$DEBGSW Set to show which debug bits are to be turned off
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; A switch value is scanned with the COMND% JSYS, if the switch
; ended with a colon.
;
;--
.DEBUG:
TRACE <.DEBUG:>
MOVE T1,STATE+.CMFLG ;[2220] Get flags returnd by the COMND% JSYS
TXNE T1,CM%SWT ;[2220] Was switch terminated with a colon?
JRST DCOLON ;[2220] Yes--get keyword or list of keywords
MOVEI T1,DB.ALL ;[1603] Use default of /DEBUG:ALL
IORM T1,ONFLG+$DEBGSW ;[1603] Turn on flags that must be on
ANDCAM T1,OFFFLG+$DEBGSW ;[1603] Turn off flags that must be off
POPJ SREG, ;Return
DCOLON: MOVEI T2,DB.K1 ;Look for a keyword or "("
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
CAIN T3,DB.K1 ;Was a keyword found?
PJRST PRSK1 ;Yes--go process keyword
;Must have got a open parenthesis
GETK1:
MOVEI T2,DB.K2 ;Look for only a keyword
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
PUSHJ SREG,PRSK1 ;Process this keyword
HRROI T4,[ASCIZ \FTNCMD 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 \FTNCMD \]
MOVEM T4,ERRPFX ;Store error message prefix
CAIN T3,COMMA ;Was a comma found?
JRST GETK1 ;Yes--get next keyword
POPJ SREG, ;Must have got close paren--return
PRSK1: HRRZ T2,(T2) ;Get keyword mask
TRNE T2,400000 ;Was this a NO form of a keyword
JRST PRNO ;Yes--Process no keyword
IORM T2,ONFLG+$DEBGSW ;Turn on flags that must be on
ANDCAM T2,OFFFLG+$DEBGSW ;Turn off flags that must be off
POPJ SREG, ;Return
PRNO: MOVE T2,ONFLG+$DEBGSW ;Turn off any on bits that were not selected
SETCAM T2,OFFFLG+$DEBGSW ;Turn off bits that must be off
POPJ SREG, ;Return
SUBTTL .ECHOOP - Process the /ECHO-OPTION switch
;++
; FUNCTIONAL DESCRIPTION:
;
; Process the /ECHO-OPTION switch by setting the word OPTECHO.
; This switch does go through the general bookkeeping required for
; other switch words because this switch word is used while
; processing SWITCH.INI, and SWITCH.INI cannot turn off this
; switch once it is set.
;
; CALLING SEQUENCE:
;
; PUSHJ SREG,.ECHOOP
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; None
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; OPTECHO Set to ones. In this state, the flag word says
; that the selected lines from SWITCH.INI are to
; be echoed.
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; None
;
;--
.ECHOOP:
TRACE <.ECHO-OPTION>
SETOM OPTECHO ;Echo the switches read from SWITCH.INI
POPJ SREG, ;Get next switch
SUBTTL .EXTEND - Process the /EXTEND switch
;++
; FUNCTIONAL DESCRIPTION:
;
; This routine sets the flag bits to show that a extend switch was
; seen. If the switch ends with a colon, either a extend keyword
; or a list of extend keywords enclosed in parentheses is scanned.
; Each extend keyword has associated with it a mask which will
; control which extend bits are set or cleared.
;
; CALLING SEQUENCE:
;
; PUSHJ SREG,.EXTEND
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; STATE+.CMFLG The flags returned by the COMND% JSYS when the
; /EXTEND switch was scanned.
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; ONFLG+$F2 Set to show that a /EXTEND switch has been seen
; OFFFLG+$F2 Set to show that a /NOEXTEND switch has not been seen
; ONFLG+$BIGARY Set to new value of BIGARY
; OFFFLG+$BIGARY Set to complement of new value of BIGARY
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; A switch value is scanned with the COMND% JSYS, if the switch
; ended with a colon.
;
;--
.EXTEND: ;[2220] This routine rewritten by RVM
TRACE <.EXTEND:>
MOVX T3,SW.EXT ;Get flag bit
IORM T3,ONFLG+$F2 ;Turn on bit that says that flag must be true
ANDCAM T3,OFFFLG+$F2 ;Turn off bit that might say that flag is false
MOVE T1,STATE+.CMFLG ;[2347] Get flags returnd by the COMND% JSYS
TXNE T1,CM%SWT ;[2347] Was switch terminated with a colon?
JRST EXTARG ;[2347] Yes--Process /EXTEND arguments
MOVX T3,DEFBIGARY ;[2470] Get default value of BIGARY
MOVEM T3,ONFLG+$BIGARY ;Will need to turn on these bits
SETCAM T3,OFFFLG+$BIGARY ;Will need to turn off these bits
MOVX T2,PSLARGE ;[2347] Get New Default Psect for COMMON blocks
MOVEM T2,ONFLG+$DFCMPS ;[2347] Store new DeFault CoMmon block PSect
SETCAM T2,OFFFLG+$DFCMPS ;[2347] Turn off bits that must be off
MOVX T3,SW.EXC ;[2442] Get flag bit for /EXTEND:CODE
IORM T3,OFFFLG+$F2 ;[2442] Turn on bit that says flag is false
ANDCAM T3,ONFLG+$F2 ;[2442] Turn off bit that says flag is true
POPJ SREG, ;[2347] Return
EXTARG: MOVEI T2,ET.K1 ;Look for a keyword or "("
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
CAIN T3,ET.K1 ;Was a keyword found?
PJRST PRSK2 ;Yes--go process keyword
;Must have got an open parenthesis
GETK2:
MOVEI T5,COMMA ;Follow set of list of keyword in list
MOVEM T5,FOLLOW ;is a comma or ")"
MOVEI T2,ET.K2 ;Look for only a keyword
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
PUSHJ SREG,PRSK2 ;Process this keyword
HRROI T4,[ASCIZ \FTNCMD 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 \FTNCMD \]
MOVEM T4,ERRPFX ;Store error message prefix
CAIN T3,COMMA ;Was a comma found?
JRST GETK2 ;Yes--get next keyword
POPJ SREG, ;Must have got a parenthesis--return
PRSK2:
HRRZ T2,(T2) ;Get address of code to process keyword from
;the entry in the keyword table
JRST (T2) ;Go to process the keyword
.CODE: MOVX T3,SW.EXC ;[2442] Get flag bit for /EXTEND:CODE
IORM T3,ONFLG+$F2 ;[2442] Turn on bit that says flag is true
ANDCAM T3,OFFFLG+$F2 ;[2442] Turn off bit that says flag is false
POPJ SREG, ;[2442] Return
.DATA: PUSHJ SREG,CHKCOLON ;See if colon flag is set
JRST DATDEF ;No colon--use default value
MOVEI T2,[FLDDB.(.CMNUM,CM%SDH,^D10,
<decimal number which is the minimum size of data objects in .LARG.>,10000)]
PUSHJ SREG,CMD ;Look for a decimal number
JRST USRERR ;EOF return--command not completed
TRNA ;Always skip
DATDEF: MOVX T2,DEFBIGARY ;[2470] Get default value
MOVEM T2,ONFLG+$BIGARY ;Will need to turn on these bits
SETCAM T2,OFFFLG+$BIGARY ;Will need to turn off these bits
POPJ SREG,
.NOCODE:MOVX T3,SW.EXC ;[2442] Get flag bit for /EXTEND:CODE
IORM T3,OFFFLG+$F2 ;[2442] Turn on bit that says flag is false
ANDCAM T3,ONFLG+$F2 ;[2442] Turn off bit that says flag is true
POPJ SREG, ;[2442] Return
.NODATA:
MOVE T2,DEFFLG+$BIGARY ;[2470] BIGARY is infinity for 30 bit addrs
MOVEM T2,ONFLG+$BIGARY ;Will need to turn on these bits
SETCAM T2,OFFFLG+$BIGARY ;Will need to turn off these bits
POPJ SREG, ;Return
SUBTTL .COMMON - Process COMMON keyword of /EXTEND
;++
; FUNCTIONAL DESCRIPTION:
;
; This routine either sets the default psect for all COMMON
; blocks or sets the psect for individually named COMMON blocks.
; If the keyword does not end in a colon, then the default
; common block for all psects is set to PSLARGE. If the keyword
; ends in a colon, then the keyword must be followed by either a
; COMMON block name or a list of COMMON blocks inclosed in
; parenthesis. In this case, the named COMMON block(s) are
; explicitly put in PSLARGE, overriding for the named block(s)
; the default psect, and the default psect for COMMON blocks is
; set to PSDATA.
;
; This routine uses the routine FNDCOMMON to construct a table
; that contains the COMMON blocks named in either /EXTEND:COMMON
; or /EXTEND:NOCOMMON. This table is then used during COMMSTA
; to assign those COMMON blocks to their proper psects.
;
; CALLING SEQUENCE:
;
; PUSHJ SREG,.COMMON
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; FOLLOW Follow set of /EXTEND, used by CHKCOLON
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; ECTAB Table of COMMON blocks named in /EXTEND:[NO]COMMON
; ONFLG+$DFCMPS Set to show what the new value of DFCMPS should be
; OFFFLG+$DFCMPS Set to show what the new value of DFCMPS should be
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; A switch value is scanned with the COMND% JSYS, if the keyword
; ends with a colon. CHKCOLON may scan something in the FOLLOW set
; while checking for the trailing colon.
;
;--
;[2343] New routine
.COMMON:
PUSHJ SREG,CHKCOLON ;See if colon flag is set
PJRST COMLRG ;No colon follows keyword
MOVEI T2,EC.K1 ;Look for a COMMON block name or "("
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
CAIN T3,EC.K3 ;Was a COMMON block name found?
PJRST PRSK4A ;[2416] Yes--go process COMMON block name
;Must have got a open parenthesis
PUSHJ SREG,COMSML ;[2416] Set default psect for COMMON to small
GETK4: MOVEI T2,EC.K2 ;Look for only a COMMON block name
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
PUSHJ SREG,PRSK4 ;Process this COMMON block name
HRROI T4,[ASCIZ \FTNCMD 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 \FTNCMD \]
MOVEM T4,ERRPFX ;Store error message prefix
CAIN T3,COMMA ;Was a comma found?
JRST GETK4 ;Yes--get next COMMON block name
POPJ SREG, ;Must have got close paren--return
PRSK4A: PUSHJ SREG,COMSML ;[2416] Set default psect for COMMON to small
PRSK4: PUSH SREG,P1 ;[2465] Save P1 Save
PUSH SREG,P2 ;[2465] Save P2 Registers
PUSH SREG,P3 ;[2465] Save P3 Smashed
PUSH SREG,P4 ;[2465] Save P4 By
PUSH SREG,P5 ;[2465] Save P5 FNDCOM
PUSH SREG,P6 ;[2465] Save P6
PUSHJ SREG,CVTCOM ;Convert COMMON block name to SIXBIT
PUSH SREG,VREG ;Pass the name as the first argument
PUSH SREG,[TRUE] ;True--Insert entry if not in table
PUSHJ SREG,FNDCOM ;Find the common block entry
ADJSP SREG,-2 ;Pop arguments off stack
POP SREG,P6 ;[2465] Restore P6 Restore
POP SREG,P5 ;[2465] Restore P5 Regs
POP SREG,P4 ;[2465] Restore P4 Used
POP SREG,P3 ;[2465] Restore P3 by
POP SREG,P2 ;[2465] Restore P2 FNDCOM
POP SREG,P1 ;[2465] Restore P1
JUMPE VREG,MANYCM ;Was there too many COMMON blocks?
HLRZ T1,CMDSOU ;Get source from which this switch came
CAIN T1,FRMSWI ;Did this switch come from SWITCH.INI
SKIPA T2,ECPSE2(VREG) ;Yes--Store into SWITCH.INI psect
MOVE T2,ECPSECT(VREG);No--Store into command line field
MOVX T3,PSLARGE ;Get psect for this entry
DPB T3,T2 ;Store psect into entry for COMMON block
POPJ SREG, ;Return
COMLRG: MOVX T2,PSLARGE ;Get New Default Psect for COMMON blocks
MOVEM T2,ONFLG+$DFCMPS ;Store new DeFault CoMmon block PSect
SETCAM T2,OFFFLG+$DFCMPS ;Turn off bits that must be off
POPJ SREG, ;Return
MANYCM: HRROI T1,[ASCIZ \Too many COMMON block names in /EXTEND\] ;[2415]
JRST SEMERR ;[2415] Give error message
SUBTTL .NOCOMMON - Process NOCOMMON keyword of /EXTEND
;++
; FUNCTIONAL DESCRIPTION:
;
; This routine either sets the default psect for all COMMON
; blocks or sets the psect for individually named COMMON blocks.
; If the keyword does not end in a colon, then the default
; common block for all psects is set to PSDATA. If the keyword
; ends in a colon, then the keyword must be followed by either a
; COMMON block name or a list of COMMON blocks inclosed in
; parenthesis. In this case, the named COMMON block(s) are
; explicitly put in PSDATA, overriding for the named block(s)
; the default psect, and the default psect for COMMON blocks is
; set to PSLARGE.
;
; This routine uses the routine FNDCOMMON to construct a table
; that contains the COMMON blocks named in either /EXTEND:COMMON
; or /EXTEND:NOCOMMON. This table is then used during COMMSTA
; to assign those COMMON blocks to their proper psects.
;
; CALLING SEQUENCE:
;
; PUSHJ SREG,.NOCOMMON
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; FOLLOW Follow set of /EXTEND, used by CHKCOLON
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; ECTAB Table of COMMON blocks named in /EXTEND:[NO]COMMON
; ONFLG+$DFCMPS Set to show what the new value of DFCMPS should be
; OFFFLG+$DFCMPS Set to show what the new value of DFCMPS should be
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; A switch value is scanned with the COMND% JSYS, if the keyword
; ends with a colon. CHKCOLON may scan something in the FOLLOW set
; while checking for the trailing colon.
;
;--
;[2343] New routine
.NOCOMMON:
PUSHJ SREG,CHKCOLON ;See if colon flag is set
JRST COMSML ;No colon follows keyword
MOVEI T2,EC.K1 ;Look for a COMMON block name or "("
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
CAIN T3,EC.K3 ;Was a COMMON block name found?
PJRST PRSK5A ;[2416] Yes--go process COMMON block name
;Must have got a open parenthesis
PUSHJ SREG,COMLRG ;[2416] Set default psect for COMMON to large
GETK5: MOVEI T2,EC.K2 ;Look for only a COMMON block name
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
PUSHJ SREG,PRSK5 ;Process this COMMON block name
HRROI T4,[ASCIZ \FTNCMD 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 \FTNCMD \]
MOVEM T4,ERRPFX ;Store error message prefix
CAIN T3,COMMA ;Was a comma found?
JRST GETK5 ;Yes--get next COMMON block name
POPJ SREG, ;Must have got close paren--return
PRSK5A: PUSHJ SREG,COMLRG ;[2416] Set default psect for COMMON to large
PRSK5: PUSH SREG,P1 ;[2465] Save P1 Save
PUSH SREG,P2 ;[2465] Save P2 Registers
PUSH SREG,P3 ;[2465] Save P3 Smashed
PUSH SREG,P4 ;[2465] Save P4 By
PUSH SREG,P5 ;[2465] Save P5 FNDCOM
PUSH SREG,P6 ;[2465] Save P6
PUSHJ SREG,CVTCOM ;Convert COMMON block name to SIXBIT
PUSH SREG,VREG ;Pass the name as the first argument
PUSH SREG,[TRUE] ;True--Insert entry if not in table
PUSHJ SREG,FNDCOM ;Find the common block entry
ADJSP SREG,-2 ;Pop arguments off stack
POP SREG,P6 ;[2465] Restore P6 Restore
POP SREG,P5 ;[2465] Restore P5 Regs
POP SREG,P4 ;[2465] Restore P4 Used
POP SREG,P3 ;[2465] Restore P3 by
POP SREG,P2 ;[2465] Restore P2 FNDCOM
POP SREG,P1 ;[2465] Restore P1
JUMPE VREG,MANYCM ;Was there too many COMMON blocks?
HLRZ T1,CMDSOU ;Get source from which this switch came
CAIN T1,FRMSWI ;Did this switch come from SWITCH.INI
SKIPA T2,ECPSE2(VREG) ;Yes--Store into SWITCH.INI psect
MOVE T2,ECPSECT(VREG);No--Store into command line field
MOVX T3,PSDATA ;Get psect for this entry
DPB T3,T2 ;Store psect into entry for COMMON block
POPJ SREG, ;Return
COMSML: MOVX T2,PSDATA ;Get New Default Psect for COMMON blocks
MOVEM T2,ONFLG+$DFCMPS ;Store new DeFault CoMmon block PSect
SETCAM T2,OFFFLG+$DFCMPS ;Turn off bits that must be off
POPJ SREG, ;Return
SUBTTL .PSECT - Process PSECT keyword of /EXTEND
;++
; FUNCTIONAL DESCRIPTION:
;
; This routine sets the names of the code and data psects.
;
; CALLING SEQUENCE:
;
; PUSHJ SREG,.PSECT
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; FOLLOW Follow set of /EXTEND
; DEFHIN Default value for HINAME (the code psect)
; DEFLON Default value for LONAME (the data psect)
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; ONHIN Set to show what the new value of HINAME should be
; OFFHIN Set to show what the new value of HINAME should be
; ONLON Set to show what the new value of LONAME should be
; OFFLON Set to show what the new value of LONAME should be
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; The COMND% jsys will scan the keyword value or stuff in the follow
; set.
;
;--
;[2445] New routine
.PSECT:
;Assume that no more of switch is typed, so set length
;and name info in HINAME and LONAME.
MOVE T1,DEFHIN ;Get word count of HINAME
DHNL: MOVE T2,DEFHIN(T1) ;Get word of default
MOVEM T2,ONHIN(T1) ;Will need to turn on these bits
SETCAM T2,OFFHIN(T1) ;Will need to turn off these bits
SOJGE T1,DHNL ;Process rest of default high name
MOVE T1,DEFLON ;Get word count of LONAME
DLNL: MOVE T2,DEFLON(T1) ;Get word of default
MOVEM T2,ONLON(T1) ;Will need to turn on these bits
SETCAM T2,OFFLON(T1) ;Will need to turn off these bits
SOJGE T1,DLNL ;Process rest of default low name
PUSHJ SREG,CHKCOLON ;See if colon flag is set
POPJ SREG, ;No colon follows keyword--Return
SETZ T1, ;No options follow colon in command
HRRM T1,EP.CL+.CMFNP ;so, make sure chain ends
MOVEI T2,EP.DA ;Look for data psect name or ":"
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
CAIN T3,EP.CL ;Was colon found instead of name
JRST GETCPN ;Yes--go get code psect name
;Got name of data psect in atom buffer--store it away.
PUSHJ SREG,CVT76 ;Convert the atom buffer to SIXBIT
JUMPE VREG,BADDPS ;Bad data psect name, or bug in TOPS-20
MOVEM VREG,ONLON ;Will need to turn on these bits
SETCAM VREG,OFFLON ;Will need to turn off these bits
SOJ VREG, ;Make count into a good index
SLNL: MOVE T2,SIXATM(VREG) ;Get word of SIXBIT psect name
MOVEM T2,ONLON+1(VREG) ;Will need to turn on these bits
SETCAM T2,OFFLON+1(VREG) ;Will need to turn off these bits
SOJGE VREG,SLNL ;Move rest of SIXATM to ONLON, OFFLON
;Get a colon
MOVE T1,FOLLOW ;Get pointer to descriptor blocks of the
HRRM T1,EP.CL+.CMFNP ;follow set and build up chain
MOVEI T2,EP.CL ;Look for colon or stuff in follow set
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
CAIN T3,EP.CL ;Was colon found instead of name
JRST GETCPN ;Yes--go get code psect name
;We must have got something the the follow set, so tell COMND% JSYS
;routines that the next field has already been scanned.
SETOM LKAHD ;Next field scanned
POPJ SREG, ;No more to do here
;Get name of code psect
GETCPN: MOVEI T2,EP.CO ;Look for code psect name
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
;Store code psect name
PUSHJ SREG,CVT76 ;Convert the atom buffer to sixbit
JUMPE VREG,BADCPS ;Bad code psect name
MOVEM VREG,ONHIN ;Will need to turn on these bits
SETCAM VREG,OFFHIN ;Will need to turn off these bits
SOJ VREG, ;Make count into a good index
SHNL: MOVE T2,SIXATM(VREG) ;Get word SIXBIT psect name
MOVEM T2,ONHIN+1(VREG) ;Will need to turn on these bits
SETCAM T2,OFFHIN+1(VREG) ;Will need to turn off these bits
SOJGE VREG,SHNL ;Move rest of SIXATM to ONHIN, OFFHIN
POPJ SREG, ;Return
BADDPS: ;TOPS-20 has a bug that allows a string to get null string when
;an alternative would match text!
MOVEI T2,EP.CL ;Look for colon
PUSHJ SREG,ECMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
JRST GIVERR ;Nothing parsed return--Colon not found
CAIN T3,EP.CL ;Was colon found
JRST GETCPN ;Yes--go get code psect name
GIVERR: HRROI T1,[ASCIZ \Psect name or colon required\]
JRST SEMERR ;Give error message
BADCPS: HRROI T1,[ASCIZ \Bad psect name\]
JRST SEMERR ;Give error message
SUBTTL CVTCOM - Convert and Syntax Check COMMON Block Name
;++
; FUNCTIONAL DESCRIPTION:
;
; This routine converts the ASCIZ string in the atom buffer to
; sixbit and returns the result. This routine also syntax
; checks the string to make sure that it is a legal COMMON block
; name.
;
; The COMMON block name is assumed to be incorrect if:
; The name is less than 1 character long
; The name is more than 32 characters long
; The name contains a "." and is not ".COMM."
; The name does not begin with a letter or "."
; The COMMON block name is the null string
;
; Note that the COMND% JSYS insures that only string is only
; made up of periods, digits, dollar signs, underlines, and
; upper and lower case letters.
;
; CALLING SEQUENCE:
;
; PUSHJ SREG,CVTCOM
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; ATMBUF The atom buffer, the source of the COMMON
; block name
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; PERIOD Zero, Iff a period was seen while scanning
; the string
;
; FUNCTION VALUE:
;
; Length,,pointer to COMMON block name in SIXBIT.
;
; SIDE EFFECTS:
;
; None
;
;--
;[2343] New routine
CVTCOM: SETZM COMBUF ;[4530]Clear COMBUF so it can get 6 bit string
MOVE T1,[XWD COMBUF,COMBUF+1];[4530]
BLT T1,COMBUF+MAXWD-1;[4530]
MOVE T1,[POINT 7,ATMBUF] ;7 bit string comes from the atom buffer
MOVE T2,[POINT 6,COMBUF] ;[4530]6 bit string goes into COMBUF
MOVEI T4,MAXCHR ;[4530]Process up to 31 characters
SETZM PERIOD ;Assume no period has been seen
CCLP: ILDB T3,T1 ;Get a seven bit character
JUMPE T3,CCCHK ;Return if null encountered
CAIN T3,"." ;Is character a period?
SETOM PERIOD ;Yes--light period flag
CAIL T3,140 ;Is character lowercase?
SUBI T3,40 ;Yes--Make it uppercase
SUBI T3," "-' ' ;Convert 7 bit to sixbit
IDPB T3,T2 ;Store sixbit character
SOJG T4,CCLP ;Process up to 31 characters
ILDB T3,T1 ;We processed 31 charaters in the loop above
JUMPN T3,CCERR ;so next character should be a null
CCCHK: SKIPN COMBUF ;[4530]The COMMON block name must not be null
JRST CCERR ;[4530] it is null
MOVEI T3,MAXCHR ;[4530] T3 = max number of characters
SUB T3,T4 ;[4530] T3 = number of characters
ADDI T3,SIXBCHARSPERWORD-1 ;[4530] number words of sixbit characters
IDIVI T3,SIXBCHARSPERWORD ;[4530] = (number characters+5)/6
SKIPE COMBUF(T3) ;[4530]
AOJ T3, ;[4530] +1 if num chars is not multiple of 6
MOVEI VREG,COMBUF ;[4530] Form cnt,,ptr to symbol in VREG
HRL VREG,T3 ;[4530]
SKIPE PERIOD ;Was a period seen while converting the name?
JRST CHKBLK ;Yes--name better be ".COMM."
LDB T3,[POINT 6,COMBUF,5] ;[4530]Get first sixbit character of name
CAIL T3,'A' ;If first character isn't a letter
CAILE T3,'Z' ;If first character isn't a letter
JRST CCERR ;First character not a letter
POPJ SREG, ;Was a letter: All was ok, return
CHKBLK: MOVE T3,COMBUF ;[4530] Get first word of symbol
CAME T3,[SIXBIT \.COMM.\] ;[4530]Was the name the name of blank COMMON?
JRST CCERR ;[4530]
SKIPN COMBUF+1 ;[4530] Is the next word null
POPJ SREG, ;All was ok, return
CCERR: HRROI T1,[ASCIZ \Illegal or missing COMMON block name in /EXTEND:[NO]COMMON\] ;[2415]
JRST SEMERR ;[2415] Give error message
SUBTTL CHKCOLON -- See if there is a colon following keyword
;++
; FUNCTIONAL DESCRIPTION:
;
; <detailed functional description of the routine>
;
; CALLING SEQUENCE:
;
; None
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; None
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; None
;
;--
;[2220] This routine added
; Call
; PUSHJ SREG,CHKCOLON
; return+1 ;Here if no colon
; return+2 ;Here if colon was scanned
CHKCOLON:
LDB T1,STATE+.CMPTR ;Pickup last character scanned
CAIN T1,":" ;Was character a colon?
JRST FOUCOL ;Yes--take found return
MOVE T1,FOLLOW ;[2331] Get pointer to descriptor blocks of the
HRRM T1,COLON+.CMFNP ;[2331] follow set and build up chain
TRYCOL: MOVEI T2,COLON ;Look for a colon using COMND
PUSHJ SREG,ECMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
POPJ SREG, ;Nothing parsed return--Colon not found
CAIN T3,COLON ;[2331] Was a colon found?
JRST FOUCOL ;[2331] Yes--return
SETOM LKAHD ;Next field scanned since something was found
POPJ SREG, ;[2331] Colon not found
FOUCOL: AOS (SREG) ;Take return that says "colon was found"
POPJ SREG, ;Take return that says nothing was found
SUBTTL .FLAG - Process the /FLAG switch
;++
; FUNCTIONAL DESCRIPTION:
;
; This routine sets the flag bits to show that a FLAG switch was
; seen. If the switch ends with a colon, either a FLAG keyword
; or a list of FLAG keywords enclosed in parentheses is scanned.
; Each FLAG keyword has associated with it a mask which will
; control which FLAG bits are set or cleared.
;
;
; CALLING SEQUENCE:
;
; PUSHJ SREG,.FLAG
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; STATE+.CMFLG The flags returned by the COMND% JSYS when the
; /FLAG switch was scanned.
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; ONFLG+$F2 Set to show that a /FLAG switch has been seen
; OFFFLG+$F2 Set to show that a /NOFLAG switch has not been seen
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; A switch value is scanned with the COMND% JSYS, if the switch
; ended with a colon.
;
;--
.FLAG: ;[2246] added this entire routine
TRACE <.FLAG:>
MOVE T1,STATE+.CMFLG ;Flags returned by COMND% JSYS
TXNN T1,CM%SWT ;Terminated by colon?
JRST CF.ALL ;No--Use default of ALL
MOVEI T2,CF.K1 ;Look for keyword or "("
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF -- Command not completed
CAIN T3,CF.K1 ;Keyword found?
PJRST CF.KWD ;Yes--Process it and leave
;Must have gotten an open parenthesis
CF.PRN:
MOVEI T2,CF.K2 ;Look only for keyword
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF -- Command not completed
PUSHJ SREG,CF.KWD ;Process that keyword
HRROI T4,[ASCIZ \FTNCMD Comma or ")" required -- \]
MOVEM T4,ERRPFX ;Store error message prefix
MOVEI T2,COMMA ;Look for "," or ")"
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF -- Command not completed
HRROI T4,[ASCIZ \FTNCMD \]
MOVEM T4,ERRPFX ;Restore the error message prefix
CAIN T3,COMMA ;Comma found?
JRST CF.PRN ;Yes--Back for another keyword
POPJ SREG, ;Must be ")" -- Return
;Process one keyword
CF.KWD:
HRRZ T2,(T2) ;Address of code to process keyword
PJRST (T2) ;Do it
;VMS Keyword [2455]
CF.VMS:
MOVX T3,SW.CFV ;This bit set
JRST CF.SET
;ANSI keyword
CF.STD:
MOVX T3,SW.CFS ;This bit set
JRST CF.SET
;ALL keyword
CF.ALL:
MOVX T3,SW.CFS!SW.CFV;Both bits set
CF.SET:
IORM T3,ONFLG+$F2 ;Turn on bit that says flag is true
ANDCAM T3,OFFFLG+$F2 ;Turn off bit that says flag is false
POPJ SREG,
;NOVMS keyword [2455]
CF.NOV:
MOVX T3,SW.CFV ;This bit turned off
JRST CF.RES
;NOANSI keyword
CF.NOS:
MOVX T3,SW.CFS ;This bit turned off
JRST CF.RES
SUBTTL /NOFLAG - Process the /NOFLAG switch
;This switch is equivalent to /FLAG:NONE
;There are no keywords.
.NOFLAG: ;[2246] added this routine
TRACE <.NOFLAG:>
CF.NON:
MOVX T3,SW.CFV!SW.CFS;Both bits turned off
CF.RES: ANDCAM T3,ONFLG+$F2 ;Turn off bit that says /FLAG is true
IORM T3,OFFFLG+$F2 ;Turn on bit that says /FLAG is false
POPJ SREG,
SUBTTL .LIST -- Process the /LIST switch ;[2246]
.LIST:
TRACE <.LIST:>
MOVX T1,LSTFLG ;Get flag that says a list file is being made
IORM T1,ONFLG+$F ;Turn on flag that says a list file is made
ANDCAM T1,OFFFLG+$F ;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 LSTRET ;Yes--Return since /LIST in SWITCH.INI can
;not take a value.
MOVE T1,STATE+.CMFLG ;[2220] Get flags returnd by the COMND% JSYS
TXNN T1,CM%SWT ;[2220] Was switch terminated with a colon?
POPJ SREG, ;[2220] No--return
SKIPGE T1,LSTFIL ;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 LSTFIL ;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 ;[2220] Get default filename text into DEFFIL
HRROI T1,DEFFIL ;Get pointer to default text
MOVEM T1,CJFNBK+.GJNAM ;Set default name
MOVE T2,ONFLG+$F ;Get flags that have been turned on
TXNE T2,SW.CRF ;Has /CREF been specified?
SKIPA T1,[CRFEXT] ;[2220] Yes--default extension is .CRF
MOVEI T1,LSTEXT ;[2220] No--default extension is .LST
MOVEM T1,DEFEXT ;[2220] 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,LSTFIL ;Store the new listing file JFN
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
LSTRET: POPJ SREG, ;Get next switch
LFIL: FLDDB. (.CMFIL,CM%SDH,,<filespec of list file>) ;[2220]
.NODEBUG:
TRACE <.NODEBUG:>
HRRZI T2,^-DB.ALL ;Turn off all debugging options
MOVE T2,ONFLG+$DEBGSW ;Turn off any on bits that were not selected
SETCAM T2,OFFFLG+$DEBGSW ;Turn off bits that must be off
POPJ SREG, ;Go get next switch
.NOEXTEND:
TRACE <.NOEXTEND>
MOVX T3,SW.EXT ;Get flag bit
ANDCAM T3,ONFLG+$F2 ;[2242] Turn off bit that might say that
; flag is true
IORM T3,OFFFLG+$F2 ;[2242] Turn on bit that says that flag
; must be false
MOVX T2,PSDATA ;[2347] Get New Default Psect for COMMON blocks
MOVEM T2,ONFLG+$DFCMPS ;[2347] Store new DeFault CoMmon block PSect
SETCAM T2,OFFFLG+$DFCMPS ;[2347] Turn off bits that must be off
MOVX T3,SW.EXC ;[2442] Get flag bit for /EXTEND:CODE
IORM T3,OFFFLG+$F2 ;[2442] Turn on bit that says flag is false
ANDCAM T3,ONFLG+$F2 ;[2442] Turn off bit that says flag is true
POPJ SREG, ;Go get next switch
.NOLIST:
TRACE <.NOLIST>
;Load T3 with /LIST, /CREF, /LNMAP, /MACHINE-CODE, and /EXPAND bits
MOVX T3,LSTFLG+SW.CRF+SW.MAP+SW.MAC+SW.EXP
ANDCAM T3,ONFLG+$F ;Turn off bits that might say flags are true
IORM T3,OFFFLG+$F ;Turn on bits that say that flags must be false
POPJ SREG, ;Go get next switch
.NOOPTION:
TRACE <NOOPTION>
SETOM NOPTION ;Do not read SWITCH.INI
POPJ SREG, ;Go get next switch
.NOWARN:
TRACE <.NOWARN:>
MOVX T3,SW.NOW ;Get bit to turn off
IORM T3,ONFLG+$F ;Turn on bit that says that flag must be true
ANDCAM T3,OFFFLG+$F ;Turn off bit that might say that flag is false
MOVE T1,STATE+.CMFLG ;[2220] Get flags returnd by the COMND% JSYS
TXNN T1,CM%SWT ;[2220] Was switch terminated with a colon?
PJRST NWALL ;[2220] No--use default of /NOWARN:ALL
MOVEI T2,WN.K1 ;Look for a keyword or "("
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
CAIN T3,WN.K1 ;Was a keyword found?
PJRST PRSK3 ;Yes--go process keyword
;Must have got a left parenthesis
GETK3:
MOVEI T2,WN.K2 ;Look for only a keyword
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
PUSHJ SREG,PRSK3 ;Process this keyword
HRROI T4,[ASCIZ \FTNCMD 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 \FTNCMD \]
MOVEM T4,ERRPFX ;Store error message prefix
CAIN T3,COMMA ;Was a comma found?
JRST GETK3 ;Yes--get next keyword
POPJ SREG, ;Must have got paren--return
PRSK3:
HRRZ T2,(T2) ;Get keyword's code
CAIN T2,1 ;Is this keyword ALL?
JRST NWALL ;Yes--Set all flags
CAIN T2,2 ;Is this keyword NONE?
PJRST .WARN ;Yes--Let .WARN clear all the flags
;Must have got a normal keyword
MOVEI T3,-1(T2) ;Determine correct word ...
IDIVI T3,^D36 ; ... and position to set
MOVEI T1,1 ;Get bit to shift
LSH T1,(T4) ;Shift to proper position
IORM T1,NWON(T3) ;Turn on bit that says that flag must be true
ANDCAM T1,NWOFF(T3) ;Turn off bit that might say that flag is false
POPJ SREG,
NWALL: SETOM NWON ;Set first word of nowarn bits
MOVE T1,[XWD NWON,NWON+1] ;Set nowarn "must be ON" bits
BLT T1,NWON+NWWDCT-1 ;Set rest of must be on bits
SETZM NWOFF ;Clear first word of nowarn bits
MOVE T1,[XWD NWOFF,NWOFF+1] ;Clear nowarn "must be OFF" bits
BLT T1,NWOFF+NWWDCT-1 ;Set rest of must be on bits
POPJ SREG,
.OBJECT:
TRACE <.OBJECT:>
MOVX T1,RELFLG ;Get flag that says a .REL file is being made
IORM T1,ONFLG+$F ;Turn on flag that says a .REL file is made
ANDCAM T1,OFFFLG+$F ;Turn off the no .REL file flag
MOVX T3,SW.OCS ;Get the /SYNTAX switch
ANDCAM T3,ONFLG+$F ;Turn off bit that might say that flag is true
IORM T3,OFFFLG+$F ;Turn on bit that says that flag must be false
HLRZ T1,CMDSOU ;Get source from which this switch came
CAIN T1,FRMSWI ;Did this switch come from SWITCH.INI
JRST OBJRET ;Yes--Return since /OBJECT doesn't take a
;value in SWITCH.INI
MOVE T1,STATE+.CMFLG ;[2220] Get flags returned by the COMND% JSYS
TXNN T1,CM%SWT ;[2220] Was switch terminated with a colon?
POPJ SREG, ;[2220] No--return
SKIPGE T1,RELFIL ;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 RELFIL
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 ;[2220] Get default filename into DEFFIL
HRROI T1,DEFFIL ;Get pointer to default filename
MOVEM T1,CJFNBK+.GJNAM ;Set default name
MOVEI T1,RELEXT ;[2220] Get pointer to table of default
MOVEM T1,DEFEXT ;[2220] extensions and store it for CMD
MOVEI T2,OBFIL ;Look for a filename
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
HRRZM T2,RELFIL ;Store the new object file JFN
OBJRET: POPJ SREG, ;Return
OBFIL: FLDDB. (.CMFIL,CM%SDH,,<filespec of object file>) ;[2220]
.OPTION:
TRACE <.OPTION>
MOVEI T2,[FLDDB.(.CMFLD,CM%SDH,,<option name>)]
PUSHJ SREG,CMD ;Try and get option string
JRST RET.ERR ;EOF return--error command not completed
MOVE T1,[POINT 7,ATMBUF] ;Get pointer to option string
MOVE T2,[POINT 7,OPTION] ;Get pointer to where to store it
MOVEI T3,^D40 ;Get max. number characters allowed (including
;null character that ends string)
OPTLP: SOJL T3,OPTLNG ;Jump if option becomes too long
ILDB T4,T1 ;Get a character of the option string
CAILE T4,140 ;Is character lower case?
SUBI T4,40 ;Yes--Convert to upper case
IDPB T4,T2 ;Store in its new home
JUMPN T4,OPTLP ;Loop until null is copied
CAIN T3,^D39 ;Was option string null
JRST OPTSHT ;Jump if option is too short
POPJ SREG,
OPTLNG: SKIPA T1,[POINT 7,[ASCIZ \Option name may not exceed 39 characters\]]
OPTSHT: HRROI T1,[ASCIZ \Option name was not specified\] ;[2415]
JRST SEMERR ;[2415] Give error message
.WARN:
TRACE <.WARN>
SETZM NWON ;Clear first word of nowarn bits
MOVE T1,[XWD NWON,NWON+1] ;Clear nowarn "must be ON" bits
BLT T1,NWON+NWWDCT-1
SETOM NWOFF ;Set first word of nowarn bits
MOVE T1,[XWD NWOFF,NWOFF+1] ;Set nowarn "must be OFF" bits
BLT T1,NWOFF+NWWDCT-1
MOVX T3,SW.NOW ;Get /NOWARN flag
ANDCAM T3,ONFLG+$F ;Turn off bit that might say that flag is true
IORM T3,OFFFLG+$F ;Turn on bit that says that flag must be false
POPJ SREG,
SUBTTL CMDINI -- Initilize the COMND% JSYS
;Call to this routine:
; T1 CMDSOU designator
; T2 INPUT,,OUTPUT JFN's for command
; T3 Byte pointer to ASCIZ prompt
CMDINI:
MOVEM T1,CMDSOU ;Tell error routine from where commands come
MOVEM T2,STATE+.CMIOJ ;Store I/O JFNs in COMND% state block
MOVEM T3,STATE+.CMRTY ;Store prompt pointer for COMND%
MOVEI T1,STATE ;Point at COMND% state block
MOVEI T2,[FLDDB. (.CMINI)] ;Do COMND% initialize function
COMND%
ERJMP MONERR ;This should never happen!
POPJ SREG, ;Return
SUBTTL CMD -- Do a COMND% JSYS
;[2220] this routine added
;Call to this routine:
; MOVEI T2,descriptor ;Get address of function descriptor
; PUSHJ SREG,CMD ;Do COMND% JSYS
; End of file return
; Normal return
;
;
;Registers, on normal return:
; T1 COMND% state Flags,,Pointer to COMND% state block
; T2 Data returned by COMND%
; T3 Address for function descriptor used (the alternative found)
CMD:
MOVE T5,DEFEXT ;Get pointer to default extension pointer
SKIPN LKAHD ;Was the next field already scanned?
JRST CMDLP ;No--try to get next field
SETZM LKAHD ;No longer got the next field already scanned
MOVE T1,CMDFLG ;Restore T1, T2, and T3 to the values
MOVE T2,CMDDAT ;they had when this routine scanned
MOVE T3,CMDUSD ;the last field
AOS (SREG) ;Prepare to take normal return
POPJ SREG, ;Return
CMDLP: MOVE T4,(T5) ;Get pointer to file extension to try
MOVEM T4,CJFNBK+.GJEXT ;Store pointer for COMND%
MOVEI T1,STATE ;Point at COMND% state block
COMND%
ERJMP CMERR ;Maybe end of file?
TXNN T1,CM%NOP ;Was something found?
PJRST CFOUND ;Yes--process what was found
JUMPE T4,USRERR ;If hit the end of the list then got an error
HLRZ T2,T3 ;Get back address of descriptor used in call
AOJA T5,CMDLP ;Try next default extension
CFOUND: MOVEM T1,CMDFLG ;[2220] Save flags for possible later use
MOVEM T2,CMDDAT ;[2220] Save data for possible later use
HRRZ T3,T3 ;Get address of function descriptor used
MOVEM T3,CMDUSD ;[2220] Save which descriptor block was used
;[2220] for possible later use
AOS (SREG) ;Assume a normal return
CAIN T3,CONFIRM ;Was a carriage return found?
SKIPN ECHOFLG ;Is this command supposted to be echoed?
POPJ SREG, ;Take normal return
MOVE T1,STATE+.CMRTY ;Get pointer to prompt string
PSOUT% ;Echo on terminal
HRROI T1,BUFF ;Get pointer to command buffer
PSOUT% ;Echo on terminal
MOVE T1,CMDFLG ;Restore value returned by COMND% JSYS
POPJ SREG, ;Return
CMERR:
MOVX T1,.FHSLF ;This process's last error
GETER% ;Get last error in T2
HRRZ T2,T2 ;Throw away fork handle
CAIE T2,COMNX9 ;Was "error" really end of file?
CAIN T2,IOX4 ;Was "error" really end of file?
POPJ SREG, ;Yes--Take failure return
CAIE T2,COMNX2 ;Was field too long for internal buffer?
CAIN T2,COMNX3 ;Was command too long for internal buffer?
PJRST USRERR ;Yes--Show user where his command went wrong
CAIE T2,DESX1 ;[1711] Was error "invalid source designator"?
PJRST MONERR ;[1711] No--Some strange error happened
HLRZ T2,CMDSOU ;[1711] Get source of command
CAIE T2,FRMTTY ;[1711] Was source designator the terminal?
PJRST MONERR ;[1711] No--Some strange error happened
;[1711] The "error" was that the primary input JFN is illegal. This
;[1711] means that the compiler is being run as a background fork.
;[1711] Since the compiler cannot get another command string, simply
;[1711] exit.
HALTF% ;[1711]
JRST RET.OK ;[1711] Try and get a new command ...
SUBTTL ECMD -- Do a COMND% JSYS with error return
;[2220] This routine added
;Call to this routine:
; MOVEI T2,descriptor ;Get address of function descriptor
; PUSHJ SREG,ECMD ;Do COMND% JSYS
; EOF return ;EOF occured
; Error return ;Failure to find match
; Normal return
;
;
;Registers, on normal return:
; T1 COMND% state Flags,,Pointer to COMND% state block
; T2 Data returned by COMND%
; T3 Address for function descriptor used (the alternative found)
ECMD:
MOVE T5,DEFEXT ;Get pointer to default extension pointer
SKIPN LKAHD ;Was the next field already scanned?
JRST ECMDLP ;No--try to get next field
SETZM LKAHD ;No longer got the next field already scanned
MOVEI T1,2 ;Prepare to take normal return
ADDM T1,(SREG)
MOVE T1,CMDFLG ;Restore T1, T2, and T3 to the values
MOVE T2,CMDDAT ;they had when this routine scanned
MOVE T3,CMDUSD ;the last field
POPJ SREG, ;Return
ECMDLP: MOVE T4,(T5) ;Get pointer to file extension to try
MOVEM T4,CJFNBK+.GJEXT ;Store pointer for COMND%
MOVEI T1,STATE ;Point at COMND% state block
COMND%
ERJMP CMERR ;Maybe end of file?
TXNN T1,CM%NOP ;Was something found?
PJRST EFND ;Yes--process what was found
JUMPE T4,EERR ;If hit the end of the list then got an error
HLRZ T2,T3 ;Get back address of descriptor used in call
AOJA T5,ECMDLP ;Try next default extension
EFND: AOS (SREG) ;We know we have a normal return. The
;code at CFOUND will AOS return address again.
JRST CFOUND ;Process found code
EERR: AOS (SREG) ;Prepare to take error return
POPJ SREG, ;Take error return
SUBTTL SCANSW -- Scan SWITCH.INI
;Register usage:
; P1 Stores the first character of the switch line
; P2 Stores the old value of the /ECHO flag
; P3 Flag: True iff at least one line selected from SWITCH.INI
; P4 JFN of SWITCH.INI file
SCANSW:
TRACE <SCANSW:>
SKIPGE NOPTION ;Was /NOOPTION specified?
POPJ SREG, ;Yes--just return
PUSH SREG,P1 ;Save P1
PUSH SREG,P2 ;Save P2
PUSH SREG,P3 ;Save P3
PUSH SREG,P4 ;Save P4
PUSH SREG,P5 ;Save P5
PUSH SREG,P6 ;Save P6
PUSH SREG,STATE+.CMFLG ;Save the Reparse address of the COMND% JSYS
PUSH SREG,OLDSTK ;Save old "old stack pointer"
MOVEM SREG,OLDSTK ;Save stack pointer so we can abort
MOVX T1,GJ%SHT+GJ%OLD ;[1623] Short arg block, File must exist
HRROI T2,INIFIL ;[1623] Filename of SWITCH.INI is in INIFIL
GTJFN% ;[1623]
JRST NOINI ;[1623] Failure return--maybe no file at all?
HRRZ P4,T1 ;Save JFN of switch file for later use
SETZ P3, ;[1611] No lines yet selected from SWITCH.INI
MOVE P2,ECHOFLG ;Save the value of the /ECHO flag
MOVE T1,OPTECHO ;Get the value of the SWITCH.INI echo flag
MOVEM T1,ECHOFLG ;Store in new value of the echo flag
MOVE T1,P4 ;Get JFN of switch file
MOVX T2,FLD(7,OF%BSZ)+.GSNRM+OF%RD ;ASCII chars, normal read access
OPENF%
JRST [CAIN T1,OPNX31 ;[1672] Did open fail because file was offline?
JRST RET.OK ;[1672] Yes--Not an error, just return
JRST IOERR] ;[1672] No--We have a real I/O error
NEWLINE:
TRACE <NEWLINE:>
MOVE T1,P4 ;Get JFN of SWITCH.INI for BIN% JSYS
MOVE T3,[POINT 7,[ASCIZ \FORTRA\]] ;Look for line starting with ...
FNDPFX: BIN%
ERJMP EOF
CAILE T2,140 ;Is character lower case?
SUBI T2,40 ;Yes--Convert to upper case
ILDB T4,T3 ;Get character from pattern
CAMN T4,T2 ;Is this the character we are looking for?
JUMPN T4,FNDPFX ;Yes--but let's not be fooled by null
JUMPN T4,REJECT ;Reject this line, if ending char wasn't null
CAIE T2,"N" ;[1611] Is character the optional "N"
JRST DIFFER ;[1611]No--make sure char doesn't differentiate
;[1611] FORTRAN from some other program
BIN% ;[1611] Get character following the "N"
ERJMP EOF ;[1611]
CAILE T2,140 ;[1611] Is character lower case?
SUBI T2,40 ;[1611] Yes--Convert to upper case
DIFFER: CAIN T2,"-" ;Is character a hyphen
JRST REJECT ;Yes--Reject this line
CAIGE T2,"0" ;Is character outside the range of digits?
JRST GETOPT ;Yes--Try and get the option string
CAIG T2,"9" ;Is character outside the range of digits?
JRST REJECT ;No--Reject this line
CAIGE T2,"A" ;Is character outside the range of letters?
JRST GETOPT ;Yes--Try and get the option string
CAIG T2,"Z" ;Is character outside the range of letters?
JRST REJECT ;No--Reject this line
GETOPT: SKIPN OPTION ;Is the option string from /OPTION null?
JRST NOCOLON ;Yes--A selected line if it doesn't have colon
CAIE T2,":" ;Is this character a colon?
JRST REJECT ;No--Scan line for continuation
MOVE T3,[POINT 7,OPTION] ;Look for the option
FNDOPT: BIN%
ERJMP EOF
CAILE T2,140 ;Is character lower case?
SUBI T2,40 ;Yes--Convert to upper case
ILDB T4,T3 ;Get character from option pattern
CAMN T4,T2 ;Is this the character we are looking for?
JUMPN T4,FNDOPT ;Yes--but let's not be fooled by null
JUMPN T4,REJECT ;Reject this line, if ending char wasn't null
CAIN T2,"-" ;Is character a hyphen
JRST REJECT ;Yes-Reject this line
CAIGE T2,"0" ;Is character outside the range of digits?
JRST SELECT ;Yes--Select this line
CAIG T2,"9" ;Is character outside the range of digits?
JRST REJECT ;No--Reject this line
CAIGE T2,"A" ;Is character outside the range of letters?
JRST SELECT ;Yes--Select this line
CAIG T2,"Z" ;Is character outside the range of letters?
JRST REJECT ;No--Reject this line
SELECT:
TRACE <SELECT:>
SETO P3, ;[1611] At least one line has been selected
MOVE P1,T2 ;Save the unparsed character
MOVE T1,P4 ;Get JFN of COMND% input
HRLI T1,FRMSWI ;Input is coming from SWITCH.INI
HRL T2,P4 ;COMND% JSYS input comes from SWITCH.INI
HRRI T2,.NULIO ;COMND% JSYS output goes to NUL:
HRROI T3,[ASCIZ \SWITCH.INI: \] ;[2415] Prompt pointer
PUSHJ SREG,CMDINI ;Init COMND% JSYS and its state block
AOS STATE+.CMINC ;We have one unparsed character already
DPB P1,[POINT 7,BUFF,6] ;Store the character in COMND%'s buffer
PUSHJ SREG,SSWITCH ;Scan the switch line
JUMPE VREG,NEWLINE ;If all is OK, then look for more lines
JUMPG VREG,REJECT ;If an error occured, reject rest of line
JRST CLOSE ;If EOF, then close files
NOCOLON:
CAIE T2,":" ;Is character a colon?
JRST SELECT ;Yes--This line has been selected
REJECT:
TRACE <REJECT:>
BIN%
ERJMP EOF
CAIN T2,"!" ;Is character a exclamation point?
JRST EXCL ;Yes--look for end of comment
CAIN T2,";" ;Is character a semicolon?
JRST SEMI ;Yes--find end of line
CAIN T2,"-" ;Is character a minus sign?
JRST MINUS ;Yes--see if this line is continued
CAIE T2,.CHCRT ;Is character a carriage return?
JRST REJECT ;No--Get another character
EATLF:
BIN%
ERJMP EOF
JRST NEWLINE ;See if we want this line
EXCL: BIN%
ERJMP EOF
CAIN T2,"!" ;Is character an exclamation point?
JRST REJECT ;Yes--comment closed
CAIE T2,.CHCRT ;Is character a carriage return?
JRST EXCL ;No--get another character
JRST EATLF
SEMI:
BIN%
ERJMP EOF
CAIE T2,.CHCRT ;Is character a carriage return?
JRST SEMI ;No--get another character
JRST EATLF
MINUS:
BIN%
ERJMP EOF
CAIE T2,.CHCRT ;Is character a carriage return?
JRST REJECT ;Nope--continue scanning line
BIN% ;Eat a linefeed
ERJMP EOF
JRST REJECT ;Scan this line as a continuation of the first
EOF:
TRACE <EOF>
MOVE T1,P4 ;Get JFN of SWITCH.INI
GTSTS% ;Get status of that JFN
TXNE T2,GS%EOF ;Did end of file occur?
JRST CLOSE ;Yes--Close up and go home (to get some sleep)
IOERR: MOVEM P2,ECHOFLG ;[1645] Restore the /ECHO flag
MOVX T1,.FHSLF ;This process
GETER% ;Get last error in T2
HRRZ T2,T2 ;Throw away fork handle
HRROI T1,[ASCIZ \%FTNCMD \] ;[1672]
PSOUT% ;[1672]
MOVX T1,.PRIOU ;Primary output stream
HRLOI T2,.FHSLF ;This process' most recent error
SETZ T3, ;Write all of message
ERSTR%
JRST UNKERR ;Unknown error return
JRST BADCALL ;Bad call to ERSTR% return
HRROI T1,[ASCIZ \
Error occurred while processing file SWITCH.INI from your logged-in directory
\] ;[1672]
PSOUT% ;[1672]
JRST RET.ERR ;[1672] Return and signal error
CLOSE: MOVEM P2,ECHOFLG ;[1645] Restore the /ECHO flag
MOVE T1,P4 ;Get JFN of SWITCH.INI
CLOSF% ;Close file
ERJMP IOERR
JUMPN P3,RET.OK ;[1611] If at least one line was select, all OK
SKIPN OPTION ;[1611]If the user didn't give a /OPTION switch
JRST RET.OK ;[1611] then all is OK
;The user gave a /OPTION switch but no line from SWITCH.INI martched.
;Warn user that the option string was probably mistyped.
HRROI T1,[ ASCIZ \%FTNCMD No lines from SWITCH.INI matched the /OPTION: specified.
\]
PSOUT ;[1611]
JRST RET.OK ;Return to caller
NOINI: CAIE T1,GJFX24 ;[1623] Was file not found?
CAIN T1,GJFX18 ;[1623] Was there no such filename?
JRST RET.OK ;[1623] Yes--no switch file exits, just return
CAIN T1,GJFX19 ;[1623] Was there no such filetype?
JRST RET.OK ;[1623] Yes--no switch file exits, just return
HRROI T1,[ASCIZ \%FTNCMD Can't read SWITCH.INI -- \] ;[1623]
PSOUT% ;[1623]
MOVX T1,.PRIOU ;[1623] Primary output stream
HRLOI T2,.FHSLF ;[1623] This process' most recent error
SETZ T3, ;[1623] Write all of message
ERSTR% ;[1623]
NOOP ;[1623] Unknown error return
NOOP ;[1623] Bad call to ERSTR% return
HRROI T1,[ASCIZ \
\] ;[1623]
PSOUT% ;[1623]
JRST RET.OK ;[1623]Since only a warning, take normal return
;[2220] This routine rewritten
;Note that this routine may abort. If it aborts,
;VREG will have the value:
; -1 if a EOF occured
; 1 if an error occured
;If nothing when wrong, this routine will return and
;VREG will have the value zero.
SSWITCH:
PUSH SREG,P1 ;Save P1
PUSH SREG,P2 ;Save P2
PUSH SREG,P3 ;Save P3
PUSH SREG,P4 ;Save P4
PUSH SREG,P5 ;Save P5
PUSH SREG,P6 ;Save P6
PUSH SREG,STATE+.CMFLG ;Save the Reparse address of the COMND% JSYS
PUSH SREG,OLDSTK ;Save old "old stack pointer"
MOVEM SREG,OLDSTK ;Save stack pointer so we can abort
GETSWITCH:
HRROI T1,[ASCIZ \FTNCMD \] ;Get pointer to prefix of error messages
MOVEM T1,ERRPFX ;Store error message prefix
MOVEI T2,COMPSW ;Look for compile switches
MOVEM T2,FOLLOW ;Set up follow set for /EXTEND
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
CAIN T3,CONFIRM ;Was command confirmed?
JRST RET.OK ;Yes--Take normal return.
HRRZ T2,(T2) ;Get action code
PUSHJ SREG,@(T2) ;Call routine to process switch
JRST GETSWITCH ;Need to get a new switch
SUBTTL Command Line Error Routines
USRERR:
TRACE <USRERR>
SETZM ERRTXT ;[2415] Use ERSTR% to get error string
JRST MAYECH ;[2415] See if we need to echo cmd line
SEMERR: TRACE <SEMERR> ;[2415] Use the error string suppiled by caller
MOVEM T1, ERRTXT ;[2415] Store the pointer to error text
MAYECH: ;[2415] Echo command if the ECHOFLG switch is on ...
SKIPE ECHOFLG ;Is this command supposted to be echoed?
JRST DOECHO ;[2415] Yes--echo it
;[2415] ... or echo command if command came from a TAKE file
HLRZ T1,CMDSOU ;[2415] Get source of command
CAIE T1,FRMTAK ;[2415] Is source of command a TAKE file?
JRST NOECHO ;[2415] Not a TAKE file, don't echo command
DOECHO: MOVE T1,STATE+.CMRTY ;Get pointer to prompt string
PSOUT% ;Echo on terminal
HRROI T1,BUFF ;Get pointer to command buffer
PSOUT% ;Echo on terminal
NOECHO:
MOVE T1,ERRPFX ;Get prefix string of error message
ESOUT%
SKIPE T1,ERRTXT ;[2415] Get ptr to error string; see if valid
JRST USEET ;[2415] Error test ptr is valid, use it
; No caller supplied error text, so get it from Monitor
MOVX T1,.PRIOU ;Primary output stream
HRLOI T2,.FHSLF ;This process' most recent error
SETZ T3, ;Write all of message
ERSTR%
JRST UNKERR ;Unknown error return
JRST BADCALL ;Bad call to ERSTR% return
JRST PUTBD ;All went OK, write bad part of command
USEET: PSOUT% ;[2415] Write out caller supplied error text
; This section of code determines the number of unparsed characters
; that are in the command buffer minus the number of characters
; that terminated the command. The number of terminating chars
; is one except in the case of line-feed, which may be preceded
; by a carriage return. Register P1 will hold the result.
PUTBD: MOVE P1,STATE+.CMINC ;[2415] Get number of unparsed chars in buffer
MOVE T1,P1 ;Copy set up for ADJBP
SOJ P1, ;Last char is terminator--don't count it
ADJBP T1,STATE+.CMPTR ;Get ptr to last char of text unparsed
LDB T3,T1 ;Get last char
CAIE T3,.CHLFD ;Was character a linefeed?
JRST OUT ;No, we now know length of unparsed string
SETO T2, ;T2 gets minus one
ADJBP T2,T1 ;Backup byte pointer, put it in T2
LDB T3,T2 ;Get new last char
CAIN T3,.CHCRT ;Is character a carriage return?
SOJ P1, ;Yes, don't count it
OUT:
HRROI T1,[ASCIZ \ -- "\]
PSOUT%
MOVX T1,.PRIOU ;Type on terminal
MOVE T2,STATE+.CMPTR ;Get ptr to text left unparsed
MOVN T3,P1 ;Get negative count
CAIE T3,0 ;If there is some error text
SOUT% ; then write it out
HRROI T1,[ASCIZ \"
\]
PSOUT%
HLRZ T4,CMDSOU ;Get source of command
CAIN T4,FRMTTY ;Did the command come from the terminal?
JRST RET.ERR ;Yes--Don't tell user where command came from
HRROI T1,[ASCIZ \Error occurred while processing \]
PSOUT%
MOVE T1,FRMTAB-1(T4) ;Get source message
PSOUT%
HRRZ T2,CMDSOU ;Get optional JFN of source
JUMPE T2,WRIRET ;If no JFN, then write final return-linefeed
MOVEI T1,.PRIOU ;Output goes to terminal
MOVE T3,[FLD(.JSSSD,JS%DEV)+FLD(.JSSSD,JS%DIR)+FLD(.JSSSD,JS%NAM)+FLD(.JSAOF,JS%TYP)+JS%PAF]
JFNS%
WRIRET: HRROI T1,[ASCIZ \
\]
PSOUT%
JRST RET.ERR ;Return and signal error
FRMTAB: POINT 7,[ASCIZ \arguments from the EXEC\]
POINT 7,[ASCIZ \command file \] ;[1657]
POINT 7,[ASCIZ \switch file \]
POINT 7,[ASCIZ \a TOPS-10 command line\]
MONERR:
HRROI T1,[ASCIZ \FTNCMD \]
ESOUT%
MOVX T1,.PRIOU ;Primary output stream
HRLOI T2,.FHSLF ;This process' most recent error
SETZ T3, ;Write all of message
ERSTR%
JRST UNKERR ;Unknown error return
JRST BADCALL ;Bad call to ERSTR% return
PJRST WRIRET ;Write final CR/LF and return
UNKERR:
TRACE <UNKERR>
HRROI T1,[ASCIZ \Unknown error
\]
PSOUT%
JRST RET.ERR ;Return and signal error
BADCALL:
TRACE <BADCALL>
HRROI T1,[ASCIZ \Bad call to ERSTR%
\]
PSOUT%
JRST RET.ERR ;Return and signal error
SUBTTL Return Code
RET.ERR: MOVEI VREG,1 ;Return value of 1 means error encountered
JRST RESTOR
RET.OK: TDZA VREG,VREG ;RETURN value of 0 means that all is OK
RET.EOF: SETO VREG, ;Return value of -1 means EOF was encountered
RESTOR: MOVE SREG,OLDSTK ;Recover the original stack pointer
POP SREG,OLDSTK
POP SREG,STATE+.CMFLG ;Restore the Reparse address for COMND% JSYS
POP SREG,P6 ;Restore P6
POP SREG,P5 ;Restore P5
POP SREG,P4 ;Restore P4
POP SREG,P3 ;Restore P3
POP SREG,P2 ;Restore P2
POP SREG,P1 ;Restore P1
POPJ SREG, ;Return
SUBTTL SCAN10 - The TOP-10 Compatibility Command Scanner
;Register Usage:
; P1 Location to return to after processing a switch
; P2 Flag--Has an object file been specified?
; P3 Flag--Has a list file been specified?
SCAN10:
PUSH SREG,P1 ;Save P1
PUSH SREG,P2 ;Save P2
PUSH SREG,P3 ;Save P3
PUSH SREG,P4 ;Save P4
PUSH SREG,P5 ;Save P5
PUSH SREG,P6 ;Save P6
PUSH SREG,STATE+.CMFLG ;Save the Reparse address of the COMND% JSYS
PUSH SREG,OLDSTK ;Save old "old stack pointer"
MOVEM SREG,OLDSTK ;Save stack pointer so we can abort
MOVEI T1,XREP10 ;Get address of code to handle a reparse
HRRM T1,STATE+.CMFLG ;Store in state block
JRST OBJ10
XREP10:
TRACE <XREP10>
MOVE SREG,OLDSTK ;Restore the stack pointer
SKIPL T1,RELFIL ;Get JFN of object file
RLJFN% ;Release JFN
ERJMP MONERR
SKIPL T1,LSTFIL ;Get JFN of list file
RLJFN% ;Release JFN
ERJMP MONERR
SKIPGE T5,FORIDX ;Get index to JFN of last source file
JRST OBJ10 ;No source file JFN's
XRL: MOVE T1,FORFIL(T5) ;Get JFN of next source file
RLJFN% ;Release JFN
ERJMP MONERR
SOJGE T5,XRL ;Loop to release rest of source file JFN's
OBJ10:
PUSHJ SREG,INIT ;Clear flags
SETOM LSTFIL ;Clear JFN of list file
SETOM RELFIL ;Clear JFN of object file
SETOM FORIDX ;No source files have JFN's
SETZM LSTTYP ;Throw away typescript from /LIST:
SETZM OPTECHO ;Don't echo options from SWITCH.INI
SETZM NOPTION ;/NOOPTION has not been seen--read SWITCH.INI
SETZM OPTION ;No option string has been given
SETZM LKAHD ;[2220] Next symbol not scanned yet
HRROI T4,[ASCIZ \FTNCMD \]
MOVEM T4,ERRPFX ;Store error message prefix
SETZB P2,P3 ;Assume /NOOBJECT and /NOLIST
MOVEI P1,. ;Location to return to if a switch is found
MOVX T1,GJ%FOU+GJ%XTN
MOVEM T1,CJFNBK+.GJGEN ;Set default flags for object file
HRROI T1,[ASCIZ \DSK\]
MOVEM T1,CJFNBK+.GJDEV ;Set default device for object file
SETZM CJFNBK+.GJNAM ;No default name for object file
MOVEI T1,RELEXT ;[2220]
MOVEM T1,DEFEXT ;[2220] Set default extension for object file
MOVEI T2,OFILE ;Look for a filename, comma, equal, or switch
MOVEM T2,FOLLOW ;[2220] Setup follow set for /EXTEND switch
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
CAIN T3,COMPSW ;Was a switch found?
JRST DOSW ;Yes--Process the switch
CAIN T3,CONFIRM ;Was a carriage return found?
JRST ERR1 ;Yes--Give error message
CAIN T3,EQUAL ;Was an equal sign found?
JRST SOU10 ;Yes--Get source files
CAIN T3,COMMA1 ;Was a comma found?
JRST LIST10 ;Yes--Get listing file
SETO P2, ;Got a object file
HRRZM T2,RELFIL ;Store its JFN
MOVX T1,RELFLG ;Get flag that says a .REL file is being made
IORM T1,ONFLG+$F ;Turn on flag that says a .REL file is made
ANDCAM T1,OFFFLG+$F ;Turn off the no .REL file flag
MOVEI P1,. ;Come back here if switch is found
MOVEI T2,COMMA1 ;Look for a comma, switch, equals
MOVEM T2,FOLLOW ;[2220] Setup follow set for /EXTEND switch
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
CAIN T3,COMPSW ;Was a switch found?
JRST DOSW ;Yes--Process the switch
CAIN T3,CONFIRM ;Was a carriage return found?
JRST ERR1 ;Yes--Give error message
CAIN T3,EQUAL ;Was an equal sign found?
JRST SOU10 ;Yes--Get source file
LIST10:
MOVEI P1,. ;[2220] Location to return to after switch
MOVX T1,GJ%FOU+GJ%XTN
MOVEM T1,CJFNBK+.GJGEN ;Set default flags of list file
HRROI T1,[ASCIZ \DSK\]
MOVEM T1,CJFNBK+.GJDEV ;Set default device of list file
SETZM CJFNBK+.GJNAM ;No default name of list file
MOVEI T1,LSTEXT ;[2220]
MOVEM T1,DEFEXT ;[2220] Set default extension of list file
MOVEI T2,LFILE ;Look for a file, equal, or switch
MOVEM T2,FOLLOW ;[2220] Setup follow set for /EXTEND switch
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
CAIN T3,COMPSW ;Was a switch found?
JRST DOSW ;Yes--Process the switch
CAIN T3,CONFIRM ;Was a carriage return found?
JRST ERR1 ;Yes--Give error message
CAIN T3,EQUAL ;Was a equal sign found?
JRST SOU10 ;Yes--Get source file
SETO P3, ;Got a listing file
HRRZM T2,LSTFIL ;Store its JFN
MOVX T1,LSTFLG ;Get flag that says a list file is being made
IORM T1,ONFLG+$F ;Turn on flag that says a list file is made
ANDCAM T1,OFFFLG+$F ;Turn off the no list file flag
MOVE T1,[POINT 7,ATMBUF]
MOVE T2,[POINT 7,LSTTYP]
L10CPY: ILDB T3,T1 ;Copy what the user typed . . .
IDPB T3,T2 ;. . . into the area to hold his typescript
JUMPN T3,L10CPY ;Copy until null byte is found
MOVEI P1,. ;Come back here if a switch is found
MOVEI T2,EQUAL ;Look for a equal sign or switch
MOVEM T2,FOLLOW ;[2220] Setup follow set for /EXTEND switch
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
CAIN T3,COMPSW ;Was a switch found?
JRST DOSW ;Yes--Process the switch
CAIN T3,CONFIRM ;Was a carriage return found?
JRST ERR1 ;Yes--Give error message
SOU10:
MOVEI P1,. ;Come back here is a switch is found
MOVX T1,GJ%OLD!GJ%XTN
MOVEM T1,CJFNBK+.GJGEN ;Set default flags for source file
HRROI T1,[ASCIZ \DSK\]
MOVEM T1,CJFNBK+.GJDEV ;Set default device for source file
SETZM CJFNBK+.GJNAM ;No default name for source file
MOVEI T1,FOREXT ;[2220]
MOVEM T1,DEFEXT ;[2220] Set default extension for source file
LOOP10:
MOVEI T2,SFILE ;Look for a source file or switch
MOVEM T2,FOLLOW ;[2220] Setup follow set for /EXTEND switch
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST USRERR ;EOF return--command not completed
CAIN T3,COMPSW ;Was a switch found?
JRST DOSW ;Yes--Process the switch
CAIN T3,CONFIRM ;Was a carriage return found?
JRST ERR1 ;Yes--Give error message
AOS T1,FORIDX ;Get index to use to store new source file JFN
CAIL T1,MAXFILES ;Does index still fit in table
JRST TOOMANY ;No--give an error message
HRRZM T2,FORFIL(T1) ;Store JFN of source file
MOVEI P1,. ;Come back here if a switch is found
MOVEI T2,COMMA2 ;Look for a comma, switch, or confirm
MOVEM T2,FOLLOW ;[2220] Setup follow set for /EXTEND switch
PUSHJ SREG,CMD ;Do COMND% JSYS
JRST EOC ;EOF return--Command is done, call compiler
CAIN T3,CONFIRM ;Was a carriage return found?
JRST EOC ;Yes--Call compiler
CAIE T3,COMPSW ;Was a switch found?
JRST LOOP10 ;No--Loop to get source file
DOSW:
HRRZ T2,(T2) ;Get action code
PUSHJ SREG,@(T2) ;Call routine to process switch
HRROI T4,[ASCIZ \FTNCMD \] ;[2220]
MOVEM T4,ERRPFX ;[2220] Store error message prefix
JRST (P1) ;Return to processing command line
EOC:
SETZM DEFFIL ;The default filename shouldn't be used
JUMPN P2,CHKLST ;Was an object file specified?
MOVX T3,RELFLG ;No--Get flag object file flag
ANDCAM T3,ONFLG+$F ;Turn off bit that might say that flag is true
IORM T3,OFFFLG+$F ;Turn on bit that says that flag must be false
CHKLST: SKIPN P3 ;Was a list file specified?
PUSHJ SREG,.NOLIST ;No--Make sure list flags are turned off
PUSHJ SREG,DOCOMPILE ;Compile this program
JRST RET.OK
ERR1: HRROI T1,[ASCIZ \You may not end a TOPS-10 style command at this point\] ;[2415]
JRST SEMERR ;[2220][2415]
OFILE: FLDDB. (.CMFIL,,,,,COMMA1)
LFILE: FLDDB. (.CMFIL,,,,,EQUAL)
SFILE: FLDDB. (.CMFIL,,,,,COMPSW)
EQUAL: FLDDB. (.CMTOK,,<POINT 7,[ASCIZ \=\]>,,,COMPSW)
COMMA1: FLDDB. (.CMCMA,,,,,EQUAL)
COMMA2: FLDDB. (.CMCMA,,,,,PLUS)
PLUS: FLDDB. (.CMTOK,,<POINT 7,[ASCIZ \+\]>,,,COMPSW)
SUBTTL Flag Mask Definitions
SALL
;FLAG BITS IN F (SEE IOFLG.BLI and COMMAN.MAC 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:
;FLAG BITS IN F2 (SEE IOFLG.BLI and COMMAN.MAC 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
SW.EXT==1B3 ;[1504] /EXTEND
SW.CFS==1B4 ;[2246] /FLAG:ANSI
SW.CFV==1B5 ;[2455] /FLAG:VMS
SW.EXC==1B6 ;[2442] /EXTEND:CODE
;FLAG BITS IN FLAGS2 (SEE IOFLG.BLI and COMMAN.MAC BEFORE CHANGING THESE BITS)
TTYINP==1B0 ;INPUT DEVICE IS A TTY
GFMCOK==1B1 ;GFLOATING MICROCODE PRESENT
FTLCOM==1B2 ;[1160] Fatal errors during this compile command
SW.ABO==1B3 ;Abort (exit) on fatal errors
SUBTTL Default file extension tables for COMND% JSYS
;[2220] These tables created
;These are the tables of the default file extensions to try when
;a filespec is being scanned. The end of the list is marked by
;a zero word, which means that as a last resort, no particular
;extension default is used.
;Table of default extensions for source files
FOREXT: POINT 7,[ASCIZ /FOR/]
IFN FTUS,< ;A DEC in-house feature
POINT 7,[ASCIZ /FTP/]
> ;A DEC in-house feature
EXP 0 ;End of list
;Table of default extensions for object files
RELEXT: POINT 7,[ASCIZ /REL/]
EXP 0
;Table of default extensions for list files /NOCROSS-REFERENCE
LSTEXT: POINT 7,[ASCIZ /LST/]
EXP 0
;Table of default extensions for list files /CROSS-REFERENCE
CRFEXT: POINT 7,[ASCIZ /CRF/]
EXP 0
;Table of default extensions for TAKE command
CMDEXT: POINT 7,[ASCIZ /CMD/]
EXP 0 ;End of list
;Table of default extensions for RUN command
EXEEXT: POINT 7,[ASCIZ /EXE/]
EXP 0 ;End of list
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>
>
KEYWD: FLDDB. (.CMKEY,0,ACTCMD,<Command,>,,CMFIL0) ;[2220]
CMFIL0: FLDDB. (.CMFIL,CM%SDH,,<filespec of source file to implicitly begin COMPILE command>,,CMSWI0) ;[2220]
CMSWI0: FLDDB. (.CMSWI,0,COMSW,<switch to implicitly begin COMPILE command,>,,ACTNSW) ;[2417]
COMPSW: FLDDB. (.CMSWI,0,COMSW,<a compilation switch,>,,CONFIRM)
ACTNSW: FLDDB. (.CMSWI,CM%SDH,ACTSW) ;[2417]
CONFIRM:
FLDDB. (.CMCFM)
OFFSET: FLDDB. (.CMSWI,0,OFFSX,,,CONFIRM)
OFFSX: XWD 2,2
TBL <OFFSET:>,,0
TBL <RUNOFFSET:>,INVIS,0
ECHO:
FLDDB. (.CMSWI,0,ECHOX,,,CONFIRM)
ECHOX:
XWD 2,2 ;[1645]
TBL <ECHO>,,1
TBL <NOECHO>,,0 ;[1645]
DB.K1: FLDDB. (.CMKEY,0,DT,<a debugging option,>,(ALL),DB.K3) ;[2220]
DB.K2: FLDDB. (.CMKEY,0,DT,<a debugging option,>) ;[2415]
DB.K3: FLDDB. (.CMTOK,CM%SDH,<POINT 7,[ASCIZ \(\]>,<"(" followed by a list of debugging options>) ;[2220]
ET.K1: FLDDB. (.CMKEY,0,ET,<an EXTEND keyword,>,(DATA:10000,COMMON,NOCODE,PSECT:.DATA.:.CODE.),ET.K3) ;[2445]
ET.K2: FLDDB. (.CMKEY,0,ET,<an EXTEND keyword,>) ;[2415]
ET.K3: FLDDB. (.CMTOK,CM%SDH,<POINT 7,[ASCIZ \(\]>,<"(" followed by a list of EXTEND keywords>) ;[2220]
EC.K1: FLDDB. (.CMTOK,CM%SDH,<POINT 7,[ASCIZ \(\]>,<"(" followed by a list of COMMON block names>,,EC.K3) ;[2343]
EC.K2: FLDBK. (.CMFLD,CM%BRK,,<a COMMON block name>,,EC.BK) ;[2343]
EC.K3: FLDBK. (.CMFLD,CM%BRK,,<a COMMON block name>,,EC.BK,) ;[2415]
EC.BK: BRMSK.(FLDB0.,FLDB1.,FLDB2.,FLDB3.,<.$_>,<->) ;[4530]
EP.DA: FLDBK. (.CMFLD,CM%BRK,,<Name of the data psect>,.DATA.,EP.BK,EP.CL) ;[2445]
EP.CO: FLDBK. (.CMFLD,CM%BRK,,<Name of the code psect>,.CODE.,EP.BK) ;[2445]
EP.BK: BRMSK.(FLDB0.,FLDB1.,FLDB2.,FLDB3.,<.$%>,<->) ;[2445]
CF.K1: FLDDB. (.CMKEY,0,CF,<a FLAG keyword,>,(ALL),CF.K3) ;[2320]
CF.K2: FLDDB. (.CMKEY,0,CF,<a FLAG keyword,>) ;[2415]
CF.K3: FLDDB. (.CMTOK,CM%SDH,<POINT 7,[ASCIZ \(\]>,<"(" followed by a list of FLAG keywords>) ;[2246]
WN.K1: FLDDB. (.CMKEY,0,WT,<warning message mnemonic,>,(ALL),WN.K3) ;[2220]
WN.K2: FLDDB. (.CMKEY,0,WT,<warning message mnemonic,>) ;[2415]
WN.K3: FLDDB. (.CMTOK,CM%SDH,<POINT 7,[ASCIZ \(\]>,<"(" followed by a list of warning mnemonics>) ;[2220]
COMMA: FLDDB. (.CMCMA,CM%SDH,,<"," or ")">,,LEFTP)
LEFTP: FLDDB. (.CMTOK,CM%SDH,<POINT 7,[ASCIZ \)\]>)
ACTSW: XWD ACTSWL,ACTSWL ;Count of number of entries
TBL <EXIT>,INVIS,.EXIT ;[2417]
TBL <HELP>,INVIS,.HELP ;[2417]
TBL <RUN:>,INVIS,.RUN ;[2417]
TBL <TAKE:>,INVIS,.TAKE ;[2417]
ACTSWL==.-ACTSW-1
ACTCMD: XWD ACTCML,ACTCML ;[2220] Create this table
TBL <COMPILE>,,.COMPILE
TBL <EXIT>,,.EXIT
TBL <HELP>,,.HELP
TBL <RUN>,,.RUN
TBL <TAKE>,,.TAKE
ACTCML==.-ACTCMD-1
SUBTTL Compilation Switch Table
COMSW: XWD COMSWL,COMSWL ;Count of number of entries
TBL <A>,ABBRIV,XXA
XXA: TBL <ABORT>,,[EXP SETFLG,SW.ABO,$FLAGS2]
TBL <B>,ABBRIV,XXB
XXB: TBL <BINARY:>,,[.OBJECT]
TBL <BUGOUT:>,INVIS,[.BUGOUT]
TBL <C>,ABBRIV,XXC
TBL <CR>,ABBRIV,XXC
TBL <CREF>,INVIS,[EXP SETFLG,SW.CRF,$F]
TBL <CRO>,ABBRIV,XXC
TBL <CROS>,ABBRIV,XXC
TBL <CROSS>,ABBRIV,XXC
XXC: TBL <CROSS-REFERENCE>,,[EXP SETFLG,SW.CRF,$F]
TBL <CROSSREFERENCE>,INVIS,[EXP SETFLG,SW.CRF,$F]
TBL <D>,ABBRIV,XXD
XXD: TBL <DEBUG:>,,[.DEBUG]
TBL <DFLOATING>,,[EXP CLRFLG,SW.GFL,$F2] ;[1611]
TBL <ECHO-OPTION>,,[.ECHOOP]
TBL <ERRORS>,,[EXP CLRFLG,SW.NET,$F]
TBL <EXPAND>,,[EXP SETFLG,SW.EXP,$F]
TBL <EXTEND:>,,[.EXTEND] ;[2220]
TBL <F>,ABBRIV,XXF ;[2320]
TBL <F66>,,[EXP CLRFLG,SW.F77,$F2]
TBL <F77>,,[EXP SETFLG,SW.F77,$F2]
XXF: TBL <FLAG-NON-STANDARD:>,,[.FLAG] ;[2320]
TBL <GFLOATING>,,[EXP SETFLG,SW.GFL,$F2]
TBL <INCLUDE>,,[EXP SETFLG,SW.IDS,$F]
TBL <L>,ABBRIV,XXL
XXL: TBL <LISTING:>,,[.LIST]
TBL <LNMAP>,,[EXP SETFLG,SW.MAP,$F]
TBL <M>,ABBRIV,XXM
TBL <MA>,ABBRIV,XXM
TBL <MAC>,ABBRIV,XXM
XXM: TBL <MACHINE-CODE>,,[EXP SETFLG,SW.MAC,$F]
TBL <MACRO>,INVIS,[EXP SETFLG,SW.MAC,$F]
TBL <NOABORT>,,[EXP CLRFLG,SW.ABO,$FLAGS2]
TBL <NOBINARY>,,[EXP CLRFLG,RELFLG,$F]
TBL <NOC>,ABBRIV,XXNOC
TBL <NOCR>,ABBRIV,XXNOC
TBL <NOCREF>,INVIS,[EXP CLRFLG,SW.CRF,$F]
TBL <NOCRO>,ABBRIV,XXNOC
TBL <NOCROS>,ABBRIV,XXNOC
TBL <NOCROSS>,ABBRIV,XXNOC
XXNOC: TBL <NOCROSS-REFERENCE>,,[EXP CLRFLG,SW.CRF,$F]
TBL <NOCROSSREFERENCE>,INVIS,[EXP CLRFLG,SW.CRF,$F]
TBL <NOD>,ABBRIV,XXNOD
XXNOD: TBL <NODEBUG>,,[.NODEBUG]
TBL <NOERRORS>,,[EXP SETFLG,SW.NET,$F]
TBL <NOEXPAND>,,[EXP CLRFLG,SW.EXP,$F]
TBL <NOEXTEND>,,[.NOEXTEND] ;[2220]
TBL <NOF>,ABBRIV,XXNOF ;[2320]
TBL <NOF77>,,[EXP CLRFLG,SW.F77,$F2]
XXNOF: TBL <NOFLAG-NON-STANDARD>,,[.NOFLAG] ;[2320]
TBL <NOINCLUDE>,,[EXP CLRFLG,SW.IDS,$F]
TBL <NOL>,ABBRIV,XXNOL
XXNOL: TBL <NOLISTING>,,[.NOLIST]
TBL <NOLNMAP>,,[EXP CLRFLG,SW.MAP,$F]
TBL <NOM>,ABBRIV,XXNOM
TBL <NOMA>,ABBRIV,XXNOM
TBL <NOMAC>,ABBRIV,XXNOM
XXNOM: TBL <NOMACHINE-CODE>,,[EXP CLRFLG,SW.MAC,$F]
TBL <NOMACRO>,INVIS,[EXP CLRFLG,SW.MAC,$F]
TBL <NOOBJECT>,INVIS,[EXP CLRFLG,RELFLG,$F]
TBL <NOOPT>,ABBRIV,XXNOOPT ;[1611]
TBL <NOOPTIMIZE>,,[EXP CLRFLG,SW.OPT,$F]
XXNOOPT:TBL <NOOPTION>,,[.NOOPTION]
TBL <NOS>,ABBRIV,XXNOS
TBL <NOSTATISTICS>,INVIS,[EXP CLRFLG,SW.STA,$F2]
XXNOS: TBL <NOSYNTAX>,,[EXP CLRFLG,SW.OCS,$F]
TBL <NOW>,ABBRIV,XXNOW
XXNOW: TBL <NOWARNINGS:>,,[.NOWARN]
TBL <O>,ABBRIV,XXO ;[1711]
TBL <OBJECT:>,INVIS,[.OBJECT]
TBL <OP>,ABBRIV,XXO
TBL <OPT>,ABBRIV,XXO
XXO: TBL <OPTIMIZE>,,[EXP SETFLG,SW.OPT,$F]
TBL <OPTION:>,,[.OPTION]
TBL <S>,ABBRIV,XXS
TBL <STATISTICS>,INVIS,[EXP SETFLG,SW.STA,$F2]
XXS: TBL <SYNTAX>,,[EXP SETFLG,SW.OCS,$F]
TBL <W>,ABBRIV,XXW
XXW: TBL <WARNINGS>,,[.WARN]
COMSWL==.-COMSW-1
SUBTTL Warning Message Mnemonic Table
;To add a new warning message mnemonic to the compiler:
; 1) Add it to the end of the list labeled with NWKTB
; 2) Add to the table labeled with WT an entry of the form:
; TBL <XXX>,,NW.XXX
; where XXX is the three letter mnemonic for the warning.
; 3) Make sure all the entires to WT are in alphabetical
; order!
DEFINE SIXTAB(L)<
NWKTBC==0
IRP L,< SIXBIT \'L\
NW.'L==.-NWKTB
NWKTBC==NWKTBC+1>
>
; /NOWARN: mnemonic tables. The three character mnemonics must be
; added to both of the below tables.
;[2305] Added mnemonics AIS through VNF
NWKTB: SIXTAB <
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,CNM,DGI,SBR,CHO,
WNA,IAT,SNO,TSI,ACB,AIL,RIM,FOO,
AIS,CAP,CCC,CNS,COS,COV,CSM,DEB,DFN,DOW,DPE,DWE,DWL,
EDD,EDS,EDX,EOC,EXD,FAR,FIF,FIN,FMT,FNG,HCP,HCU,INS,
KWU,KWV,LNE,LOL,LSP,MLN,MSL,NAM,NDP,NEC,NIB,NIG,NIK,
NIS,NIX,NLK,NPC,NPP,NSC,OCU,OIO,PWS,RLC,SBC,SEP,SMD,
ANS,SNN,SPN,SRO,SVN,TLF,VFS,VGF,VIF,VNG,WDU,XEN,XOR,
RLX,LNC,NLC,CIS,SOR,FNS,VSD,VNS,VNF,ADS,IMN,MBD,VKI,
EIR,EID,INC,LDI,ADV> ;[4544]
; Below table must be in alphabetical order!
WT:
XWD NWKTBC,NWKTBC
TBL <ACB>,,NW.ACB ;[1535]
TBL <ADS>,,NW.ADS ;[2430]
TBL <ADV>,,NW.ADV ;[4544]
TBL <AGA>,,NW.AGA
TBL <AIL>,,NW.AIL ;[1535]
TBL <AIS>,,NW.AIS ;[2305]
TBL <ALL>,,NW.ALL
TBL <ANS>,,NW.ANS ;[2305]
TBL <CAI>,,NW.CAI
TBL <CAO>,,NW.CAO
TBL <CAP>,,NW.CAP ;[2305]
TBL <CCC>,,NW.CCC ;[2305]
TBL <CHO>,,NW.CHO
TBL <CIS>,,NW.CIS ;[2305]
TBL <CNM>,,NW.CNM
TBL <CNS>,,NW.CNS ;[2305]
TBL <COS>,,NW.COS ;[2305]
TBL <COV>,,NW.COV ;[2305]
TBL <CSM>,,NW.CSM ;[2305]
TBL <CTR>,,NW.CTR
TBL <CUO>,,NW.CUO
TBL <DEB>,,NW.DEB ;[2305]
TBL <DFN>,,NW.DFN ;[2305]
TBL <DGI>,,NW.DGI
TBL <DIM>,,NW.DIM
TBL <DIS>,,NW.DIS
TBL <DOW>,,NW.DOW ;[2305]
TBL <DPE>,,NW.DPE ;[2305]
TBL <DWE>,,NW.DWE ;[2305]
TBL <DWL>,,NW.DWL ;[2305]
TBL <DXB>,,NW.DXB
TBL <EDD>,,NW.EDD ;[2305]
TBL <EDS>,,NW.EDS ;[2305]
TBL <EDX>,,NW.EDX ;[2305]
TBL <EID>,,NW.EID ;[4530]
TBL <EIR>,,NW.EIR ;[4501]
TBL <EOC>,,NW.EOC ;[2305]
TBL <EXD>,,NW.EXD ;[2305]
TBL <FAR>,,NW.FAR ;[2305]
TBL <FIF>,,NW.FIF ;[2305]
TBL <FIN>,,NW.FIN ;[2305]
TBL <FMR>,,NW.FMR
TBL <FMT>,,NW.FMT ;[2305]
TBL <FNA>,,NW.FNA
TBL <FNG>,,NW.FNG ;[2305]
TBL <FNS>,,NW.FNS ;[2305]
TBL <FOO>,,NW.FOO ;[1750]
TBL <HCP>,,NW.HCP ;[2305]
TBL <HCU>,,NW.HCU ;[2305]
TBL <IAT>,,NW.IAT
TBL <ICC>,,NW.ICC
TBL <ICD>,,NW.ICD
TBL <ICS>,,NW.ICS
TBL <IDN>,,NW.IDN
TBL <IFL>,,NW.IFL
TBL <IMN>,,NW.IMN ;[2473]
TBL <INC>,,NW.INC ;[2524]
TBL <INS>,,NW.INS ;[2305]
TBL <IUA>,,NW.IUA
TBL <KWU>,,NW.KWU ;[2305]
TBL <KWV>,,NW.KWV ;[2305]
;[4553]
TBL <LID>,,NW.LID
TBL <LNC>,,NW.LNC ;[2305]
TBL <LNE>,,NW.LNE ;[2305]
TBL <LOL>,,NW.LOL ;[2305]
TBL <LSP>,,NW.LSP ;[2305]
TBL <MBD>,,NW.MBD ;[2374]
TBL <MLN>,,NW.MLN ;[2305]
TBL <MSL>,,NW.MSL ;[2305]
TBL <MVC>,,NW.MVC
TBL <NAM>,,NW.NAM ;[2305]
TBL <NDP>,,NW.NDP ;[2305]
TBL <NEC>,,NW.NEC ;[2305]
TBL <NED>,,NW.NED
TBL <NIB>,,NW.NIB ;[2305]
TBL <NIG>,,NW.NIG ;[2305]
TBL <NIK>,,NW.NIK ;[2305]
TBL <NIS>,,NW.NIS ;[2305]
TBL <NIX>,,NW.NIX ;[2305]
TBL <NLC>,,NW.NLC ;[2305]
TBL <NLK>,,NW.NLK ;[2305]
TBL <NOD>,,NW.NOD
TBL <NONE>,,NW.NONE
TBL <NPC>,,NW.NPC ;[2305]
TBL <NPP>,,NW.NPP ;[2305]
TBL <NSC>,,NW.NSC ;[2305]
TBL <OCU>,,NW.OCU ;[2305]
TBL <OIO>,,NW.OIO ;[2305]
TBL <PAV>,,NW.PAV
TBL <PPS>,,NW.PPS
TBL <PWS>,,NW.PWS ;[2305]
TBL <RDI>,,NW.RDI
TBL <RIM>,,NW.RIM ;[1652]
TBL <RLC>,,NW.RLC ;[2305]
TBL <RLX>,,NW.RLX ;[2305]
TBL <SBC>,,NW.SBC ;[2305]
TBL <SBR>,,NW.SBR
TBL <SEP>,,NW.SEP ;[2305]
TBL <SID>,,NW.SID
TBL <SMD>,,NW.SMD ;[2305]
TBL <SNN>,,NW.SNN ;[2305]
TBL <SNO>,,NW.SNO
TBL <SOD>,,NW.SOD
TBL <SOR>,,NW.SOR ;[2305]
TBL <SPN>,,NW.SPN ;[2305]
TBL <SRO>,,NW.SRO ;[2305]
TBL <SVN>,,NW.SVN ;[2305]
TBL <TLF>,,NW.TLF ;[2305]
TBL <TSI>,,NW.TSI
TBL <VAI>,,NW.VAI
TBL <VFS>,,NW.VFS ;[2305]
TBL <VGF>,,NW.VGF ;[2305]
TBL <VIF>,,NW.VIF ;[2305]
TBL <VKI>,,NW.VKI ;[4500]
TBL <VND>,,NW.VND
TBL <VNF>,,NW.VNF ;[2305]
TBL <VNG>,,NW.VNG ;[2305]
TBL <VNI>,,NW.VNI
TBL <VNS>,,NW.VNS ;[2305]
TBL <VSD>,,NW.VSD ;[2305]
TBL <WDU>,,NW.WDU ;[2305]
TBL <WNA>,,NW.WNA
TBL <WOP>,,NW.WOP
TBL <XCR>,,NW.XCR
TBL <XEN>,,NW.XEN ;[2305]
TBL <XOR>,,NW.XOR ;[2305]
TBL <ZMT>,,NW.ZMT
RELOC ;Back to low segment
NWWDCT==<<NWKTBC-1>/^D36>+1 ;Words needed for bits
NWBITS: BLOCK NWWDCT ;Holds nowarning bits
NWON: BLOCK NWWDCT ;Holds nowarning bits that must be on
NWOFF: BLOCK NWWDCT ;Holds nowarning bits that must be off
SNWON: BLOCK NWWDCT ;Holds nowarning ON bits from command line
;during SWITCH.INI processing.
SNWOFF: BLOCK NWWDCT ;Holds nowarning OFF bits from command line
;during SWITCH.INI processing.
RELOC ;Back to high segment
SUBTTL /DEBUG Option Masks
; Note that bit 400000 (1_^D17) is reserved for signaling that a
; mask comes from a NO option. This implementation allows at most
; 17 debugging options (exclusive of ALL, NONE, and the NO forms
; of the options).
DB.ALL==377777
DB.DIM==1_0
DB.LBL==1_1
DB.IDX==1_2
DB.TRA==1_3
DB.BOU==1_4
DB.ARG==1_5 ;[1613]
DT: XWD DTL,DTL ;Count of number of entries
TBL <ALL>,,DB.ALL
TBL <ARGUMENTS>,,DB.ARG ;[1613]
TBL <BOUNDS>,,DB.BOU
TBL <DIMENSIONS>,,DB.DIM
TBL <INDEX>,,DB.IDX
TBL <LABELS>,,DB.LBL
TBL <NOARGUMENTS>,,^-DB.ARG ;[1613]
TBL <NOBOUNDS>,,^-DB.BOU
TBL <NODIMENSIONS>,,^-DB.DIM
TBL <NOINDEX>,,^-DB.IDX
TBL <NOLABELS>,,^-DB.LBL
TBL <NONE>,,^-DB.ALL
TBL <NOTRACE>,,^-DB.TRA
TBL <TRACE>,,DB.TRA
DTL==.-DT-1
SUBTTL /EXTEND keywords added by edit 2220
ET: XWD ETL,ETL ;Count of number of entires
TBL <CODE>,,.CODE ;[2442]
TBL <COMMON:>,,.COMMON
TBL <DATA:>,,.DATA
TBL <NOCODE>,,.NOCODE ;[2442]
TBL <NOCOMMON:>,,.NOCOMMON
TBL <NODATA>,,.NODATA
TBL <PSECT:>,,.PSECT ;[2445]
ETL==.-ET-1
SUBTTL /FLAG keywords
;[2246] Add entire table
CF: XWD CFL,CFL ;Count of number of entries
TBL <ALL>,,CF.ALL
TBL <ANSI>,,CF.STD ;[2322] ANSI flagger
TBL <NOANSI>,,CF.NOS ;[2322] ANSI flagger
TBL <NONE>,,CF.NON
TBL <NOVMS>,,CF.NOV ;[2455]
TBL <VMS>,,CF.VMS ;[2455]
CFL==.-CF-1
XLIST ;Don't list literals
LIT
LIST
END FORTRA