Trailing-Edge
-
PDP-10 Archives
-
BB-D480G-SB_FORTRAN10_V11.0_short
-
forddt.mac
There are 27 other files named forddt.mac in the archive. Click here to see a list.
Title FORDDT FORTRAN INTERACTIVE DEBUGGING AID ,11(405)
SUBTTL P.E.T. HARDING/DBT/FLD/MD/JMT/MA/SJW/JNG/DCE/BPK/CKS/DCC/BAH/BL/TGS/MRB
; Brad Merrill/BCM/AlB/MEM/PLB/CDM 10-Jul-86
;COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1973, 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.
EDITNO==405 ;EDIT NO
VERSION==11 ;MAJOR VERSION NO
VMINOR==0 ;MINOR VERSION NO
VWHO==0 ;WHO LAST EDITED
.JBDDT=74
.JBREN=124
.JBVER=137
; Get universals and HELPER
IFNDEF TOPS20,<TOPS20==-1> ;[147] 0 = TOPS10, -1 = TOPS20
IFNDEF EXTHLP,<EXTHLP==0> ;[147] -1 If using external HELPER
IFN EXTHLP,< ;[147] external HELPER
IFE TOPS20,<.TEXT 'REL:HELPER/SEGMENT:LOW'> ;[142] load HELPER in low-seg
IFN TOPS20,<.REQUEST SYS:HELPER> ;[142] Load HELPER
> ;[147] end IFN EXTHLP
IFE TOPS20,<
SEARCH UUOSYM,MACTEN ;[142] Get -10 monitor symbols
OPDEF XMOVEI [MOVEI] ;[310] define XMOVEI for -10
OPDEF EFIW [EXP] ;[310] make sure its defined
OPDEF IFIW [EXP] ;[310] ditto
> ;end IFE TOPS20
IFN TOPS20,<SEARCH MONSYM,MACSYM> ;[142] Get -20 monitor symbols
;Report what code is being assembled.
IF1,
<IFE TOPS20,<
PRINTX [Assembling for TOPS10]
>;END OF IFE TOPS20
IFN TOPS20,<
PRINTX [Assembling for TOPS20]
>;END OF IFN TOPS20
>;END OF IF1
;[300]
; These locations may not exist on TOPS-20 as of V10. The symbol tables
; will be in PDV's and the version number and reenter address are stored
; in the program entry vector. FORDDT will not load with LINK V6 if the
; LOC's remain, so until we can resolve the problems associated with JOBDAT
; vestiges, the LOC's themselves will be for TOPS10 only.
;
IFE TOPS20,<
LOC .JBVER
BYTE(3)VWHO(9)VERSION(6)VMINOR(18)EDITNO ;SETS FORDDT VERSION #
LOC .JBREN
RE.ENT ;SETS THE RE - ENTER ADDRESS
LOC .JBDDT
SFDDT ;[145] MAKES DEBUG PROG,FORDDT WORK
RELOC
> ;END IFN TOPS20
SUBTTL REVISION HISTORY
COMMENT \
***** Begin Revision History *****
21 REMOVE ALL HIBERNATE CALLS - JUST USE TTCALL 4
22 CHANGE TRACE% TO TRACE.
23 BEGIN UPDATE FOR (1) SYMBOL TABLE LOOKUP ALGORITHMS
(2) GENERAL CLEAN UP
24 (CONTINUING)
25 CONTINUING; ALSO REWRITE OF LOOK
26 CONTINUING; REWRITE OF OFFSET
REMOVAL OF 'BIGCOD'
27 CONTINUING
30 CONTINUING; INCLUDING SYMBOL USAGE CLEANUP AND REMOVAL
OF SYMSET
31 CONTINUING; REMOVAL OF MOST 'DEBUG' CONDITIONAL CODE
AND INTCPT CONDITIONAL AND CODE
32 CONTINUING; REMOVAL OF SMART PORTION OF LOOK
33 CONTINUING; FIXUP OF PAUSE LOGIC
34 CONTINUING; REINSERT OF SMART CODE TO LOOK - IGNORE
UDDT, FORDDT, AND JOBDAT ON LOOKUP.
35 FINAL EDIT OF UPDATE - PATCH AREA GOES UNDER DEBUG
CONDITIONAL, CALL TO DO MACRO IS FIXED, SO THIS WILL
NOW ASSEMBLE WITH MACRO V50.
36 ANOTHER FINAL - HIERARCHY IN LOOK; FNDSYM RESOLVED
37 CONTINUING FINAL - SCATTERED BUGS
40 FIX AC LONG ASCII AND RASCII
FIX - LOCATE FOR LOCALS OUTSIDE OPEN
FIX - DIM A(X(1)/1)
41 FIX USAGE OF PROGRAMS NAMED OTHER THAN MAIN.
42 INITIALIZE ODF (NUMERIC BASE) FOR GROUP TYPEOUT
43 ADD CURGRP (BIT MASK ) TO NOTE CURRENT GROUPS
ACTIVE IN A TYPEOUT AND CATCH RECURSION
44 FIX UP "LOOK" SO THAT IF "MATHSM" IS NON-0 THAT IT
WILL ACCEPT ONLY A SYMBOL WHOSE NAME IS IN "MATHSM"
45 FIX PAUSE TYPING TO LISTEN TO TTY BETTER
46 CHECK RANGES TO SEE THAT EACH SYMBOL IS THE SAME
***** Begin Version 4A *****
47 DIFFERENTIATES ASCII- AND RASCII-MODE "TYPE"-OUTPUT
50 ALLOWS = AS DELIMITER IN ACCEPT STATEMENTS
51 FIXES "HELP" TO LIST COMMANDS
52 FIX TYPEOUT OF COMPLEX VALUES
53 15732 FIX TYPOUT OF SYMBOL WHEN LOCAL SYMBOL FOUND BEFORE GLOBAL
54 15732 ***** DELETED *****TYPE OUT NAMES OF ARGUMENTS WHEN PAUSE AT
ROUTINE
55 15708 MAKE TYPE KNOW ABOUT FORMAL ARGUMENTS
***** Begin Version 4B *****
56 16928 ACCEPT LOWER CASE MODE MODIFIERS
57 17043 IF TWO SYMBOLS HAVE SAME ADDRESS VALUE AND SAME
NAME VALUE , THEN THEY MUST BE IN COMMON , SO LOOK
SHOULD SUCCEED (OK SKIP 2 RETURN)
ALSO REMEMBER NAME OF ARRAY FOR DIM COMMAND.
60 17272 IF ARRAY INFORMATION DOES NOT EXIST, TELL THE USER
BUT DO NOT GIVE FDTIER ERROR.
61 17574 IF ERROR HAPPENS IN TYPING GROUP, CURRENT GROUP VARIABLE
IS NOT CLEARED AND LATER GIVES ERROR FDTRGR.
62 18059 ADD INFORMATION IN THE "WHAT" OUTPUT
(LOCATION OF THE PAUSE LABEL)
63 18374 GIVE CORRECT INFORMATION FOR "WHAT" COMMAND:
SINGLE VARIABLE NAME + ARRAY NAMES AND SUBSCRIPT
+ LOCATION OF NAMES
64 S19206 DONT TYPE EXTRA CRLF BETWEEN TYPED VALUES.
65 18715 ACCEPT COMMENTS ON COMMAND LINES
DELIMITER IS ! TO END OF LINE OR OTHER !
66 --- FIX TEST FOR ARRAY BOUNDS EXCEEDED IN DIM COMMAND
67 19541 FIX LOWER CASE RANGE CHECK
70 QA570 FIX REENTER MESSAGE TO ALWAYS GIVE SECTION NAME
***** Begin Version 5A ***** 7-Nov-76
71 20553 TYPING A FORMAT STATEMENT CAUSES AN E8 INTERNAL
ERROR IF THE PROGRAM WAS NOT COMPILED WITH THE
/DEBUG SWITCH. ADD MORE INFORMATIVE ERROR MESSAGE
AREAS AFFECTED: FRMSET, ERR41
72 10088 WHEN TYPING AN ARRAY, THE INDEXES ARE NOT CORRECTLY
TYPED IF AND ONLY IF THE IS A HIGH SEGMENT SYMBOL
TABLE (FOR EXAMPLE FOROTS IS LOADED WITH SYMBOLS).
73 21818 WHEN TYPING A COMPLEX ITEM OR ARRAY, OR ACCEPTING A
VALUE FOR A COMPLEX ARRAY, FORDDT DOESN'T NOTICE THAT
EACH ENTRY IS TWO WORDS AND MESSES UP SUBSCRIPTS ETC.
74 21988 FORDDT CANT SET BREAK POINTS (PAUSE) IN HIGH SEGMENT
OF A FORTRAN PROGRAM. ROUTINE CHKADR CLOBBERS (T)
75 21910 WHEN DOING A START, PROGRAM SHOULD CLEAR
ANY SUPPLIED ARGUMENTS FROM THE TTY BUFFER.
76 21910 FIX ERROR IN ACCEPT ROUTINE WHICH CAUSES UNNECESSARY
WARNING MESSAGE WHEN EXACTLY 5 (OR EXACTLY 10 IF IN
LONG MODE) CHARACTERS ARE ACCEPTED
77 21910 MAKE THE PAUSE COMMAND WITH NO ARGUMENTS DISPLAY
THE PAUSES.
100 Add TOPS20 conditional, make FORDDT run in native
mode under TOPS-20.
101 QA2171 FIX FORDDT OUTPUT TO USE FOROTS CORRECTLY AFTER OTS EDIT
661: OUTPUT MUST START WITH + AND CLEAR TTY BUFFER
AFTERWARDS
***** Begin Version 5B ***** 8-Nov-77
102 11018 PREVENT LOOP IF SYMBOL TABLE HAS BEEN BLT'ED TO
ZERO, AS CAN HAPPEN WITH AN OVERLAID PROGRAM.
103 QA2182 PUT "SEARCH MONSYM" FROM EDIT 100 UNDER "IFN TOPS20"
AND MOVE IT TO AFTER THE DEFINITION OF TOPS20
104 24427 PREVENT ILLEGAL MEMORY REFERENCE IF SYMBOL TABLE ENDS
EXACTLY AND THE END OF LEGAL MEMORY.
105 11395 HANDLE TYPE WITH MULTIPLE ARGUMENTS. FORDDT WAS
BLOWING UP IF FIRST ARG WAS FORMAL ARRAY, BECAUSE
FORMAL ARRAY FLAG NEVER GOT CLEARED.
106 25207 CHANGE FDTNAR NOT AN ARRAY TO FDTNAA. THIS AVOIDS
CONFLICT WITH FDTNAR NOT AFTER REENTER.
107 FIX SYMBOL SEARCH TERMINATION TEST (OFF BY 2).
110 25384 FIX TYPE OF A FORMAL ARRAY IN SMALL PROGRAMS.
111 11839 ACCEPT STMNT EATS FIRST CHARACTER OF INPUT VALUE
112 27201 MAKE USE OF TYPEOUTS AND MODE CONTROL MORE CONSISTANT
113 12316 RESTRICT USE OF DOUBLE PRECISION IN CONDITIONALS
114 ----- CLEAN UP SOME TOPS-20 CODE: IMPLEMENT NONTRIVIAL DDT
COMMAND, FIX HALTF WHEN COMND JSYS GIVES AN ERROR
RETURN, REMOVE SOME REDUNDANT CODE IN LISTEN
115 ----- GET VMDDT ON TOPS-10 WHEN DDT ISN'T LOADED WITH PROG
116 28581 Implement use of logicals (.TRUE. and .FALSE.) in
PAUSE conditionals.
117 ----- Make error messages upper and lower case /BPK
120 ----- Implement logicals into ACCEPT, MODE and TYPE statements
using the flag "/L". "/L" was previously used
to specify long (ie. two word) ASCII, RASCII and OCTAL
values in the ACCEPT and MODE commands. This switch
has been changed to "/B", mnemonic for "BIG".
121 ----- Fix -20 code to clear bad lines properly.
122 ----- Set .JBDDT when VMDDT is pulled in to prevent overflow
warnings from FOROTS.
123 ----- Prevent infinite loop on TOPS-20 if .JBHSO is 0 but
.JBHRL isn't.
124 ----- Fix logical TYPEing so that all positive values are .FALSE.
and all negative values are .TRUE.
125 ----- Add a new entry point (%FDDT) to be used when returning
from DDT in place of .F10 (which will still work).
126 ----- Add ?FDT prefix to COMND JSYS error messages.
127 ----- Call FOROTS routine DEC. to interpret real, integer,
complex, and double precision numbers instead of IN. .
130 ----- Call HELPER to print out FORDDT.HLP when the HELP command
is issued.
131 ----- Search universal FDDT20 to define TOPS20 instead of
defining it within FORDDT.
132 29363 Fix various problems that occur when core file is filled
during GROUP and TYPE commands.
133 29261 Fix up error handling when reading program name.
Use command JSYS when reading program name on -20.
134 ----- PAUSE sometimes hangs if a line terminator is typed in an
inappropriate place. Fix it.
135 ----- When looking up symbol in symbol table, make sure we
compare the whole symbol and not just the right half-word
136 ----- PAUSE command doesn't allow comments in all places.
fix it.
***** Begin Version 6 ***** 9-Jun-80
137 ----- Add G-floating capability for input/output. Use of G-floating
is determined at initialization time by the presence
of the symbol "..GFL.". If ..GFL. is missing, default
to D-floating. If ..GFL. is present, use G-floating.
140 ----- Fix COMND trailing space problem. On the -20, the COMND JSYS
is used to parse the first keyword. COMND supplies an extra
space which makes FORDDT think that there are arguments
following the keyword. This bug fix edits the COMND text buffer
before doing a RSCAN JSYS and passing it to FORDDT's parsing
code. It appropiately skips over comments. /DCC 3-July-80
141 ---- Fix G-floating bug. Symbol ..GFL. was changed to a deleted
output global symbol, breaking FORDDT's symbol lookup routine.
One line patch at: EVAL1. Replace existing line with
MOVSI R,GLOBAL!DELO /DCC 5-August-80
142 ----- Use the new FOROTS routine to get high-segment symbol table
pointer. This is in case the high segment is protected.
Make sure HELPER gets loaded into the low-seg and that we
look for it on REL: on TOPS-10. Fix up some error messages.
Relocate univeral searches.
143 ----- Assume that FOROTS and FORLIB are loaded from now on. So
remove almost all the SKIPIF macro calls. This also fixes
the problem of GHSSYP recursively calling itself.
144 QA5031 Change output format to suppress FOROTS's CR, as FORDDT types
a CR also. Also remove FORBUF, which is now unnecessary.
145 ----- Make FORDDT the entry point for FORTRAN users who wish to
call FORDDT as an error routine. SFDDT is the new entry
point for initializing FORDDT (including reseting all files
opened by FOROTS). SFDDT replaces the old FORDDT symbol.
Replace FORBUF.
NOTE: Since FORDDT is now a global symbol, users should be
careful if they decide to use the label FORDDT as a program,
subroutine or function name.
146 ----- New calling sequence for FOROP.
147 ----- Fix up help code so that we get FORDDT.HLP ourselves instead
of using HELPER. This way FOROTS' data will not get stomped
on. Conditionalize out the old code for the time being.
Redefine AC0 to be accumulator 0 and redefine the memory
location previously defined as AC0 to be SAVACS. Also,
remove universal file FDDT20.
150 ----- Change so that all JSYSs consistently end with a percent sign
(%). Also clean up the listing a bit (e.g., change PAGE
pseudo-ops to form-feeds, delete definitions already defined
in UUOSYM, etc.).
151 16084 FORDDT always flags lowercase on ASCII typeout. On TOPS20,
don't do any flagging--the monitor and user commands will do
it. On TOPS10, if the terminal is set to uppercase, flag the
lowercase character; if it is set to lowercase, don't do any
flagging (default is no flagging).
152 Q20-1675 Prevent FORDDT from getting arithmetic overflows in its
symbol offset calculation.
153 ----- Report what is assembling (TOPS10 or TOPS20). Also PURGE
some symbols which my conflict with users' subroutine names.
154 ----- Move setting .JBREN to before the call to RESET. Use a
different mechanism for detecting multiple REENTER entries.
***** Begin Version 7 *****
155 ----- Change START2 to look for global symbol instead of program
name when finding START address, since there can now be
character descriptors in front of executable code. (BL)
Change also in GETPRG.
156 ----- Fix bug in ACCEPT code...when ACCEPTing /ASCII/BIG input
into a range of double precision array elements, the
second word of the last element within the range was
not ACCEPTed, due to RANGE being set to the address of
the first word of the element. (BL)
157 ----- Lots of code to make FORDDT TYPE and ACCEPT character
scalars and arrays.
160 ----- Make character scalars work again.
161 ----- Fix problem recognizing character arrays using /DEBUG.
162 ----- Enable type-out of character strings at PAUSEes.
Also insert check for G-floating arrays in RAYNAM
F10-array-checking.
163 ----- Insert new address-checking code: allow R/W to low-
segment, R only from High-segment.
Array range checking now done only if array pointer
is in symbol table (if compiled /DEBUG).
Inserted <widgets> around (most) error messages.
164 ----- Fix bug in multiple type-out modes.
165 CDM 1-Sept-82
Change
TRNE T5,1B13
to
TRNE T5,(1B13)
to make it assemble without warnings.
166 BL 3-NOV-82
Eliminate check of indirect bit in CKBPTR...it was failing legal
byte pointers
167 BL 3-Nov-82
Insert code to simulate V6 EDIT 155...we were getting array type-out
failures on formal arrays
170 BL 17-Nov-82
Change a TLNE to a TRNE in OFFSET, so we test the correct output mode
options.
Change test of return instruction in START4 so that it tests the
instruction, not the address of its storage location. This was
causing a subroutine which had been entered via a NEXT to be repeated
if a GOTO was then performed.
171 BL 18-Nov-82
Merge in V6 EDIT 165...fix problems with TYPE of variables in
COMMON.
172 BL 2-Dec-82
Reinstate the check of the indirect bi in CKBPTR...but do it right!!!
173 BL 12-13-82
Move swapping of local and default type-out modes in DISP10 so that
OFFSET is called with the right option. (was causing inaccurate
subscripts).
174 BL 7-Jan-83
Move %FDDT (reentry from DDT) so that user-modes are not reset.
175 BL 11-Jan-83
typo at DISP10+4.
176 BL 13-Jan-83
Revise EDIT 174 so that %fddt still performs everything except the
resetting of modes.
***** End V7 Development *****
;.BEGINR ***** Begin V7 Maintenance *****
;.COMPONENT FORDDT
;.VERSION 7
;.AUTOPATCH 7
;.EDIT 177 ALLOW " = " CONSTRUCTS IN ACCEPT,IMPLEMENT ERR= DECODE CALLS
;; Since "ACCEPT A=3" is allowed (although a user error), also allow
;; "ACCEPT A = 3" style constructs. Push a 'STOP!!' billboard on FORDDT's
;; stack so FORERR's PC finder will not loop. Install an ERR= argument
;; for calls to DECODE so truly illegal arguments passed to FOROTS will
;; not abort debugging.
; TGS,09-APR-83,SPR:20-19167
; A:SRC FORDDT.MAC
;.EDIT 200 ACCEPT NAME/MODE<CR> HANGS
;; ACCEPT Name/Mode<CR> hangs waiting for another CRLF. Treat this and
;; other cases where ACCEPT command lines terminate without any value
;; supplied by the user as cases of bad syntax.
; TGS,14-JUN-83,SPR:NONE
; A:SRC FORDDT.MAC
;.EDIT 201 PROBLEM TYPING VARIABLE NAME WHEN SAME AS PROGRAM NAME
;; If the PROGRAM name is the same as a variable name, then TYPEing
;; the variable name yields "MAIN PROGRAM(1) = " etc.
; TGS,22-JUL-83,SPR:10-34002
; A:SRC FORDDT.MAC
;.EDIT 202 1+NTH ARRAY NAME TYPED OUT AS "PAT..(n)"
;; Typing an array on TOPS10 will garble the 2nd through nth array
;; element name, typing it as PAT..
; TGS,28-JUL-83,SPR:10-34001
; A:SRC FORDDT.MAC
;.EDIT 203 PROBLEMS AFTER PAUSING AT MAIN.
;; Setting a breakpoint at MAIN. will cause an ?Ill mem ref on
;; TOPS10 as soon as the program is STARTed. On TOPS20 a private
;; page may be created; in addition, a subsequent STRACE after
;; the START will loop, finally getting an ?Ill instruction.
; TGS,29-JUL-83,SPR:NONE
; A:SRC FORDDT.MAC
;.EDIT 204 GARBLED ENTRY NAME ON TOPS20 CALL TO FORDDT
;; On TOPS20, having found a valid offset during a low-seg symbol
;; table search, do not then search the hiseg symbol table as well.
; TGS,1-AUG-83,SPR:NONE
; A:SRC FORDDT.MAC
;;.ENDA 7-SEP-83
;.EDIT 205 ACCEPT/S ECHO TYPEOUT ALWAYS IN FLOATING POINT
;; ACCEPT/S <var> will always echo in floating point format, regardless
;; of the current MODE setting.
; TGS,19-SEP-83,SPR:10-34142
; A:SRC FORDDT.MAC
;;.ENDA 3-OCT-83
;;.ENDA 31-OCT-83
;;.EDIT 206 RESERVED FOR AUTOPATCH
;.ENDA
;.AUTOPATCH 8
;;.ENDA 27-DEC-83
;;.ENDA 20-JAN-84
;;.ENDA 16-FEB-84
;.EDIT 207 NOOP EDIT TO UPDATE OUR VERSION
;; Update the edit number and thereby teach Autopatch to update it
;; also. No code changes.
; TGS,24-FEB-84,SPR:NONE
; A:SRC FORDDT.MAC
;;.ENDA 23-MAR-84
;;.ENDA 26-APR-84
;.ENDA
;.AUTOPATCH 9
;;.ENDA 18-MAY-84
;.EDIT 210 FIX COMPLEX ARRAY TYPE OUT
;; Recognize a complex array as a double word array.
; MRB,5-JUN-84,SPR:20-20178
; A:SRC FORDDT.MAC
;.EDIT 211 WARN IF WE CAN'T HACK IWI ERRORS FROM FOROTS
;; FORDDT can't do anything useful if the user has set a breakpoint
;; in an IOLST function call, since any TYPE or ACCEPT command will
;; call FOROTS, thus getting an "I/O within I/O" (IWI) error. Check
;; at breakpoint processing by calling FO$UDB FOROP and warn if this
;; breakpoint is "restricted". Type an error if the user tries to
;; ACCEPT or TYPE under IWI conditions.
;; NOTE: This edit must not be installed unless FOROTS Edit 3432 has
;; been installed.
; TGS,7-JUN-84,SPR:20-20133
; A:SRC FORDDT.MAC
;.EDIT 212 MONSYM "ENDSTR" CONFLICT
;; Change label ENDSTR, as it may conflict with future releases of
;; MONSYM and give a compilation error.
; TGS,22-JUN-84,SPR:NONE
; A:SRC FORDDT.MAC
;;.EDIT 213 RESERVED FOR AUTOPATCH
;;.EDIT 214 RESERVED FOR AUTOPATCH
;;.ENDA 22-JUN-84
;.EDIT 215 HACK AN OFFSET WHEN NEXTING WITHOUT LOCAL SYMBOLS
;; If a program or program unit has been loaded /NOLOCALS, and
;; the user tries to NEXT from a global pause, don't give up
;; with FDTIER #7 when trying to print the label or source line.
;; Use the offset returned by LOOK instead.
; TGS,28-JUN-84,SPR:10-34742
; A:SRC FORDDT.MAC
;;.EDIT 216 RESERVED FOR AUTOPATCH
;;.ENDA 19-JUL-84
;.EDIT 217 TYPE CHAR(VAR)/C TYPES VAR(1)...
;; Each time SYMIN reads a variable it stores the symbol pointer in
;; CRYSYM for special character array typeout. Since CHAR(VAR) forms
;; of variables will cause routine EITHER to call SYM2 recursively,
;; CRYSYM will be left pointing to the subscript instead of the array
;; name, causing OFFSET to type the wrong name.
; TGS,2-AUG-84,SPR:10-34776
; A:SRC FORDDT.MAC
;;.EDIT 220 RESERVED FOR AUTOPATCH
;;.ENDA 16-AUG-84
;;.ENDA 20-SEP-84
;.ENDA
;.AUTOPATCH 10
;.EDIT 221 NOOP EDIT TO UPDATE OUR VERSION
;; Update the edit number and thereby teach Autopatch to update it
;; also. No code changes.
; MRB,19-OCT-84,SPR:NONE
; A:SRC FORDDT.MAC
;;.ENDA 19-OCT-84
;.EDIT 222 ACCEPT VAR/C MAY NOT DISPLAY NEW VALUE
;; If the ACCEPTed string exactly fills the variable, the ACCEPT
;; command does not display the new value.
; TGS,27-NOV-84,SPR:10-34962
; A:SRC FORDDT.MAC
;.EDIT 223 TYPING FORMAL ARRAY PARAMETERS LACK SUBSCRIPT
;; A request to TYPE a formal array will type all subscripts
;; except the first; a one-shot TYPE request (e.g. TYPE ARRAY(2))
;; will thus not show which subscript is being typed.
; TGS,7-DEC-84,SPR:10-34961
; A:SRC FORDDT.MAC
;;.EDIT 224 RESERVED FOR AUTOPATCH
;;.ENDA 26-DEC-84
;;.ENDA 16-JAN-85
;.ENDA
;.ENDV
;.ENDR ***** End V7 Maintenance *****
***** Begin V10 Development *****
300 EXTENDED ADDRESSING DEVELOPMENT
Many changes:
Modify breakpoint table layout and handling.
Address arithmetic changes.
Extended FOROTS calls.
Misc cleanup.
BCM,18-JUN-84
301 ARRAY DEFINITION TABLE HAS GLOBAL INDICES
The DIMTAB table is expanded to have three-word entries,
and all entries contain global indices.
The definition of the entries have symbolic names.
References to the entries are changed from half-word
to full-word.
Miscellaneous cleanup.
AlB,26-Jun-84
302 HELP COMMAND REQUIRES ONE-WORD GLOBAL BYTE POINTER
The HELP command requests the allocation of core memory from
the FOROTS ALCOR. routine. That routine returns a global
address, and thus the FORDDT HELP command must turn it into
a OWGBP in order to get at the assigned buffer (which could be
in another section under extended addressing).
AlB,27-Jun-84
303 More development fixes
Indirect reference in START4 no good in non-zero.
Bug introduced by edit 170 that showed up in non-zero section.
Address test failed with extra section number in WT15.
Dummy the PC using current section number in STEP4.
Fixed up address arithmetic in AUTOP.
Push an AC instead of hiding on stack in FP7.
BCM,28-Jun-84
304 RECOGNIZE GLOBAL SYMBOLS FOR LOCATE
Fix an indirect reference in QLIST6.
BCM,29-Jun-84
305 VERIFY THE CORRECT ADDRESS FOR BYTE POINTERS
A call to CKWRIT was using the updated byte pointer
after a ADJBP. Changed to use original address for
checking page access.
BCM,9-Jul-84
306 CHECKING LH FLAGS FOR RH VALUE
Old bug that showed up using flag DOUBLE.
BCM,9-Jul-84
307 ADDITIONAL WORK FOR EDIT 301
Needed to correct logic in DISP14 for DOUBLE arrays.
AlB/BCM,9-Jul-84
310 TOPS-10 ADDITIONAL WORK
Fix up EFIW,IFIW definitions for -10.
Fix XJRSTF in RESTOR to have only RH of PC and not get flags.
BCM,17-Jul-84
311 CANNOT PAUS/GOTO/START AT SOME LOCATIONS
Insufficient check for FORMAT statement disallowed some legal
breakpoints. Fix to check second ascii character for being
a control character, and if so, assume its NOT a FORMAT statement.
BCM,17-Jul-84
312 Fix ERR branch & Page access bug in CKWREX.
BCM,25-Jul-84
313 Development edit. Make extended code work with FORDDT. See spec
for details.
BCM,16-Aug-84
314 Get rid of all references to NEARST.
Clean up the LOOK routine.
AlB,23-Aug-84
315 Change the search of the symbol table which looks for the name of
the main program. Instead of looking for a program name of 'MAIN.',
use the program which contains the global value 'MAIN.'.
AlB,24-Aug-84
316 Change the START mechanism such that the main program could be
in a section other than the one in which FORDDT is loaded.
AlB,24-Aug-84
317 Add a three-word entry vector for Tops-20.
The use of .JBREN is retained for Tops-10.
AlB,24-Aug-84
320 Prepare for the handling of symbol tables which exist in a section
other than the one in which FORDDT is loaded.
o Add a temporary 'build a symbol vector' routine. This routine
will be removed when a FOROP. call is added to do the same thing.
o Change the SETLST and FIXSYR routines to allow for global indices
into the symbol tables.
o Remove SETLXS, which is no longer needed.
o Modify GHSSYP to take error exit if we are in a non-zero section.
o Modify OVRLAY so as to call SETLST whenever it detects that
.JBSYM has changed.
AlB,27-Aug-84
321 Change the symbol searches to use global addresses.
Essentially, instead of using the JOBDAT IOWD-style symbol table
addresses, we use two words: one is a global address into a
symbol table, and the other is the number of unsearched words.
This change enables the symbol tables to be anywhere in memory.
Also made several miscellaneous changes to reflect the fact that
we may be in a section other than the one in which the symbol
tables reside.
Also fixed some problems with array indices being larger than a
half-word, and with array sizes larger than a half-word.
Also made some changes just because I couldn't stand to look at
some rottenly constructed code ONE MORE TIME!!
AlB,29-Aug-84
322 Fix ACCEPT of character data. When exactly enough characters were
entered for the field, the field was not being displayed in
confirmation.
Fix TYPE of a range of character array elements. Prior to this fix,
only the last element was being TYPEd.
AlB,30-Aug-84
323 Fix BLDVEC to get the correct section number for symbols.
Re-do the handling of optional command switches. It was rather
confusing as written. Now register P3 contains the default settings
in the left half, and the currently active settings in the right half.
AlB,4-Sep-84
324 Fix CONTINUE. LEAV2 was returning to user program via an indirect jump
jump through a bogus location.
AlB,7-Sep-84
325 Add PAUSE ON ERROR command.
MEM,6-Sep-84
326 Remove references to FGLSNM, which was a flag to tell LOOK (a symbol
table lookup) that global symbols are Ok. Since that flag was being
turned off by CPOPJ1 and CPOPJ2, we sometime could not find a global
symbol. Since global symbols are always Ok, we don't need that flag.
Also changed all references to (erroneous) edit number 2460 and
replaced them with 325. Put edit number on all places that were
touched by 325 aka 2460. Fixed bugs in AC save and restore caused
by edit 325.
AlB,25-Sep-84
327 Use the routine in FORLIB which determines the location of the
symbol table. In this way, we are assured that FOROTS/FORLIB and
FORDDT are using the same symbol table.
AlB,25-Sep-84
330 Use the default MODEs when confirming the value ACCEPTed with
modifier /S.
AlB,27-Sep-84
331 Instead of typing message "Pause on error", JRST FORDDT
which will print message "Entering Forddt at..." and then do a
breakpoint 0.
MEM,2-Oct-84
332 Modify pause on error code according to comments made during its
inspection. Make REMOVE remove pause on error and make WHAT
display pause on error if it is set.
MEM,9-Oct-84
333 Fixup problems with edit 321.
BCM,5-Nov-84
334 Change message, when reentering FORDDT from ^C and running extended,
from garbage address to "from FORDDT".
MEM,27-Dec-84
335 Add a TOPS-20 conditional left out of edit 334
JLC,27-Feb-85
***** End V10 Development *****
;.VERSION 10
;.AUTOPATCH 11
;.EDIT 336 NOOP EDIT TO UPDATE OUR VERSION NUMBER
;; No code changes. (See edit 221).
; MRB,9-MAY-85,SPR:NONE
; A:SRC FORDDT.MAC
;;.ENDA 9-MAY-85
;;.EDIT 337 RESERVED FOR AUTOPATCH
;;.ENDA 24-JUN-85
;;.EDIT 340 FORDDT CRUSHES USER ACS
;; SAVACS was being used as scratch in PAUSE, START, and RESET
; PLB,2-JUL-85,SPR:20-20789
; A:SRC FORDDT.MAC
;;.ENDA
;.ENDA
;.ENDV
;.ENDR REVISION HISTORY
***** Begin V11 Development *****
400 Become Version 11.
MRB, 28-Mar-85
401 Add substring support in ACCEPT and TYPE statements.
MEM, 19-Dec-85
402 Add long symbol support. For each FORDDT memory location that stores
a symbol we also have a flag word that is zero if the symbol is short.
When we have a symbol in a register then the LNAME bit of the left
half is lit when the symbol is long.
MEM, 17-Feb-86
403 Correct various error messages and an extended addressing problem.
MEM/MRB, 1-Jun-86
404 CDM 10-Jul-86
Call ERRSET when doing PAUSE ON ERROR, so that the user will
get error/warning messages when his program pauses!
405 MEM 26-Sep-86
In LSPT, check if global address before making OWGBP since KS
can't handle them.
***** End V11 Development *****
***** End Revision History *****
ENDV11
\;END OF COMMENT
SUBTTL DEFINITIONS
;DEFINE ACCUMULATORS
ENTRY FORDDT,FDDT.,.F10,%FDDT
EXTERN .JBREL,.JBHRL,.JBSYM,.JBSA,.JBOPC,.JBDA ;[321]
EXTERN ERRSET ;[404] Set number of ots warnings to receive
IFN EXTHLP,<EXTERN .HELPR> ;[147] for external HELPER
;AC0=<F=0> ;[147] FLAGS
;AC1=<TF=1> ;[147] TEMPORARY FLAGS, RESET ON RETURN TO RET:
;AC2=<R=<T1=<A=2>>> ;[147] POINTERS TO TABLES, CORE, ETC.
;AC3=<S=<T2=<B=3>>> ;[147]
;AC4=<W=<T3=<C=4>>> ;[147] CONTAINS DISPATCH ADDR IN WORD ASSEMBLER
;AC5=<T=<T4=5>> ;[147] TRANSFER DATA
;W1=<T5=6>
;W2=<T6=7>
;TMOD=10 ;TYPE MODE FLAGS
;AR=11
;ODF=12 ;RADIX DEFINITION
;TT=<P3=13> ;TEMPORARY
;TT1=<P4=14> ;TEMPORARY
;RAY.==15 ;POINTS TO NEXT F10 DEFINE ARRAY DIMENSION
;L=16 ;[147] POINTER TO ARGUMENT LIST
;P=17 ;PUSH DOWN
T0==0 ;FLAGS
T1==1 ;TEMPORARY FLAGS, RESET ON RETURN TO RET:.
T2==2 ;POINTERS TO TABLES, CORE, ETC
T3==3
T4==4 ;CONTAINS DISPATCH ADDR IN WORD ASSEMBLER
T5==5 ;TRANSFER DATA
P1==6
P2==7
P3==10 ;[323] Mode flags (default,,active)
P4==11
S1==12 ;RADIX DEFINITION
S2==13 ;TEMPORARY
S3==14 ;TEMPORARY
S4==15 ;POINTS TO NEXT F10 DEFINE ARRAY DIMENSION
L==16 ;POINTER TO ARGUMENT LIST
P==17 ;STACK
;DEFINE SYMBOL TABLE SYMBOL TYPES
; The SECONDARY SYMBOL TABLE which starts at the local symbol .SYMTB in each
; module has its start address stored into SSTAB in FORDDT by the code to OPEN
; the current module. This table starts with a count of the number of entries
; in the right half and the left half is zero if the secondary symbol table
; contains only globals. The first entry in the symbol table (at .SYMTB+1)
; is for the module name. Each entry in the table is two words long. The first
; word has a 3 bit flag field, a 3 bit count of the number of words in the
; symbol name, and a 30 bit address to where the symbol name is stored. The
; second word is the address of the location where the value of the symbol is
; stored.
;
; +-------------------------------------------------+
; .SYMTB: | symtb flag | entry count |
; +-------+------------+---+------------------------+
; | flags | word count | ptr to symbol | First entry is
; +-------+------------+----------------------------+ module name
; | address of value of symbol |
; +-------+------------+---+------------------------+
; | |
; | ... |
; +-------+------------+---+------------------------+
; | flags | word count | ptr to symbol |
; +-------+------------+----------------------------+
; | address of value of symbol |
; +-------+------------+----------------------------+
;
;
;
;
CNTSFT==^D30 ;[402] SHIFT TO GET CNT FROM CNT+PTR FOR LONG NAME
LGLOBL==200000 ;[402] GLOBAL in secondary symbol table
LPNAME==600000 ;[402] program name in secondary symbol table
LFLG== 700000 ;[402] flag field in secondary symbol table entries
; In LINK's symbol table entries are also 2 words long. The first word contains
; a four bit flag field followed by the radix 50 name. The second word in the
; address of the symbol value.
; +-------+------------+----------------------------+
; | flags | radix 50 symbol name |
; +-------+------------+----------------------------+
; | address of value of symbol |
; +-------+------------+----------------------------+
; | |
; | ... |
; +-------+------------+----------------------------+
; | flags | radix 50 symbol name |
; +-------+------------+----------------------------+
; | address of value of symbol |
; +-------+------------+----------------------------+
GLOBAL==040000 ;GLOBAL SYMBOL
LOCAL==100000 ;in ddt and secondary symbol table
PNAME==740000 ;PROGRAM NAME
DELI==200000 ;DELETE INPUT
DELO==400000 ;DELETE OUTPUT
;[137] SYMBOLS REPRESENTING FOROTS ARG TYPES
TP%DPR==10 ;[137] D-floating double precision
TP%DPX==13 ;[137] G-floating double precision
TP%CPX==14 ;[210] Complex
TP%CHR==15 ;[157] Character
FO$HSP==4 ;[142] FOR RETURNING HISEG SYBOL TABLE PTR.
FO$GBA==20 ;[332] GET BREAK ADDRESS
FO$UDB==23 ;[211] FOR RETURNING CONTENTS OF %UDBAD
; DEFINE SYSTEM PARAMETERS
IFNDEF SYMSPC,<SYMSPC==2> ;[402] 1 word for ptr to symbol
;[402] plus 1 word for flag word
IFNDEF NBP,<NBP==^D10> ;NUMBER OF PUASE REQUESTS
IFNDEF GPMAX,<GPMAX==10> ;NUMBER OF GROUP STRINGS (MAX 35 )
IFNDEF PDSIZ,<PDSIZ==10> ;[327] DEFINE PDL SIZE FOR INITIAL STACK
IFG PDSIZ-100,<PDSIZ==100> ;LIMIT SIZE TO ^D64
IFNDEF CFSIZ,<CFSIZ==^D15> ;CORE FILE LENGTH
IFNDEF DIMSIZ,<DIMSIZ==^D50> ;AMOUNT OF SPACE FOR DIMENSION DEFINITIONS
IFNDEF DEBUG,<DEBUG==0> ;KEEP OFF - DEVELOPMENT ONLY - UNSUPORTED
IFN DEBUG< IF1<
PRINTX FORDDT - DEVELOPMENT VERSION
> >
COMMENT \
NBP DEFINE THE MAXIMUM NUMBER OF PAUSE REQUESTS ALLOWED
EACH PAUSE INCREASES CORE REQUIREMENTS BY DECIMAL 10
GPMAX DEFINE THE MAXIMUM NUMBER OF GROUPS
EACH GROUP SETTING REQUIRES AN EXTRA DECIMAL 23 LOCATIONS
PDSIZ DEFINE THE SIZE OF THE PUSH DOWN STACK
ALLOW SUFFICIENT STACK FOR ALL GROUPS TOGETHER
LIMITS PDSIZE TO ^D64
CFSIZ DEFINE THE SIZE OF EACH CORE FILE
DIMSIZ DEFINE THE NUMBER OF ENTRIES
USED TO HOLD ARRAY DIMENSION DATA
ESEFIW location of table of EFIW of JSR's under /EXTEND
SZEFIW Table of the EFIW's referenced by the JSR instruction.
Word 0 points to BP1, word 1 points to BP2, etc. In non-zero
sections, this table will be copied to the address given by ESEFIW.
ESDIEB Location of dispatch instruction execute block under /EXTEND
SZDIEB Table of displaced instruction blocks. In non-zero sections,
this table will be copied to the address given by ESDIEB.
\
ESEFIW==.JBDA+1 ;[313] location of EFIW table
ESDIEB==ESEFIW+NBP ;[313] location of displaced instruction block table
;FLAG F DEFINITIONS, LEFT HALF:
EOL== 400000 ;END OF USER LINE
FPF== 200000 ;PERIOD TYPED FLAG
FEF== 100000 ;EXPONENT FLAG
MF== 040000 ;MINUS FLAG
SIGN== 020000 ;PLUS OR MINUS TYPED
CFLIU== 010000 ;CORE FILE IN USE FLAG
OFCFL== 004000 ;OUTPUT FROM CORE FILE REQUESTED
CONS== 002000 ;CONSTANT SEEN FLAG
GRPFL== 001000 ;GROUP FLAG - ALLOWS GROUP LOGIC
AUTO== 000400 ;AUTO PROCEDE FLAG
OCTF== 000200 ;OCTAL NUMBER TYPED FLAG
;FGLSNM==000100 ;[326] ALLOW GLOBAL SYMBOL NAMES (FOR LOOK AND FINDSYM)
LABEL== 000040 ;INDICATES STATEMENT LABEL BEING PROCESSED
LFTSQB==000020 ;FLAG THAT A [ IS SEEN - SO A ] WILL END THE SPECIFICATION
BAR== 000010 ;FLAG THAT WE HAVE SEEN A / IN DIMENSION ANALYSIS
DIMEND==000004 ; ) OR ] FOUND I.E. END OF DIMENSION SPEC IMINENT
;[321] FPRNM== 000002 ; FIND PROGRAM NAME (FOR FNDSYM)
;[321] FLCLNM==000001 ; FIND LOCAL IN CURRENT OPEN PROGRAM (FOR SYMBOL SEARCH)
;RIGHT HALF
POWF== 400000 ;POWER FLAG # TO FOLLOW
DOUBLE==200000 ;FLAG FOR DOUBLE WORD ARRAY DATA
BASENM==100000 ;AN ARRAY BASE NAME HAS BEEN ACCEPTED
TRLABL==040000 ;TRACING LABEL ONLY FLAG
;[157]PNAMEF==020000 ;PROGRAM NAME SEEN IN SYBOL TABLE SEARCH
CHARS== 020000 ;[157]Character array
MDLCLF==010000 ;USED BY SYMBOL SEARCHES - MULTIPLY DEFINED LOCAL SYBOL
ID== 004000 ;SYMBOL IDENTIFIED FLAG
IDINOS==002000 ;SYMBOL IDENTIFIED IN OPEN SECTION
SILENT==001000 ;DO NOT TYPE SYMBOL IF FOUND IN 'LOOK'UP
SUBFLG==000400 ;SUBSCRIPT FLAG - CHECK SUBSCRIPTS IF ON
FLSHAL==000200 ;FLUSH ALL ARRAY NAMES FROM BASRAY ONWARDS
IDPNAM==000100 ;IF SET CAUSES 'LOOK' TO REMEMBER SECTION NAME
;[314] NEARST==000040 ;IF SET CAUSES 'LOOK' TO RETURN THE NEXT LARGER SYMBOL
F10RAY==000020 ;CURRENT ARRAY IS F10 DEFINED
TRLINE==000010 ;TRACE AT LINES LEVEL
FORMAL==000004 ;HANDLING ARRAY AS SUBROUTINE FORMAL PARAMETER
GFLOAT==000002 ;[137] If set, G-floating is in use; else D-floating.
SURGFL= 000001 ;ACCEPT / AND : AS DIMENSION RANGE DELIMETERS
; *** FLAG T1 ***
;
; T1 TEMPORARY FLAG DEFINITIONS:
; CLEARED ON EVERY RETURN TO USER (RET:)
;
; RIGHT HALF
DCOPFG==000001 ;DON'T CHANGE OPEN PROGRAM FOR GROUP
ALPHA== 000002 ;PERSUADES ROUTINE EITHER TO RETURN SIXBIT ON NON # INPUT
ACCPT== 000004 ;SIGNALS AN ACCEPT IN PROGRESS
ADELIM==000010 ;FLAG THAT WE HAVE HAD AN ASCII TEXT DELIMITER
IMPRNG==000020 ;REQUEST FOR IMPLIED RANGE
ARRAY.==000040 ;AN ARRAY HAS BEEN DETECTED DURING ACCEPT LOGIC
; ALSO DURING TYPE OFFSET PROCESS
GUDLBL==000100 ;A GOOD NUMERIC LABEL FOUND IGNORING LAST CHARACTER
FGLONL==000200 ;FIND GLOBAL SYMBOL ONLY
SYMLAB==000400 ;SYMBOL IS A LABEL
DCEVAL==001000 ;DON'T CALL EVAL ( FROM SYMIN )
COMDEL==002000 ;COMMENT PROCESS IN PROGRESS
LGCLEG==004000 ;[116] LOGICALS ARE LEGAL WHEN FLAG IS ON
ISLOGI==010000 ;[116] WE ARE DEALING WITH A LOGICAL CONSTANT
TYPCMD==020000 ;[171] Processing TYPE
COMDAT==040000 ;[171] COMMON data
LNAME== 100000 ;[402] WE HAVE A LONG SYMBOL NAME IN A REGISTER
; *** FLAG P3 ***
;
; DEFINE THE PRINT OPTION FLAGS USED IN LEFT & RIGHT OF P3
;[323] LEFT HAND - DEFAULT USER SETTING
;[323] RIGHT HAND - LOCAL TEMPORARY SETTING (TAKES PRIORITY)
F.==000001 ;TYPE FLOATING POINT FORMAT
I.==000002 ;TYPE INTEGER FORMAT
O.==000004 ;TYPE OCTAL FORMAT
A.==000010 ;TYPE ASCII FOMAT
D.==000020 ;TYPE DOUBLE PRECISION FORMAT
R.==000040 ;TYPE RIGHT JUSTIFIED ASCII
X.==000100 ;[157]TYPE COMPLEX FORM
B.==000200 ;[120] 'BIG' OPTION REQUESTED
L.==002000 ;[120] LOGICAL FORMAT (.TRUE. AND .FALSE.) OR TRACE LABELS
C.==004000 ;[157] Character string
S.==000400 ;TRACE SOURCE LINES
E.==001000 ;TRACE ENTRIES
ANYMOD==400000 ;USED BY OPTION TO SHOW LEGAL MODIFIER SEEN
;
; ********** FLAGS FOR LEFT HALF OF COND0 **********
LFTLOG==000001 ;[116] LEFT CONSTANT IN CONDITIONAL WAS LOGICAL
RHTLOG==000002 ;[116] RIGHT CONSTANT IN CONDITIONAL IS LOGICAL
;FLAG T0 - "STICKY FLAGS"
STIKYS==TRLABL!TRLINE!GFLOAT ;[137] Add "GFLOAT" to mask to be
;[137] "and"ed with STKYFL at RET:
; USEFUL OPDEFS
OPDEF PJRST [JRST] ;PUSHJ/=POPJ
; POSSIBLE ERROR MESSAGES OF THE FORM ? E#
; THE ASSOCIATED ERROR MESSAGE IS:
; ?FDTIER Internal FORDDT error - (number)
;
; ? E1 CANNOT FIND SYMBOLIC NAME FOR THE PAUSE IN A 'WHAT'
; ? E2 CANNOT FIND SYMBOLIC NAME FOR THIS PAUSE(BREAK)
; ? E3 CANNOT FIND SYMBOLIC NAME FOR AN ARGUMENT OF THE
; ROUTINE ABOUT TO BE ENTERED
; ? E4 BAD LABEL FOUND WHERE SOURCE LINE OR STATEMENT LABEL EXPECTED
; ? E5 CANNOT FIND SYMBOL IN DIMENSION LOGIC
; ? E6 CANNOT FIND SYSMBOL MATCH IN A RE-ENTER
; ? E7 CANNOT FIND SYMBOL IN A TRACE INTERUPT
; ? E8 CANNOT FIND END OF F10 FORMAT STATEMENT = LABEL+F
; THESE ERRORS SHOULD NEVER OCCUR - BUT COULD INDICATE THAT
; THE SYMBOL TABLE HAD BEEN MODIFIED(OVERLAYED?) OR SOMETHING
SUBTTL MACRO'S
;[325] Removed SETPDL
; Each FORDDT symbol is stored as follows:
; The first word may either contain a radix50 name or it may contain a 6 bit
; word count for the length of the symbol followed by a 30 bit address of the
; symbol (which is actually .+2). The symbol is long if the LNAME bit in the
; left half of the flag word is set.
;
; +------------------------+
; | wordcount| ptr to name | or radix50 name
; +------------------------+
; | flag name |
; +------------------------+
; | symbol name |
; | ... |
; +------------------------+
;
;
;
DEFINE CLRFLG(SYM)
<SETZM SYM+1>
DEFINE SETFLG(SYM)
<SETOM SYM+1>
DEFINE GETFLG(REG,SYM)
<MOVE REG,SYM+1>
DEFINE SYMSKN(SYM)
<SKIPN SYM+1>
DEFINE SYMSKE(SYM)
<SKIPE SYM+1>
DEFINE LDFLG(SYM)
< TRZ T1,LNAME ; Clear long symbol flag
SKIPE SYM+1 ; Is this a long symbol?
TRO T1,LNAME ; Yes, so set long symbol flag
>
DEFINE LDSYM(REG,SYM)
< MOVE REG,SYM ; Load long symbol into register
TRZ T1,LNAME ; Clear long symbol flag
SKIPE SYM+1 ; Is this a long symbol?
TRO T1,LNAME ; Yes, so set long symbol flag
>
DEFINE STSYM(REG,SYM)
< MOVEM REG,SYM ; Store symbol into memory
SETZM SYM+1 ; Assume symbol was short
TRNE T1,LNAME ; Was symbol long?
SETOM SYM+1 ; Yes, so set long symbol flag
>
DEFINE MOVSYM(SYM1,REG,SYM2)
< MOVE REG,SYM1+1 ;Copy flag word
MOVEM REG,SYM2+1
MOVE REG,SYM1 ;Copy symbol
MOVEM REG,SYM2
>
DEFINE QUERY
< TYPE (? ) >
ife tops20,<
DEFINE TYPE(X)
< OUTSTR [ASCIZ/X/] >
DEFINE LINE
< OUTSTR CRLF >
define atype(x)
< outstr x >
define stype(x)
< outstr [asciz x]>
define tab
< outstr [byte(7)11,0] >
define openp
< outstr [byte(7)"(",0] >
define closep
< outstr [byte(7)")",0] >
define openb
< outstr [byte(7)74,0] >
define closeb
< outstr [byte(7)76,0] >
define putchr(x)
< outchr x>
> ;end of conditional
ifn tops20,<
define type(x)
< push p,T1
hrroi T1,[asciz/x/]
psout%
pop p,T1 >
define atype(x)
< push p,T1
hrroi T1,x
psout%
pop p,T1 >
define stype(x)
< push p,T1
hrroi T1,[asciz x]
psout%
pop p,T1 >
define line
< push p,T1
hrroi T1,[byte(7)15,12,0]
psout%
pop p,T1 >
define openp
< push p,T1
hrrzi T1,"("
pbout%
pop p,T1 >
define closep
< push p,T1
hrrzi T1,")"
pbout%
pop p,T1 >
define openb
< push p,T1
hrrzi T1,74
pbout%
pop p,T1 >
define closeb
< push p,T1
hrrzi T1,76
pbout%
pop p,T1 >
define tab
< push p,T1
hrrzi T1,11
pbout%
pop p,T1 >
define putchr(x)
< push p,T1
move T1,x
pbout%
pop p,T1 >
> ;end of conditional
DEFINE SKIPIF(STRING) ;IS STRING LOADED? - SKIP IF IT IS
< MOVE T5,[SQUOZE 0,STRING] ;GET RAD50 FORM OF 'STRING'
PUSHJ P,FINDST ;SEE IF STRING IS LOADED>
DEFINE PROGIF(NAME) ;IS NAME LOADED? SKIP IF SO
< MOVE T5,[SQUOZE 0,NAME]
MOVEM T5,SYM
PUSHJ P,FINDP > ;[321]
; RECURSION MACRO'S
;
; MACRO -RECURS- TO SAVE RELEVANT INFORMATION TO
; ALLOW RECURSION
; CALL SRUCER TO RESTORE
DEFINE RECURS(X)
< XLIST
IRP(X)< PUSH P,X>
DEFINE SRUCER<NAMLST <X> >
LIST >
DEFINE NAMLST(X)
< ..A=100
IRP(X)<DO(\..A,X)>
..A=..A-1
IRP(X)<UNDO(\..A)>
PURGE ..A >
DEFINE DO(I,J)
< ..K'I=J
..A=..A+1 >
DEFINE UNDO(I)
< XLIST
POP P,..K'I
..A=..A-1
PURGE ..K'I
LIST >
DEFINE JUSTIFY ;JUSTIFY THE OUTPUT & RESET T5
< PUSHJ P,JUSTFY ;DO TYPE COMMAND OUTPUT JUSTIFICATION>
SALL ;SUPPRESS ALL MACRO EXPANSIONS
DEFINE NAMES<
XLIST
C ACCEPT,ACCEPT
C CHARAC,CARRAY
C CONTIN,CONTIN
C DDT,DDT
C DIMENS,DIM
C DOUBLE,DUBLE
C GROUP,GROUP
C GOTO,GOTO
C HELP,HELP
C LOCATE,Q
C MODE,MODE
C NEXT,NEXT
C OPEN,OPEN
C PAUSE,PAUSE
C REMOVE,RESET
C START,START
C STOP,EX.
C STRACE,TRACE
C TYPE,DISPLA
C WHAT,WHAT
LIST
>
SUBTTL INITIALIZATION
; Below are all valid entry points to FORDDT except for the entry
; to FORDDT caused by a PAUSE. The PAUSE entry is a JSR into the table
; at BP1. This table's index is a function of the breakpoint number.
; From there a JSA to BCOM is performed.
; This entry point is used when stepping through a user program
; using the NEXT command. If a NEXT has been issued, PUSHJ P,STEP4
; will be placed in FDDT.. An XCT FDDT. is performed at the beginning
; of each executable source statement if the /DEBUG:TRACE option was used.
FDDT.: JFCL ;DEFAULT TO NO TRACE MODE
;OTHERWISE PUSHJ P,STEP4 TO TRACE
; This entry point should be used for reentering FORDDT from DDT.
; The DDT command %FDDT<ESC>G should be used.
%FDDT: ;[176] ADD THIS ENTRY POINT FROM DDT
JSR SAVE ;[176]SAVE USERS ACS
PUSHJ P,REMOVB ;[176]REMOVE PAUSES
JRST MODRT2 ;[176]Re-enter(DDT only...& skip reset of mode)
;[174]%FDDT: ;[125] ADD THIS ENTRY POINT FROM DDT
.F10: JSR SAVE ;SAVE USERS ACS
PUSHJ P,REMOVB ;REMOVE PAUSES
JRST MODRET ;DO A RE-ENTER - FOR DDT ONLY
; A user may CALL FORDDT from his FORTRAN program. This will
; fake a breakpoint. FORDDT must have been run previously, as
; when DEBUG PROG.FOR is used, before the user may call this
; routine. A CONTINUE may subsequently be used to reenter the
; user program.
FORDDT: ;[145] 'CALL' HERE FROM FORTRAN USER PROG
POP P,BP0 ;[145] FAKE JSR TO GET RETURN ADDRESS
SETOM BP0FLG ;[145] REMEMBER WE WERE 'CALL'ED
JRST BP0+1 ;[145]
;[317] The Tops-20 entry vector
ENTVEC: JRST SFDDT ;[317] Normal start address
REENT.::JRST RE.ENT ;[317] REENTER address
Z ;[317] Reserved for user
; This is the entry point when FORDDT is first run. All
; initialization procedures are performed, including a call
; to FOROTS' RESET.
SFDDT:
MOVE P,[IOWD PDSIZ,PDL] ;[327] Stack for use during setup
IFE TOPS20,<
MOVEI T5,RE.ENT ;AND SET UP THE RE-ENTER ADDRESS
MOVEM T5,.JBREN ;[317]
>
IFN TOPS20,<
SETZM EXTEND ;[300] clear the extend flag
XMOVEI T5,. ;[317] Are we in
TLNE T5,-1 ;[317] non-zero section?
SETOM EXTEND ;[300] yes, set the flag
SKIPE EXTEND ;[327] In non-zero section?
HLL P,T5 ;[327] Yes--Set section in stack pointer
>
JSR SAVE ;[145] SAVE THE WORLD
PUSHJ P,REMOVB ;REMOVE ANY STANDING PAUSE REQUESTS
LINE
TYPE(STARTING FORTRAN DDT)
LINE
JSP 16,FINIT.## ;[325] INITIALISE THE FOROTS SYSTEM
0,,0 ;[142] DUMMY RESET ARG
MOVEM P,SAVACS+17 ;[326] So that RESTOR has something
PUSHJ P,SETLST ;[320] Set up symbol vector
IFN TOPS20,<
SKIPE EXTEND ;[300] non-zero section?
JRST FORDX1 ;[300] yes, get extended addrs symbol table
>
HRRZ T5,.JBSA ;REMEMBER THE START ADDRESS
MOVEM T5,JOBSA ; AND THE
MOVE T5,.JBSYM ; SYMBOL TABLE DETAILS AT THE-
MOVEM T5,JOBSYM ; TIME FORDDT IS ENTERED
ife tops20,< ;This hack doesn't work under TOPS20
MOVE T5,[XWD -1,3] ;GET THE CURRENT JOB
GETTAB T5, ; NAME
CAIA ;DON'T PANIC IF NO JOB NAME
MOVEM T5,JOBNAM ;AND SAVE,
;THIS WILL SERVE TO DETECT OVERLAYS
SETZM TTYLC ;[151] DEFAULT TO DON'T FLAG LOWERCASE
MOVNI P2,1 ;[151] GET CURRENT JOB'S CONTROLLING TERMINAL UDX
TRMNO. P2, ;[151]
JRST FORDD2 ;[151] ERROR. DEFAULT TO NO FLAGGING OF LOWERCASE
MOVEI P1,.TOLCT ;[151] TRMOP. FUNCTION TO READ LOWERCASE SETTING
MOVE T5,[2,,P1] ;[151] SET UP TRMOP. CALL
TRMOP. T5, ;[151]
JRST FORDD2 ;[151] ERROR. ASSUME LOWERCASE. DOESN'T FLAG LC
MOVEM T5,TTYLC ;[151] STORE THE SETTING
FORDD2: ;[151]
> ;END OF IFE TOPS20
IFN TOPS20,<
JRST FORDX2 ;[300] skip this stuff if not extended
FORDX1: MOVEI T1,ESEFIW ;[320] GET THE NON-ZERO VALUE
MOVEM T1,EFIWAD ;[313] STORE IT FOR LATER USE
MOVEI T1,ESDIEB ;[313] GET THE NON-ZERO VALUE
MOVEM T1,DIEBAD ;[313] STORE IT FOR LATER USE
XHLLI T1,. ;[313] SECTION # IN LH
HRLZI T2,-NBP ;[313] SETUP LOOP CNTR
FORDXL: HLLM T1,SZEFIW(T2) ;[313] STORE SECTION #
AOBJN T2,FORDXL ;[313] INCR AND LOOP
FORDX2:
>
XMOVEI T5,[JRST RET] ;[313] GUARD AGAINST CONTINUE AFTER CNTRL C
MOVEM T5,PROC0 ;[313] STORE FULL ADDRESS
MOVEI T5,1 ;RESET THE INITIAL TRACE VALUE
MOVEM T5,STPVAL ; TO ONE
SETZM STARTU ;[316] User must 'START'
PUSHJ P,RE.NTR ;ALLOW A RE-ENTER TO WORK
SETOM ESCAPE ;NO ^C'S SO ALLOW ESCAPES TO FOROTS
; RE - ENTER ENTRY
RE.RET: ;[326] Removed SETPDL
SKIPIF (CEXIT.) ;
SETZM T5 ;NO CLUDGE CONECTIONS IN THIS PROG
HRRM T5,HELLO ;SET UP FOR HELLO MACRO DETECTOR
MOVE T0,STKYFL ;REINSTATE THE FLAG REGISTER
;[137] This routine provides g-floating
;[137] capability to those programs
;[137] compiled with the /gfl switch.
TRZ T0,GFLOAT ;[137] Default to d-floating mode.
TRO T1,FGLONL ;[137] Search for globals only in sym table
MOVE S3,[SQUOZE 0,..GFL.] ;[137] Store "..GFL." in SYM for EVAL
MOVEM S3,SYM
PUSHJ P,EVAL ;[137] Search symbol table for "..GFL."
JRST FSET ;[137] Not found, mode is d-floating; done
MOVE T0,STKYFL ;[137] Found, reinstate the flag reg(in case
;[137] T0 was modified by EVAL)
TRO T0,GFLOAT ;[137] Set GFLOAT flag to get g-floating
MOVEM T0,STKYFL ;[137] Update sticky flag store.
FSET: MOVSI T5,(JFCL) ;RESET THE TRACE ENTRY
MOVEM T5,FDDT. ;
MOVE T5,M2.F ;GET THE FOROTS FIN CALL
MOVEM T5,M2.I ;RE-INSTATE IN FORMAT - AFTER COMPLEX INPUT
; SET THE DEFAULT TYPING FORMAT TO FLOATING - ALSO SET STKYFL
MODRET: HRRZI T5,F. ;SET UP TO TYPE FLOATING FORM
MOVEM T5,MODFLG ;SAVE AS THE STANDARD DEFAULT
MODRT2: SKIPE STARTU ;[402] See if already started
JRST RET ;YES - SO NOT FIRST TIME THROUGH
PUSHJ P,MAINF ;[315] Find the main program
CAIA ;[315] Not found
JRST BEGIN3 ;[315] Name is in T4
BEGIN2: PUSHJ P,GETPRG ;NOT FOUND - GET THE MAIN PROGRAM NAME
MOVE T4,[SQUOZE 0,MAIN.];No name -- Use MAIN. as default
;DEFAULT MAIN PROG NAME IS MAIN.
BEGIN3: STSYM T4,PRGNAM ;[402] Store symbol into PRGNAM
MOVEM T4,SYM ;SET SO SETNAM CAN OPEN THE MAIN PROGRAM
PUSHJ P,SETNAM ;'OPEN' THE MAIN PROGRAM
SUBTTL USER INPUT
RET: MOVE P3,MODFLG ;[323] Get the default settings into
HRLS P3 ;[323] both halves
AND T0,[STIKYS] ;MAKE SURE WE SAVE THE GOOD FLAGS
MOVEM T0,STKYFL ; IN THE STICKY STORE
SETZI T1, ;RESET THE TEMPORARY FLAGS
SKIPGE TERMK ;END OF LAST LINE SEEN?
PUSHJ P,CLRLIN ;CLEAR OUT THE REST OF USERS LINE
;[325] Removed SETPDL
CLEARM CURGRP ;CLEAR CURRENT GROUP NUMBERS
CLEARM SYL
CLEARM MATHSM
CLEARM SYM
CLEARM DEN
CLEARM RANGE
CLEARM GETCHR
CLEARM SECSAV ;CLEAR SECTION NAME SAVED
ife tops20,<
SKPINL ;CLEARS THE EFFECT -
JFCL> ; OF ^O, end of conditional
ifn tops20,<
push p,T1 ;save T1
push p,T2 ;save T2
hrrzi T1,.priou ;get terminal output designator
rfmod% ;get terminal JFN word
tlz T2,(tt%osp) ;clear ^o effects
hrrzi T1,.priou ;get terminal output designator
sfmod% ;set new JFN word
pop p,T2 ;restore T2
pop p,T1> ;restore T1, end of conditional
LINE
PUSHJ P,OVRLAY ;HAS AN OVERLAY OCCURED
pushj p,readcm ;prompt and read user command
JUMPE T3,RET ;NO SIGNIFICANT INFORMATION
MOVEM T3,COMAND ;SAVE USER COMAND
JUMPN T2,BADSYN ;COMMAND TERMINOLOGICAL INEXACTITUDE
SKIPGE T2,TERMK ; SPACE IS NOT EOL
TLZA T0,EOL ;CLEAR EOL FLAG
TLO T0,EOL ;SET EOL FLAG
;NOW SEE WHAT USER WANTS!
; ENTER WITH SIXBIT USER COMMAND IN T3
;
; EXIT TO COMMAND IF RECOGNISED AND UNIQUE, OTHERWISE
; DISPATCH TO UNKNOWN OR COMMAND NOT UNIQUE ROUTINES
; N.B. T2 = DISPATCH ADDRESS
; T3 = USER COMMAND NAME
; T4 = OFFICIAL COMMAND NAME
COMCON: MOVE T3,COMAND ;GET USER COMMAND IN T3
MOVEI S2,DISP ;START OF DISPATCH TABLE
MOVE S3,[XWD -DISPL,COMTAB] ;STEP THRO COMMANDS
MOVE T2,T3 ;COPY USER COMMAND
SETOI T5, ;SET ALL ONES MASK
LSH T5,-6 ;SET MASK IN
LSH T2,6 ; T5 TO LENGTH OF
JUMPN T2,.-2 ; USER COMMAND
MOVEI P4,0 ;NO. OF NON-UNIQUE OCURRENCES
MOVE T2,S3 ;AOBJN FOR COMMAND TABLE
COMLP: MOVE T4,(T2) ;GET NEXT COMMAND
TDZ T4,T5 ;MASK OUT FOR MATCH WITH USER
CAMN T3,(T2) ;EXACT MATCH?
JRST COMFND ; YES - THIS IS IT
CAME T3,T4 ;MATCH SO FAR
JRST COMNEQ ;NO MATCH AT ALL
AOS P4 ;FLAG ANOTHER MATCH
HRL S2,T2 ;MARK LAST INDEX
COMNEQ: AOBJN T2,COMLP ;TRIED ALL KNOWN COMMANDS?
JUMPN P4,.+2 ;UNKNOWN?
AOS T2 ;SET FOR NONE UNIQUE
CAIN P4,1 ;WAS THE COMMAND UNIQUE?
HLR T2,S2 ;YES - REMEMBER THIS INDEX
MOVEI S2,DISP ;[303] BASE OF DISPATCH TABLE, AGAIN
COMFND: MOVE T4,(T2) ;SAVE OFFICIAL COMMAND NAME
SUBI T2,(S3) ;INDEX DOWN DISPATCH
ADDI S2,(T2) ;INDEX INTO DISPATCH
MOVE T2,(S2) ;GET DISPATCH ADDRESS
JRST @T2 ; DISPATCH
SUBTTL COMMAND DECODER
DEFINE C(A,B)
< SIXBIT/A/ >
COMTAB: XLIST ;NAMES
NAMES
LIST
DISPL=.-COMTAB
DEFINE C(A,B)
< IFIW B > ;[300]
DISP: XLIST ;HANDLERS
NAMES
EXP NOTUNQ ;COMMAND NOT UNIQUE
EXP ERROR ;UNKNOWN COMMAND
LIST
SUBTTL COMMAND SERVICE MODULES
;STRACE - SUBROUTINE CALLING SEQUENCE TRACE (WALK-BACK)
TRACE: SKIPN SAVACS+17 ;[203] HAS USER INITIALIZED FOROTS?
JRST RET ;[203] NO, JUST RETURN
SKIPN STARTU ;[316] User must
JRST ERR4 ;[316] initialize with START
SKIPN ESCAPE ;ARE WE ALLOWING ESCAPES
JRST ERR30 ;NO TRACE
MOVE T2,16 ;[325] SAVE FORDDT REG 16??
MOVE 16,SAVACS+16 ;[147] - GET FOROTS REG 16
PUSHJ P,TRACE.## ;[143] DO A FORTRAN TRACE
MOVE 16,T2 ;[325] Restore Reg 16
JRST RET ;END OF TRACE
; START FUNCTION
START: MOVSI T5,(JFCL) ;RESET THE TRACE ENTRY
MOVEM T5,FDDT. ;
PUSHJ P,CLRLIN ;FLUSH OUT LINE BUFFER
START2: LDSYM T5,PRGNAM ;[402]GET THE MAIN PROGRAM NAME
MOVEM T5,SYM ;SAVE FOR EVAL
TRNE T1,LNAME ;[402]IS LONG PROGRAM NAME FLAG SET?
JRST STRT2B ;[402] YES
MOVSI T2,GLOBAL ;[157]Global prefix
MOVEM T2,SYMASK ;[157]Reset mask in case it's been munged
PUSHJ P,FINDG ;No, Find the start of short name
JRST ERR8 ;NO START ADDRESS
JRST STRT2C ;[402]
STRT2B: MOVSI T2,LPNAME ;[402] global/program name in sec. symbol tab
MOVEM T2,SYMASK ;[402] Reset mask in case it's been munged
PUSHJ P,FINDLG ;[402]
JRST ERR8 ;[402]
STRT2C: MOVEM T5,STARTU ;[316] Save for go
MOVEM T0,STKYFL ;MAKE THE FOROTS FLAG STICK
PUSHJ P,RE.NTR ;ALLOW RE-ENTERS AGAIN
PUSHJ P,INSRTB ;PUT IN BREAKPOINTS
HRRZI T0,FO$GBA ;[332] HAVE FOROTS RETURN BREAK ADDRESS
PUSHJ P,FOROP. ;[325] IN T0
MOVE T5,@T0 ;[332] IF @T0=0 THEN NO PAUSE ON ERROR
JUMPE T5,START3 ;[332]
MOVEM T0,TEM10 ;[340] SAVE BREAK ADDRESS
JSP L,FINIT. ;[332] INITIALIZE FOROTS
JFCL ;[332]
XMOVEI T4,PAUERR ;[332] RESET PAUSE ON ERROR FLAG
MOVEM T4,@TEM10 ;[340] STORE VIA BREAK ADDRESS
XMOVEI 16,ERRARG ;[404] Biggest integer
PUSHJ 17,ERRSET ;[404] Set number of errors allowed
START3: JSP T5,RESTORE
SETZI 16, ;MAKE F40 STRACE WORK
JRST @STARTU ;[316] Start user program
; GOTO STATEMENT LABEL OR SYMBOL CONTENTS
GOTO: JUMPL T0,START4 ;NO ARGUMENTS = START AT LAST GOTO
PUSHJ P,SYMIN ;GET USERS ARGUMENT
JRST ERR6 ;NONE SUCH
CAIA ;NUMERIC
MOVE T5,(T5) ;GET CONTENTS
PUSHJ P,ONFORM ;ON A FORMAT STATEMENT?
JRST ERR36 ;YES - ERROR
PUSHJ P,CHKADR ;DO A CHECK OF USER AREA
JRST ERR31 ;ILLEGAL - ERROR
JFCL
CAIA
START4: MOVE T5,STARTU ;[316] Get start address
SKIPN STARTU ;[316] Any start address?
JRST ERR4 ;[316] No address - Refuse START and GOTO
MOVEM T5,GOLOC ;SET UP FOR EXTASK
MOVE T2,SAVACS+17 ;[325] Get user P
MOVSI T5,(POPJ P,) ;HAVE WE STOPPED AFTER A NEXT?
LDB T3,[POINT 23,LEAV,35] ;[303] PICK UP AC,I,E
TLO T3,400000 ;[303] MAKE THIS AN IFIW
CAME T5,@T3 ;[303]Have we stopped after NEXT?
SKIPA T5,GOLOC ;[303] NO, so skip the pop and reload T5
POP T2,T5 ;[170]YES, POP the user return addr
MOVEM T2,SAVACS+17 ;[325] And reset his P
SKIPN ESCAPE ;HAS A RE ENTER BEEN DONE?
JRST ERR30 ;YES - ONLY SOME FORM OF CONTINUE ALLOWED
PUSHJ P,ONFORM ;SKIP IF NOT A FORMAT AT (T5)
JRST ERR24 ;NOT ALLOWED
PUSHJ P,RE.NTR ;ALLOW RE-ENTERS AGAIN
MOVSI T5,(JFCL) ;RESET THE TRACE ENTRY
MOVEM T5,FDDT. ;
PUSHJ P,EXTASK ;TRANSFER TO EXTERNAL TASK
; OPEN
OPEN: JUMPL T0,OPEN2 ;ASSUME MAIN PROG IF JUST 'OPEN'
PUSHJ P,TTYIN ;WHAT NEXT
JUMPN T2,BADSYN ;MUST BE LINE END DELIMITER
JUMPE T3,BADSYN ;MUST HAVE SOME CHARACTERS
PUSHJ P,VALID ;CHECK VALIDITY & GET RAD50 IN T4
OPEN3: MOVEM T4,SYM ;SAVE FOR 'OPEN'
PUSHJ P,SETNAM ;DO THE OPEN
JRST RET ;WHAT NEXT
OPEN2: LDSYM T4,PRGNAM ;[402]GET FORTRAN MAIN PROG NAME
JRST OPEN3 ;OPEN THIS
; DDT FUNCTION
IFE TOPS20,< ;[114] TOPS-10 HAS UDDT LOADED, SO IT'S IN
;[114] SYMBOL TABLE
DDT: PROGIF (UDDT) ;IS DDT LOADED?
JRST MAPDDT ;[115] NO, GO GET VMDDT
MOVE T5,1(T2) ;[321] The address
HRRZM T5,GOLOC ;[333] just the RH
JRST EXTASK ;TRANSFER TO EXTERNAL TASK
MAPDDT: MOVE T5,[.PAGCA,,700] ;[115] CHECK FOR PAGE 700
PAGE. T5, ;[115] IS IT THERE?
JRST ERR11 ;[115] NO PAGE UUO, NO VMDDT
TLNN T5,(PA.GNE) ;[115] DOES PAGE EXIST?
JRST GODDT ;[115] YES, GO TO IT
MOVEM 17,MRGACS+17 ;[115] MERGE WRECKS ALL ACS
MOVEI 17,MRGACS ;[115] SO SAVE THEM
BLT 17,MRGACS+16
MOVEI T5,['SYS ' ;[115] SET UP TO GET DDT
'VMDDT '
EXP 0,0,0,0]
MERGE. T5, ;[115] GET IT
JRST [MOVSI 17,MRGACS ;[115] CAN'T, TOUGH
BLT 17,17
JRST ERR11]
MOVE T5,[775777,,700000] ;[122] SET .JBDDT
SETDDT T5, ;[122]
MOVSI 17,MRGACS ;[115] PUT ACS BACK
BLT 17,17
GODDT: MOVEI T5,700000 ;[115] SET ADDRESS
MOVEM T5,GOLOC
JRST EXTASK ;[115] GO CALL EXTERNAL TASK
>
IFN TOPS20,<
DDT: MOVE T1,[.FHSLF,,770] ;[114] LOOK AT PAGE 770
RPACS% ;[114] GET PAGE ACCESS BITS
TXNN T2,PA%PEX ;[114] DOES PAGE 770 EXIST?
JRST MAPDDT ;[114] NO, GO MAP IN UDDT.EXE
MOVE T1,770000 ;[300] GET DDT ENTRY VECTOR
CAMN T1,[JRST 770002] ;[114] IS IT REALLY DDT?
JRST GODDT ;[114] YES, JUMP TO IT
MAPDDT:
MOVEI T1,.FHSLF ;[114] GET ENTRY VECTOR LOC
SKIPE EXTEND ;[300] IS THIS AN EXTENDED PROG?
JRST [XGVEC% ;[300] YES, GET X-ENTRY VECTOR
DMOVEM T2,DDTVEC ;[300] SAVE THE DDT ENTRY VECTOR
JRST MAPDD2] ;[300] SKIP THE NON-EXTENDED VERSION
GEVEC% ;[300] GET NON-EXTENDED ENTRY VECTOR
MOVEM T2,DDTVEC ;[300] STORE IT
MAPDD2: ;[300] COMMON JUNCTURE
MOVX T1,GJ%SHT+GJ%OLD ;[114] SHORT FORM, FILE MUST EXIST
HRROI T2,[ASCIZ /SYS:UDDT.EXE/] ;[114] DDT
GTJFN% ;[114] FIND IT
ERJMP ERR11 ;[114] NOT THERE, CAN'T HELP
HRLI T1,.FHSLF ;[114] MAP INTO THIS FORK
TRO T1,GT%ARG!GT%NOV ;[300] LIGHT SOME FUNCTION CODE BITS
XMOVEI T2,GTBLK ;[300] ARG BLOCK FOR GET%
HLRZM T2,GTBLK+.GBASE ;[300] STORE CURRENT SECTION NUMBER
GET% ;[114] READ IN DDT
ERJMP ERR11 ;[114] CAN'T
DMOVE T1,.JBSYM ;[300] GET SYMBOL TABLE PTRS FROM SAME SECTION
MOVEM T1,@770001 ;[114] STORE FOR DDT
MOVEM T2,@770002
MOVEI T1,.FHSLF ;[114] THIS FORK
SKIPE EXTEND ;[300] ARE WE RUNNING EXTENDED?
JRST [DMOVE T2,DDTVEC ;[300] YES, RESTORE ENTRY VECTOR
XSVEC% ;[300] SET THE ENTRY VECTOR
JRST GODDT] ;[300] JOIN COMMON CO
MOVE T2,DDTVEC ;[300] RESTORE ENTRY VECTOR
SEVEC% ;[114] SET ENTRY VECTOR
GODDT: TYPE (<To return to FORDDT, type "%FDDT<ESC>G">)
LINE
XMOVEI T2,770000 ;[300] GET DDT START ADDRESS
MOVEM T2,GOLOC ;[114] SAVE
JRST EXTASK ;[114] GO CALL EXTERNAL TASK
>;[114] END IFN TOPS20
; EXIT FUNCTION
EX.: JUMPGE T0,EX.R ;IS THE USER REQUESTING A MONITOR RETURN
SKIPN STARTU ;[316] NO - SEE IF A START HAS BEEN DONE
JRST EX.A ;[316] NO START, DO NORMAL EXIT
PUSHJ P,CHKIWI ;[211] RECURSIVE IO IF WE CALL EXIT.?
JRST EX.R2 ;[211] YES, SIMULATE A STOP/RETURN
SETZM STARTU ;[316] No CONTINUE or REENTR
SETZM TEM ;SET UP ARG BLOCK
SETZM TEM1 ; TO EXIT FOROTS
PUSHJ P,INSRTB ;REPLACE PAUSES
JSP T5,RESTORE ;RESTORE USERS ACS
XMOVEI L,TEM ;[300] GET EXIT ARGBLOCK
PUSHJ P,EXIT.## ;[143] DO A FOROTS EXIT
EX.R: PUSHJ P,TTYIN ;GET NEXT INPUT
JUMPN T3,BADSYN ;LOOKING FOR / - NOCHARACTERS ALLOWED
JUMPE T2,BADSYN ;BETTER BE /
CAIE T2,"/"
JRST BADSYN ;SORRY
PUSHJ P,TTYIN ;LOOK FOR RETURN
JUMPN T2,BADSYN ;NO MORE CHARACTERS ALLOWED
JUMPE T3,BADSYN ;NO CHARACTERS IN INPUT????
LSHC T2,6 ;GET FIRST CHARACTER
CAIE T2,' R' ;LOOK FOR 'RETURN' - IMPLIED BY R
JRST BADSYN ;WE DONT UNDERSTAND ANY OTHER CHARACTER
EX.R2: ;[211]
ife tops20,<
CALLI 1,12> ;DO A MONRET
ifn tops20,<
haltf%> ;do a monret
JRST RET ;CONTINUE'S ALLOWED
ife tops20,<
ex.a: exit> ;do a non-returnable return
ifn tops20,<
ex.a: reset% ;close files, etc.
haltf% ;stop
jrst ex.a> ;and don't permit continues
; ROUTINE OVERLAY - TO DETECT WHEN THERE HAS BEEN AN APPARENT
; OVERLAY OF THE PROGRAM. THIS IS DONE BY OBSERVING THE
; VALUES OF .JBSA AND .JBSYM EVERY RETURN TO USER MODE
;[320] OVRLAY through OVRL2 rewritten
OVRLAY:
IFN TOPS20,<
SKIPE EXTEND ;[321] Don't want this if
POPJ P,> ;[321] we are in non-zero section
PUSH P,T4
SETZ T5, ;Becomes non-zero if difference found
MOVE T4,.JBSYM ;Lowseg symbol pointer
EXCH T4,JOBSYM ;Save new symbol pointer
JUMPE T4,OVRL1 ;Old value is zero if not inited
CAMN T4,JOBSYM ;Compare to last known value
JRST OVRL1 ;No change
PUSHJ P,SETLST ;Reset the symbol tables
MOVEI T5,1 ;Remember that we did that
OVRL1: HRRZ T4,.JBSA ;The start address
EXCH T4,JOBSA ;Swap with previous value
JUMPE T4,OVRL2 ;Exit if old start not set up
CAME T4,JOBSA ;Has this changed?
AOJ T5, ;Yes
OVRL2: POP P,T4 ;Restore register
SKIPN T5 ;Any change?
POPJ P, ;No - All is well
LINE
TYPE(<%FDTPOV Program overlayed>)
ife tops20,< ;this doesn't work under TOPS20
MOVE T5,[XWD -1,3] ;SET FOR PROGRAM NAME
GETTAB T5,> ;FIND THE CURRENT NAME,end of conditional
JRST OVRL3 ;SECRETIVE TYPE??
SKIPN JOBNAM ;HAS ANY NAME BEEN STORED?
MOVEM T5,JOBNAM ;NO - REMEMBER THIS
CAMN T5,JOBNAM ;OVERLAYED BY SYSTEM WHICH DOSN'T CHANGE NAME?
JRST OVRL3 ;YES
MOVEM T5,JOBNAM ;REMEMBER NEW NAME
TYPE( by )
PUSHJ P,SIXBP ;OUTPUT PROGRAM NAME
OVRL3: TYPE( ***)
LINE
SKIPN T5,JOBOPC ;ANY RE-ENTER ADDRESS?
MOVE T5,BCOM ;IF NOT BCOM SHOULD BE USER BREAK
HRRZ T5,T5 ;JUST THE ADDRESS THANK YOU
PJRST WHERE ;TELL WHERE - END OF OVERLAY
; RE-ENTER LOGIC
RE.ENT: ;[325] Removed SETPDL
SKIPE REENTR ;ARE WE ALREADY REENTERED?
JRST ER.ENT ;YES. REPORT
IFE TOPS20,< ;[300]
MOVEM P,SAVLOC ;FREE UP A SPARE REG
HRRZ P,.JBOPC ;GET THE BREAK P.C.
> ;[300]
SKIPE ESCAPE ;RE-ENTERS ALLOWED ONCE(SEE ER.ENT)
JRST RE.BRK ;DONT DESTROY USER PROFILE
IFE TOPS20,< ;[300]
MOVE P,SAVLOC ;RE-INSTATE THE OLD REG
> ;[300]
JSR SAVE ;SAVE THE EXTERNAL PROG STATUS
PUSHJ P,REMOVB ;AND REMOVE THE PAUSES
IFE TOPS20,< ;[300]
MOVE T5,.JBOPC ;GET THE PROG P.C.
MOVEM T5,JOBOPC ;STORE AND FLAG THAT WE ARE HANDLING RE-ENTER
MOVEM T5,JOBBRK ;SAVE THE JOB BREAK LOCATION
MOVEM T5,STARTU ;[316] ALLOW CONTINUES TO WORK
> ;[300]
SETOM REENTR ;SET FLAG THAT WE HAVE REENTERED
SKIPE PRGNAM ;[315] Do we have a main program?
JRST RE.LOC ;YES
PUSHJ P,MAINF ;[315] Find the main program
JRST RE.LOC ;[315] Not found
STSYM T4,PRGNAM ;[402] Store main program name
PUSHJ P,SETNAM ;OPEN MAIN PROG
; HERE TO DISPLAY THE CURRENT SUSPEND POINT
; JOBBRK IS THE BREAK - NEED NOT = JOBOPC
RE.LOC: ;CLEAR THE OUTPUT BUFFER
ife tops20,<
clrbfo
>
ifn tops20,<
push p,t1
hrrzi t1,.priou
cfobf%
pop p,t1
>
TYPE([ Program suspended )
HRRZ T5,JOBBRK ;SET UP THE ACTUAL SUSPEND POINT
ifn tops20,< ;[335]
SKIPN EXTEND ;[334] IF REENTERING AND PROGRAM IS IN EXTENDED
JRST RE.LO2 ;[334] SECTION THEN JUST SAY REENTERING FROM
> ;[335]
TYPE (from FORDDT) ;[334] FORDDT SINCE WE CAN'T GET ADDRESS
LINE ;[334]
SKIPA ;[334]
RE.LO2: PUSHJ P,WHERE ;TELL USER WHERE HE IS SUSSPENDED
TYPE(Open section: )
LDSYM T5,OPENED ;[402]WHAT IS THE CURRENTLY OPEN SECTION
PUSHJ P,SPT1 ;TYPE THAT
TYPE ( ])
MOVE T0,STKYFL ;RESET THE FLAG REGISTER
JRST RET ;RETURN TO NORMAL WORKING
ER.ENT: JRST RE.LOC ;INDICATE THAT WE ARE ALREADY HANDLING A REENTER
RE.NTR: SETZM REENTR ;ALLOW REENTERS AGAIN
SETZM JOBOPC ;CLEAR THE RE-ENTER IN PROGRESS FLAG
SETZM ESCAPE ;DO NOT ALLOW ESCAPES FROM FORDDT
POPJ P,
RE.BRK: ;[325] Removed SETPDL
SKIPN STARTU ;[316] Has a start been done?
JRST RE.RET ;[316] No - Return to FORDDT user mode
MOVE T5,BCOM ;GET THE PAUSE POINT
MOVEI T5,-1(T5) ;CORRECT FOR JSA
ANDI T5,-1 ;JUST THE ADDRESS PORTION
MOVEM T5,JOBBRK ;SAVE THE JOB BREAK FOR RE.LOC
JRST RE.LOC ;DISPLAY PROGRAM EXECUTION SUSPENSION
; ROUTINE TO DISPLAY WHERE THE PROGRAM IS SUSPENDED
WHERE:
IFN TOPS20,<
SKIPE EXTEND ;[300] CHECK IF WE ARE RUNNING EXTENDED
JRST [TYPE(in extended section)
JRST RE.L2] ;[300] YES, SAY SO, AND CONTINUE
>
SKIPN .JBHRL ;SKIP IF WE HAVE A HIGH SEG.
JRST RE.L2
CAMLE T5,.JBREL ;ARE WE SUSPENDED OVER THE LOW SEG.
JRST [TYPE(in high segment)
JRST RE.L2]
TYPE(in low segment)
RE.L2: TYPE( at )
;[326] TLO T0,FGLSNM ;GLOBALS ARE OK
PUSHJ P,LOOK ;DO A SYSMBOL 'LOOK'-UP
JRST [TYPE( an unknown location) ;[300] SAY WE DON'T KNOW
JRST RE.L3] ;[300] AND PROCEED
CAIA ;NOTHING TYPED
JRST RE.L3A ;FOUND AND TYPED
MOVEM T5,TEM ;REMEMBER NEAREST REFERENCE
PUSHJ P,SPT ;TYPE THE SYMBOL
TYPE( + )
MOVE T5,TEM ;GET THE OFFSET
PUSHJ P,TYP4 ;DISPLAY AS OCTAL
RE.L3A: SKIPN PNAMSV ;DID WE FIND A SECTION NAME
JRST RE.L3 ;NO
TYPE( in )
LDSYM T5,PNAMSV ;[402]GET THE SECTION NAME
PUSHJ P,SPT1 ;DISPLAY THAT
RE.L3: LINE ;
POPJ P, ;
; PAUSE LOGIC
PAUSE: JUMPL T0,PSEALL ;DISPLAY ALL PAUSES IF NO ARGUMENTS
TRO T1,FGLONL ;FIND GLOBAL SYMBOL ONLY
SETZM ONFLG ;[325]
PUSHJ P,SYMIN ;GET THE NEXT SYMBOL IN SYM
JRST ONCHK ;[325]NONE SUCH!
JRST PAUS11 ;[332] ;STATEMENT # FROM USER
JRST PAUS10 ;SYMBOL - MEANS STOP AT ROUTINE
ONCHK: CAME T3,[SIXBIT/ON/] ;[325]
JRST ERR6 ;[325] INVALID SYMBOL
JRST PAUS2 ;[325]
PAUS11: MOVEM T5,TEM1 ;[313] SAVE POINTER TEMPORARILY
SETZM TEM ;CLEAR CONDITIONAL REQUEST
SKIPL TERMK ;WAS THAT ALL THE USER WANTED?
JRST PAUS5 ; YES
PUSHJ P,TTYIN ; NO,GET MOR
JUMPN T2,BADSYN ;DO WE HAVE A LEGAL DELIMITER
JUMPE T3,PAUS5 ;[136] DID WE REALLY GET ANYTHING?
SKIPN ONFLG ;[325]
JRST TYPCHK ;[325] NO SUBROUTINE CALLED "ON"
CAMN T3,[SIXBIT/ERROR/];[325]
JRST P2OK ;[325] PAUSE ON ERROR
CAMN T3,[SIXBIT/ERR/];[325]
JRST P2OK ;[325]
TYPCHK: CAMN T3,[SIXBIT/TYPING/] ;[134] YES, MAYBE A 'TYPING' REQUEST
JRST PAUS7 ;[134]
SKIPL TERMK ;[134] DID WE GET A LINE TERMINATOR?
JRST BADSYN ;[134] YES, WRONG PLACE FOR IT
CAMN T3,[SIXBIT/AFTER/] ;FORCE USER TO TYPE WHOLE WORD
JRST PAUS4 ;AFTER REQUESTED
CAME T3,[SIXBIT/IF/] ;WAS IT 'IF'?
JRST BADSYN ;ANYTHING ELSE MEANS TROUBLE
TLZ T0,CONS ;CLEAR CONSTANT SEEN FLAG
TRO T1,LGCLEG ;[116] LET EITHER KNOW WE MAY GET LOGICALS
PUSHJ P,EITHER ;NUMBER OR SYMBOL SHOULD FOLLOW
PUSHJ P,NUMB ;CONSTANT SEEN
MOVEM T5,COND1 ;SAVE CONSTANT
SKIPL TERMK ;[134] DID WE GET A LINE TERMINATOR?
JRST BADSYN ;[134] YES, WRONG PLACE FOR IT
CLEARM COND0 ;CLEAR FOR TYPE OF TEST
TRZE T1,ISLOGI ;[116] IS IT A LOGICAL CONSTANT
JRST [SETZ T5, ;[116] YES, SET FLAG IN COND0
TLO T5,LFTLOG ;[116]
MOVEM T5,COND0 ;[116]
JRST .+1] ;[116]
JUMPN T2,.+2 ;DELIMITER?
PUSHJ P,GETSKB ;NEXT CHARACTER
CAIE T2,"." ;MUST BE . OF .EQ. ETC
JRST BADSYN
PUSHJ P,TTYIN ;GET SIXBIT STRING
CAIE T2,"." ;MUST AGAIN BE TERMINATED BY .
JRST BADSYN
HLRZS T3,T3 ;MORE USEFUL IN RIGHT HALF
CAIN T3,'LT '
JRST TEST1
CAIN T3,'LE '
JRST TEST2
CAIN T3,'EQ '
JRST TEST3
CAIN T3,'NE '
JRST TEST4
CAIN T3,'GT '
JRST TEST5
CAIN T3,'GE '
JRST TEST6
JRST BADSYN ;UNKNOWN CONDITION
TEST6: AOS COND0 ;GE=5
TEST5: AOS COND0 ;GR=4
TEST4: AOS COND0 ;NE=3
TEST3: AOS COND0 ;EQ=2
TEST2: AOS COND0 ;LE=1
TEST1: TRO T1,LGCLEG ;[116] LET EITHER KNOW LOGICALS ARE LEGAL
PUSHJ P,EITHER
PUSHJ P,NUMB ;SAVE AS A NUMBER
MOVEM T5,COND2 ;SAVE THE LOCATION
TRZE T1,ISLOGI ;[116] DID WE GET A LOGICAL CONSTANT?
JRST [SETZ T5, ;[116] YUP, SET COND0 FLAG
TLO T5,RHTLOG ;[116]
ORM T5,COND0 ;[116]
JRST .+1] ;[116]
MOVE T5,[JSR COND]
MOVEM T5,TEM ;FORM THE (CONDITIONAL TEST) LOCATION LINK
PAUS5: SKIPA T5,[Z 1] ;PROCEDE COUNT=1
PAUS4: PUSHJ P,EITHER ;GET USERS PROCEDE COUNT IN T5
CAIA ;CONSTANT GIVEN
MOVE T5,(T5) ;SYMBOL - GET CONTENTS
JUMPL T5,BADSYN ;DO NOT ALLOW NEGATIVE PROCEDE COUNTS
EXCH T5,TEM1 ;GET BACK BREAKPOINT ADDRESS
SKIPL TERMK ;WAS THAT ALL
JRST PAUS6 ; YES
MOVEM T5,SAVLOC ;SAVE PAUSE ADDRESS TEPORARILY
PUSHJ P,TTYIN ;GET SIXBIT USER INPUT
JUMPN T2,BADSYN
MOVE T5,SAVLOC ;[136] RESTORE PAUSE ADDR., IN CASE WE'RE DONE
JUMPE T3,PAUS6 ;[136] WAS THERE REALLY ANYTHING THERE?
CAME T3,[SIXBIT/TYPING/] ;YES
JRST BADSYN
PAUS8: SKIPL TERMK ;[134] DID WE GET A LINE TERMINATOR?
JRST ERR15 ;[134] YES, WRONG PLACE FOR IT
PUSHJ P,GETNUM ;USER WANTS AUTO DISPLAY
JUMPN T5,PAUS3 ;ASSUME ZERO MEANS NO INPUT
CAIN T2,"/" ;A / HERE DENOTES THAT A GROUP# FOLLOWS
JRST PAUS8 ;TRY FOR THE NUMBER AGAIN
PAUS3: CAIL T5,1 ;MAKE SURE HE GETS
CAILE T5,GPMAX ; ONLY A VALID GROUP #
JRST ERR15 ;COMPLAIN ABOUT GROUP #
HRLM T5,TEM1 ;[300] GROUP # TO LH OF PROCEDE COUNT
MOVE T5,SAVLOC ;[300] GET BACK PAUSE ADDRESS
TLO T0,AUTO ;SET THE AUTO PROCEDE FLAG
PAUS6: PUSHJ P,ONFORM ;SKIP IF NOT A FORMAT AT (T5)
JRST ERR19
PUSHJ P,BPS1 ;PLACE ALL PARAMETERS TO EFFECT A PAUSE
JRST RET ;DONE!
PAUS7: SETZI T5, ;CLEAR PROCEDE COUNT
EXCH T5,TEM1 ;GET PAUSE PLACE
MOVEM T5,SAVLOC ;STORE PAUSE LOCATION
JRST PAUS8
PAUS2: SKIPL TERMK ;[332] DID WE GET A LINE TERMINATOR?
JRST ERR6 ;[332] YES, WRONG PLACE FOR IT
PUSHJ P,TTYIN ;[325] GET SIXBIT USER INPUT
JUMPN T2,BADSYN ;[325]
CAMN T3,[SIXBIT /ERROR/];[325] IS IT 'PAUSE ON ERROR'?
JRST P2OK ;[325] YES
CAME T3,[SIXBIT /ERR/];[325] YES
JRST BADSYN ;[325] NO SO PRINT ERROR MESSAGE
P2OK: SKIPGE TERMK ;[332] DID WE GET A LINE TERMINATOR?
PUSHJ P,CLRLIN ;[332] NO, JUNK AFTER "PAUSE ON ERROR"
HRRZI T0,FO$GBA ;[332] HAVE FOROTS RETURN BREAK ADDRESS
PUSHJ P,FOROP. ;[325] IN T0
PUSH P,T4 ;[340] SAVE T4
XMOVEI T4,PAUERR ;[332]
MOVEM T4,@T0 ;[332] Set address for trap
XMOVEI 16,ERRARG ;[404] Biggest integer
PUSHJ 17,ERRSET ;[404] Set number of errors allowed
POP P,T4 ;[340] RESTORE T4
JRST RET ;[325] GET NEXT FORDDT COMMAND
PAUS10: SKIPE SUBSCR ;NOR MUST THERE BE AN OFFSET
JRST ERR19
MOVE T2,@SYMSAV ;GET SYMBOL
TRNE T1,LNAME ;[402]Short symbols?
JRST PAU10L ;[402]No
TLNE T2,700000 ;IS THIS A PROGRAM NAME OR GLOBAL
JRST ERR19 ;NO SO DONT ALLOW
TLZ T2,PNAME ;[331]
CAMN T2,[SQUOZE 0,ON];[331] IF IT IS "ON" THEN
AOS ONFLG ;[325] SET "PAUSE ON" FLAG
JRST PAU10A ;[402]
PAU10L: TLNN T2,LGLOBL ;[402]IS THIS A PROGRAM NAME OR GLOBAL
JRST ERR19 ;[402]NO SO DONT ALLOW
MOVE T2,(T2) ;[402] Get name
CAMN T2,[SIXBIT /ON/];[402] IF IT IS "ON" THEN
AOS ONFLG ;[325] SET "PAUSE ON" FLAG
PAU10A: MOVE T2,1(T5) ;DOES THIS ROUTINE INVOKE THE 'HELLO' MACRO?
CAMN T2,HELLO ;YES IT DOES - STOP 2 ON
ADDI T5,2 ;
JRST PAUS11
ONFLG: Z ;[325] =1 IF "PAUSE ON"
COND0: Z ;[116] LEFT = FLAGS; RIGHT = # OF TEST
COND1: Z ;SAVE ADDRESS OF FIRST ARGUMENT
COND2: Z ;SAVES ADDRESS OF SECOND ARGUMENT
COND3: Z ;SAVE VALUE OF CONSTANT IF DEFINED
NUMB: TLOE T0,CONS ;SET CONSTANT SEEN FLAG IF NOT ALREADY SET
JRST ERR14
MOVEM T5,COND3 ;SAVE VALUE OF CONSTANT
MOVEI T5,COND3 ;SAVE ADDRESS OF CONSTANT
POPJ P,
; ROUTINE TO CHECK IF A FORTRAN FORMAT EXISTS AT
; THE ADDRESS POINTED TO BY T5
; RETURN 1 IF IT IS A FORMAT
; RETURN 2 IF NOT A FORMAT
ONFORM: LDB P1,[POINT 7,(T5),6]
CAIE P1,"(" ;[311] TRUE IF FIRST CHAR IS AN OPEN PAREN
JRST CPOPJ1 ;NOT A FORMAT STATEMENT
LDB P1,[POINT 7,(T5),13] ;[311]
CAIL P1," " ;[311] IS IT LESS THAN A BLANK?
POPJ P, ;[311] NO, PROBABLY IS A FORMAT STATEMENT
JRST CPOPJ1 ;[311] NOT FORMAT, CHAR IS A CNTRL CHAR
; CONTINUE LOGIC
CONTIN: MOVSI T5,(JFCL) ;RESET THE TRACE ENTRY
MOVEM T5,FDDT.
SKIPN STARTU ;[316] Has START been done?
JRST ERR4 ;[316] No - Please type START
SKIPE T5,JOBOPC ;ARE WE IN A RE-ENTER CONDITION
JRST CONT2 ;YES - DEAL WITH IT
MOVEI T5,[POPJ P,] ;POPJ P, IS THE EXIT AFTER A 'NEXT'
CAMN T5,LEAV ;DID WE DO A 'NEXT' LAST TIME
JRST PROCED ;YES - DO NOT TAKE ARGS - RETURN WITH A POPJ
JUMPL T0,PROCED ;CONTINUE 1
PUSHJ P,EITHER ; NO - GET ARGUMENT
CAIA ;NUMBER TYPED
MOVE T5,(T5) ;SYMBOL TYPED - GET CONTENTS
JUMPL T5,BADSYN ;DO NOT ALLOW NEGATIVE PROCEDE SETTINGS
JRST PROCDX ;SET UP A PROCEDE COUNT
CONT2: MOVE T5,JOBOPC ;GET THE CONTINUE P.C.
MOVEM T5,GOLOC ;PREPARE TO CONTINUE
PUSHJ P,RE.NTR ;ALLOW RE-ENTERS AGAIN
PUSHJ P,INSRTB ;PUT BACK PAUSES
JSP T5,RESTOR ;RESTORE USER ACS
JRST @GOLOC ;[300] DO AN OFFICIAL RE-ENTER, using JRST
;HELP code for using either external HELPER or an internal version
;depending on the value of EXTHLP (1 = use external HELPER, 0 =
;use internal HELPER). WARNING: The current TOPS10 version of
;HELPER which uses memory above .JBFF for it's input buffers, will
;trash FOROTS' data areas.
;
;NOTE: All of the following help code unless otherwise noted is part
; of edit [147].
IFN EXTHLP,< ;when using external HELPER
HELP: MOVE T1,[SIXBIT/FORDDT/]
PUSHJ P,.HELPR ;GIVE 'EM SOME REAL HELP
JRST RET ; AND RETURN
> ;end IFN EXTHLP
;Starting IFE EXTHLP (internal help code). TOPS-10 native
;help code.
IFE EXTHLP,< ;start internal help code
IFE TOPS20,< ;start -10 internal help code
DSK=0 ;INPUT CHANNEL FOR FORDDT.HLP
HELP: PUSH P,T0 ;SAVE THE FLAGS
;Generate a home made buffer ring of two buffers and a buffer
;control block. Use FOROTS' ALCOR and DECOR routines for
;allocating and deallocating the buffer space.
;Allocate the buffer space.
MOVEI T1,^D264 ;ALLOCATE ENOUGH FOR TWO 128 WORD BUFFERS
MOVEM T1,ALCBLK+1 ;PUT IT WHERE ALCOR WILL FIND IT
MOVEI L,ALCBLK ;POINT TO IT
PUSHJ P,ALCOR.## ;LET FOROTS DO IT'S THING
SKIPG T0 ;A POSITIVE VALUE?
JRST ALCFAL ;NO, ALLOCATION FAILED
MOVEM T0,ALCBLK+1 ;SAVE ADDR FOR DECOR
;Set up the buffer header blocks.
AOS T2,T0 ;POINT TO 2ND WORD OF BUFFER HDR
HRLZI T1,^D129 ;SIZE OF BUFFER+1
HRR T1,T2 ;TACK ON ADDRESS OF 1ST BUFFER HDR+1
MOVEM T1,^D131(T2) ;PUT IT IN WORD 2 OF 2ND BUFFER HDR
ADDI T1,^D131 ;ADDR OF 2ND BUFFER HDR+1
MOVEM T1,(T2) ;PUT IT IN WORD 2 OF 1ST BUFFER HDR
;Try to find the help file.
SETZB T2,T5 ;SET UP A COUNTER AND ZERO T2
GETHLP: SKIPA T3,['HLP '] ;GET HLP:
GETSYS: MOVSI T3,'SYS' ;OR GET SYS:
MOVEI T4,HLPCTB ;ADDRESS OF BUFFER CONTROL BLOCK
OPEN DSK,T2 ;OPEN THE DEVICE CHANNEL
JRST HLPNHF ;LOSE...
MOVE T1,[EXP BF.VBR] ;SET UP THE BUFFER CONTROL BLOCK
MOVEM T1,HLPCTB ;SIGNIFY VIRGIN BUFFER
HRRM T0,HLPCTB ;GIVE ADDRESS OF 2ND WORD OF 1ST BUFFER
SETZM HLPCTB+1 ;ZERO NEXT TWO LOCATIONS
SETZM HLPCTB+2
MOVE T1,[SIXBIT/FORDDT/] ;FILE NAME
MOVSI T2,'HLP' ;EXTENSION
SETZB T3,T4 ;ZERO NEXT TWO
LOOKUP DSK,T1 ;LOOKUP FORDDT.HLP
TLZA T2,-1 ;CLEAR JUNK, WE BLEW IT
JRST NXTBUF ;GOOD--GO READ FILE
CAIE T2,ERSNF% ;SFD NOT FOUND?
CAIN T2,ERSLE% ;SEARCH LIST EMPTY?
JRST NXTSTR ;ONE OF THE ABOVE
CAILE T2,ERIPP% ;INCORRECT PPN OR FILE NOT FOUND?
JRST HLPNHF ;HORRIBLE DISK ERROR
NXTSTR: SETZM T2 ;CLEAR PHYSICAL BIT
AOS T5 ;TRY NEXT CASE
TRNE T5,1 ;SEE IF ODD
TXO T2,UU.PHS ;YES--TRY PHYSICAL ONLY
JRST @[GETHLP ;TRY HLP: AGAIN
GETSYS ;THEN LOGICAL SYS:
GETSYS ;THEN PHYSICAL SYS:
HLPNHF]-1(T5) ;THEN GIVE UP
NXTBUF: IN DSK, ;GET A BUFFER
JRST OUTBUFF ;OUTPUT THE BUFFER
STATZ DSK,IO.ERR ;SEE IF ERRORS
JRST HLPIOE ;YES--ISSUE MESSAGE
STATZ DSK,IO.EOF ;DONE YET?
JRST HLPDON ;YES
OUTBUF: HRRZ T1,HLPCTB+1 ;POINT TO 1ST DATA LOC IN BUFFER
AOS T1 ; ''
OUTSTR @T1 ;OUTPUT THE BUFFER
JRST NXTBUF ;GO GET THE NEXT
ALCFAL: OUTSTR [ASCIZ /%FDTCAB Cannot allocate buffer for help file/]
JRST HLPRET
HLPIOE: OUTSTR [ASCIZ \%FDTIOE I/O error reading help file\]
SKIPA
HLPNHF: OUTSTR [ASCIZ /%FDTNHF Cannot find help file/]
OUTSTR [ASCIZ /; I'm sorry, I can't help you/]
HLPDON: RELEAS DSK, ;RELEASE DISK CHANNEL
MOVEI L,ALCBLK ;NEED TO DEALLOCATE BUFFER SPACE
PUSHJ P,DECOR.## ;DO IT
HLPRET: OUTSTR CRLF
POP P,T0 ;RESTORE FLAGS
JRST RET ;ALL DONE
HLPCTB: BLOCK 3
> ;end IFE TOPS20 (-10 internal help code)
;Continuing IFE EXTHLP (internal help code). TOPS-20 native
;help code.
IFN TOPS20,< ;start -20 internal help code
HELP: PUSH P,T0 ;SAVE THE FLAGS
;Use FOROTS' ALCOR and DECOR routines for
;allocating and deallocating the buffer space.
MOVEI T1,^D128 ;ALLOCATE ONE BLOCK FOR THE FILE
MOVEM T1,ALCBLK+1 ;PUT IT WHERE ALCOR WILL FIND IT
XMOVEI L,ALCBLK ;[300] POINT TO IT
PUSHJ P,ALCOR.## ;LET FOROTS DO IT'S THING
SKIPG T0 ;A POSITIVE VALUE?
JRST ALCFAL ;NO, ALLOCATION FAILED
MOVEM T0,ALCBLK+1 ;SAVE ADDR FOR DECOR
TLO T0,(61B5) ;[302] Make it a OWGBP
MOVEM T0,ALCPTR ;[302] Remember it
MOVEI T3,4 ;NUMBER OF ATTEMPTS AT FINDING FILE
GETHLP: MOVE T4,[POINT 7,[ASCIZ/HLP:/]] ;GET THE HLP: POINTER
MOVEM T4,GTJBLK+2 ;PUT IT IN THE GTJFN BLOCK
JRST GETIT
GETSYS: MOVE T4,[POINT 7,[ASCIZ/SYS:/]] ;GET THE SYS: POINTER
MOVEM T4,GTJBLK+2 ;PUT IT IN THE GTJFN BLOCK
GETIT: HRROI T2,FILENM ;GET POINTER TO 'FORDDT'
MOVEI T1,GTJBLK ;LONG FORM GTJFN BLOCK
GTJFN% ;GET FORDDT.HLP
JRST NXTSTR ;LOSE TEMPORARILY
HRRM T1,JFN ;SAVE THE JFN
MOVE T2,[FLD(7,OF%BSZ)!OF%RD] ;BYTE SIZE OF 7 AND READ ONLY
OPENF% ;OPEN THE FILE FOR READ ACCESS
JRST HLPIOE ;SOMETHING WEIRD HAPPENED
PRINT: MOVE T1,JFN ;GET JFN
MOVE T2,ALCPTR ;[302] POINTER FOR TEXT BUFFER
MOVEI T3,^D639 ;HELP TEXT BUFFER SIZE IN CHARS (128*5-1)
SIN% ;FILL THE BUFFER
ERJMP HLPDON ;DON'T CARE ABOUT THIS ERROR
SETZ T1, ;NEED A ZERO BYTE
IDPB T1,T2 ;MAKE SURE ZERO THE LAST BYTE
MOVE T1,ALCPTR ;[302] POINT TO BUFFER
PSOUT% ;OUTPUT ASCIZ STRING
JRST PRINT ;IF THERE'S MORE, GO GET IT
NXTSTR: MOVE T4,GTJBLK ;GET THE FLAGS
TXOE T4,GJ%PHY ;TURN ON PHYSICAL DEVICE BIT
TXZ T4,GJ%PHY ;CLEAR PHYSICAL BIT
MOVEM T4,GTJBLK ;PUT IT BACK IN GTJFN BLOCK
SOJLE T3,HLPNHF ;SEE IF ANY DEVICES LEFT
CAIG T3,2 ;TIME TO TRY SYS:?
JRST GETSYS ;YES, USE SYS:
JRST GETHLP ;NO, USE HLP:
HLPDON: SETZ T1, ;NEED A ZERO BYTE
IDPB T1,T2 ;MAKE SURE ZERO THE LAST BYTE
MOVE T1,ALCPTR ;[302] POINT TO BUFFER
PSOUT% ;OUTPUT ASCIZ STRING
HRROI T1,CRLF ;OUTPUT CRLF
PSOUT%
MOVE T1,JFN
CLOSF% ;GET RID OF THE JFN
JFCL ;NOT LIKELY
JRST HLPRET ;AND RETURN
HLPIOE: MOVE T1,JFN ;WE STILL HAVE TO RELEASE THE JFN
CLOSF%
JFCL ;NOT LIKELY
HRROI T1,[ASCIZ/%FDTEOH Error opening help file/]
SKIPA
HLPNHF: HRROI T1,[ASCIZ /%FDTNHF Cannot find help file/]
PSOUT%
HRROI T1,[ASCIZ/; I'm sorry I can't help you/]
PSOUT%
HRROI T1,CRLF
PSOUT%
HLPRET: XMOVEI L,ALCBLK ;[300] NEED TO DEALLOCATE BUFFER SPACE
PUSHJ P,DECOR.## ;DO IT
POP P,T0 ;RESTORE FLAGS
JRST RET ;ALL DONE
ALCFAL: HRROI T1,[ASCIZ/%FDTCAB Cannot allocate buffer for help file/]
PSOUT%
HRROI T1,CRLF
PSOUT%
POP P,T0 ;RESTORE FLAGS
JRST RET ;ALL DONE
FILENM: ASCIZ /FORDDT/
JFN: 0
GTJBLK: GJ%OLD ;FLAGS
.NULIO,,.NULIO
POINT 7,[ASCIZ/HLP:/] ;POINTER TO DEVICE
0
0
POINT 7,[ASCIZ/HLP/] ;POINTER TO EXTENSION
0
0
0
ALCPTR: BLOCK 1 ;[302] OWGBP to allocated buffer
> ;end IFN TOPS20 (internal -20 help code)
-1,,0 ;NUMBER OF ARGUMENTS TO ALCOR
ALCBLK: IFIW ALCBLK+1 ;[302] POINTER TO ARGUMENT
BLOCK 1 ;NUMBER OF WORDS NEEDED
> ;end IFE EXTHLP (internal help code)
; REMOVE LOGIC
RESET: JUMPL T0,RESET5 ;'RESET' - RESET ALL PAUSES
TRO T1,FGLONL ;FIND GLOBAL ONLY IF NOT LABEL
PUSHJ P,SYMIN ; NO - MUST BE ANOTHER SYMBOL TO FOLLOW
JRST [CAME T3,[SIXBIT/ON/]
JRST ERR6
JRST .+1] ;[332]
JFCL ;STATEMENT #
RESET6: MOVEM T3,TEM11 ;[340] SAVE T3
MOVE T3,SYMSAV ;[332]
TRNE T1,LNAME ;[402]Short symbols?
JRST REST6L ;[402]No
TLZ T3,PNAME ;[332]
CAME T3,[SQUOZE 0,ON];[332] IS IT A "REMOVE ON"
SKIPL TERMK ;[332] DID WE GET A LINE TERMINATOR?
JRST RSET3 ;[332] YES, CAN'T BE PAUSE ON ERRROR
JRST REST6A ;[402]
REST6L: MOVE T3,(T3) ;[402] Get ptr to name
MOVE T3,(T3) ;[402] Get name
CAMN T3,[SIXBIT /ON/];[402] IF IT IS "ON" THEN
SKIPL TERMK ;[332] DID WE GET A LINE TERMINATOR?
JRST RSET3 ;[332] YES, CAN'T BE PAUSE ON ERRROR
REST6A:
PUSHJ P,TTYIN ;[332] GET SIXBIT USER INPUT
JUMPN T2,BADSYN ;[332]
CAMN T3,[SIXBIT /ERROR/];[332] IS IT 'REMOVE ON ERROR'?
JRST RESET1 ;[332] REMOVE ON ERROR
CAME T3,[SIXBIT/ERR/];[332]
JRST ERR6 ;[332] "REMOVE ON" FOLLOWED BY JUNK
RESET1: SKIPGE TERMK ;[332] DID WE GET A LINE TERMINATOR?
PUSHJ P,CLRLIN ;[332] "REMOVE ON ERROR" FOLLOWED BY JUNK
HRRZI T0,FO$GBA ;[332] HAVE FOROTS RETURN BREAK ADDRESS
PUSHJ P,FOROP. ;[332] IN T0
SETZM @T0 ;[332] CLEAR "REMOVE ON ERROR"
JRST RET ;[332]
RSET3: MOVEI T2,B1ADR ;[402] LOOK THRO PAUSE POINTS FOR THE RIGHT ONE
RESET3: MOVE T3,TEM11 ;[340] RESTORE T3, WAS NOT ERROR PAUSE
HRRZ T4,(T2) ;GET THE PAUSE CONTENTS
CAIN T4,(T5) ;IS THIS IT?
JRST RESET2 ; YES - REMOVE IT!
ADDI T2,3 ; NO - TRY ANOTHER
CAIG T2,BNADR ;TRIED ALL POINTS YET?
JRST RESET3 ; NO - FIND THE NEXT
JRST ERR17 ;NO - NOT AN ARRAY NAME - YOU LOSE
RESET2: MOVE T4,1(T5) ;DOES THIS ROUTINE USE THE HELLO MACRO
CAMN T4,HELLO
ADDI T5,1 ;YES IT DOES - SO STOP 2 ON
ADDI T5,1 ;STOP 1 ON FOR NORMAL ROUTINES
CLEARM (T2) ;CLEAR LOCATION OF PAUSE
CLEARM 1(T2) ;CLEAR CONDITIONAL CLAUSE
CLEARM 2(T2) ;CLEAR PROCEDE COUNT
JRST RET ;REMOVED!
RESET5: CAME T3,[SIXBIT/REMOVE/] ;DO NOT ALLOW ABREVIATIONS OF REMOVE
JRST BADSYN ;THIS ANNOYS MANY USERS
HRRZI T0,FO$GBA ;[332] HAVE FOROTS RETURN BREAK ADDRESS
PUSHJ P,FOROP. ;[332] IN T0
SETZM @T0 ;[332] CLEAR "PAUSE ON ERROR"
PJRST BPS ;RESET ALL PAUSES
; ACCEPT LOGIC = ACCEPT NAME/X #
ACCEPT: JUMPL T0,BADSYN ;ACCEPT ALONE IS MEANINGLESS!
SETZM ARGVAL+1 ;CLEAR IN CASE LONG INPUT
SKIPN ESCAPE ;ESCAPE TO FOROTS?
JRST ERR30 ;SORRY
PUSHJ P,CHKIWI ;[211] RECURSIVE IO IF WE CALL THE OTS?
JRST ERRIWI ;[211] YES, TELL AND RETURN TO COMMAND LOOP.
TRO T1,ACCPT ;ACCEPT IN PROGRESS
CLEARM CLMOFF ;[401]
CLEARM CLMRNG ;[401]
CLEARM SSLOW ;[401]ZERO THE LOWER SUBSTRING BOUND
CLEARM SSUP ;[401]ZERO THE UPPER SUBSTRING BOUND
PUSHJ P,SYMIN ;GET USERS SYMBOL
JRST ERR6 ;SORRY - WE DONT HAVE IT!
JRST ACC2 ;STATEMENT # = FORMAT
MOVEM T5,TEM2 ;STORE FOR UPDATE
;[157]***For character, T5/TEM2=descriptor of array base=SAVLOC
TRNE T1,IMPRNG ;IS THIS AN IMPLIED RANGE?
PUSHJ P,DISP14 ;YES SETUP RANLIM/RANGE IN CASE OF A RANGE
MOVE T5,SYMSAV ;GET THE SYMBOL POINTER
HLRZ T5,(T5) ;GET RADIX 50 FORM AND FLAGS
TRNN T1,LNAME ;[402] if it is not long name - check if local
JRST [TRNN T5,LOCAL;[402]ALLOW ONLY LOCAL VARIABLES TO CHANGE
JRST ERR24 ;YOU LOOSE
JRST .+1] ;[402]
MOVE T2,LSTCHR ;RESTORE USERS LAST CHARACTER
; HERE HAVING READ A GOOD VARIABLE = ACCEPT NAME/
SKIPL TERMK ;END OF LINE SEEN?
JRST BADSYN ;YES - BAD NEWS
JUMPE T2,ACCF ;SPACE DELIMITER ASSUMES REAL TO FOLLOW
CAIN T2,"=" ;ALLOW = AS DELIMITER
JRST ACCF
CAIN T2,"-" ;A - MEANS A RANGE OF VALUES TO SET
JRST ACC23 ;
CAIE T2,"/" ; WE EXPECT ONLY / FROM NOW ON
JRST BADSYN ;ANYTHING ELSE LOOSES
SETZM TEM ;[323] No switches yet
ACC22: PUSH P,T1 ;[402] Save long name flag
PUSHJ P,TTYIN ;READ ARGUMENT TYPE REQUIRED BY USER
POP P,T1 ;[402] Restore long name flag
JUMPE T3,BADSYN ;NO CHARACTERS - BAD
LDB T5,[POINT 6,T3,5];GET 1ST. CHARACTER TO IDENTIFT ARG TYPE
CAIE T5,'B' ;[323] BIG SWITCH ?
TRZA P3,777777-B. ;[323] No - Remove all but 'B'
TROA P3,B. ;[120] YES - SET IT AND LOOK FOR ANOTHER SWITCH
MOVEM T5,TEM ;[323] NOT 'BIG', SAVE SWITCH IN CASE B FOLLOWS
JUMPE T2,ACC21 ;NOTHING FOLLOWS
CAIN T2,"=" ; ALLOW = AS DELIMITER
JRST ACC21 ;PROCESS FORMAT
CAIE T2,"/" ;ANOTHER SWITCH ?
JRST BADSYN ;NO - ONLY / ALLOWED
JRST ACC22 ;PROCESS ANOTHER SWITCH
; HERE HAVING READ ALL THE MODE SWITCHES
;[120] THE LAST SWITCH TAKES PRIORITY (/F/D/C/I/O/A/R/L) /B ALLOWED
; ACCEPT NAME/B/I
;[156] We now check to see whether input is /BIG/ASCII into a range
; of double-precision array elements. If so, RANGE must be
; incremented to the address of the second word of the last
; element, in order for the end-of-range check at ACC14 to
; be valid. (we were losing the second word of the last element).
ACC21: SKIPL TERMK ;[200] ALREADY AT EOL?
JRST BADSYN ;[200] YES: BAD COMMAND SYNTAX
SKIPN T5,TEM ;[323] Get current mode flags
MOVEI T5,'F' ;[323] Default is 'F'
SKIPE RANGE ;[156]looking for a range?
JRST ACC21A ;[156]YES
SETZM CLMRNG ;[163]In case character
JRST ACC21B ;[163]Go get input
ACC21A: TRNE P3,B. ;[323]/BIG?
TRNN T0,DOUBLE ;[306]and double precision?
JRST ACC21B ;[156]NO
CAIE T5,'A' ;[156]ASCII?
CAIN T5,'R' ;[156]or RASCII?
AOS RANGE ;[156]YES. Don't lose second word
ACC21B: CAIN T5,'S' ;SYMBOLIC?
JRST ACCS ;DO SYMBOL INPUT
CAIN T5,'A' ;ASCII?
JRST ACCA ;PROCESS ASCII
CAIN T5,'R' ;RASCII?
JRST RASCII ;PROCESS RIGHT JUSTIFIED ASCII
CAIN T5,'O' ;OCTAL?
JRST ACCO ;PROCESS OCTAL
CAIN T5,'C' ;[157]Character?
JRST ACCC ;[157] YES. Process string
TRZ P3,B. ;[323] IGNORE /BIG FOR THE REST
CAIN T5,'F' ;FLOATING?
JRST ACCF ;PROCESS A FLOATING INPUT
CAIN T5,'D' ;REAL*8?
JRST ACCD ;PROCESS REAL*8
CAIN T5,'I' ;INTEGER?
JRST ACCI ;PROCESS INTEGER INPUT
CAIN T5,'X' ;[157]COMPLEX?
JRST ACCX ;[157]PROCESS COMPLEX INPUT
CAIN T5,'L' ;[120] LOGICAL?
JRST ACCL ;[120] PROCESS LOGICAL INPUT
JRST BADSYN ;NO OTHER TYPES SUPPORTED
; ACCEPT A RANGE PROCESSING = ACCEPT NAME(X)-
ACC23: MOVE T5,TEM2 ;SAVE THE FIRST VALUE SOMEWHERE SAFE
MOVEM T5,RANGE ;SAVE THE FIRST VALUE OF A RANGE
MOVE T5,CLMOFF ;[157]Get beginning offset
MOVEM T5,CLMRNG ;[157]Save it in case this is /C
TLZ T0,GRPFL ;MAKE SURE WE DONT DO GROUP LOGIC
;OR ACCEPT ANY PRINT MODIFIERS
MOVE T5,MATHSM ;[403]SAVE CURRENT SYMBOL
MOVEM T5,TEM10 ;[403]
PUSHJ P,SYMIN ;GET THE NEXT VALUE
JRST ERR6 ;DOSNT EXIST
JRST BADSYN ;NUMERICS????
MOVE T4,TEM10 ;[403]GET FIRST SYMBOL BACK
CAME T4,MATHSM ;ARE THEY THE SAME
JRST ERR40 ;NO - SORRY
TRNN T0,CHARS ;[157]Character?
JRST CKRANG ;[157]NO
; clmrng=first offset given
; clmoff=offset just received
MOVE T2,CLMOFF ;[157]Get the lower offset
CAMLE T2,CLMRNG ;[157]Is lower .le. upper?
EXCH T2,CLMRNG ;[157]NO. Make it so
MOVEM T2,CLMOFF ;[157]Restore lower offset
MOVE T5,SAVLOC ;[157]Restore sym
JRST ACCONT ;[157]And continue
CKRANG: CAML T5,RANGE ;SORT OUT THE RANGE ORDER
EXCH T5,RANGE ;WRONG WAY ROUND
MOVEM T5,TEM2 ;LOWER VALIUE IN RANLIM, HI IN RANGE
ACCONT: PUSHJ P,EVAL ;GET SYMBOL IN SYMSAV
JFCL
MOVE T5,SYMSAV ;GET THE SYMBOL POINTER
HLRZ T5,(T5) ;GET SYMBOL FLAGS
TRNN T5,LOCAL ;MODIFY LOCALS ONLY
JRST ERR24 ;NOT ALLOWED
MOVE T2,LSTCHR ;RESTORE USERS LAST CHARACTER
CAIN T2,"/" ;MAYBE FORMAT SPECIFIER
JRST ACC22 ;YES - GO FIND THEM
SKIPGE TERMK ;[200] EOL ALREADY?
JUMPE T2,ACCF ;[200] NO. SPACE IMPLIES REAL*4
JRST BADSYN ;DONT ACCEPT ANYTHING ELSE HERE
; *** FLOATING INPUT ***
ACCF: TRO P3,F. ;[323] DISPLAY TO USER AS FLOATING
MOVEI T3,4 ;ARG TYPE REAL FOR FOROTS
PUSHJ P,FORINP ;YES - ASK FOROTS FOR INPUT
; HERE TO PLACE ALL ACCEPTED VALUES
ACC10: MOVE T5,ARGVAL ;LETS SEE WHAT FOROTS HAS BEEN UP TO
ACC13: EXCH T5,TEM2 ;[163]Save input value
PUSHJ P,CKWRIT ;[163]Validity check
EXCH T5,TEM2 ;[163]Regain value
MOVEM T5,@TEM2 ;PLACE VALUE WHERE USER REQUESTED
MOVEM T5,ARGVAL ;SOME PRINT OPTIONS NEED THIS
AOS T2,TEM2 ;NEXT ARRAY LOCATION
TRNN P3,X.!B.!D. ;[323] IF EITHER COMPLEX REAL*8 OR BIG OR -
TRNE T0,DOUBLE ;[112] WE HAVE A DOUBLE WORD ARRAY?
CAIA ;THEN WE PLACE TWO ARGUMENTS
JRST ACC14 ;IF NOT THEN CHECK THE RANGE CONDITION
TRO T0,SILENT ;QUIET
PUSH P,MATHSM ;SAVE CURRENT SYMBOL
PUSH P,T1 ;[402] Save long name flag in T1 for symbol
MOVE T5,[SQUOZE 0,.VEND] ;END OF VARIABLE AREA
MOVEM T5,MATHSM ;ONLY ACCEPTABLE SYMBOL
MOVE T5,TEM2 ;GET DESTINATION;T=dest addr
PUSHJ P,CKWRIT ;[163]Validity check; return if OK
PUSHJ P,LOOK ;FIND A SYMBOL FOR IT
JFCL ;NONE-OK
JRST ACC13A ;[402]OFFSET - OK
POP P,T1 ;[402]
POP P,T5 ;[402]
JRST ERR35 ;YES - ERROR
ACC13A: POP P,T1 ;[402]
POP P,T5
STSYM T5,MATHSM ;[402]RESTORE CURRENT SYMBOL
MOVE T5,ARGVAL+1 ;GET THE 2ND WORD
MOVEM T5,@TEM2 ; - AND PLACE IN NEXT LOCATION
AOS T2,TEM2 ;YES - SO NEXT DOUBLE WORD
ACC14: SKIPN RANGE ;ACCEPT A RANGE ?
JRST ACCPUT ;NO - UNLESS IMPLIED
TRNE P3,A. ;[323] SPECIAL TREATMENT FOR ASCII ARRAYS
JRST [CAMG T2,RANGE ;END OF ARRAY?
JRST ACC12 ;GET SOME MORE
JRST RET ] ;QUIT
CAMG T2,RANGE ;ALL DONE ?
JRST ACC10 ;NO - KEEP GOING
JRST RET ;ALL OVER
; VARIABLE 'ACCEPT'ED - NOW CONFIRM TO USER
ACCPUT: SOS T5,TEM2 ;REMOVE OFFSET FROM ACC13
ACPUT1: SETZM TERMK ;PREPARE FOR -
SETZM RANGE ; INPUT CONFIRMATION
TRZN T0,DOUBLE ;CHECK FOR ANY -
TRNE P3,X.!B.!D. ;[323] DOUBLE WORD WORKING
SOS T5,TEM2 ; AND IF SO CORRECT BASE ADDRESS
PUSHJ P,DISP10 ;AND LET HIM SEE HIS EFFORTS
JRST RET ;END OF ACCEPT
PUSHJ P,GETNUM ;GENERAL GET NUMBER ROUTINE
JRST ACC13 ;STORE FOR USER
; *** DOUBLE PRECISION INPUT ***
ACCD: TRO P3,D. ;[323] DISPLAY TO USER AS REAL*8
MOVEI T3,TP%DPR ;[137]Set up for default D-float arg type=10
TRNE T0,GFLOAT ;[137]If D-float, skip to FOROTS call.
MOVEI T3,TP%DPX ;[137] else, we have G-float, set arg type=13
PUSHJ P,FORINP ;REQUEST INPUT
JRST ACC10 ;PLACE FINAL ARG
; *** INTEGER INPUT ***
ACCI: TRO P3,I. ;[323] DISPLAY TO USER AS INTEGER
MOVEI T3,2 ;GET ARG TYPE INTEGER FOR FOROTS
PUSHJ P,FORINP ;GO TO FOROTS
JRST ACC10 ;PLACE ARG FOR USER
; *** COMPLEX INPUT ***
ACCX: TRO P3,X.!B. ;[323] DISPLAY TO USER AS VCOMPLEX
ACC11: PUSHJ P,GETSKB ;GET SIGNIFIGANT CHARACTER
CAIE T2,"(" ;MAKE SURE ITS A (
JRST ERR32 ; ( REQUIRED
MOVE T5,[401200,,ARGVAL+1] ;[300] WHERE TO PUT IMAGINARY OF COMPLEX
MOVEM T5,M2.I ;SET UP THE FORMAT
MOVEI T3,4 ;SET UP FOR TYPE REAL INPUT
PUSHJ P,FORINP ;LET FOROTS GET THE REAL PART
MOVE T5,M2.F ;RECOVER THE FIN CALL
MOVEM T5,M2.I ;AND REMOVE THE COMPLEX SETTING
JRST ACC10 ;GO PLACE THE RESULTS
; *** SYMBOLIC INPUT ***
ACCS: TRNE P3,B. ;[323] IF 'BIG' SET THEN
TROA P3,X. ;[330] DISPLAY TO USER AS TWO REAL*4
HLRS P3 ;[330] OTHERWISE USE CURRENT DEFAULT
MOVE T5,MATHSM ;[403]SAVE MATHSM
MOVEM T5,TEM10 ;[403]
MOVE T5,SAVLOC ;[403]SAVE SAVLOC AROUND CALL
MOVEM T5,TEM11 ;[403]
PUSHJ P,SYMIN ;GET A USER SYMBOL
JRST ERR6 ;CAN'T FIND IT!
JRST BADSYN ;DONT GIVE ME STATEMENT #
MOVE T2,TEM11 ;[403]
MOVEM T2,SAVLOC ;[403]RESTORE SAVLOC
MOVE T2,TEM10 ;[403]
MOVEM T2,MATHSM ;[403]RESTORE
MOVE T2,(T5) ;I'LL ACCEPT THAT ONE
MOVEM T2,ARGVAL ;SAVE THE FIRST WORD VALUE
TRNN P3,B. ;[323] DOUBLE WORD WORKING?
JRST ACC10 ;NO JUST PLACE SINGLE VALUE
MOVE T5,1(T5) ;GET SECOND VALUE
MOVEM T5,ARGVAL+1 ;STORE THAT
JRST ACC10 ; AND EVEN STORE IT
; *** ASCII INPUT RIGHT JUSTIFIED ***
RASCII: TRO P3,R. ;[323] DISPLAY TO USER AS RASCII
JRST ACC1 ;DO ASCII INPUT TO T
;[120] ** LOGICAL INPUT **
ACCL: TRO P3,L. ;[323] DISPLAY TO USER AS LOGICAL
MOVE T2,[POPJ P,] ;[120] HOW WE WANT TO RETURN FROM LOGICL
MOVEM T2,DONE ;[120]
TRO T1,LGCLEG ;[120] LET 'EM WE'RE EXPECTING A LOGICAL
PUSHJ P,GETSKB ;[120] GET NEXT CHAR.
CAIE T2,"." ;[120] DOES IT START WITH A "."?
JRST ERR7 ;[120] NO GOOD.
PUSHJ P,LOADCH ;[120] GET THE NEXT CHAR.
PUSHJ P,LOGICL ;[120] AND LET LOGICL HANDLE THE REST
JRST ACC13 ;[120] SAVE THE RESULTS
; *** ASCII INPUT ***
ACCA: TRO P3,A. ;[323] DISPLAY TO USER AS ASCII
MOVE T5,[ASCII . .] ;BLANK SECOND WORD FOR POSSIBLE
MOVEM T5,ARGVAL+1 ;LONG OR DOUBLE
SKIPN RANGE ;[120] IGNORE /BIG IF ACCEPTING LONG ASCII
JRST ACC1 ;OK IF NOT A RANGE
TRZ P3,B. ;[323] CLEAR /B FLAG
TRZ T0,DOUBLE ;CLEAR DOUBLE
ACC1: SKIPE SSLOW ;[400]ASSIGNING INTO SUBSTRING
JRST ERR42 ;[400]DON'T LET USER - IT WILL MESS UP BYTEPTR
PUSHJ P,GETSKB ;GETA SIGNIFICANT USER CHARACTER
SKIPL TERMK ;EOL?
JRST BADSYN ;YES - SYNTAX ERROR
MOVEI P1,(T2) ;SAVE IN T3
ACC12: SETZM ARGVAL ;CLEAR FOR DOUBLE LENGTH ASCII
TRZE T1,ADELIM ; IF SET WE CLEAR THE REST OF THE ARRAY
JRST ACCA2 ;
ACC24: MOVE T5,[ASCII . .] ;T BUILDS ASCII INPUT
TRNE P3,R. ;[323] BUILD WITH ZERO IF RASCII
SETZI T5,
MOVE P2,[POINT 7,T5] ;STORES BYTES IN T5
ACC15: pushj p,loadch ;NEXT ASCII CHARACTER
CAIN T2,(P1) ;TEXT DELIMITER FOUND?
JRST ACC18 ;YES - CHECK FOR A SECOND
TRZE T1,ADELIM ;WAS THE LAST CHARACTER OUR DELIMITER
JRST [PUSH P,T2 ;YES
MOVE T2,[pushj p,loadch] ;FOR GETSKB
MOVEM T2,GETCHR
POP P,T2
PUSHJ P,GETSK2 ;CHECK FOR COMMENT
PUSHJ P,CLRLIN ; WIND UP
JRST ACC17]
ACC19: IDPB T2,P2 ;SAVE USERS TEXT
TLNE P2,760000 ;FILLED T?
JRST ACC15 ;NO - TAKE MORE
CAIA ;DONT CONFUSE THE INDEFINATE ACCEPT
ACC17: TRO T1,ADELIM ;SET TO CLEAR REST OF ARRAY IF IN A RANGE
TRNE T0,DOUBLE ;TEST FOR ANY DOUBLE WORD -
JRST ACC2WD ; WORKING -
TRNN P3,B. ;[323] IMPLIED BY REAL*8 OR B.
JRST ACC20 ;STORE FINAL SINGLE VALUE IN T5
; DOUBLE WORD WORKING
ACC2WD: SKIPN ARGVAL ;IS THE FIRST VALUE STOREF?
JRST ACC3WD ;NO
MOVEM T5,ARGVAL+1 ;YES STORE SECOND
JRST ACC25 ;PLACE BOTH VALUES
ACC3WD: MOVEM T5,ARGVAL ;HOLD FIRST OF PAIR
TRNN T1,ADELIM ;ANY MORE TO COME
JRST ACC24 ;YES - GO FIND IT
ACC25: HRRZM P1,DELCHR ;SAVE DELIMITER FOR CLRLIN
PUSHJ P,CLRLIN ;CLEAR REST OF LINE
TRNN P3,R. ;[323] ARE WE ACCEPTING RIGHT JUSTIFIED TEXT
JRST ACC10 ;RELAX JUST ASCII
MOVE T2,ARGVAL ;GET BACK THE DOUBLE WORD
JUMPE T2,ACC10 ;NO TEXT?????
MOVE T3,ARGVAL+1 ;INTO A LONG SHIFT FORM
LSH T2,-1 ;FIRST MAKE A CONTINUOUS STRING OF TEXT
LSHC T2,-1 ;GET READY FOR 7BIT CHARACTER SHIFTS
ACC27: LDB T4,[POINT 7,T3,35]
JUMPN T4,ACC26 ;TEST FOR SUCCESSFUL RIGHT JUSTIFICATION
LSHC T2,-7 ;NOT YET MOVE DOWN
JRST ACC27 ;TRY AGAIN
ACC26: LSH T2,1 ;ASCII-ISE
TLZE T3,400000 ;SHOULD THERE BE A LOWER BIT FOR T2
TRO T2,1 ;YES - PUT IT IN
MOVEM T2,ARGVAL ;STORE TOP VALUE
MOVEM T3,ARGVAL+1 ;AND FINALLY LAST VALUE
JRST ACC10 ;AND GIVE THEM TO THE USER
ACC18: TRON T1,ADELIM ;FLAG THIS AS OUR DELIMITER
JRST ACC15 ;SEE IF NEXT CHARACTER IS SAME
TRZ T1,ADELIM ;YES IT IS -
JRST ACC19 ;PASS ON JUST ONE
ACCA2: TRZ P3,A.!R. ;[323] REMOVE THE TEXT FLAGS
MOVE T5,[ASCII . .] ;FILL THE REST OF THE ARRAY
MOVEM T5,ARGVAL ;WITH SPACES
MOVEM T5,ARGVAL+1
JRST ACC13
; FINISHED TEXT INPUT
ACC20: HRRZM P1,DELCHR ;SAVE DELIMITER FOR CLRLIN
SKIPN RANGE ;IF NOT IN A RANGE SETTING -
PUSHJ P,CLRLIN ;THEN CLEAR THE REST OF THE USER INPUT
TRNN P3,R. ;[323] LEFT OR RIGHT JUSTIFY
JRST ACC13 ;LEFT
LDB T2,[POINT 6,P2,5] ;RIGHT - GET THE T4 POINTER RESIDUE
SETCA T2, ;RIGHT SHIFT
LSH T5,1(T2) ; NOW
JRST ACC13 ;NOW PLACE TEXT
; *** CHARACTER STRING INPUT *** ;[157]
ACCC: ;[157]
TRO P3,C. ;[323]Display to user properly
PUSHJ P,GETSKB ;[157]Look for quote
SKIPL TERMK ;[157]EOL?
JRST BADSYN ;[157]YES. Syntax error
ACCC1: CAIE T2,"'" ;[157]Single quote?
JRST [TYPE (<%Character string must begin with single quote>)
JRST RET] ;[157]Try again
DMOVE T2,@SAVLOC ;[157]Get descriptor
MOVE T4,T3 ;[163]Save length for descriptor check & loop
IMUL T3,CLMOFF ;[157]Compute for ADJBP
SKIPN SSLOW ;[401]
JRST ACOMOF ;[401]
MOVE T4,SSUP ;[401]
SUB T4,SSLOW ;[401]
AOJ T4, ;[401] t4 = length = upper - (lower - 1)
ADD T3,SSLOW ;[401]substring offset
SOJ T3, ;[401] t3 = array offset + (lower - 1)
ACOMOF: ADJBP T3,T2 ;[157]Get BP to element
MOVEM T3,ORIGLM ;[157]Save starting address
MOVEI T5,T3 ;[163]T5=location of descriptor to validate
PUSHJ P,CKBPTR ;[163]Validate descriptor; return if OK
MOVE T5,T2 ;[305]GET THE REAL ADDR TO VALIDATE
TLZ T5,770000 ;[305]CLEAR THE OWGBP BITS LEAVING ADDR
PUSHJ P,CKWRIT ;[163]Check destination; return if OK
INSTRL: PUSHJ P,LOADCH ;[157]Get next character
CAIE T2,"'" ;[157]Quote?
JRST PUTBYT ;[157]NO. Store it.
PUSHJ P,LOADCH ;[157]YES. see if there is another
CAIN T2,"'" ;[157]Another quote?
JRST PUTBYT ;[157]YES. Store one only!
DMOVEM T3,TEM4 ;[157]Save pointer & count
MOVE T5,[PUSHJ P,LOADCH] ;[157]for GETSKB
MOVEM T5,GETCHR ;[157]Tell GETCHR how to get input
PUSHJ P,GETSK1 ;[157]Check for comment
PUSHJ P,CLRLIN ;[157]Clear extraneous input
DMOVE T3,TEM4 ;[157]Restore pointer & count
JRST STREND ;[212][157]End of this string
BYT2T5==^D29 ;[BL]Bits left if BP points to firstbyte in word
PUTBYT: IBP T3 ;[163]Destination address
MOVE T5,T3 ;[163]T5=address to validate
LDB P1,[POINT 6,T3,05] ;[163]Get byte position within word
CAIN P1,BYT2T5 ;[163]First byte in this word?
PUSHJ P,CKWRIT ;[163]YES. Validate destination; here +1 if OK
DPB T2,T3 ;[163]Store byte
SOJG T4,INSTRL ;[157]Loop thru input string
MOVEI T5,"'" ;[157]Anticipated delimiter
MOVEM T5,DELCHR ;[157]Save for CLRLIN
STREND: MOVEI T5," " ;[212][157]Fill character
FILSTR: SOJL T4,NDSTR1 ;[157]Jump if string full
IDPB T5,T3 ;[157]Store a space
JRST FILSTR ;[157]Loop till full
NDSTR1: MOVE T4,CLMRNG ;[157]Relative location of last element
SUB T4,CLMOFF ;[157]Elements to fill
JUMPLE T4,ENDCK ;[157]NONE.....
MOVE T5,SAVLOC ;[157]Addr/descriptor
MOVE T5,1(T5) ;[157]Get count
IMULI T5,(T4) ;[157]Total bytes to move
MOVE T4,ORIGLM ;[157]Get source addr
RNGLUP: ILDB P1,T4 ;[157]Load byte
IDPB P1,T3 ;[157]Store it
SOJG T5,RNGLUP ;[157]
ENDCK: MOVE T5,[pushj p,loadch];FOR GETSKB
MOVEM T5,GETCHR
PUSHJ P,GETSK1 ;[157]CHECK FOR COMMENT
SKIPGE TERMK ;[322]Line terminator?
PUSHJ P,CLRLIN ;[322]No - Show user error
MOVE T5,SAVLOC ;[322]Restore for display
SKIPN CLMRNG ;[157]Accept a range?
JRST ACPUT1 ;[157]NO. Go display single element
JRST RET ;[157]YES. all done!!!!!
; *** OCTAL INPUT ***
ACCO: TRO P3,O. ;[323] DISPLAY TO USER AS OCTAL
SETZI T5, ;CLEAR FOR OCTAL BUILD
SKIPL TERMK ;END OF LINE SEEN?
JRST ACC13 ;YES - ASSUME OCTAL = 0
PUSHJ P,GETSKB ;LOOK FOR "-"
SKIPL TERMK
JRST ACC13 ;END OF LINE - =0
SETZB P1,P2 ;CLEAR BUILD AREA
MOVEI T5,^D12 ;INITIALIZE COUNT
TRNE P3,B. ;[323] CHECK BIG
MOVEI T5,^D24 ;[120] DOUBLE IT FOR BIG
CAIA
ACC29: PUSHJ P,GETSKB ;GET NEXT CHARACTER
SKIPL TERMK ;END OF LINE?
JRST ACC16 ;
CAIE T2,"+" ;PLUS?
JRST ACC31
TLNE T0,MF ;YES - MINUS SEEN?
JRST BADSYN
JRST ACC29 ;NO - IGNORE THE +
ACC31: CAIN T2,42 ;DOUBLE QUOTE?
JRST ACC29 ;YES - IGNORE
CAIE T2,"-"
JRST ACC16 ;NOT A "-"
TLC T0,MF ;COMPLEMENT FLAG
JRST ACC29 ;GET NEXT CHARACTER
ACC16: SUBI T2,60 ;OCTALISE
JUMPL T2,ERR2 ;CHARACTER MUST OF COURSE -
CAIL T2,10 ; BE OCTAL
JRST ERR2 ;NOT OCTAL - COMPLAIN
LSHC P1,3 ;BUILD OCTAL VALUE
IOR P2,T2
SOJE T5,ACC28 ;CHECK FOR PROPER NUMBER OF CHARACTERS
ACA16: PUSHJ P,GETSKB ;GET A CHARACTER
SKIPGE TERMK ;END OF LINE
JRST ACC16 ;BACK FOR MORE
; HERE WITH LINE END OR FULL WORD(S)
ACC28: TRNN P3,B. ;[323] BIG WORKING?
JRST ACC30 ;AS YOU WERE - STORE OCTAL
MOVEM P1,ARGVAL ;STORE LONG OCTAL
MOVEM P2,ARGVAL+1
JRST ACC32
ACC30: MOVEM P2,ARGVAL ;STORE SINGLE OCTAL
; HERE AT END OF INPUT
ACC32: PUSHJ P,CLRLIN ;CLEAR THE LINE
TLZN T0,MF ;FLAGGED AS A NEGATIVE #?
JRST ACC10 ;NORMAL
SETCMM ARGVAL ;SET TO NEGATIVE -
SETCMM ARGVAL+1 ; = 1'S COMPLEMENT
AOS ARGVAL+1 ; LETS MAKE IT 2'S COMPLEMENT
SKIPN ARGVAL+1
AOS ARGVAL
JRST ACC10 ;NOW PLACE THAT LOT
; 'ACCEPT' FORMAT PROCESSING
ACC2: SKIPL TERMK ;[200] EOL ALREADY?
JRST BADSYN ;[200] YES
PUSHJ P,EVAL
JRST ERR6 ;NO SUCH STATEMENT NO
PUSHJ P,FRMSET ;SET UP TO ACCESS A FORMAT STATEMENT
JRST RET ;CANT DO IT!
MOVE P1,T4 ;FORMAT START
MOVE P2,T2 ;FORMAT END
; HERE WITH A RECOGNISED FORMAT REFFERENCE SET UP
ACC3: MOVE T5,[POINT 7,(P1)]
pushj p,loadch ;GET A USER CHARACTER
CAIE T2," " ;BLANKS
CAIN T2,11 ; AND TABS IGNORED TO START WITH
JRST ACC3
MOVE T3,[pushj p,loadch]
MOVEM T3,GETCHR ;SET TO READ FROM USER
PUSHJ P,GETSK2
CAIE T2,"(" ;FIRST FORMAT CHARACTER MUST BE (
JUMPA T2,BADSYN
ACC4: ILDB T3,T5 ;INCREMENT POINTER NOW
HRRM T5,.+1
CAIG P2,(P1) ;HAVE WE EXHAUSTED THE FORMAT
JRST [JUMPE T2,RET
JRST ERR13] ;YES
DPB T2,T5 ;STORE NEXT CHARACTER
JUMPE T2,ACC4
ACC6: pushj p,loadch ;GET ANOTHER USER FORMAT CHARACTER
CAIE T2," " ;NOW ALLOW
CAIN T2,11 ;BLANKS AND TABS AS USER WANTS
CAIA
PUSHJ P,GETSK2
JUMPN T2,ACC7 ;NOT THE LAST CHARACTER YET IF NON ZERO
CAIE T4,")" ;LAST USER CHARACTER MUST BE A )
JRST ERR32 ; IT WASN'T SO COMPLAIN
ACC7: MOVE T4,T2 ;REMEMBER THE LST USER CHARACTER
CAIE T2,37 ;DOES USER WANT LINE CONTINUATION = ^_
JRST ACC4 ;NO - NORMAL
ACC5: pushj p,loadch ;ACCEPT ANOTHER USER CHARACTER
CAIN T2,12 ;UNTIL END OF LAST LINE
JRST ACC6
JRST ACC5 ;DO A CONTINUATION
; TYPE LOGIC
DISPLA: SKIPN ESCAPE ;CAN WE USE FOROTS?
JRST ERR30 ;NOT AFTER A ^C RE-ENTER
PUSHJ P,CHKIWI ;[211] RECURSIVE IO IF WE CALL THE OTS?
JRST ERRIWI ;[211] YES, TELL AND RETURN TO COMMAND LOOP.
PUSHJ P,FORBUF ;[211] OK, CLEAR FOROTS BUFFER
SETZM CURGRP ;CLEAR CURRENT GROUP STACK FLAGS
TRO T1,TYPCMD ;[171] Remember it's a TYPE command
TLO T0,CFLIU!GRPFL ;SET CORE FILE IN USE - ALLOW GROUPS
CLEARM GETCHR ;THIS IS THE FIRST ACCESS TO CORE FILE THIS LINE
TLNE T0,EOL ;USER GAVE ANY ARGUMENTS?
TLOA T0,OFCFL ;NO - GET THEM FROM CORE FILE
TLZ T0,OFCFL ;YES - PUT THEM INTO CORE FILE
PUSHJ P,DISP4 ;DISPLAY ROUTINE
TLZ T0,CFLIU!OFCFL!GRPFL ;PULL DOWN DANGEROUS FLAGS
PUSHJ P,REINOP ;REINSTATE OPEN PROGRAM
JRST RET ;END OF TYPE COMMAND
DISP4: CLEARM RANGE ;CLEAR FOR RANGE INDICATION
CLEARM CLMOFF ;[157]Initialization
CLEARM CLMRNG ;[157]
CLEARM SSLOW ;[401]ZERO THE LOWER SUBSTRING BOUND
CLEARM SSUP ;[401]ZERO THE UPPER SUBSTRING BOUND
HLRS P3 ;[323] Use default flags
PUSHJ P,SYMIN ;GET USERS NEXT SYMBOL VALUE
JRST DISP9 ;NOT THERE
CAIA ;STATEMENT # FOUND
JRST DISP2 ;TRUE VARIABLE
; FORMAT STATEMENT PROCESSOR
DISP13: PUSHJ P,FRMSET ;SET UP TO ACCESS A FORMAT STATEMENT
JRST DISP5 ;CANNOT DO IT
; NOW FOUND A RECOGNISED FORMAT STATEMENT
MOVE T3,[POINT 7,(T4)]
MOVEI P1,SYM ;SET UP FOR SYMBOL PRINT
TRZ T1,LNAME ;[402] clear long name flag
PUSHJ P,SPT ;PRINT SYMBOL=STATEMENT #
TYPE( FORMAT)
DISP6: ILDB T5,T3 ;GET A CHARACTER FROM THE FORMAT TEXT
HRRM T3,.+1 ;GET NO OF WORDS DONE
CAIG T2,(T4) ;ALL DONE?
JRST DISP5 ;DONE WITH FORMAT
putchr (T5) ;TYPE IT
JRST DISP6 ;MORE TO DO - BACK FOR MORE
; SET UP ACCESS TO A FORMAT STATEMENT T4=START T2=END
; SKIP ON SUCCESS.
FRMSET: MOVEI T4,(T5) ;SHOULD POINT TO A JRST
LINE
LDB T5,[POINT 7,(T4),6] ;GET FIRST CHARACTER OF FORMAT
CAIE T5,"(" ;FIRST CHARACTER MUST BE A (
PJRST ERR16 ;USER LOSES
MOVE T5,T4 ;ACCEPTED START OF FORMAT -
MOVEM T5,SAVLOC ; NOW FIND END OF F10 FORMAT
HRREI T5,-12 ;CHANGE LABEL+P TO LABEL+F
ADDM T5,SYM ;LIKE SO
PUSH P,T4 ;SAVE (T4)
PUSHJ P,EVAL ;LOCATE THE FORMAT END
JRST [POP P,T4 ;[403]
JRST ERR41] ;[403]CANT FIND FORMAT END
POP P,T4 ;RESTORE
MOVEI T2,1(T5) ;SET UP END OF FORMAT IN T2
JRST CPOPJ1 ;T4 START - T2 END . . . ALL SET UP
VAL2: TAB
MOVE T5,RANLIM ;GET THE CURRENT VALUE POINTER
MOVE T5,1(T5) ;GET THE NEXT VALUE
POPJ P,
; IMPLIED RANGE I.E. TYPE ARRAY
DISP2: CAIN T2,"-"
JRST DISP1 ;GET LIMIT OF RANGE
TRZN T1,IMPRNG ;IS THIS A SIMULATED RANGE
JRST DISP10 ; NO - JUST NORMAL
DISP11: PUSHJ P,DISP14 ;SET UP RANGE WITH UPPER LIMIT
TLO T0,GRPFL ;[323] PERMIT GROUP LOGIC AGAIN
; ONE-SHOT TYPE REQUEST
; ENTER WITH SYMBOL VALUE IN T5
; ENSURE TERMK,RANGE=0
DISP10:
MOVEM T5,LWT ;SAVE SYMBOL VALUE
MOVE T5,(T5) ;GET CONTENTS OF SYMBOLIC ADDRESS
EXCH T5,LWT ;SAVE CONTENTS AND GET SYMBOL VALUE
;SAVE SYMBOL VALUE IN CASE WE DO A RANGE
MOVEM T5,RANLIM ;SAVE FOR RANGE NAME ID SUPRESSION
TRO P3,ANYMOD ;[173]FLAG FIRST PRINT ON LINE
PUSHJ P,OFFSET ;TYPE USERS SYMBOL
JRST DISP9
;[202]
EXCH T5,SYM ;GET BACK SYMBOL CONTENTS
TRNN P3,C. ;[157]Character string?
JRST TYPF ;[157]NO. Next test
; *** TYPE CHARACTER ***
DMOVE T2,@SAVLOC ;[157]Load ptr & length
MOVE T4,T3 ;[163]Save string length
IMUL T4,CLMOFF ;[157]Compute for ADJBP
SKIPN SSLOW ;[401]
JRST DCOMOF ;[401]
MOVE T3,SSUP ;[401]
SUB T3,SSLOW ;[401]
AOJ T3, ;[401] t3 = length = upper - (lower - 1)
ADD T4,SSLOW ;[401]
SOJ T4, ;[401] t4 = array offset + (lower - 1)
DCOMOF: ADJBP T4,T2 ;[157]Create BP to element
MOVE T2,T4 ;[157]Get the adjusted pointer
CHKPTR: MOVEI T5,T2 ;[163]T5=Location of descriptor to validate
PUSHJ P,CKBPTR ;[163]Validate; return if OK
MOVE T5,T2 ;[163]T5=address to validate
PUSHJ P,CKREAD ;[163]Validate;return if OK
CKBIG: TRNE P3,B. ;[157]Display whole string?
JRST TYPEC ;[157]YES. skip size check
CAILE T3,^D256 ;[157]Large string?
;*** flag
MOVEI T3,^D256 ;[157]YES. truncate
TYPEC: PUSHJ P,DSPSTR ;[162]Put out string
JRST TYPF ;[157][164]Go check for other type-out modes
; DSPSTR is a routine to display character strings.
; DSPST1 is an entry point to allow TYPCS (from PAUSE) to display
; character strings without calling JUSTIFY.
DSPSTR: JUSTIFY ;[164](VARIABLE NAME),TAB,=
; TYPE ( ) ;[157]Space
DSPST1: TYPE (') ;[157]Initial quote
BYTLUP: IBP T2 ;[163]Destination address
MOVE T5,T2 ;[163]T5=location of address to validate
LDB T4,[POINT 6,T2,05] ;[163]Get byte position within word
CAIN T4,BYT2T5 ;[163]First byte in this word?
PUSHJ P,CKREAD ;[163]YES. Validate source; return here if OK
LDB T5,T2 ;[163]Store byte
CAIN T5,"'" ;[157]Single quote?
PUSHJ P,ASCOUT ;[157]YES. double it
PUSHJ P,ASCOUT ;[157]Display it
SOJG T3,BYTLUP ;[157]Loop til thru
TYPE (') ;[157]Concluding quote
POPJ P,
;*** check for truncated string?
; *** TYPE FLOATING ***
TYPF: TRNN P3,F. ;TEST THE FLOATING FLAG
JRST TYPD ;NO REAL TRY DOUBLE REAL
JUSTIFY
MOVEI T3,4 ;ARG TYPE REAL FOR FOROTS
PUSHJ P,FOROUT ;ONE ARG OUTPUT
; *** TYPE DOUBLE REAL ***
TYPD: TRNN P3,D. ;TEST FOR DOUBLE REAL
JRST TYPX ;NO FLOATING TRY COMPLEX
JUSTIFY
MOVE T3,RANLIM ;GET ARG POINTER
MOVE T5,1(T3) ;GET SECOND ARG
MOVEM T5,ARGVAL+1 ;SAVE 2ND. HALF FOR FOROTS
MOVE T5,(T3) ;RE-INSTATE IST.ARG IN T5
MOVEI T3,TP%DPR ;[137]Set up for default D-float arg type=10
TRNE T0,GFLOAT ;[137]If D-float, skip to FOROTS call.
MOVEI T3,TP%DPX ;[137] else, we have G-float, set are type=13
PUSHJ P,FOROUT ;OUTPUT REAL*8
; *** TYPE COMPLEX ***
TYPX: TRNN P3,X. ;[157]TEST FOR COMPLEX TYPE OUT
JRST TYPI ;NO COMLEX TRY FOR INTEGER
JUSTIFY
MOVE T3,RANLIM ;GET ARG POINTER
MOVE T5,1(T3) ;GET SECOND ARG
MOVEM T5,ARGVAL+1 ;SAVE 2ND HALF FOR FOROTS
MOVE T5,(T3) ;REINSTATE 1ST ARG IN T5
MOVEI T3,14 ;SET UP ARGTYPE FOR COMPLEX
PUSHJ P,FOROUT ;ONE ARG OUTPUT
; ** TYPE INTEGER ***
TYPI: TRNN P3,I. ;TYPE AS INTEGER?
JRST TYPO ;NO - TRY OCTAL
JUSTIFY
MOVEI S1,^D10 ;PREPARE FOR DECIMAL TYPE OUT
PUSHJ P,FTOC ;CONSTANT PRINT
; *** TYPE OCTAL ***
TYPO: TRNN P3,O. ;TYPE AS OCTAL?
JRST TYPA ;NO - TRY ASCII
JUSTIFY
MOVEI S1,10 ;PREPARE FOR OCTAL PRINT
PUSHJ P,FTOC ;PRINT IN OCTAL
TRNN P3,B. ;[120] DOUBLE WORD
JRST TYPA ;NO - TRY ASCII
PUSHJ P,VAL2 ;GET THE NEXT VALUE
PUSHJ P,FTOC ; DISPLAY THAT
; *** TYPE ASCII ***
TYPA: TRNN P3,A. ;TYPE AS ASCII?
JRST TYPR ;NO - SEE IF RIGH JUSTIFIED ASCII
JUSTIFY
PUSHJ P,TXT341 ;THROW UP ASCII
TRNN P3,B. ;[120] DOUBLE?
JRST TYPR ;NO - TRY RASCII ?????????
PUSHJ P,VAL2 ;GET THE NEXT VALUE
PUSHJ P,TXT341 ;AND TYPE THAT AS ASCII
; *** TYPE RIGHT JUSTIFIED ASCII ***
TYPR: TRNN P3,R. ;TYPE AS ASCII RIGHT JUSTIFY
JRST TYPL ;[120] NO - TRY OCTAL
JUSTIFY
TYPE(R) ;RASCII IDENTIFIER
LSH T5,1 ;MAKE LEFT JUSTIFIED ASCII
PUSHJ P,TXT341 ;TYPE AS USUAL
TRNN P3,B. ;[120] DOUBLE RASCII?
JRST TYPL ;[120] NO
PUSHJ P,VAL2 ;GET NEXT VALUE
LSH T5,1 ;FAKE ASCII
PUSHJ P,TXT341 ;TYPE AS ASCII
TYPL: TRNN P3,L. ;[120] TYPE AS LOGICAL?
JRST TYPS ;[120] NO - SEE IF IN RANGE
JUSTIFY ;[120]
JUMPGE T5,TYPL1 ;[124][120] IF POSITIVE, IT'S FALSE
TYPE(.TRUE.) ;[124][120] IT MUST BE NEGATIVE SO TRUE
JRST TYPS ;[124][120]
TYPL1: TYPE(.FALSE.) ;[124][120] IT'S POSITIVE
TYPS: TRNN P3,S. ;/S IS ILLEGAL FOR TYPE
JRST TYPN
JRST ERR37 ; - ERROR
; HERE AT END OF TYPING - EXAMINE RANGE CONDITION
TYPN: LINE
SKIPN RANGE ;ARE WE IN A RANGE CONDITION
JRST DISP5 ; NO
TRNE P3,C. ;[157]Character string?
JRST TYPC ;[157]YES.
AOS T5,RANLIM ; YES INCREMENT VARIABLE
TRNE T0,DOUBLE ;[112] IS THIS A DOUBLE WORD ARRAY RANGE
AOS T5,RANLIM ;DOUBLE WORD ARRAYS GO UP BY TWO
CAMG T5,RANGE ;TO LIMIT OF RANGE
JRST DISP10 ;AND TYPE ALL REQUIRED
JRST DISP5 ;[157]DONE. Go clean up
TYPC: MOVE T5,RANLIM ;[157]Restore base
AOS T2,CLMOFF ;[157]Count this element
CAMG T2,CLMRNG ;[157]Was that the last?
JRST DISP10 ;[157]NO. Go type next element
DISP5: SKIPGE TERMK ;[323] END OF USER INPUT LINE YET?
JRST DISP4 ; NO - KEEP GOING
POPJ P, ; YES - END OF TYPE COMMAND
JUSTFY: TRZN P3,ANYMOD ;SEE IF FIRST OUTPUT THIS VARIABLE
jrst [LINE
jrst .+1]
TYPE( = )
MOVE T5,LWT ;GET BACK THE OUTPUT VARIABLE CONTENTS
POPJ P,
; GET THE LIMIT OF A RANGE CONDITION AND CHECK THE ORDER
DISP1:
; if character, save original offset, get new offset, save as
; hi offset. (ranlim?)
;
;
;
MOVEM T5,RANGE ;REMEMBER START OF RANGE
MOVE T5,CLMOFF ;[157]Get beginning offset
MOVEM T5,CLMRNG ;[157]Save it in case this is /C
TLZ T0,GRPFL ;NO GROUP REQUESTS HERE OR PRINT MODIFIERS
MOVE T5,MATHSM ;[403]SAVE CURRENT SYMBOL
MOVEM T5,TEM10 ;[403]
PUSHJ P,SYMIN ;GET NEXT SYMBOL
JRST DISP9 ;BAD LABEL
JRST BADSYN ;STATEMENT NO. ????
MOVE T4,TEM10 ;[403]GET FIRST SYMBOL BACK
CAME T4,MATHSM ;ARE THEY THE SAME
JRST ERR40 ;NO - SORRY
TRZE T0,SUBFLG ;WAS THERE AN IMPLIED RANGE
JRST DISP11 ;YES - GO DEAL WITH IT
CAML T5,RANGE ;SORT OUT SYMBOL ORDER
EXCH T5,RANGE ;CHANGE THEIR ORDER
CAIN T2,"-" ;"-" IS A DELIMITER BUT IS BAD HERE
JRST BADSYN
TLO T0,GRPFL ;O.K. FOR GROUPS AGAIN
TRNN P3,C. ;[322] MODE Character?
JRST DISP10 ;[322] No - Now type range
; clmrng=first offset given
; clmoff=offset just received
DISP1B: MOVE T2,CLMOFF ;[157]Get the lower offset
CAMLE T2,CLMRNG ;[157]Is lower .le. upper?
EXCH T2,CLMRNG ;[157]NO. Make it so
MOVEM T2,CLMOFF ;[157]Restore lower offset
JRST DISP10 ;[157]Go type for the user
SYM4: TLNE T0,GRPFL ;ARE WE ALLOWING CORE STRINGS
CAIE T2,"/" ;AND IF SO DOES THE USER WANT ONE
JRST SYM1 ;NOT IN GROUP LOGIC
; ACCEPT TEMPORARY PRINT OPTION MODIFIERS
SYM15: PUSHJ P,OPTION ;GET THE PRINT OPTION SETTINGS
JRST SYM14 ;NUMERIC - MUST HAVE BEEN A GROUP REQUEST
HRLS P3 ;[323] New settings become the default
SKIPL TERMK ;EOL?
JRST BADSYN ;CAN'T HAVE THAT!
PJRST SYMIN ;RESUME SYMIN ACTIVITIES
; HANDLE GROUP REQUESTS
SYM14: CAIL T5,1
CAILE T5,GPMAX ;WHICH MUST BE IN RANGE
JRST ERR15 ;NO GOOD
CAIE T2,"," ;ALLOW COMMA AS DELIMITER
JUMPN T2,BADSYN ;ANYOTHER CHARACTER IS BAD
PUSHJ P,SYM5 ;PROCESS GROUP CONTENTS
POP P,(P) ;REMOVE SYMIN PUSH
JRST DISP5 ;ANYTHING ELSE ON USERS LINE?
SYM1: TLNN T0,GRPFL ;IS GROUP LOGIC IN ACTION
JRST RET ;ASSUME NUL INPUT GO BACK TO USER
POP P,(P) ;REMOVE THE SYMIN PUSH
JUMPE T2,DISP5 ;EMPTY GROUP?
JRST BADSYN ;MUST BE BAD SYNTAX
; ROUTINE TO DETERMINE THE LENGTH OF AN IMPLIED RANGE
DISP14: MOVEM T5,RANLIM ;SAVE THE BASE ARRAY REFFERENCE
SETZM PUTTER ;SET FOR RAYNAM
PUSHJ P,GET.RP ;GET THE RANGE PRODUCT FOR THIS ARRAY
MOVE T5,DIMTOT ;
SOJ T5, ;
MOVEM T5,CLMRNG ;[157]In case character
TRNE T0,DOUBLE ;[307] IS IT DOUBLE PRECISION?
LSH T5,1 ;[307] YES, DOUBLE THE RANGE PRODUCT
ADD T5,RANLIM ;FORM UPPER RANGE LIMIT
MOVEM T5,RANGE ;SAVE THE RANGE
MOVE T5,RANLIM ;GET THE START ADDRESS
POPJ P,
; ENTRY POINT FOR A GROUP 'TYPE' REQUEST
; PUSHJ P,SYM5
; WITH GROUP # 1-GPMAX IN T5
; AND TERMK=0
SYM5: TRZE T1,DCOPFG ;DON'T OPEN PROG?
JRST SYM16 ;NO - DON'T
SKIPN T4,GRP2(T5) ;GET GROUP'S PROG
JRST SYM16 ;NULL - IGNORE IT
CAMN T4,OPENED ;IS IT CURRENT?
JRST SYM16 ;YES
MOVEM T4,SYM ;NO - SAVE IT
MOVSYM OPENED,T4,OLDOPN;[402]Save OPENED into OLDOPN
TRZ T1,LNAME ;[402] ASSUME SHORT NAME
SKIPE GRPFLG(T5) ;[402] WAS IT SHORT
TRO T1,LNAME ;[402] NO, SET LONG NAME FLAG
PUSH P,T5 ;SAVE (T5)
PUSHJ P,IMPOPN ;DO THE OPEN AND MESSAGE
POP P,T5 ;RESTORE (T5)
SYM16:
; CHECK FOR GROUP RECURSION
MOVEI T4,1
LSH T4,(T5) ;SET UP MASK BIT
TDOE T4,CURGRP ;CHECK AND SET
JRST ERR39 ;GROUP ALREADY ACTIVE - ERROR
MOVEM T4,CURGRP ;SAVE STATE
PUSH P,T5 ;SAVE T
IMULI T5,CFSIZ ;GET RELEVANT GROUP SECTION
ADD T5,[POINT 7,GRP1-CFSIZ] ;FORM POINTER TO IT
RECURS <CFLPTR,CFLST,GETCHR,TERMK>
;CFLPTR - SAVE CURRENT CORE POINTER
;CFLST - SAVE CURRENT CORE LIMIT
;GETCHR - SAVE CURRENT STRING SOURCE
;TERMK - SAVE CURRENT DELIMITER DESCRIPTOR
MOVEM T5,CFLPTR ;SET UP NEW POINTER
HRRZM T5,CFLST ;DEFINE NEW STRING LIMIT
MOVE T5,[ILDB T2,CFLPTR] ;GET POINTER TO NEW INFORMATION
MOVEM T5,GETCHR ;STATE NEW STRING SOURCE
PUSHJ P,DISP4 ;DO A RE-ENTER
SRUCER ;POP BACK ALL ABOVE RECURS-ED VALUES
; CLEAR CURRENT GROUP FLAG
POP P,T5 ;GET NUMBER BACK
MOVEI T4,1
LSH T4,(T5) ;SET UP MASK
TDC T4,CURGRP ;CLEAR THIS GROUP FLAG
MOVEM T4,CURGRP ;SAVE IT
PJRST DISP5 ;SEE IF THERE IS AN ORIGINAL USER
;STRING TO PROCESS
DISP3: PJRST DISP9 ;CANNOT FIND SYMBOL
;OPEN LOGIC
; input: SYM contains section name
; output: OPENED contains section name
; SSTAB points to secondary symbol table
SETNAM: SETZM SSTAB ;[402] Zero ptr to secondary symbol table
CLRFLG OPENED ;[402] Assume short name of open section
TRNE T1,LNAME ;[402] Looking for long symbol name?
JRST SETLNM ;[402] Yes
PUSHJ P,FINDP ;[321] Find program name
JRST ERR6 ; NO SUCH NAME
MOVE T5,SYM
MOVEM T5,OPENED ; PROGRAM NAME OPENED
JRST SETNM1 ;[402]
SETLNM: MOVSI T2,LPNAME ;[402]Global prefix
MOVEM T2,SYMASK ;[402]Reset mask in case it's been munged
PUSHJ P,FINDLG ;[402] Yes
JRST ERR6 ;[402] No such name
MOVE T5,SYM
STSYM T5,OPENED ;[402] PROGRAM NAME OPENED
SOJ T2, ;[402] Point to top of table
MOVEM T2,SSTAB ;[402] STORE PTR TO SECONDARY SYMBOL TABLE
MOVE T2,TMPSAV ;[402] Get .SYMTB entry in ddt symbol table
LG9LP: ADDI T2,2 ;[402] Loop to find ddt entry for program name
MOVE T5,(T2) ;[402] Get name of entry
TLNE T5,PNAME ;[402] Program name?
JRST LG9LP ;No
SETNM1: HLRE T5,1(T2) ;[321] Length of module (negative)
MOVMM T5,OPENLZ ;[321] Save positive size
ADD T5,T2 ;[321] Point to beginning of
ADDI T5,2 ;[321] symbols for
MOVEM T5,OPENLS ;[321] this module
TRNN T1,LNAME ;[402] Short program name?
JRST SETNM2 ;[402] No
;[402] Yes, Look for secondary symbol table
MOVE T5,[SQUOZE 0,.SYMTB] ;[402] .SYMTB in RAD50
MOVEM T5,SYM ;[402]
PUSHJ P,FINDL ;[402] Look for local .SYMTB
JRST SETNM2 ;[402] No .symtb
MOVEM T5,SSTAB ;[402] Store ptr to secondary symbol table
SETNM2: MOVE T5,OPENED ;[402]
MOVEM T5,SYM ;[402]
POPJ P,
; DIMENSION LOGIC
;
; [301] Reworked
;
; This is the heap which will contain dimension information.
;
; Each heap entry contains three words, and come in three types:
; 1) Empty
DENXT==0 ;Global index to next free entry
;The remaining two words are unused
;
; 2) Array Header
DSNXT==0 ;Global index to next array header
DSDIM==1 ;Global index to first dimension entry for
; this array.
DSLOC==2 ;Global index to the first element of the array
; 3) Dimension information
DDNXT==0 ;Global index to next dimension for this array
DDLOW==1 ;Lower dimension
DDRNG==2 ;Number of elements (less 1) in this dimension
; Higher dimension = DDLOW + DDRNG
; Bits 1-5 of DSDIM can contain flags.
; Note that these bits are not used by global indexing.
DFDBL==1B1 ;The array contains double-word data
DFCHAR==1B2 ;The array contains character data
DIMTAB: XLIST ;Allocate an empty heap
REPEAT DIMSIZ-1,<
EFIW .+3 ;Next empty slot
EXP 0 ;Unused
EXP 0 ;Unused
>
DIMTE: EXP 0 ;Zero index in last entry
EXP 0
EXP 0
LIST
DIMFF: EFIW DIMTAB ;Start of free slots
DIMLF: EFIW DIMTE ;End of free slots
DIMNAM: EXP 0 ;Global index to first array header
; ROUTINE TO OBTAIN A FREE DIMTAB ENTRY
; CALL PUSHJ P,GETRAY
; RETURN - ADDRESS OF SLOT IN T5
GETRAY: MOVE T5,DIMFF ;[301] Get the start of the free list
MOVE T2,DENXT(T5) ;[301] Find the location of the next slot
JUMPE T2,GETNON ;END OF LIST REACHED
MOVEM T2,DIMFF ;[301] Remove this entry from free list
POPJ P, ;RETURN WITH GOOD ENTRY ADDRESS IN T5
GETNON: PUSHJ P,FLUSHA ;REMOVE ALL STRUCTURES CREATED FOR
;THE ARRAY VALUE IN SAVLOC
TYPE(?FDTDTO Dimension table overflow)
JRST RET
; SUBROUTINE TO RETURN A DIMTAB ENTRY TO THE FREE LIST
; CALL PUSHJ P,PUTRAY
; ENTER WITH ADDRESS OF SLOT IN T5
; RETURN
PUTRAY: MOVE T2,DIMLF ;[301] Get address of end of free list
MOVEM T5,DENXT(T2) ;[301] Append the slot
SETZM DSNXT(T5) ;[301] Slot becomes end of list
MOVEM T5,DIMLF ;[301] Record that fact
POPJ P,
; ROUTINE TO LOOK THROUGH LIST OF ARRAY NAMES TO FIND IF
; THIS (SAVLOC) NAME IS ALREADY IN USE
; CALL PUSHJ P,RAYNAM
; RETURN HERE IF NOT FOUND
; RETURN HERE IF FOUND . . . T5=ADDRESS OF ARRAY, T3=LAST ARRAY
; F10RAY IN T0 IS SET IF F10 DEFINED
RAYNAM: TRZ T0,FORMAL!F10RAY ;[105] ASSUME NEITHER HOLDS
;[202]
XMOVEI T3,DIMNAM ;[301] Set up for
MOVE T5,(T3) ;[301] first array
RAY: JUMPE T5,RAY3 ;T3 WILL POINT TO THE END OF THE LIST
MOVE T2,DSLOC(T5) ;[301] THIS IS AN ARRAY BLOCK - GET THE VALUE
CAMN T2,SAVLOC ;ARE WE REDEFINING CURRENT NAME?
JRST RAY2 ; YES - REMOVE THE ENTRY FIRST
MOVE T3,T5 ;T3 WILL POINT TO THE CURRENT GOOD ENTRY
MOVE T5,DSNXT(T5) ;[301] Find the next entry
JRST RAY
RAY2: TRZ T0,DOUBLE!CHARS ;[301] Assume they are going to be off
MOVE T4,DSDIM(T5) ;[301] Flags from array entry
TLNE T4,(DFDBL) ;[301] Is it double word?
TRO T0,DOUBLE ;[301] Yes - Remember that
TLNE T4,(DFCHAR) ;[301] Character array?
TRO T0,CHARS ;[157]YES. mark it.
JRST CPOPJ1 ;ARRAY IDENTIFIED EXIT
; HERE IF NO USER DEFINITION EXISTS IN FORDDT DIMENSION LISTS
; NOW CHECK FOR AN F10 DEFINITION
RAY3: PUSH P,T5 ;SAVE BOTH T5 AND-
PUSH P,T3 ; T3 AROUND EVAL
MOVE T5,SAVLOC
TRO T0,SILENT ;DON'T PRINT SYMBOL
PUSHJ P,LOOK ;SETS UP P1 FROM T5
JRST RAYPOP ;
JRST RAYPOP ;DOSENT EXIST
POP P,T3 ;RETURN T3
POP P,T5 ; AND T5
MOVE S4,P1 ;[321] GET THE ARRAY SYMBOL
MOVE T2,(S4) ; AND SEE IF WE HAVE AN F10 ARRAY -
TRNE T1,LNAME ;[402] Long name?
JRST RAY3A ;[402] Yes - skip
TLZ T2,PNAME ; DEFINITION -
TLO T2,(50B5) ;[301] THIS IS THE SAME SYMBOL
RAY3A: CAME T2,2(S4) ;[402] WITH FLAGS 50 SET
POPJ P, ;NO - NOT AN F10 DEFINITION
TRO T0,F10RAY ;YES - FLAG THIS AS AN F10 ARRAY
MOVE S4,3(S4) ;SET POINTER TO ARRAY TABLE INFORMATION
LDB T2,[POINT 4,1(S4),12]
TRZ T0,DOUBLE ;[162]MAKE SURE DOUBLE IS OFF
CAIE T2,TP%DPR ;[112] [161]Double word array?
CAIN T2,TP%DPX ;[162]NO. G-Floating double array?
TROA T0,DOUBLE ;[162]YES FLAG IT & reset character flag
CAIN T2,TP%CPX ;[210]Complex is double word array also
TRO T0,DOUBLE ;[210]Yes it's complex
CAIE T2,TP%CHR ;[161]Character array?
TRZA T0,CHARS ;[161]NO
TRO T0,CHARS ;[161]YES
;[161] LDB T2,[POINT 9,1(S4),8]
LDB T2,[POINT 7,1(S4),8] ;[161]
MOVEM T2,DIMCNT ;SET UP THE NUMBER OF DIMENSIONS
LDB T2,[POINT 2,2(S4),1] ;[301] Array & Formal flags (V6 or before)
CAIN T2,2 ;[301] V7 Fortran (or later)?
LDB T2,[POINT 2,2(S4),3] ;[301] Yes - These flags instead
TRNN T2,1 ;[301] Is it a formal array argument?
JRST RAY5 ;[301] No
TRO T0,FORMAL ;[301] Yes - Flag it
XMOVEI T5,@1(S4) ;[301] Get the actual array base
MOVEM T5,FRMSAV ;[301] Save the formal reference
RAY5: ADDI S4,3 ;[301] SET TO POINT TO THE FIRST DIMENSION
JRST CPOPJ1
RAYPOP: POP P,T3 ;[321] MUST RESET T3-
POP P,T5 ; AND T5 BEFORE
POPJ P, ; GIVING A NO FOUND EXIT
; ROUTINE TO CREATE AN ARRAY ENTRY
; MUST HAVE A PAIR OF SUBSCRIPTS IN TEM,TEM1
; CALL PUSHJ P,PUTNAM
; ENTER WITH SAVLOC = VALUE OF NAME OF ARRAY
PUTNAM: PUSH P,T0 ;SAVE FLAGS ROUND THE NEXT FEW LINES
PUSHJ P,SIMDEF ;SEE IF THIS ARRAY NAME IS AFTER BASE-ARRAY
PUTCHK: PUSHJ P,RAYNAM ;HAVE WE USED THIS NAME BEFORE?
JRST PUTOK ;NO - GO AHEAD - PLACE NEW NAME
PUSHJ P,FLUSH ;NAME ALREADY IN USE STAND BY FOR REDEFINITION
TRZE T0,FORMAL ;ATTEMPT TO RE-DIMENSION A FORMAL PARAMETER
JRST [POP P,T0 ;[403]
JRST ERR33] ;[403]NO YOU DON'T
TRNN T0,F10RAY ;F10 DEFINED ARRAY?
JRST PUTCHK ;RESET ALL
JRST ERR28 ;WARN OF F10 REDEFINITION
PUTOK: POP P,T0 ;RESTORE FLAGS FROM ABOVE
PUSHJ P,GETRAY ;[301] GET A SLOT - END OF NAMES = T3
MOVEM T5,T4 ;SAVE FOR NAME DEFINITION - T4
PUSHJ P,GETRAY ;[301] GET A SLOT FOR DIMENSION DEFINITION
;ENSURE WE HAVE 2 SLOTS FREE NOW
;SAVE PAIN IN 'FLUSHING' LATER
MOVEM T4,DSNXT(T3) ;[301] SAY HELLO TO NEW MEMBER
SETZM (T4) ;NEW MEMBER BECOMES END OF CHAIN
MOVE T2,SAVLOC ;GET THE NEW MEMBERS NAME
MOVEM T2,DSLOC(T4) ;[301] ACCEPT THE NEW MEMBER TO THE FAMILY
TRNE T0,DOUBLE ;IS THIS A DOUBLE WORD ARRAY
TLO T5,(DFDBL) ;[301] YES - SAVE THE FACT
TRNE T0,CHARS ;[157]Character array?
TLO T5,(DFCHAR) ;[301] YES.
MOVEM T5,DSDIM(T4) ;[301] NEW MEMBERS ARE GIVEN A DIMENSION LIST
PUSHJ P,PUTSUB ;STORE THE SUBSCRIPTS
JRST CPOPJ1 ;JUMP OVER POSSIBLE PUTDIM ENTRY
PUTSUB: MOVE T2,TEM1 ;GET THE UPPER SUBSCRIPT
SUB T2,TEM ;[301] Compute the
MOVEM T2,DDRNG(T5) ;[301] dimension range
MOVE T2,TEM ;[301] Save the
MOVEM T2,DDLOW(T5) ;[301] lower dimension
SETZM DDNXT(T5) ;[301] End of present list
MOVEM T5,PUTTER ;SAVE THE END OF THE DIMENSION LIST
POPJ P,
; ROUTINE TO ADD ANOTHER DIMENSION TO AN ARRAY DIMENSION LIST
; CALL PUSHJ P,PUTDIM
; ENTER WITH TEM,TEM1 = LOWER AND UPPER SUBSRIPTS
PUTDIM: PUSHJ P,GETRAY ;[301] GET A FREE ENTRY
MOVE T2,PUTTER ;FIND WHERE THE LAST DIMENSION WAS STORED
MOVEM T5,DDNXT(T2) ;[301] Link new entry to list
PJRST PUTSUB ;SAVE THE SUBSCRIPTS
; ROUTINE TO GET THE DIMENSIONS, IN ORDER, FOR THE ARRAY VALUE(SAVLOC)
; CALL PUSHJ P,GETDIM
; WITH ARRAY VALUE IN SAVLOC AND PUTTER = 0 FOR FIRST CALL
; EXIT WITH TEM=SUB LOWER TEM1=SUB UPPER
GETDIM: SKIPE T5,PUTTER ;IS THIS THE FIRST CALL?
JRST GET4 ; NO - GET NEXT DIMENSION RANGE
PUSHJ P,RAYNAM ;YES - SET UP THE ARRAY REFERENCES
JRST E5 ;SAVLOC NAME NOT KNOWN??
TRNE T0,F10RAY ;F10 DEFINED?
JRST GET3 ;YES
MOVE T5,DSDIM(T5) ;[301] GET THE START OF DIMENSION LIST
JRST GET5 ;FIRST TIME IS SPECIAL
GET4: TRNE T0,F10RAY ;F10 ARRAY DEFINITION?
JRST GET3 ;YES
MOVE T5,DDNXT(T5) ;[301] GET NEXT DIMENSION IF ANY
GET5: JUMPE T5,ERR22 ;END OF LIST - TOO MANY DIMENSIONS EXPECTED
MOVEM T5,PUTTER ;SAVE LINK TO NEXT DIMENSION
MOVE T3,DDLOW(T5) ;[301] Get the
MOVEM T3,TEM ;[301] lower dimension
ADD T3,DDRNG(T5) ;[301] Form the
MOVEM T3,TEM1 ;[301] upper dimension
POPJ P,
; HERE TO GET THE NEXT UPPER AND LOWER BOUNDS
; FOR AN F10 DEFINED ARRAY
GET3: SETOM PUTTER ;FLAG NOT FIRST TIME FOR F10 ARRAYS
SOSGE DIMCNT ;ARE THERE ANY MORE DIMENSIONS TO COME?
JRST ERR22 ;NO HARD LUCK
MOVE T5,@(S4) ;GET THE LOWER BOUND
MOVEM T5,TEM ;SAVE LOWER
MOVE T5,@1(S4) ;GET THE UPPER BOUND
MOVEM T5,TEM1 ;SAVE UPPER
ADDI S4,3 ;[301] S4 NOW POINTS TO NEXT DIMENSION-
POPJ P, ; IF ANY
; ROUTINE TO GUARD AGAINST SIMULTANEOUS SINGLE COMMAND RE-DIMENSIONING
; OF THE SAME ARRAY. THE LOCATION BASRAY CONTAINS A REFFERENCE TO
; THE ARRAY NAME WHICH STARTED THE CURRENT DIMENSION WORKING
; AND WILL BE THE POINT IN THE NAMES LIST AFTER WHICH A REDEFINITION
; OF THE NAME NOW FOUND IN SAVLOC WILL BE ILLEGAL
SIMDEF: MOVE T4,SAVLOC ;GET THE NEW ARRAY NAME(VALUE)
EXCH T4,BASRAY ;SAVE AND START AT BASE-ARRAY NAME
PUSHJ P,RAYNAM ;SET UP POINTERS TO BASE-ARRAY
POPJ P, ; ????
MOVEM T4,BASRAY ;RESET BASE ARRAY AND CURRENT NAME
TRNE T0,F10RAY ;F10 DEFINED ARRAY?
POPJ P, ;MUST BE A NEW DEFINITION
PUSHJ P,RAY ;SEE IF THIS ARRAY NAME OCCURS AFTER BASRAY
POPJ P, ;NO
TYPE (?FDTMLD )
MOVE T5,SAVLOC ;GET THE OFFENDING VALUE
PUSHJ P,LOOK ;DISPLAY IT
JFCL
JFCL
TYPE( Multi-level array definition not allowed.)
PUSHJ P,FLUSHA ;FLUSH ALL FROM BASRAY TO END OF NAME LIST
JRST RET ;EXIT TO USER MODEFORDDT
; ROUTINE TO ENSURE THAT THERE ARE NO MORE DIMENSIONS
; TO BE CHECK FOR THIS (SAVLOC) ARRAY
SUBCHK: PUSHJ P,MORDIM ;ARE THERE ANY MORE DIMENSIONS LEFT
POPJ P, ;O.K.
JRST ERR1 ;NOT ENOUGH DIMENSION INFO
; TYPE THE DIMENSION LIST FOR THE ARRAY NAME VALUE IN SAVLOC
DIM1: PUSHJ P,RAYNAM ;SET UP REFERENCES TO THIS ARRAY NAME
JRST ERR34 ;NONE SUCH
TRNE T0,F10RAY ;IS THIS AN F10 DEFINED ARRAY
SKIPA T4,[EXP SAVLOC-1] ;IF SO FOOL TYPDIM
MOVE T4,T5 ;PREPARE FOR TYPDIM
PUSHJ P,TYPDIM ;TYPE OUT THE DIMENSIONS
JRST RET ;ALL DONE
; ROUTINE TO REMOVE AND RETURN(GARBAGE COLLECTION) ALL REFERENCE
; TO THE ARRAYS WHICH FOLLOW THAT DEFINED IN SAVLOC IF FLSHAL IS SET
FLUSHA: TRO T0,FLSHAL ;SET UP TO FLUSH ALL FROM BASE-ARRAY
MOVE T5,BASRAY ;GET THE BASE ARRAY VALUE
MOVEM T5,SAVLOC ;AND SET UP FOR RAYNAM
PUSHJ P,RAYNAM ;RESET F10RAY FLAG TO NEW BASRAY SETTING
POPJ P, ;?????
FLUSH: TRNN T0,F10RAY ;NOTHING TO DO IF AN F10 ARRAY
PUSHJ P,RAYNAM ;SET UP POINTERS TO THE ARRAY IN SAVLOC
POPJ P, ; CAN'T FIND THE ARRAY NAME
;T3=POINTS TO LAST ARRAY NAME BLOCK
;T5= CURRENT ARRAY NAME BLOCK
FLUSH2: MOVE T4,DSDIM(T5) ;[301] GET DIMENSION LIST ADDRESS
MOVE T2,DSNXT(T5) ;[301] GET NEXT MEMBER ADDRESS
MOVEM T2,DSNXT(T3) ;[301] LOOP OUT THE OFFENDING ARRAY NAME ENTRY
PUSHJ P,PUTRAY ;[301] RETURN A ENTRY
PUSHJ P,DELIST ;DELETE THE LIST STARTING AT C(T4)
TRNN T0,FLSHAL ;HARD FLUSH?
POPJ P, ;JUST ONE ARRAY FOR NOW
MOVE T5,DSNXT(T3) ;[301] GET NEXT ARRAY REFERENCE IF ANY
JUMPE T5,CPOPJ ;EXIT IF END OF LIST
JRST FLUSH2 ;MORE TO DO
;ROUTINE TO DELETE A LIST - STARTING IN T4
DELIST: SKIPN T5,T4 ;TEST FOR END OF LIST - RETURN ENTRY IN T5
POPJ P, ;END OF LIST
MOVE T4,DDNXT(T4) ;[301] GET NEXT ENTRY ADDRESS
PUSHJ P,PUTRAY ;[301] RETURN THE OLD ENTRY
PJRST DELIST ;FOLLOW THROUGH TO END OF LIST
DIM5: PUSHJ P,DIMOUT ;DISPLAY ALL ARRAY INFO.
LINE
JRST RET
; DIMENSION LOGIC
CARRAY: TROA T0,CHARS ;[157]Character array
DUBLE: TRO T0,DOUBLE ;[112] FLAG THIS AS A DOUBLE WORD ARRAY
DIM: JUMPL T0,DIM5 ;OUTPUT ALL DIMENSION SPECS
PUSHJ P,TTYIN ;GET NEXT USER STRING
JUMPE T3,DIM5 ;TYPE ALL ARRAYS IF EOL
PUSHJ P,ALLNUM ;SEE IF USER TYPED A LABEL
JRST DIM13 ;NO - MUST BE VARIABLE
JRST BADSYN ;BAD SYNTAX
DIM13: PUSHJ P,VALID ;CHECK VALIDITY OF VARIABLE
STSYM T4,MATHSM ;[402]THATS WHAT USER TYPED
MOVEM T4,SYM ;SAVE FOR 'EVAL'UATION
PUSHJ P,EVAL ;EVALUATE SYMBOL
JRST ERR6 ;WE DON'T HAVE IT
MOVEM T5,SAVLOC ;SAVE ARRAY NAME VALUE
MOVE T2,LSTCHR ;RE-INSTATE USERS LAST CHARACTER
SKIPL TERMK ;END OF LINE?
JRST DIM1 ;YES - USER WANTS TO SEE DIMENSION LIST
PUSHJ P,NXTCHR ;MOVE TO NEXT SIGNIFICANT CHARACTER
CAIN T2,"(" ; [ DENOTES START OF DIMENSION DEFINITION
JRST DIM14 ;COMMAND - WILL NOW BE NON ZERO
CAIE T2,"[" ; ( IS AN ALTERNATIVE TO [
JRST DIM7
TLO T0,LFTSQB ;FLAG THAT A LSB FOUND - SO RSB MUST END SPEC
DIM14: PUSHJ P,DIMIN ;SET UP A NEW ARRAY DEFINITION
JRST RET
DIM7: CAIE T2,"/" ;A / IS ACCEPTABLE TO REMOVE ARRAYS
JRST BADSYN ;ANYTHING ELSE WONT DO
PUSHJ P,TTYIN ;GET NEXT INPUT
JUMPN T2,BADSYN ;MUST BE LINE END NOW
JUMPE T3,BADSYN ;NO CHARACTERS??
LSHC T2,6 ;GET THE FIRST SWITCH CHARACTER
CAIE T2,'R' ;DID THE USER REQUEST A REMOVE
JRST BADSYN ;NO - WELL TOO BAD
PUSHJ P,RAYNAM ;SEE IF WE KNOW ABOUT HIS ARRAY
JRST ERR26 ;NO - TELL HIM
PJRST DMFLSH ;REMOVE IT
; ROUTINE TO SET UP A NEW ARRAY DEFINITION
DIMIN: SETZM DIMTOT ;CLEAR TOTAL ELEMENT COUNT
TROE T0,BASENM ;HAS A BASE NAME BEEN ACCEPTED
JRST DIM0 ;YES - DON'T FLUSH YET
SETZM F10RP ;[163]Reset
PUSH P,T0 ;PROTECT THE DOUBLE FLAG AWHILE
PUSHJ P,RAYNAM ;HAVE WE HAD THIS BASE ARRAY BEFORE
JRST DIMBAS ;[163]No references to this array
TRNE T0,F10RAY ;[163]Compiler reference?
JRST DRNGPR ;[163]YES. Go get range product
PUSHJ P,FLUSH ;[163]Clear user reference
PUSHJ P,RAYNAM ;[163]Look for compiler reference
JRST DIMBAS ;[163]None
TRNN T0,F10RAY ;[163]Better be F10 defined!!!!
JRST DIMBAS ;[163]NOT!!!!!
DRNGPR: SETZM PUTTER ;[163]Reset first-time flag
PUSHJ P,GET.RP ;[163]Get the compiled range-product
MOVE T5,DIMTOT ;[163]Load the range product
MOVEM T5,F10RP ;[163]Save it
SETZM DIMTOT ;[163]Clear
bpw==5
DIMBAS: MOVE T5,SAVLOC ;GET THE ARRAY VALUE
MOVEM T5,BASRAY ;MARK THIS AS OUR BASE ARRAY
POP P,T0 ;RE-INSTATE THE DOUBLE FLAG IF THERE
DIM0: TRO T0,SURGFL ;FLAG THIS CALL AS SUBSCRIPT GATHERING
PUSHJ P,EITHER ;READ A SUBSCRIPT
CAIA ;CONSTANT
MOVE T5,(T5) ;VARIABLE - GET VALUE
TRZ T0,SURGFL ;CLEAR SUBSCRIPT RANGE ACCEPT FLAG
MOVEM T5,TEM1 ;SAVE TEMPORARILY AS UPPER SUBSRIPT
PUSHJ P,NXTCHR ;MOVE TO NEXT CHARACTER
CAIN T2,"," ;COMMA IS THE USUAL DELIMITER
JRST DIMCOM ;PROCESS A COMMA
CAIE T2,":" ;A : IS AS GOOD AS A BAR=/
CAIN T2,"/" ;BAR IS THE SUBSCRIPT SEPARATOR
JRST DIMBAR ;PROCESS A BAR
TLNN T0,LFTSQB ;SKIP IF WE HAD A [ TO START
ADDI T2,"]"-")" ;ACCEPTABLE DELIMITER IF )
CAIN T2,"]" ;ONLY ] ACCEPTED AS DELIMITER
JRST DIM4 ;DENOTE END OF DEFINITIONS
PUSHJ P,FLUSHA ;REMOVE THE PRESUMABLY WRONG DEFINITION
JRST BADSYN ;COMPLAIN ABOUT SYNTAX
DIM4: TLO T0,DIMEND ;FLAG THAT THIS IS THE END OF THE LIST
DIMCOM: TLZE T0,BAR ;HAVE HAD TWO SUBSCRIPTS?
JRST DIM2 ;YES - CHECK THE ORDER
MOVEI T5,1 ;ADJUST LOWER SUBSCRIPT TO BE 1
MOVEM T5,TEM ;LOWER SCR IN TEM
DIM2: MOVE T5,TEM1 ;GET THE SECOND SUBSCRIPT
CAMGE T5,TEM ;ENSURE THAT IT IS GREATER THAN THE FIRST
JRST ERR3 ;TELL USER ABAOUT THE ERROR
;[301] SUB T5,TEM ;FIND THE RANGE
;[301] CAIG T5,777777 ;CANT HAVE ARRAYS OWNING WHOLE OF CORE
;[301] JRST DIM3 ;SUBSCRIPTS OK
;[301] JRST ERR27 ;BAD SUBSCRIPTS
SKIPN DIMTOT ;[301] IS THIS THE FIRST SETTING FOR THIS ARRAY
PUSHJ P,PUTNAM ;YES - USE PUTNAM
PUSHJ P,PUTDIM ;N0 - ADD ANOTHER DIMENSION
MOVE T5,TEM1 ;GET UPPER SUBSCRIPT
SUB T5,TEM ;FORM RANGE
AOJ T5, ;MUST HAVE AT LEAST ONE
SKIPN DIMTOT ;IS THIS THE FIRST DIMENSION
AOS DIMTOT ;YES - MAKE FIRST RANGE DEFAULT = ONE
IMULM T5,DIMTOT ;FORM TOTAL SUBSCRIPT COUNT IN DIMTOT
TLNN T0,DIMEND ;WAS A RIGHT SQUARE BRACKET SEEN LAST?
JRST DIM0 ;NO - BACK FOR MORE
PUSHJ P,ARYSIZ ;[301] Get the true size
JRST ERR27 ;[301] Too big
SKIPE T5,F10RP ;[301] Was there a compiler definition?
CAML T5,DIMTOT ;[301] Yes - Is that less than user wants?
POPJ P, ;[301] Looks OK
LINE
TYPE (<%FDTABX >) ;WARNING
PUSHJ P,TYPRAY ;TYPE THE (SAVLOC) ARRAY NAME
TYPE( compiled array bounds exceeded)
POPJ P,
DMFLSH: PUSHJ P,FLUSH ;THE WHOLE SETUP FAILS
JRST RET
TYPRAY: MOVE T5,SAVLOC ;GET THE OFFENDING ARRAY NAME
TRZ T0,SILENT ;SPEAK-UP
PUSHJ P,LOOK ;SHOW THE USER
JFCL
JFCL
POPJ P,
DIMBAR: TLOE T0,BAR ;FLAG A BAR IF NOT ALREADY SET
JRST BADSYN
MOVE T5,TEM1 ;MOVE FIRST SUBSCRIPT TO APPROPRIATE PALCE
MOVEM T5,TEM ; IN TEM
JRST DIM0 ;LOOK FOR SECOND SUBSCRIPT
NXTCHR: SKIPL TERMK ;END OF LINE?
JRST BADSYN ;YES - SHOULD'T BE
JUMPN T2,CPOPJ ;TERMINATOR?
PJRST GETSKB ;MOVE TO NEXT SIGNIFICANT CHARACTER
; DISPLAY ALL ARRAY DATA ENTERED BY USER
DIMOUT: LINE
ife tops20,<
SKPINL ;INTERCEPT A USER CONTROL O
JFCL> ;end of conditional
ifn tops20,<
push p,T1 ;save T1
push p,T2 ;save T2
hrrzi T1,.priou ;get terminal output designator
rfmod% ;get terminal JFN word
tlz T2,(tt%osp) ;clear ^o effects
hrrzi T1,.priou ;get terminal output designator
sfmod% ;set new JFN word
pop p,T2 ;restore T2
pop p,T1> ;restore T1, end of conditional
LINE
SKIPN T4,DIMNAM ;START AT HEAD OF ARRAY NAMES
jrst [TYPE(No )
jrst .+1]
TYPE(Array specifications)
LINE
JUMPE T4,CPOPJ ;EXIT IF NOTHING TO PRINT
LINE
;[163] TYPE(USED MAX ARRAY DIMENSIONS)
TYPE(USED ARRAY DIMENSIONS)
LINE
MOVE T4,DIMNAM ;[301] Where first one is
TYPNXT: JUMPE T4,CPOPJ ;ALL PROCESSED?
PUSHJ P,TYPDIM ;NO - TYPE DIMENSIONS
MOVE T4,DSNXT(T4) ;[301] Find next array reference
JRST TYPNXT ;LOOK FOR MORE
; TYPE THE DIMENSION LIST FOR THE ARRAY ENTRY IN T4
TYPDIM: PUSH P,T4 ;SAVE T4 ROUND LOOK-UP
LINE
MOVE T5,DSLOC(T4) ;[301] GET THE ARRAY NAME VALUE
MOVEM T5,SAVLOC ;SAVE THE ARRAY REFERENCE
PUSHJ P,GET.RP ;GET THE RANGE PRODUCT = DIMTOT
MOVE T5,DIMTOT ;GET TOTAL ELEMENT COUNT
TRNE T0,DOUBLE ;[301] Double-word elements?
LSH T5,1 ;[301] Yes - Get true size
TRNN T0,CHARS ;[163]Character array?
JRST TYPLO ;[163]NO
MOVE T2,SAVLOC ;[163]Address/array descriptor
IMUL T5,1(T2) ;[163]Length of array in bytes
TYPLO: PUSHJ P,TYP0 ;AND DISPLAY IT
TAB
tab
SETZM PUTTER ;RESET FOR RESCAN OF ARRAY'S DIMENSIONS
MOVE T5,SAVLOC ;GET THE ARRAY NAME VALUE
TRZ T0,SILENT ;[314] TURN OFF PRINT SUPPRESS SWITCH
PUSHJ P,LOOK ;DO A LOOK UP ON C(T5)
JFCL ;NOT FOUND
JRST [POP P,T4 ;[403]
JRST E5] ;[403] OR NOT EXACT??
TAB
TYPE([)
DIM10: PUSHJ P,GETDIM ;GET THE SUBSCRIPTS FOR THE NEXT DIMENSION IN TEM,TEM1
MOVE T5,TEM ;GET THE LOWER SUBSCRIPT
PUSHJ P,TYP0 ;AND TYPE IT
stype(":")
MOVE T5,TEM1 ;GET TUE UPPER SUBSCRIPT
PUSHJ P,TYP0 ;AND TYPE THAT
PUSHJ P,MORDIM ;ANY MORE DIMENSIONS?
JRST DIM20 ;NO
stype(</,/>)
JRST DIM10 ;PROCESS NEXT DIMENSION
DIM20: TYPE(])
POP P,T4 ;GET BACK ARRAY REFERENCE
TRNE T0,F10RAY ;F10 ORIGINATED?
jrst [TYPE( - F10 ORIGINATED)
jrst .+1]
TRNE T0,DOUBLE ;REAL*8
jrst [TYPE( DP)
jrst .+1]
TRNE T0,CHARS ;[157]Character?
JRST [TYPE( CH)
JRST FRMLCK] ;[157]
TRNN T0,DOUBLE ;REAL*4
jrst [TYPE( SP)
jrst .+1]
FRMLCK: TRNE T0,FORMAL ;ARRAY IS A FORMAL ?
jrst [TYPE( FORMAL)
jrst .+1]
POPJ P,
; SUBROUTINE TO SEE IF THERE ARE ANY MORE DIMENSIONS TO COME
; FOR THE CURRENT ARRAY
; CALL PUSHJ P,MORDIM
; RETURN NO MORE
; RETURN MORE TO FOLLOW
MORDIM: TRNE T0,F10RAY ;F10 DEFINED ARRAY?
JRST MORD2 ;YES
SKIPN T5,PUTTER ;EXIT IF PUTTER = 0
POPJ P, ;NO MORE TO COME
MOVE T5,DDNXT(T5) ;[301] NO MORE IF NEXT IN LINE = 0
JUMPE T5,CPOPJ ;T5 WILL BE ZERO IF THIS IS THE LAST DIMENSION
JRST CPOPJ1 ;MUST BE MORE THERE
MORD2: SKIPG DIMCNT ;ANY MORE DIMENSIONS TO COME?
POPJ P, ;NO
JRST CPOPJ1 ;YES
; ROUTINE TO GET THE RANGE PRODUCT FOR THE ARRAY WHOSE VALUE
; IS HELD IN SAVLOC. EXIT WITH DIMTOT = RANGE PROD.
GET.RP: SETZM DIMTOT ;CLEAR THE ELEMENT COUNT CELL
SETZM PUTTER ;CLEAR FOR NEW SCAN IN GETDIM
DIM11: PUSHJ P,GETDIM ;GET THE NEXT SET OF DIMENSIONS FOR THE (SAVLOC) ARRAY
MOVE T5,TEM1 ;GET THE UPPER SUBSCRIPT SU
SUB T5,TEM ;FORM SU-SL
AOJ T5, ;FORM SU-SL+1
SKIPN DIMTOT ;FIRST TIME IS SPECIAL
AOS DIMTOT
IMULM T5,DIMTOT ;FORM TOTAL SPACE DECLARED FOR THIS ARRAY
PUSHJ P,MORDIM ;SEE IF THERE ARE ANY MORE DIMENSIONS
POPJ P, ;[301] NO - ALL DONE
JRST DIM11 ;YES - BACK FOR MORE
;[301] TRNE T0,DOUBLE ;[112] IS THIS ARRAY DOUBLE WORD
;[301] ADDM T5,DIMTOT ;YES - DOUBLE UP THE RANGE ACCESSED
;[301] POPJ P, ;WE NOW HAVE THE TRUE SCOPE OF THE ARRAY
;++
; FUNCTIONAL DESCRIPTION:
;
; The number of elements (DIMTOT) is multiplied by the size of
; each element to compute the total allocated size of the array.
; That computed size is checked to insure that the array is not
; too large.
;
; Checks are made during the computation to insure that there will
; be no arithmetic overflow.
;
; CALLING SEQUENCE:
;
; PUSHJ P,ARYSIZ
; Return here if array is too large
; Return here normally
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; DIMTOT contains the number of elements in the array.
; SAVLOC contains the global address of the array.
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; None
;
;--
; [301] New
ARYSIZ: PUSH P,T4 ;Save work registers
PUSH P,T5
MOVE T4,DIMTOT ;Number of elements in array
TLNE T4,(3B1) ;Can we have overflow problems?
JRST ASIZ99 ;Yes - Give up
TRNE T0,DOUBLE ;Double-word element?
LSH T4,1 ;Yes - Double the size
TRNN T0,CHARS ;Character data?
JRST ASIZ10 ;No - Check the limits
MOVE T5,SAVLOC ;Yes - Location of pointer/size pair
MUL T4,1(T5) ;Multiply by element size
JUMPN T4,ASIZ99 ;Quit
TLNE T5,(3B1) ; if
JRST ASIZ99 ; too big
MOVE T4,T5 ;Convert from
ADDI T4,4 ; characters
IDIVI T4,5 ; to words
ASIZ10: IFN TOPS20,<
SKIPN EXTEND ;23 bits OK?
>
TLNN T4,777777 ; No - Cannot be more than 18 bits
TLNE T4,777740 ; Yes - Cannot be more than 23 bits
JRST ASIZ99 ;Too big
AOS -2(P) ;We will return to call+2
ASIZ99: POP P,T5 ;Restore work registers
POP P,T4
POPJ P,
; GROUP LOGIC
GROUP: JUMPL T0,GRPALL ;DISPLAY ALL GROUPS
PUSHJ P,GETNUM ;WHICH GROUP IS THE USER SETTING?
JUMPLE T5,ERR15 ;NOT VALID
CAILE T5,GPMAX ;GPMAX IS THE MOST HE SHOULD ASK FOR
JRST ERR15
GETFLG T2,OPENED ;[402] Store flag saying whether OPENED has a
MOVEM T2,GRPFLG(T5) ;[402] long name into group table entry
MOVE T2,OPENED
MOVEM T2,GRP2(T5) ;THIS GROUP BELONGS TO THIS SECTION
IMULI T5,CFSIZ ;END OF GROUP AREA
SKIPL TERMK
JRST [PUSHJ P,GRTYP ;FORGETFULL USER WANTS TO SEE GROUP CONTENTS
JRST RET]
ADD T5,[POINT 7,GRP1-CFSIZ]
MOVEM T5,CFLPTR ;WHERE TO STORE NEW STRING
HRRZM T5,CFLST ;GUARD AGAINST OVERFLOW
MOVE T5,[PUSHJ P,I2CFIL]
MOVEM T5,GETCHR ;SETUP TTYIN TO READ CORE FILE
GRPMOR: PUSHJ P,I2CFIL ;CRAFTY READ AND STORE ROUTINE
PUSHJ P,GETSK2 ;SET UP ANY DELIMITER FLAGS
JUMPN T2,GRPMOR ;IF NO DELIMITERS - DO MORE
SKIPL TERMK ;END OF INPUT?
JRST RET ; YES - ALL DONE
JRST GRPMOR ; NO - DO MORE, WAS A SPACE
; DISPLAY THE CONTENTS OF THE GROUP WHOSE # IS IN T5
GRTYP: HRRZM T5,T3 ;
ADD T5,[POINT 7,GRP1-CFSIZ,6] ;[132]
MOVE T2,[ILDB T2,T5]
MOVEM T2,GETCHR ; INPUT FROM GROUP FILE
GRPNXT: SETOM TERMK ;SET UP FOR DELIMETER TEST
LDB T2,T5 ;[132] GET NEXT CHAR FROM STRING
PUSHJ P,GETSK2 ;END OF STRING?
JUMPN T2,.+2
MOVEI T2, " " ;SPACE IS SPECIAL
SKIPL TERMK
POPJ P, ;YES - IF TERMINAL CHARACTER TERMK +VE
putchr (T2) ;SHOW CHARACTER
IBP T5 ;[132] POSITION FOR NEXT BYTE
HRRZM T5,T4
CAIE T4,GRP1(T3) ;OVERFLO CHECK
JRST GRPNXT ;KEEP GOING
POPJ P, ;BETTER STOP
; GROUP STRING CORE STORAGE
GRP1: REPEAT GPMAX,< XWD 050000,0 ;NULL GROUP CONTENTS
BLOCK CFSIZ-1 ;SPACE FOR GROUP STRING
>
GRP2=.-1
BLOCK GPMAX ;PROGRAM NAMES FOR GROUPS
GRPFLG: BLOCK GPMAX ;[402] FLAG = 0 IF PROGRAM NAME IS SHORT
CURGRP: BLOCK 1 ;BITS TO FLAG CURRENT GROUP STACK
;IN ORDER TO CATCH RECURSION
; WHAT LOGIC
WHAT: LINE
TYPE(Open section: )
LDSYM T5,OPENED ;[402] Get name of opened section
PUSHJ P,SPT1 ;TYPE NAME OF OPEN SECTION
LINE
SKIPA T5,[0] ;FLAG DISPLAY OF EVERYTHING
PSEALL: SETO T5, ;FLAG DISPLAY OF PAUSES ONLY
PUSH P,T5 ;SAVE FLAG
MOVEI T5,^D10
MOVEM T5,S1 ;SET RADIX 10 AS STANDARD IN 'WHAT'
MOVEI T5,B1ADR ;START OF PAUSES
WT10: SKIPE (T5)
JRST WT9 ;THERE IS AT LEAST ONE PAUSE SET
ADDI T5,1 ;NO PAUSES SEEN SO FAR
CAIG T5,BNADR ;[300] ALL PAUSES EXAMINED?
JRST WT10 ;NO
HRRZI T0,FO$GBA ;[332] HAVE FOROTS RETURN BREAK ADDRESS
PUSHJ P,FOROP. ;[332] IN T0
SKIPN @T0 ;[332] IF @T0 IS NOT 0 THEN "PAUSE ON ERROR"
JRST [LINE
TYPE(No pause requests)
JRST WT11] ;[332]
WT9: LINE
MOVEI P4,B1ADR ;GET START OF PAUSES
WT6: HRRZ T5,(P4) ;GET THE PAUSE ADDRESS
JUMPE T5,WT1 ;[402]OMIT IF NO PAUSE SETTING
; PAUSE IDENTIFICATION
LINE ;[402]
TYPE (Pause: ) ;[402]
MOVE T5,(P4) ;GET PAUSE ADDRESS
;[326] TLO T0,FGLSNM ;GLOBALS OK
PUSHJ P,LOOK ;LOOKUP SYMBOL
JRST E1 ;NOT THERE??
PUSHJ P,SPT ;TYPE SUBROUTINE NAME
;ADD PROGRAM NAME WHERE PAUSE IS
LINE ;[402]
TYPE ( Located in: ) ;[402]
SKIPN T5,PNAMSV ;[402]WAS A PROGRAM NAME FOUND?
JRST WT5B ;[402] NO
PUSH P,T1 ;[402] Save T1
LDFLG PNAMSV ;[402]Set longname flag if needed
PUSHJ P,SPT1 ;DISPLAY THAT
POP P,T1 ;[402] Restore T1
; ANY CONDITIONALS?
WT5B: SKIPE 1(P4) ;[402]IS THIS A CONDITIONAL PAUSE?
JRST WT14 ; YES
; PROCEDE SETTING
WT5: MOVE T5,1(P4) ;GET CONDITIONAL SETTING
JUMPN T5,WT13 ;[402] DISPLAY GROUP
LINE ;[402]
TYPE ( After: ) ;[402]
WT2: HRRE T5,2(P4) ;[300] GET PROCEDE COUNT
PUSHJ P,FTOC ;TYPE THE PROCEDE COUNT
; TYPING OPTION = GROUP
WT13: HLRZ T5,2(P4) ;[300] GET THE 'TYPING' OPTION
JUMPE T5,WT1 ;[402] WAS TYPING REQUESTED?
LINE ;[402]
TYPE ( Typing Group: );[402]
HLRZ T5,2(P4) ;[300] YES - GET GROUP #
PUSHJ P,FTOC ;DISPLAY GROUP #
WT1: SKIPE (P4) ;[402]
jrst [LINE
jrst .+1]
ADDI P4,3 ;MOVE ON TO NEXT PAUSE
CAIG P4,BNADR ;DONE ALL PAUSES?
JRST WT6 ;NO - BACK FOR MORE
HRRZI T0,FO$GBA ;[332] HAVE FOROTS RETURN BREAK ADDRESS
PUSHJ P,FOROP. ;[332] IN T0
SKIPE @T0 ;[332] IF @T0 IS NOT 0 THEN "PAUSE ON ERROR"
JRST [LINE ;[402]
TYPE (Pause: ON ERROR);[402]
JRST .+1] ;[332]
JRST WT11 ;FINISHED PAUSE DISPLAY - DO GROUPS
; TYPE PARAMETERS OF CONDITIONAL PAUSE
WT14: LINE
TYPE ( Condition: ) ;[402]
TYPE(IF )
HRRZ T2,P4 ;GET CURRENT PAUSE ADDRESS
SUBI T2,B1ADR ;REMOVE OFFSETT
IDIVI T2,3 ;FORM PAUSE#
LSH T2,2 ;FORM INDEX TO TESTAB
MOVEM T2,WT16 ;SAVE T2 TEMPORARILY
MOVE T5,TESTAB(T2) ;[116] GET LOGICAL FLAGS
TLNE T5,LFTLOG ;[116] IS ARG. LOGICAL?
JRST WTLLOG ;[116] YES, TAKE CARE OF IT
MOVE T5,TESTAB+1(T2) ;GET FIRST ARG ADDRESS
CAIN T5,TESTAB+3(T2) ;IS IT A CONSTANT?
JRST [MOVE T5,(T5) ;YES
PUSHJ P,TFLOT ;TYPE FLOATING
JRST WT15]
CLEARM SAVLOC ;USER DIDNT GIVE ANY INFO!
CLEARM SECSAV ;CLEAR SAVED NAME OF SECTION
PUSHJ P,OFFSET ;TYPE THE ARGUMENT NAME
JRST E1 ;NAME NOT FOUND?
WT15: MOVE T2,WT16 ;RE-INSTATE T2
MOVE T5,TESTAB(T2) ;GET CONDITIONAL TYPE
TYPE( .)
atype(TYPTST(T5)) ;TYPE THE CONDITION
TLNE T5,RHTLOG ;[116] IS THIS ARG. LOGICAL?
JRST WTRLOG ;[116] YES, TAKE CARE OF IT
HRRZ T5,TESTAB+2(T2) ;[303] GET SECOND ARG ADDRESS
CAIN T5,TESTAB+3(T2) ;IS THIS A CONSTANT?
JRST [MOVE T5,(T5) ;YES -
PUSHJ P,TFLOT ;TYPE FLOATING
JRST WT5]
CLEARM SAVLOC ;USER DIDNT GIVE ANY INFO!
CLEARM SECSAV ;CLEAR SAVED NAME OF SECTION
PUSHJ P,OFFSET ;DISPLAY THE SECOND ARGUMENT NAME
JRST E1 ;NAME NOT FOUND
JRST WT5 ;RETURN FOR NEXT PAUSE
WTLLOG: MOVE T5,@TESTAB+1(T2) ;[124][116] GET VALUE
JUMPL T5,WTLTRU ;[124][116] IS IT POSITIVE?
TYPE(.FALSE.) ;[116] YES, SO .FALSE.
JRST WT15 ;[116]
WTLTRU: TYPE(.TRUE.) ;[116] MUST BE .TRUE.
JRST WT15 ;[116]
WTRLOG: MOVE T5,@TESTAB+2(T2) ;[124][116] GET VALUE
JUMPL T5,WTRTRU ;[124][116] IS IT POSITIVE?
TYPE(.FALSE.) ;[116] YES, SO IT'S .FALSE.
JRST WT5 ;[115]
WTRTRU: TYPE(.TRUE.) ;[116] MUST BE .TRUE.
JRST WT5 ;[116]
TYPTST: ASCIZ/LT. /
ASCIZ/LE. /
ASCIZ/EQ. /
ASCIZ/NE. /
ASCIZ/GT. /
ASCIZ/GE. /
WT16: 0
; GROUP SETTINGS
WT11: LINE
POP P,T5 ;GET DISPLAY FLAG BACK
JUMPL T5,RET ;DONE IF FLAG IS SET
PUSHJ P,GROUPS ;DISPLAY THE USERS GROUP SETTINGS
PUSHJ P,DIMOUT ;DISPLAY ANY USER DEFINED ARRAY SPECS.
LINE
JRST RET ;END OF WHAT
; PUSHJ P,GRPALL TO TYPE ALL GROUP SETTINGS
GRPALL: PUSHJ P,GROUPS
JRST RET
GROUPS: MOVEI P4,GPMAX ;CHECK IF ANY ARE USED
GROU1: SKIPE GRP2(P4) ;USED?
JRST GROU2 ;YES
SOJG P4,GROU1 ;NO, TRY NEXT
LINE
TYPE (No group specifications)
POPJ P,
GROU2: MOVEI P4,1 ;SET UP FOR FIRST GROUP
JRST WT7.5
WT7: SKIPN GRP2(P4) ;THIS ONE USED?
JRST WT7.3 ;NO - IGNORE IT
LINE
TLO T0,CFLIU!OFCFL ;MAKE REQUEST FOR CORE FILE USE
TYPE(GROUP )
MOVE T5,P4
MOVEI S1,12 ;DECIMAL BASE FOR GROUP NUMBERS
PUSHJ P,FTOC ;TYPE GROUP #
type(:)
tab
MOVEI T5,(P4) ;GET GROUP # BACK
IMULI T5,CFSIZ ;POINT TO ACTUAL LOCATION OF GROUP START
PUSHJ P,GRTYP ;DISPLAY GROUP CONTENTS
WT7.3: ADDI P4,1 ;BUMP GROUP NUMBER
WT7.5: CAIG P4,GPMAX ;DONE ALL GROUPS?
JRST WT7 ;NO - BACK FOR MORE
WT8: TLZ T0,CFLIU!OFCFL ;REMOVE DANGEROUS FLAGS
POPJ P, ;
; NEXT LOGIC - STEPS THROUGH STATEMENT LABELS(S),
; SOURCE LINES(L) OR SUBROUTINE ENTRIES(E)
NEXT: JUMPL T0,STEP2 ;NO ARGUMENTS USES DEFAULTS
PUSHJ P,EITHER ;ACCEPT EITHER A NUMERIC OR VARIABLE
CAIA ;NUMERIC
MOVE T5,(T5) ;GET VARIABLE CONTENTS
JUMPE T5,.+2 ;ZERO = LAST VALUE SUPPLIED
MOVEM T5,STPVAL ;STORE THE NEW STEP VALUE
CAIE T2,"/" ;TRACE OPTION FOLLOWS?
JRST STEP2 ;NO SWITCHES
PUSHJ P,OPTION ;FIND WHICH
JRST BADSYN ;NO GROUP REQUESTS HERE
TRNN P3,L.!S.!E. ;ANY TRACE OPTIONS SELECTED?
JRST STEP2 ;NO JUST 'NEXT'
TRZ T0,TRLABL!TRLINE ;FIRST RESET THE TRACE FLAGS
TRZE P3,L. ;DO WE TRACE LINES?
TRO T0,TRLINE ;YES
TRZE P3,S. ;DO WE TRACE LABELS?
TRO T0,TRLABL ;YES
STEP2: MOVEM T0,STKYFL ;RECORD THE STICKY FLAGS
MOVE T5,STPVAL ;GET THE STEP VALUE
MOVEM T5,STPCNT ;AND SET UP THE STEP COUNT
MOVE T5,[PUSHJ P,STEP4] ;PREPARE TO SET UP THE TRACE FEATURE
MOVEM T5,FDDT. ;LIKE-SO
SKIPN STARTU ;[316] Has START been done?
JRST START2 ;[316] No -- Simulate START with TRACE on
SKIPE T5,JOBOPC ;WAS A RE-ENTER THE LAST ACTION
JRST CONT2 ;YES - PROCEED FROM THERE
JRST PROCED ; NO - DO A NORMAL CONTINUE
; THIS IS THE ENTRY POINT FOR TRACING EACH SOURCE LINE OR LABEL
STEP4: JSR SAVE ;SAVE THE USERS ACS
PUSHJ P,REMOVB ;AND REMOVE THE PAUSES
MOVE T5,SAVACS+17 ;[325] GET THE FORTRAN PDL POINTER TO FIND THE PUSHJ
IFN TOPS20,<
SKIPE EXTEND ;[313]
SKIPA T5,(T5) ;[313]
>
HRRZ T5,(T5) ;[313]
SOJ T5, ;P.C. = STOPS ONE ON
MOVEM T5,BCOM ;SET UP FOR RE.BRK
SETZM SYM ;ACCEPT FIRST SYMBOL FOUND IN 'LOOK'UP
SETOM ESCAPE ;ALLOW ESCAPES
TRO T0,SILENT ;RIG FOR SILENT RUNNING
;[326] TLO T0,FGLSNM ;GLOBALS ARE OK
SETZM TROFFS ;[215] CLEAR ANY PREVIOUS OFFSET
PUSHJ P,LOOK ;'LOOK'-UP THE INTERCEPT
JRST E7 ;JUST HAS TO BE THERE
MOVEM T5,TROFFS ;[215] SAVE OFFSET: WE HAVE NO LOCALS
PUSH P,T1 ;[402] Save T1
PUSHJ P,STEP11 ;OPEN AND NAME SECTION IF NEW
POP P,T1 ;[402] Restore T1
TRNN T0,TRLINE!TRLABL ;REQUESTED TO TRACE ENTRIES ONLY?
JRST STEP7 ;YES
STEP13: MOVEM P1,P2 ;SAVE THE NOW RECOGNISED SYMBOL(LINE)
MOVE T5,TRUFST ;GET THE LAST CHARACTER OF THE LABEL
CAIN T5,32 ;"P"?
TRNN T0,TRLABL ;AND TRACING LABELS?
CAIA
JRST STEP5 ;YES - OK
TRNN T0,TRLINE ;ARE WE TRACING LINES?
JRST STEP7 ;NO - IGNORE
; PREPARE TO TYPE NEXT LABEL OR LINE
STEP5: SOSG TABCNT ;COUNT UP TO 8 LABELS PER LINE
JRST [line
MOVEI T5,10 ;SET FOR 8 LABELS/LINE
MOVEM T5,TABCNT ;RECORD IN TABCNT
JRST .+1]
TAB
MOVE P1,P2 ;GET BACK THE NEW FOUND SOURCE LINE
PUSHJ P,SPT ;AND PROUDLY DISPLAY IT
SKIPN T5,TROFFS ;[215] OFFSET FOUND?
JRST STEP5A ;[215] NO, A REAL LABEL
TYPE (+) ;[215] YES, TYPE IT
PUSHJ P,TYP4 ;[215] IN OCTAL
SETZM TROFFS ;[215] AND CLEAR IT
STEP5A: SKIPL STPCNT ;[215] SKIP IF AN INFINITE TRACE
JRST STEP6 ;OTHERWISE GO COUNT DOWN STPCNT
; HERE BEGINS THE EXIT
STEP7: PUSHJ P,LISTEN ;HAS THE USER HAD ENOUGH
CAIA ;NO
JRST STEP8 ;ENOUGH - ENOUGH
PUSHJ P,INSRTB ;REPLACE PAUSES
JSP T5,RESTOR ;RESTORE FORTRAN ACS
POPJ P, ;RETURN THE WAY WE CAME IN
; TRACE COUNT EXHAUSTED?
STEP6: SOSE STPCNT ;DECREMENT THE STEP COUNT
JRST STEP7 ;MORE TO DO - SEE IF THE USER INTERCEPTS
; TRAP TO USER COMMAND LEVEL
STEP8: XMOVEI T5,[POPJ P,] ;[313] MAKE SURE WE DO A POPJ RETURN
HRRZM T5,LEAV ;[313] PLACE IT IN THE LEAVE LOCATION
MOVEM T5,PROC0 ;[313] TO MAKE SURE WE DO A POPJ RETURN TO FORTRAN
JRST RET ;NORMAL WORKING
; XCT REFFERENCE FOUND BUT NOT 'P' OR 'L'
STEP12: TRZN T1,GUDLBL ;DID WE FIND A GOOD NUMERIC LABEL?
JRST STEP7 ;NO - THEN IT MUST BE A SUBROUTINE
MOVE T5,BCOM ;WHAT ARE WE 'LOOK'ING FOR
TRO T0,SILENT ;SILENCE AGAIN
PUSHJ P,RELOOK ;REFFERENCE DID NOT POINT TO A KNOWN LINE#
JRST E7 ;CAN'T FIND A PROPPER REFFERENCE?
JRST E7 ;THERE REALLY SHOULD BE SOMETHING THERE
JRST STEP13 ;VALIDATE THIS ONE THEN
; ROUTINE TO TYPE OUT NEW SECTION NAME
STEP11: PUSHJ P,SAV2AC ;SAVES T5 & P1
PUSHJ P,OVRLAY ;LOOK FOR AND TELL WHERE & IF AN OVERLAY HAPPENED
PUSHJ P,CMPPO ;[402] Compare PNAMSV and OPENED
SKIPA ;[402] Don't match
POPJ P, ;YES MATCH so JUST EXIT - AND RESET T5,P1
MOVEM T5,SYM ;SET UP FOR SETNAM
PUSHJ P,SETNAM ;AND OPEN THIS SECTION FOR EFFICIENT SEARCHES
MOVE T5,OPENED ;WHAT IS THE CURRENTLY OPEN SECTION
LINE
type([)
PUSHJ P,SPT1 ;DISPLAY THE SECTION NAME
type(])
tab
TRNN T0,TRLINE!TRLABL ;ARE WE TRACING ENTRIES?
JRST STEP6 ;YES - COUNT THEM - RET: RESETS PDL
SETZM TABCNT ;PRODUCE A PRETTY PRINT OF 8 LABELS/LINE
POPJ P, ;RESET T5,P1
; LOCATE LOGIC
Q: LINE
JUMPL T0,BADSYN ;MUST HAVE AN ARGUMENT
TRO T1,DCEVAL ;DON'T CALL EVAL
PUSHJ P,SYMIN ;GET A SYMBOL REFERENCE
TRZ T0,ID ;SYMBOL FOUND FLAG
PUSHJ P,SYMADR ;[327] Get the symbol table
JRST ERR6 ;[327] No table -- Error
QLIST2: PUSHJ P,FIXSYR ;Maybe skip modules we don't want
JUMPLE T4,QLIST9 ;[327] Off end of table
MOVE T5,(T2) ;PICK UP SYMBOL
JUMPE T5,QLIST3
TLZ T5,LOCAL ;[402]Locals only
CAME T5,[SQUOZE 0,.SYMTB] ;[402] .SYMTB in RAD50
JRST QLST2E ;[402] NO
MOVE T5,1(T2) ;[402] PTR to 2ndary symbol table
MOVE T5,1(T5) ;[402] First entry is program name
MOVEM T5,QLPNAM ;[402] Save long program name
;[402] T5 has flags+cnt+ptr to name
TLZ T5,LFLG ;[402] Clear flag
LSH T5,-CNTSFT ;[402] Get word count
CAIG T5,1 ;[402] Is name more than 1 word?
SETZM QLPNAM ;[402] No, so we will use short name
TRNN T1,LNAME ;[402] Is SYM a long name?
JRST QLST2E ;[402] NO
PUSH P,T2 ;[402] Save T2
PUSH P,SSTAB ;[402] Save SSTAB
PUSH P,T4 ;[402] and T4
MOVE T5,1(T2) ;[402] VALUE OF .SYMTB
MOVEM T5,SSTAB ;[402] Store ptr to this 2ndary symbol table
PUSHJ P,FINDLL ;[402] and search the symbols for a match
JRST QLST2D ;[402] NO MATCH
MOVEM T2,QLPNT ;[402] MATCH - Save it
SETFLG PNAMSV ;[402]Set flag saying it is long
POP P,T4 ;[402] Restore T4
POP P,SSTAB ;[402] Restore SSTAB
POP P,T2 ;[402] Restore T2
JRST QLIST3 ;[402] MATCH
QLST2D: POP P,T4 ;[402] Restore T4
POP P,SSTAB ;[402] Restore SSTAB
POP P,T2 ;[402] Restore T2
QLST2E: MOVE T5,(T2) ;PICK UP SYMBOL
TLZN T5,PNAME ;A PROGRAM NAME?
JRST QLIST6 ;YES
CAMN T5,SYM ;NO, IS AN OCCURANCE FOUND?
MOVEM T2,QLPNT ;[321] Yes - Remember where
QLIST3: ADDI T2,2 ;[321] Step to next entry
SUBI T4,2 ;[321] If there are more in this table,
JUMPG T4,QLIST2 ;[321] try again
;[327]
QLIST9: TRZE T0,ID ;ANY FOUND
JRST RET ;DONE
JRST ERR6 ;NO - ERROR
QLIST6: SKIPN QLPNT ;FOUND THE SYMBOL?
JRST QLIST3 ;NO
TRO T0,ID
PUSH P,T1 ;[402] Save T1
SKIPE QLPNAM ;[402] Do we have a long program name
JRST [TRO T1,LNAME;[402] Yes, set flag to long name
MOVE T5,QLPNAM;[402] Get long program name
JRST QLST6A] ;[402]
TRZ T1,LNAME ;[402] set flag to short name
QLST6A: PUSHJ P,SPT1 ;No, PRINT THE short PROGRAM NAME
MOVE T5,@QLPNT ;[321] GET THE SYMBOL BACK AND
SYMSKE PNAMSV ;[402] Is QLPNT a long name?
JRST QLST6B ;[402] Yes
TLNE T5,GLOBAL ; TEST FOR A GLOBAL SYMBOL
JRST QLIST8 ; THIS IS A GLOBAL SYMBOL
JRST QLIST7 ;[402] Not a global
QLST6B: TLNE T5,LGLOBL ;[402] Test for a global symbol
JRST QLIST8 ;[402] Yes, global
QLIST7: TYPE( )
SETZM QLPNT ;RESET FLAG
CLRFLG PNAMSV ;[402] Reset long name flag
POP P,T1 ;[402] Restore T1
JRST QLIST3 ; AND SEARCH THE NEXT SET OF SYMBOLS
QLIST8: type( )
openp
MOVE T5,SYM ;PREPARE TO -
PUSHJ P,SPT1 ; PRINT THE SYMBOL
type( IS GLOBAL)
closep
JRST QLIST7 ;LOOK FOR MORE - SHOULD BE NONE
; MODE CHANGE LOGIC
MODE: JUMPL T0,MODRET ;'MODE' ALONE - MEANS RESUME STANDARD SETTING
MODNXT: PUSHJ P,TTYIN ;GET AN ARGUMENT FROM USER
JUMPE T3,BADSYN
SETZI P1, ;NO - PREPARE FOR A MODE CHANGE
LDB T3,[POINT 6,T3,5] ;GET FIRST CHARACTER OF USERS ARGUMENT
CAIN T3,'F'
JRST [TRO P1,F.
JRST MODMOR]
CAIN T3,'D'
JRST [TRO P1,D.
JRST MODMOR]
CAIN T3,'I'
JRST [TRO P1,I.
JRST MODMOR]
CAIN T3,'O'
JRST [TRO P1,O.
JRST MODMOR]
CAIN T3,'R'
JRST [TRO P1,R.
JRST MODMOR]
CAIN T3,'X' ;[157]Complex?
JRST [TRO P1,X. ;[157]
JRST MODMOR]
CAIN T3,'C' ;[157]Character string?
JRST [TRO P1,C. ;[157],[164]
JRST MODMOR] ;[157]
CAIN T3,'L' ;[120]
JRST [TRO P1,L. ;[120]
JRST MODMOR] ;[120]
CAIE T3,'A'
JRST BADSYN
TRO P1,A.
MODMOR: SKIPL TERMK
JRST MODSET ;END OF USER LINE SET MODES
JUMPE T2,MODNXT ;SPACE IS A DELIMITER
CAIE T2,"," ;COMMA IS THE ONLY ARG SEPARATOR
JRST BADSYN
JRST MODNXT ;GET MORE ARGUMENTS
MODSET: MOVEM P1,MODFLG ;SAVE USERS DEFAULT TYPE OPTIONS
JRST RET ;END OF MODE CHANGE
SUBTTL SYMBOL TABLE LOGIC
; SYMBOL EVALUATION ROUTINE - EVALUATES THE SYMBOL IN SYM
EVAL: MOVSI T2,LOCAL ;YES, LOOK FOR OUTSIDE LOCALS
MOVEM T2,SYMASK ;[321] Set the bit mask
MOVEI T2,SYM ;CHECK SYM
PUSHJ P,TRUVAR ;LABEL OR STATEMENT #?
TROA T1,SYMLAB ;YES
TRZ T1,SYMLAB
TRNN T1,LNAME ;[402] Long Symbol?
JRST EVAL1A ;[402] No - Short
TRZE T1,FGLONL ;LOOKING FOR GLOBALS ONLY?
TRNE T1,SYMLAB ;AND THIS IS NOT A LABEL?
CAIA
JRST EVAL1B ;YES
PUSHJ P,FINDLL ;[402] Yes, look for local
SKIPA ;[402] FAIL
JRST EVAL2 ;[402] FOUND
MOVSI T2,LOCAL!LGLOBL ;[402] Look for outside locals
SKIPA ;[402]
EVAL1B: MOVSI T2,LGLOBL ;[402] Look for globals
MOVEM T2,SYMASK ;[402] Set the bit mask
PUSHJ P,FINDLG ;[402]
SKIPA ;[402] FAIL
JRST EVAL2 ;[402] FOUND
MOVSI T2,LOCAL ;YES, LOOK FOR OUTSIDE LOCALS
MOVEM T2,SYMASK ;[321] Set the bit mask
EVAL1A: TRZE T1,FGLONL ;LOOKING FOR GLOBALS ONLY?
TRNE T1,SYMLAB ;AND THIS IS NOT A LABEL?
CAIA
JRST EVAL1 ;YES
PUSHJ P,FINDL ;[321] Find local name
CAIA
JRST EVAL2 ; FOUND
TRNE T1,SYMLAB ;IS IT A LABEL?
POPJ P, ;YES - FAIL
EVAL0: PUSHJ P,FINDG ;[321] Find a global symbol
POPJ P, ; FAIL
EVAL2: MOVEM T2,SYMSAV ;[321] Always save pointer
MOVE P1,T2 ;
;[BL] WHAT GOOD IS THIS?????
MOVE P2,1(T2)
SKIPA T5,1(T2) ;GET VALUE OF SYMBOL
CPOPJ2: AOS (P) ;SKIP TWICE
CPOPJ1: AOS (P) ;FOUND SYMBOL, SKIP
;[326] TLZ T0,FGLSNM ;KILL FLAG
CPOPJ: POPJ P,
EVAL1: MOVSI T2,GLOBAL!DELO ;[141] GLOBALS ONLY(ALSO DELETED GLOBALS)
MOVEM T2,SYMASK ;[402]
JRST EVAL0 ;GO
; GET HISEG START ADDRESS IN (T2)
ife tops20,<
GSTAH: MOVE T2,[XWD -1,.GTSGN]
GETTAB T2, ; GET HISEG INDEX
HALT . ; *****
HRLZI T2, (T2) ; GET INDEX
HRRI T2,.GTUPM
GETTAB T2, ; GET HISEG START
HRLZI T2,400000 ;PRE-507 MONITOR - FUDGE VALUE
HLRZ T2,T2
POPJ P,> ;End of conditional
;[300] ROUTINE IS NOT NEEDED WHEN RUNNING EXTENDED
ifn tops20,<
gstah: skipn T2,.jbhso ;[123]get page of high segment
movei T2,400 ;[123]not set, guess 400
lsh T2,11 ;get address of high segment
popj p,> ;return,end of conditional
;THIS ROUTINE SETS UP IGNORE LISTS FOR SYMBOL TABLE LOOKUPS.
;[320] Rewritten
SETLST: SETZ P4, ;[327] Count
PUSHJ P,SYMADR ;[327] Get location of symbol table
JRST SETLS9 ;[327] If no table, go away
ADD T2,T4 ;Get to last entry, plus 1
SETLS2: SUBI T2,2 ;Back up to
MOVE P2,(T2) ; program name
HLRE T5,1(T2) ;Length of table segment for
MOVMS T5 ; this program
ADDI T2,2 ;Get to the first
SUB T2,T5 ; entry for this program
CAME P2,[SQUOZE 0,UDDT];Grab these programs
CAMN P2,[SQUOZE 0,FORDDT]
JRST SETLS3
CAME P2,[SQUOZE 0,JOBDAT]
JRST SETLS4 ;Not wanted
SETLS3: MOVEM T2,SYMLST(P4) ;Save location of first entry
MOVEM T5,SYMLSZ(P4) ;Save length of table segment
AOJ P4, ;Count it
SETLS4: SUB T4,T5 ;Reduce count of entries in table
JUMPG T4,SETLS2 ;Loop unless done
SETLS9: MOVEM P4,SYMCNT ;Number of segments to be ignored
POPJ P,
;Skip past any ignored table segments [321] Rewritten
FIXSYR: SKIPN S2,SYMCNT ;Get number of ignored programs
POPJ P, ;Return if none
FIXS1: CAMN T2,SYMLST-1(S2) ;One of the ignored programs?
JRST FIXS2 ;Yes
SOJG S2,FIXS1 ;No - Try next one
POPJ P, ;No more - Return
FIXS2: ADD T2,SYMLSZ-1(S2) ;Step to next program
SUB T4,SYMLSZ-1(S2) ;Reduce number of words to search
JRST FIXSYR ;Try again
SYMCNT: BLOCK 1 ;Count of programs being ignored
SYMLST: BLOCK 5 ;Indices to segment of programs being ignored
SYMLSZ: BLOCK 5 ;Sizes of those segments
;Find the main program. [315] New
; PUSHJ P,MAINF
; Return if not found
; Return if found, with T4 containing the program name
MAINF: TRZ T1,LNAME ;[402] Assume short program name
MOVE T5,[SQUOZE 0,MAIN.];Search for this global symbol
MOVEM T5,SYM
MOVSI T2,GLOBAL
MOVEM T2,SYMASK
PUSHJ P,FINDG
JRST CPOPJ ;Not found
MAINF1: ADDI T2,2 ;[321] Step to next entry
SUBI T4,2 ;[321] Any words left?
JUMPLE T4,CPOPJ ;[321] No - No program name
MOVE T5,(T2) ;[321] Is this a
TLNE T5,PNAME ;[321] program name?
JRST MAINF1 ;No--Keep looking
MOVE T4,T5 ;[321] Yes - This is the name
;[402] look for long program name after finding short program name
LOOKLP: TRZ T1,LNAME ;[402] Assume short program name
MOVEM T2,TEM12 ;[402] Yes - This is the name
MOVEM T4,TEM4 ;[402] Save T2,T4 for short name
;[402]open this symbol table
;[402] Set T4 to module length and T2 start of symbol table
HLRE T5,1(T2) ;[402]Length of module (negative)
MOVMM T5,T4 ;[402]Save positive size
ADD T2,T5 ;[402]Point to beginning of
ADDI T2,2 ;[402] symbols for
;[402] this module
MOVE T5,[SQUOZE 0,.SYMTB] ;[402] .SYMTB in RAD50
MOVEM T5,SYM ;[402]
PUSHJ P,FINDL1 ;[402] Search for local .SYMTB
JRST MAINF2 ;[402] No .symtb
MOVE T5,1(T5) ;[402] T5 = cnt+ptr
;[402] Program name (first entry)is at .SYMTB+1
MOVE T4,T5 ;[402] Copy of T5
TRO T1,LNAME ;[402] We have a long name
JRST CPOPJ1 ;[402] Success with long name
MAINF2: MOVE T4,TEM4 ;[402] Restore T4 = name
MOVE T2,TEM12 ;[402] Restore T2 = STE
JRST CPOPJ1 ;[402] Success with short name
;Find a program name in the symbol table [321] New
;Entry: SYM contains the program name
; PUSHJ P,FINDP
; Return if not found
; Return if found, with T2 pointing to the symbol entry
FINDP: PUSHJ P,SYMADR ;[327] Find the symbol table
POPJ P, ;[327] No table, so symbol not found
MOVEM T2,OJBSYM ;Remember the start
ADD T2,T4 ;Get to last entry
SUBI T2,2 ; of this table
FINDP2: MOVE T4,(T2) ;Is this the
CAMN T4,SYM ; program we want?
JRST CPOPJ1 ;Yes
HLRE T4,1(T2) ;No - Get length of module (negative)
JUMPGE T4,FINDP9 ;[327] If table zeroed, not in table
ADD T2,T4 ;Step to next program
CAML T2,OJBSYM ;Outside the table?
JRST FINDP2 ;No - Try this one
FINDP9: POPJ P, ;[327] Not in table
;Find a local long symbol name in the symbol table [402] New
;LSYMBF contains the entry to be found, SYM contains cnt+ptr to LSYMBF
; PUSHJ P,FINDLL
; Return if not found
; Return if found,
; with T2 pointing to the symbol entry
; and T5 containing symbol value
FINDLL: MOVE T5,SYM
MOVE T2,SSTAB ;ptr to symbol table
HRRZ T4,(T2) ;Number of symbols
AOJ T2, ;First entry
FINDL2: PUSHJ P,CMPSYM ;Compare entry at t2 with T5
SKIPA
JRST CPOPJ1 ;Successful return
SOJLE T4,CPOPJ ;Reduce count of unsearched words
;No more entries? = Failure
ADDI T2,2 ;Step to next entry
JRST FINDL2 ;Loop
; Compares names in OPENED and PNAMSV ![402] New
; PUSHJ P,CMPPO
; Return if not found
; Return if found
; This routine smashes T5 and T2
CMPPO:
TRZ T1,LNAME ;Clear long name flag
SYMSKE PNAMSV ;Long name in PNAMSV?
JRST CMPPOA ;Yes
SYMSKN OPENED ;Long name in OPENED?
JRST CMPPOC ;No - compare 2 short names
;PNAMSV is short and OPENED is long
XMOVEI T5,PNAMSV ;Input for R50six
PUSHJ P,R50SIX ;Convert PNAMSV radix 50 name in R5 to sixbit
MOVEM T5,PNAMSV
JRST CMPPOB
CMPPOA: ;Long name in PNAMSV!
SYMSKE OPENED ;Long name in OPENED?
JRST CMPPOB ; Yes - compare 2 long names
XMOVEI T5,OPENED ;Input for R50six
PUSHJ P,R50SIX ;Convert OPENED radix 50 name in R5 to sixbit
MOVEM T5,OPENED ;
CMPPOB: TRO T1,LNAME ;Yes - set long name flag
SETFLG OPENED
MOVE T5,PNAMSV ;WHAT WAS THE SECTION IN WHICH IT WAS FOUND
MOVEI T2,OPENED ;
PUSHJ P,CMPSYM ;DO WE ALREADY NOW ABOUT IT
JRST CPOPJ ;NO
JRST CPOPJ1 ;YES JUST EXIT
CMPPOC: MOVE T5,PNAMSV ;WHAT WAS THE SECTION IN WHICH IT WAS FOUND
CAME T5,OPENED ;DO WE ALREADY NOW ABOUT IT
JRST CPOPJ ;NO
JRST CPOPJ1 ;YES JUST EXIT
;[402] Compare symbol pointed to by ptr to cnt+ptr in T2 and cnt+ptr in T5
; PUSHJ P,CMPSYM
; Return if not found
; Return if found
CMPSYM: PUSH P,T2 ;Save T2,T3,T4,T5
PUSH P,T3
PUSH P,T4
PUSH P,T5
MOVE T2,(T2) ;Set T2 to point to the first word to compare
MOVE T4,T2
TLZ T4,LFLG ;clear flag bits
LSH T4,-CNTSFT ;Number of words to compare
MOVE T3,T5
TLZ T3,LFLG ;clear flag bits
LSH T3,-CNTSFT
CAME T3,T4 ;Are lengths of both words the same
JRST CRET ;No, so can't match
TLZ T5,770000 ;clear what is not part of 30bit addr
TLZ T2,770000 ;clear what is not part of 30bit addr
CLP: MOVE T3,(T5)
CAME T3,(T2) ;Compare
JRST CRET ;No match
AOJ T2,
SOSE ,T4 ;Found - No words left to compare
AOJA T5,CLP ;Loop to compare next word
POP P,T5 ;Restore T2,T3,T4,T5
POP P,T4
POP P,T3
POP P,T2
JRST CPOPJ1 ;Match
CRET: POP P,T5 ;Restore T2,T3,T4,T5
POP P,T4
POP P,T3
POP P,T2
JRST CPOPJ ;No match
;Find a local name in the symbol table [321] New
;Entry: SYM contains the program name
; PUSHJ P,FINDL
; Return if not found
; Return if found,
; with T2 pointing to the symbol entry
; and T5 containing symbol value
FINDL: SKIPE T2,OPENLS ;Any OPEN module?
SKIPN T4,OPENLZ ;Yes - Any symbols in that module?
POPJ P, ;No - Not found
FINDL1: MOVE T5,(T2) ;Next symbol
TLNN T5,PNAME ;Program name?
JRST FINDL5 ;Yes - Ignore it
TLZ T5,LOCAL ;Locals only
CAME T5,SYM ;One we want?
JRST FINDL8 ;No
MOVE T5,1(T2) ;Value of symbol
JRST CPOPJ1 ;Successful return
FINDL5: TRNE T1,TYPCMD ;Is this a TYPE command?
POPJ P, ;Yes - Failure
FINDL8: ADDI T2,2 ;Step to next entry
SUBI T4,2 ;Reduce count of unsearched words
JUMPG T4,FINDL1 ;Loop unless done
POPJ P, ;Failure
;Find a local or global name in the symbol table [402] New
;Entry: SYM contains the program name
; SYMASK contains either the LOCAL or LGLOBL or LPNAME bit
; LPNAME indicates we are looking for an entry name
; SYM contains ptr to name
; PUSHJ P,FINDLG
; Return if not found
; Return if found,
; with T2 pointing to the symbol entry
; and T5 containing the value
FINDLG: SETZ P1, ;P1 is zero if we haven't found anything yet
PUSHJ P,SYMADR ;Set T2 to table and T4 to tables size
POPJ P, ;No table
PUSH P,T3 ;Save T3
LGLP: PUSHJ P,FIXSYR ;if table size = 0 go to next table
JUMPLE T4,LG8 ; No more tables
MOVE T5,(T2) ;Get name of this entry
TLZ T5,LOCAL ;Locals only
CAME T5,[SQUOZE 0,.SYMTB] ; .SYMTB in RAD50
JRST LGINCR ;NOT .SYMTB
MOVEM T2,TMPSAV
MOVE T2,1(T2) ;VALUE OF .SYMTB = ptr to 2ndary symbol table
MOVE T5,SYM
MOVEM T4,TEM9 ;Number of words left
HRRZ T4,(T2) ;Number of symbols
AOJ T2, ;First entry
LGLPLP: MOVE T3,(T2) ;Get flg+cnt+ptr to name
TLNN T3,LOCAL ;Is this a local?
JRST GLBCHK ;No, its a global
MOVE T3,SYMASK ;
TLNE T3,LOCAL ;Did we want a local
JRST LGCHK ;Yes, check it
JRST LGNEXT ;No, go to next entry
GLBCHK: MOVE T3,SYMASK ;We wanted a global
TLNN T3,LGLOBL ;Was this a global?
SKIPA ;No, go to next entry
LGCHK: PUSHJ P,CMPSYM ;Compare entry at t2 with T5
SKIPA ;no match
JRST LG9 ;MATCH
LGNEXT: ADDI T2,2 ;Step to next entry
SOJG T4,LGLPLP ;Reduce count of unsearched words
;Loop unless done
MOVE T2,TMPSAV ;Failure - Restore T2 and T4
MOVE T4,TEM9 ;
;Go to next entry
LGINCR: ADDI T2,2 ;Increment to next table entry
SUBI T4,2 ;Decrement table size
JRST LGLP
LG8: MOVEM T4,TEM9 ;Number of words left
JUMPN P1,LG9 ;something found
POP P,T3 ;Restore T3
JRST CPOPJ
LG9: POP P,T3 ;Restore T3
MOVE T5,1(T2) ;Value of ste
MOVE T4,TEM9 ;Restore T4
JRST CPOPJ1
;Find a local or global name in the symbol table [321] New
;Entry: SYM contains the program name
; SYMASK contains either the LOCAL or GLOBAL bit
; PUSHJ P,FINDG
; Return if not found
; Return if found,
; with T2 pointing to the symbol entry
; and T5 containing the value
FINDG: SETZ P1,
PUSHJ P,SYMADR ;[327] Find symbol table
POPJ P, ;[327] No table, so symbol not found
FINDG2: PUSHJ P,FIXSYR ;Maybe skip this program
JUMPLE T4,FINDG8 ;If no more entries, quit
MOVE T5,(T2) ;Next symbol
TLNN T5,PNAME ;Program name?
JRST FINDG7 ;Yes - Ignore it
TDZ T5,SYMASK ;Clear legal bits
CAME T5,SYM ;Is it the one we want?
JRST FINDG7 ;No
MOVE T5,(T2) ;Get name again
TLNE T5,GLOBAL ;Is it a global?
JRST FINDG9 ;Yes - We win
JUMPN P1,FINDG3 ;Is this the first match?
MOVE P1,T2 ;Yes - Remember it
MOVEM T4,TEM9 ;Number of words left
MOVE T5,1(T2) ;The value
JRST FINDG7 ;Look some more
FINDG3: TRO T0,MDLCLF ;Multiply defined
TRNN T1,TYPCMD ;If not 'TYPE',
POPJ P, ; exit
CAME T5,1(T2) ;Same as before?
JRST FINDG7 ;No
TRO T1,COMDAT ;Yes - It is in COMMON
JRST FINDG9 ;Succesful exit
FINDG7: ADDI T2,2 ;Step to next entry
SUBI T4,2 ;Reduce the number of entries left
JUMPG T4,FINDG2 ;Loop unless done
FINDG8: JUMPE P1,CPOPJ ;Fail if nothing found
MOVE T2,P1 ;Where it was
MOVE T4,TEM9 ;Number of words that were left
FINDG9: MOVE T5,1(T2) ;Value of symbol
JRST CPOPJ1
;[327] Routine NEXTAB removed
SUBTTL ENTER AND LEAVE FORDDT LOGIC
; SAVE THE ACS AND PI SYSTEM
SAVEF: Z ;[300] EXTENDED FLAGS
SAVE: Z ;SAVE THE ACS AND PI SYSTEM
IFN TOPS20,<
SKIPE EXTEND ;[300] ARE WE NON-EXTENDED?
XSFM SAVEF ;[300] NO, SAVE EXTENDED FLAGS
>
SKIPN SARS
JRST SAV1
AOS SAVE
JRST SAV5
SAV1: MOVEM T0,SAVACS ;[325] SAVE AC 0
MOVE T0,[1,,SAVACS+1] ;[325] Now save
BLT T0,SAVACS+17 ;[325] ACs 1-17
MOVE T0,SAVACS ;[325] PUT T0 BACK JUST IN CASE...
IFN TOPS20,<
SKIPE EXTEND ;[300]
JRST SAV6 ;[333] not section 0
>
SAV5: MOVE T5, SAVE
HLLM T5, SAVPI
HRRZM T5, SAVE ;[333] clear left half of PC word
SAV6: MOVE T0,STKYFL ;INIT THE FLAG REGISTER
SETOM SARS ;FLAG PROTECTING SAVED REGISTERS
XJRSTF SAVEF ;[300] JUMP AND RESTORE FLAGS
; RESTORE ACS AND PI SYSTEM
RESTOR: IFN TOPS20,<
MOVEM T5,SAVE ;[300] STORE 30-BIT ADDR
SKIPN EXTEND ;[310] IF SECTION 0
> ;END IFN TOPS20
HRRZM T5,SAVE ;[310] MAKE SURE RH ADDR PART ONLY
IFN TOPS20,<
SKIPN T5,SAVEF ;[313] PICK UP EXTENDED FLAGS IF ANY
>
MOVE T5,SAVPI
TLZ T5,010037 ;DON'T TRY TO RESTORE USER MODE FLAG
HLLZM T5,SAVEF ;[300] FOR FLAG RESTORATION
HRLZI 17,SAVACS ;[325][326]
BLT 17,17 ;[325][326]
SETZM SARS
XJRSTF SAVEF ;[300]
; PAUSE LOGIC
BP0: 0 ;[145] USERS PC FROM FAKED JSR
JSA T5,BCOM ;[145] SAVE T5 AND GO TO BCOM
BP0INS: TRN ;[300] BREAKPOINT INSTRUCTION
BPNCR1=.-BP0 ;[300]
BP1: XLIST ;TABLE FOR ENTRY FROM BREAKPOINTS
REPEAT NBP,< 0 ;JSR TO HERE FOR A PAUSE
JSA T5, BCOM
0 ;HOLDS INSTRUCTION WHILE PAUSE IS IN PLACE
>
LIST
B1INS=BP1+2
BPN=.-BPNCR1 ;[300]
.SZCNT==0
SZEFIW: repeat nbp,<
EFIW BP1+.SZCNT ;[313] TABLE OF EFIW'S REF'D BY JSR
.SZCNT==.SZCNT+3
>
SZDIEB: BLOCK <NBP+1>*3 ;[313] DISPLACED INSTR EXECUTE BLOCK TABLE
SZALL==.-SZEFIW-1
DSPBLK: BLOCK 1 ;[313] LOCAL PTR TO DISPLACED INSTR BLOCK
EFIWAD: EXP SZEFIW ;[313] SEC 0, DEFAULT VALUES
DIEBAD: EXP SZDIEB ;[313]
SECDSP: BLOCK 1 ;[313] SECTION FLAG WORD FOR XBLT COPY
; CONDITIONAL LOGIC
TESTAB: XLIST
REPEAT NBP,< 0 ;NUMBER OF TEST
0 ;ADDRESS OF ARG1
0 ;ADDRESS OF ARG2
0 ;CONSTANT VALUE>
LIST
COMPAR: CAML T3,T4
CAMLE T3,T4
CAME T3,T4
CAMN T3,T4
CAMG T3,T4
CAMGE T3,T4
COND: 0
MOVEI T5,BCOM2B-BCOM2 ;[300]
ADDM T5,COND ;[300]
HRRZ T5,BCOM2E ;[313]
SUBI T5,B1ADR ;[313]
IDIVI T5,3
LSH T5,2
MOVE T2,TESTAB(T5)
MOVE T3,@TESTAB+1(T5)
MOVE T4,@TESTAB+2(T5)
XCT COMPAR(T2)
AOS COND
JRST @COND
BCOMAC: Z ;[300] SAVE T AT BP ENTRY
BCOM: Z
TLO T5,-1 ;[300] MAKE POP WORK OUTSIDE SECTION 0
POP T5,LEAV ;MOVE INSTRUCTION TO LEAV
XMOVEI T5,B1SKP-B1INS(T5) ;[313] GET 30-BIT ADDR
MOVEM T5,BCOM1E ;[313] STORE ADDRESS
AOS T5 ;[313] INCR FOR NEXT PTR
MOVEM T5,BCOM2E ;[313] STORE
AOS T5 ;[313] INCR FOR LAST PTR
MOVEM T5,BCOM3E ;[313] STORE
HLRZ T5,(T5) ;[313] GET GROUP # IF ANY
MOVEM T5,BCOMGP ;[300] STORE GROUP NUMBER
MOVE T5,BCOM3E ;[300] GET BACK ADDRESS
MOVE T5,BP1-B1CNT(T5) ;GET PC WORD
IFN TOPS20,<
SKIPN EXTEND ;[300] SKIP IF EXTENDED
>
HLLM T5,LEAV1 ;SAVE FLAGS FOR RESTORING
EXCH T5,BCOM ; ALSO SAVE PC WORD IN BCOM
JSR SAVE ;SAVE ACS
;ADDR MOD TO LOOK AT COND. INST.
BCOM3: SKIPE S2,@BCOM2E ;[313] CONDITIONAL BREAK?
JSR COND ;[300] YES, SEE IF CONDITION EXISTS
;ADDR MOD TO LOOK AT PROCEED COUNTER
BCOM2: HRRE S2,@BCOM3E ;[313] LOAD PROCEED COUNT
SOS S2 ;[300] DECR COUNT
HRRM S2,@BCOM3E ;[313] STORE IT FOR POSTERITY
SKIPG S2 ;[300] NOT 0, DON'T BREAK YET
BCOM2B: JRST BREAK ;[300] YOU DESERVE A BREAK TODAY!
SKIPE T5,BCOMGP ;[300] TYPING A GROUP?
JRST BCOM1 ;[300] YES, GO TYPE A GROUP
LDB T5,[POINT 9,LEAV,8] ;GET INSTRUCTION
CAIL T5,264 ;JSR
CAILE T5,266 ;JSA,JSP
TRNN T5,700 ;UUO
JRST PROC1 ;MUST BE INTERPRETED
CAIE T5,260 ;PUSHJ
CAIN T5,256 ;XCT
JRST PROC1 ;MUST BE INTERPRETED
PUSHJ P,SETDSP ;[313] SETUP DISPLACED INSTR BLOCK
XMOVEI S2,LEAV2 ;[313] GET LOC OF RETURN JUMP
MOVEM S2,LEAV1 ;[313] STORE IT FOR THE XJRSTF JUMP
JSP T5,RESTOR ;[313] RESTORE AC's
XJRSTF LEAVF ;[300] RESTORE FLAGS, ETC.
LEAVF: Z ;[300] EXTENDED FLAGS
LEAV1: Z ;[313] 30-BIT ADDR
LEAV2: JRST @DSPBLK ;[324] RETURN THRU THE DISPLACED INSTR BLOCK
BCOMGP: Z ;[300] HOLD GROUP TO TYPE
BCOM1E: Z ;[313] HOLD INDEX ADDRESS
BCOM2E: Z ;[313] HOLD CONDITION CHECKING ADDRESS
BCOM3E: Z ;[313] HOLD PROCEED COUNT
BCOM1: MOVE T5,SAVACS+T5 ;[147] RESTORE T5
PUSHJ P,LISTEN ;DID THE DOOR BELL RING?
JRST BREAK3 ;NO - THIS IS NOT A TRUE BREAK
CAIA ;YES - LETS STOP HERE
BREAK:
; JSR SAVE ;SAVE THE WORLD
TLO T0,AUTO ;SIGNAL THAT THIS WAS A TRUE BREAK
BREAK3: PUSHJ P,REMOVB ;REMOVE BREAKPOINTS
SETZM MATHSM ;CLEAR SPECIFIC SYMBOL LOOKUP FLAG
SETOM ESCAPE ;USER ENVIRONMENT PROTECTED ALLOW ESCAPES
PUSHJ P,TTYCLR ;FLUSH WAITING TTY CHARACTERS FOR INPUT
PUSHJ P,CHKIWI ;[211] OK TO CALL THE OTS?
TRNA ;[211] NO
PUSHJ P,FORBUF ;[145] LET FOROTS CLEAR ITS BUFFER
HRRZ T5,BCOM2E ;[313] GET ADR OF CONDITIONAL BREAK INST
SUBI T5,B1ADR-3 ;CHANGE TO ADDRESS OF $0B
IDIVI T5,3 ;QUOTIENT IS BREAK POINT NUMBER
HRRM T5,BREAK2 ;SAVE BREAK POINT #
;NOW DISPLAY BREAK INFORMATION
SETZI T1,
LINE
SKIPL BP0FLG ;[145] SKIP IF FORDDT WAS 'CALL'ED
JRST [TYPE (Pause at ) ;[145] ANNOUNCE BREAKPOINT
JRST BRKAT] ;[145] PROCEED
TYPE (Entering FORDDT from ) ;[145] SAY WHERE 'CALL'ED FROM
SKIPN T5,PAUFLG ;[331] PAUSE ON ERROR-- PAUSE ADDR IS IN PAUFLG
BRKAT: MOVE T5,BCOM ;[145]
HLLM T5, SAVPI ;SAVE PROCESSOR FLAGS
XMOVEI T5,-1(T5) ;[300] GET JUST THE 30-BIT ADDR MINUS 1
TRO T0,SILENT ;SILENCE
;[326] TLO T0,FGLSNM ;GLOBALS ARE OK
PUSHJ P,LOOK ;TYPE PC AT BREAK
JRST BP0E2 ;[145] NO NAME, PROBABLY ERROR
CAIA ;[145] OFFSET
JRST BPOK ;[145] FOUND AND TYPED
SKIPL BP0FLG ;[145] ERROR IF NOT FROM BREAKPOINT 0
JRST E2 ;[145]
MOVEM T5,TEM ;[145] REMEMBER NEAREST REFERENCE
PUSHJ P,SPT ;[145] TYPE SYMBOL
TYPE ( + ) ;[145]
MOVE T5,TEM ;[145] TYPE OFFSET
PUSHJ P,TYP4 ;[145] IN OCTAL
JRST BPSEC ;[145]
BPOK: TRNN T1,LNAME ;[402] All long symbols?
JRST BPOK1 ;[402] No
MOVE T5,(P1) ;[402]
TLNE T5,LGLOBL ;[402] Yes, is symbol global?
JRST LBRK6 ;[402] LONG GLOBAL
JRST BPOK2 ;[402] Not long symbol
BPOK1: MOVE T5,(T2) ;[145] GET SYMBOL
TLNE T5,GLOBAL ;GLOBAL?
JRST BREAK6 ;YES - THIS IMPLIES A ROUTINE
BPOK2: PUSHJ P,SPT1 ;NO, SO PRINT IT
BPSEC: TYPE( in ) ;[145]
LDSYM T5,PNAMSV ;[402]GET NAME OF SYMBOL'S SECTION
MOVEM T5,SYM ;SAVE IT
PUSHJ P,SPT1 ;AND TYPE IT
PUSHJ P,CMPPO ;[402] Compare PNAMSV and OPENED
JRST BREAK7 ;[402] NO MATCH
;[402] MATCH
BPSECA: SKIPGE BP0FLG ;[145] IF FROM BREAKPOINT 0,
JRST BP0RET ;[145] DONE
BREAK4: LINE
MOVE T5,@BCOM1E ;[313] LOAD ADDRESS
MOVEM T5,PROC0 ;[313] STORE IT
SKIPN T5,BCOMGP ;[300] TYPING A GROUP?
JRST BREAK1 ;[300] NO
MOVE P3,MODFLG ;REMEMBER TO SET UP THE PRINT FLAGS
HRLS P3 ;[323] IN BOTH HALVES
TLO T0,GRPFL!CFLIU!OFCFL ;WE WANT TO ALLOW GROUP LOGIC HERE
SETZM TERMK
PUSHJ P,SYM5 ;DISPLAY USERS GROUP IN 'TYPING' REQUEST
PUSHJ P,REINOP ;RE-OPEN PROG
TLZ T0,GRPFL!CFLIU!OFCFL ;REMOVE FLAG, IT MAY CAUSE TROUBLE
BREAK1: MOVSI T3,400000
BREAK2: ROT T3,.-. ;ROT BY # OF BREAK POINT
TLZE T0,AUTO ;DO WE HAVE A TRUE BREAK CONDITION?
ANDCAM T3,AUTOPI ;YES - END OF 'TYPING' LOGIC
TDNN T3,AUTOPI ;DONT PROCEED IF NOT AUTOMATIC
JRST BP0RT2 ;[211] DONT PROCEED
JRST PROCD1
BP0E2: SKIPN BP0FLG ;[145] IN BREAKPOINT 0?
JRST E2 ;[145] NO, ERROR
MOVEI T5,@BCOM ;[145] TYPE IT IN OCTAL
SUBI T2,1 ;[145]
PUSHJ P,TYP4 ;[145]
BP0RET: LINE ;[145]
MOVNS BP0FLG ;[145] MAKE IT POSITIVE NOW
BP0RT2: PUSHJ P,CHKIWI ;[211] RESTRICTED BREAKPOINT?
PUSHJ P,WRNIWI ;[211] YES, WARN THE USER
JRST RET ;[145] INITIALIZE SOME FLAGS ETC.
LBRK6: PUSH P,T1 ;[402] Save T1
TRO T1,LNAME ;[402] Long routine name
MOVE T5,(P1) ;[402] Get SYMBOL
JRST BRK6 ;[402]
BREAK6: PUSH P,T1 ;[402] Save long name flag
TRZ T1,LNAME ;[402] Short routine name
LDB T5,[POINT 32,0(P1),35] ;[201] GET SYMBOL
BRK6: MOVEM T2,SAVLOC ;NAME OR ROUTINE
TYPE (routine )
PUSHJ P,SPT1 ;[201] TYPE ROUTINE NAME
POP P,T1 ;[402] Restore T1
PUSHJ P,CHKIWI ;[211] CAN WE CALL THE OTS?
TRNA ;[211] NO, DON'T PRINT ARGS
PUSHJ P,GETARG ;DISPLAY ANY ARGS
SKIPGE BP0FLG ;[145] DONE IF FROM BREAKPOINT 0
JRST BP0RET ;[145]
LDSYM T5,PNAMSV ;[402]GET PROGRAM NAME
BREAK7: MOVEM T5,SYM ;SAVE IT
PUSHJ P,IMPOPN ;AND OPEN IT
SKIPGE BP0FLG ;[145] IF FROM BREAKPOINT 0,
JRST BP0RET ;[145] DONE
JRST BREAK4
; COME HERE IF PAUSE ON ERROR
PAUERR: POP P,BP0 ;[331] SAVE RETURN ADDRESS TO FOROTS
SETOM BP0FLG ;[331]
MOVE T5,@1(L) ;[332] SAVE ADDRESS OF ERROR IN USER PGM
AOJ T5, ;[331] INCR IT BECAUSE BCOM WILL DECR IT
MOVEM T5,PAUFLG ;[331]
JRST BP0+1 ;[331]
PROCED: MOVEI T5,1 ;SET UP FOR PROCEDE OF 1
HRRE T2,@BCOM3E ;[313] GET JUST THE PROCEED COUNT
SKIPG T2 ;[300] DO NOT CHANGE VALUE IF ALREADY SET
PROCDX: HRRM T5,@BCOM3E ;[313] STORE PROCEED COUNT
MOVE T2,BCOM1E ;[313] ADDR OF BREAK-POINT-TABLE ELEMENT
SETZM TEM ;DO NOT RE-INSERT 'CONDITIONAL' INFO.
MOVE T3,BCOMGP ;[300] LOAD GROUP #
JUMPE T3,.+2 ;SET THE AUTO PROCEDE FLAG
TLO T0,AUTO ;IF THIS IS A 'TYPING' REQUEST
PUSHJ P,AUTOP
PROCD1: LINE
TRNA ;[313] SKIP NEXT
PROC0: Z ;[313] GETS ADDR OF BREAKPOINT
XMOVEI T2,@[IFIW @PROC0] ;[313] GETS TO ADDR OF BREAKPOINT
SKIPE BP0FLG ;[145] PHANTOM BREAKPOINT?
JRST PROC00 ;[145] YES, DON'T WORRY ABOUT LEAV INSTRUCTION
;[145] EXCEPT THAT PROC0 MAY BE MODIFIED
PUSHJ P,FETCH
JRST BPLUP1 ; GET HERE ONLY IF MEMORY SHRANK
MOVEM T5,LEAV
PROC00: CLEARM BP0FLG ;[145] WON'T NEED THIS ANYMORE
CLEARM PAUFLG ;[331]
PUSHJ P,INSRTB
JRST PROC2
PROC1: MOVE T5,BCOM ;STORE FLAGS WHERE "RESTORE"
HLLM T5,SAVPI ; CAN FIND THEM
PROC2: MOVEI T4,100
MOVEM T4,TEM1 ;SETUP MAX LOOP COUNT
JRST IXCT5
IXCT4: SUBI T5,041 ;IS UUO "INIT"?
JUMPE T5,BPLUP
AOJGE T5,IXCT6 ;DONT PROCEDE FOR INIT
;DONT INTERPRET FOR SYSTEM UUOS
MOVEM T2,40 ;INTERPRET FOR NON-SYSTEM UUOS
MOVEI T2,41
IXCT: SOSL TEM1
PUSHJ P,FETCH
JRST BPLUP ;BREAKPOINT LOOPING OR FETCH FAILED
MOVEM T5,LEAV
IXCT5:; SETZM ESCAPE ;NO ESCAPES FROM FORDDT
LDB T5,[POINT 9,LEAV,8] ;GET INSTRUCTION
CAIN T5,254 ;DON'T DO ANYTHING TO JRST
JRST IXCT6
HLLZ T5,@BCOM1E ;[403] Get section number
IFN TOPS20,<
SKIPE EXTEND ;[403]
>
SKIPE T5 ;[403]
TRNA ;[403]
XMOVEI T5,. ;[403]
HLLZM T5,LEAVX ;[403] Store it
HRR T5,LEAV ;[403] Get E
HRRM T5,LEAVX ;[403] Store it
LDB T5,[POINT 5,LEAV,17] ;[403] PICK UP AC,I
DPB T5,[POINT 5,LEAVX,5] ;[403] Store it to complete EFIW
MOVE T5,LEAVX ;[403]
HRLZI 17,SAVACS ;[325][326] SETUP FOR BLT
BLT 17,17 ;[325][326] RESTORE ACS
XMOVEI T5,@LEAVX ;[300] NOW GET EFFECTIVE ADDRESS
MOVEM T5,LEAVX ;[300] STORE IN AN INTERMEDIATE
LDB P1,[POINT 4,LEAV,12] ;PICK UP AC FIELD
LDB T5,[POINT 9,LEAV,8] ;PICK UP INSTRUCTION FIELD
;[325] Removed SETPDL
CAIN T5,260
JRST IPUSHJ ;INTERPRET PUSHJ
CAIN T5,256
JRST [MOVE T2,LEAVX ;[300] GET INSTR POINTED AT
JRST IXCT] ;[300] AND THEN INTERPRET XCT
IXCT6: PUSHJ P,SETDSP ;[313] SETUP DISPLACED INSTRUCTION BLOCK
JSP T5,RESTOR
JRST @DSPBLK ;[313] GO TO THE DISPLACED INSTR BLOCK
LEAV: 0 ;INSTRUCTION MODIFIED
JRST @BCOM
AOS BCOM
JRST @BCOM
LEAVX: 0 ;[300] 30-BIT ADDRESS
BPLUP: PUSHJ P,REMOVB ;BREAKPOINT PROCEED ERROR
BPLUP1: JSR SAVE
JFCL
JRST ERR18
IPUSHJ: PUSHJ P,FNDDSP ;[313] GET DISPL INSTR BLOCK INFO
MOVEM T2,2(T3) ;[313] STORE ADDR OF LOC AFTER BREAKPOINT
HRRI T1,2(T3) ;[313] GET PTR TO ADDR
HLL T1,[PUSH] ;[313] HELP FORM PUSH INSTR
DPB P1,[POINT 4,T1,12] ;[313] STORE AC FIELD INTO A PUSH
MOVEM T1,(T3) ;[313] STORE IN DISPL INSTR BLOCK
HLL T2,[JRST] ;[313] MAKE THE JRST INSTR
HRR T2,LEAVX ;[313] GET ADDR
MOVEM T2,1(T3) ;[313] STORE THE JRST INSTRUCTION
JSP T5,RESTOR ;RESTORE THE MACHINE STATE
JRST @DSPBLK ;[313] JUMP TO THE DISPLACED INSTR BLOCK
IJSA: MOVE T5,BCOM ;INTERPRET JSA
HRL T5,LEAVX ;[300] GET 18-BIT ADDR (OK FOR SAME SECTION)
EXCH T5,SAVACS(P1) ;[147]
JRST IJSR2
IJSR: MOVE T5,BCOM ;INTERPRET JSR
IJSR2: XMOVEI T2,@LEAVX ;[300] GET 30-BIT EFFECTIVE ADDRESS
PUSHJ P,DEPMEM
JRST BPLUP ;ERROR, CAN'T STORE
AOSA T5,LEAVX ;[300] INCR THE EFFECTIVE ADDRESS
IJSR3: MOVE T5,LEAV
JRST RESTOR
IJSP: MOVE T4,BCOM ;INTERPRET JSP
JRST IJSR3
SETDSP: PUSHJ P,FNDDSP
HLLZ T4,[JRST] ;THE JRST INSTR
MOVEM T2,1(T3) ;STORE RET ADDR
HLLM T4,1(T3) ;PUT IN THE JRST INSTRUCTION
AOS T2
MOVEM T2,2(T3) ;STORE RET ADDR+1
HLLM T4,2(T3) ;PUT IN THE JRST INSTRUCTION
MOVE T2,LEAV ;GET INSTR
MOVEM T2,(T3) ;STORE INSTR
POPJ P,
;;;
; Sets up DSPBLK to point to beginning of displaced instruction block.
; T1/ Offset into B0ADR table, will point to 1st word in 3 word entry
; T2/ Original return address
; T3/ Displaced instruction block start address
FNDDSP: MOVEI T1,@BCOM1E ;THE TABLE INDEX TO CORRECT FOR
SUBI T1,B0ADR ;GET CORRECTED OFFSET
MOVE T2,BP0(T1) ;GET RET ADDR FROM ORIGINAL JSR
HRRZ T3,T1 ;PUT IN OFFSET
IFN TOPS20,<
SKIPN EXTEND ;SKIP IF EXTENDED
JRST FNDDS1 ;DO THE SEC-0 STUFF
HLL T3,T2 ;GET SECTION # OF ORIGINAL JSR
XMOVEI T3,ESDIEB(T3) ;GET THE ADDR OF START OF DISP INSTR BLK
TRNA
>
FNDDS1: MOVEI T3,SZDIEB(T3) ;GET ADDR OF START OF DISP INSTR BLK
MOVEM T3,DSPBLK ;STORE PTR TO START OF DISPATCH BLOCK
POPJ P,
; INSERT PAUSES REQUESTS
INSRTB: MOVEI T3,BP1 ;[300] GET ADDR OF BREAKPOINT
XMOVEI T4,@EFIWAD ;[313] EFIW TABLE
INSRT1: SKIPE T2,B1ADR-BP1(T3)
PUSHJ P,FETCH
JRST INSRT3
MOVEM T5,B1INS-BP1(T3)
IFN TOPS20,<
DMOVEM T1,TMPSAV
HLRZS T2 ;[313] GET THE SECTION NUMBER IN RH
JUMPE T2,INSRT2 ;[313] IF 0, THEN DON'T COPY
MOVEI T5,1B35 ;[313] LIGHT RIGHTMOST BIT
LSH T5,-1(T2) ;[313] POSITION IS SECTION #
TDNE T5,SECDSP ;[313] HAVE TABLES BEEN COPIED TO SEC?
JRST INSRT2 ;[313] YES, DON'T BOTHER
MOVEM T3,TMPSV1
MOVEI T1,SZALL ;[313] WORD COUNT
HRL T3,T2 ;[313] PUT SEC # BACK IN LH
HRRI T3,ESEFIW ;[313] START PLACING STUFF HERE
XMOVEI T2,SZEFIW ;[313] SOURCE ADDRESS
EXTEND 1,[XBLT T1] ;[313] TRANSFER THE STUFF
MOVE T3,TMPSV1
IORM T5,SECDSP ;[313] SET BIT SAYING WE COPIED
INSRT2: DMOVE T1,TMPSAV
>
MOVE T5,T4
HLL T5,[JSR @] ;[300] JSR TO BREAKPOINT
PUSHJ P,DEPMEM
JFCL ;HERE ONLY IF CAN'T WRITE IN HIGH SEG
INSRT3: ADDI T3,3
AOS T4 ;[313] INCR EFIW COUNT
CAIG T3,BPN ;[300] HAVE WE DONE ALL BREAK-POINTS?
JRST INSRT1
POPJ P,
;REMOVE PAUSE REQUESTS
REMOVB: MOVEI T3,BNADR
REMOV1: MOVE T5,B1INS-B1ADR(T3)
SKIPN T2,(T3) ;[300] THIS BP SET?
JRST RX ;[300] NO!
PUSHJ P,DEPMEM
JFCL ;HERE ONLY IF NO WRITE IN HIGH SEG
RX: SUBI T3,3 ;[300] NEXT BREAK POINT
CAIL T3,B1ADR ;[300] ALL BPS DONE?
JRST REMOV1 ;[300] NO, LOOP AND PROCESS THIS ONE
POPJ P, ;
; HERE TO SET PAUSE BREAKS
BPS: MOVE T5,[XWD B1ADR,B1ADR+1] ; CLEAR ALL PAUSES
CLEARM B1ADR
BLT T5,AUTOPI ;CLEAR OUT ALL PAUSES AND AUTO PROCEDE REGESTER
JRST RET
BPS1: PUSH P,T5 ;[300] SAVE THE ADDR
MOVE T2,T5 ;[313] COPY THE ADDRESS
PUSHJ P,FETCH ;CAN PAUSE BE INSERTED HERE?
JRST [POP P, ;[300] POP THE SAVED ITEM
JRST ERR19] ;[300] NO
PUSHJ P,DMEMER ; AGAIN NO
POP P,T5 ;[300] PUT THE PAUSE ADR BACK IN T5
SETZM SAVLOC ;STORES AVAILABLE PAUSE SLOT
MOVEI T2,B1ADR ;START OF PAUSE ARGUMENTS
BPS4: MOVE T4,@[IFIW (T2)] ;GET ADDRESS OF PAUSE IF ALREADY SET
CAMN T4,T5 ;[313] SEE IF ALREADY SET (FULL ADDR)
JRST BPS5 ;YES - USE THIS
SKIPN (T2) ;IS IT FREE?
MOVEM T2,SAVLOC ;[300] YES - REMEMBER WHERE
ADDI T2,3 ;LOOK AT NEXT
CAIG T2,BNADR ;[300] ALL EXAMINED?
JRST BPS4 ;NO GO ON IN CASE THIS ADDRESS USED ALREADY
SKIPN T2,SAVLOC ;WHERE THERE ANY FREE?
JRST ERR9 ;NO - UNLUCKY USER
BPS5: MOVEM T5,@[IFIW (T2)] ;[300] SET UP PAUSE ADDRESS
MOVE T5,TEM ;GET CONDITIONAL IF ANY L.H. = WHAT TO TYPE
MOVEM T5,@[IFIW 1(T2)];[300]
MOVE T5,TEM1 ;GET THE PROCEDE COUNT
MOVEM T5,@[IFIW 2(T2)];[300] PLACE WHERE IT DOES THE MOST GOOD
AUTOP: SUBI T2,B1ADR ;AUTO PROCEDE SETUP SUBROUTINE
IDIVI T2,3
MOVEI T3,1
LSH T3,(T2)
ANDCAM T3,AUTOPI
TLNE T0,AUTO ;DID USER ASK FOR AUTO PROCEDE?
IORM T3,AUTOPI ;YES - LET HIM HAVE IT
HRRZ T5,TEM ;DID USER ASK FOR A CONDITIONAL
JUMPE T5,CPOPJ ;NO - ALL DONE
LSH T2,2 ;FORM INDEX TO TEST TABLES
ADDI T2,TESTAB
MOVE T5,COND0
MOVEM T5,(T2) ;SAVE TEST NO.
MOVE T5,COND1
CAIN T5,COND3 ;SHOULD THIS BE A CONSTANT
XMOVEI T5,3(T2) ;[303] YES CORRECT IT
MOVEM T5,1(T2) ;SAVE ADDRESS OF FIRST ARG
MOVE T5,COND2
CAIN T5,COND3
XMOVEI T5,3(T2) ;[303] SAVE ADDRESS OF SECOND ARG
MOVEM T5,2(T2) ;SAVE ADDRESS OF SECOND ARG
MOVE T5,COND3 ;GET CONSTANT IF ANY
MOVEM T5,3(T2) ;AND SAVE
POPJ P,
SUBTTL MEMORY MANAGER SUBROUTINES
;DEPOSIT INTO MEMORY SUBROUTINE
DEPMEM: EXCH T2,T5 ;CHECK (T5)
PUSHJ P,CHKADR ;LEGAL ADDRESS?
POPJ P, ;NO - ILLEGAL
JRST DEP4 ;YES BUT IN HI SEGMENT
EXCH T2,T5
TRNN T2,777760
JRST DEPAC ;DEPOSIT IN AC
MOVEM T5,(T2)
JRST CPOPJ1 ;SKIP RETURN
DEPAC: MOVEM T5,SAVACS(T2) ;[147] DEPOSIT IN AC
JRST CPOPJ1 ;SKIP RETURN
ife tops20,<
DEP4: EXCH T2,T5
MOVEI S3,0
SETUWP S3, ;IS HI SEGMENT PROTECTED? TURN OFF
POPJ P, ;PROTECTED, NO SKIP RETURN
MOVEM T5,(T2) ;STORE WORD IN HI SEGMENT
TRNE S3,1 ;WAS WRITE PROTECT ON?
SETUWP S3, ;YES, TURN IT BACK ON
JFCL
JRST CPOPJ1> ;skip return, end of conditional
ifn tops20,<
dep4: exch T2,T5 ;restore T2 and T5
push p,T1 ;save regs for JSYS
push p,T2
lsh T2,-11 ;form page number from address
hrrzi T1,(T2) ;put into T1
hrli T1,.fhslf ;[300] get process handle into left half
rpacs% ;get access bits into T2
tlne T2,(pa%wt!pa%cpy) ;[300] can we write to this page?
jrst dep5 ;[300] yes, go do it
and T2,[pa%wt!pa%rd!pa%cpy!pa%ex]
;[300] clear out any unneeded bits
tlo T2,(pa%cpy) ;[300] get copy-on-write access for page
spacs%
dep5: pop p,T2 ;restore T2
pop p,T1 ;restore flags
movem T5,(T2) ;save away T5
jrst cpopj1> ;skip return,end of conditional
DMEMER: PUSHJ P,DEPMEM ;DEPOSIT AND GO TO ERR IF IT FAILS
JRST ERR19
POPJ P,
FETCH: EXCH T2,T5 ;CHECK (T5)
PUSHJ P,CHKADR ;LEGAL ADDRESS?
POPJ P, ;NO
JFCL ;HIGH OR LOW OK FOR FETCH
EXCH T2,T5
TRNN T2,777760 ;ACCUMULATOR?
SKIPA T5,SAVACS(T2) ;[147] YES
TRNA ;[300] NO, SKIP
JRST CPOPJ1 ;SKIP RETURN ONLY FOR LEGAL ADDRESS
IFN TOPS20,<
PUSH P,T2 ;[300] SAVE THE ADDRESS
SKIPN EXTEND ;[313]
TLZ T2,-1 ;[300] CLEAR ANY LH
>
MOVE T5,(T2) ;[300] GET CONTENTS
IFN TOPS20,<
POP P,T2 ;[300] RESTORE AS BEFORE
>
JRST CPOPJ1 ;[300] GIVE SKIP RETURN
SUBTTL BINARY TO SYMBOLIC CONVERSION
; PUSHJ P,LOOK ;AC T5 CONTAINS BINARY TO BE INTERPRETED
; RETURN 1 ;NOTHING AT ALL FOUND THAT'S USEFUL
; RETURN 2 ;SOMETHING FOUND, BUT NO EXACT MATCH
; ; OR MULTIPLY DEFINED IF OFFSET = 0 IN T5
; RETURN 3 ;EXACT MATCH FOUND AND PRINTED IF T2=0
; ;T2=SYMBOL VALUE IF SILENT FLAG ON
; ;T5 = SYMBOL VALUE BEING 'LOOKED' UP
; ;P1 = ADDRESS OF BEST SYMBOL SO FAR
; ;TRULST=LAST CHARACTER IF LABEL FOUND
LOOK: SETZM PNAMSV ;RESET PROGRAM NAME OF SYMBOL
TRZ T0,MDLCLF!ID ;[157]Clear flags
PUSHJ P,LOKSYM ;CHECK IT
POPJ P, ;NOTHING FOUND
JRST LOOK4 ;MULT. DEF. OR OFFSET
TRNN T1,LNAME ;[402] Long name?
MOVE T2,P1 ;No, PTR TO SYMBOL
MOVEM P1,LASYM ;[402]SAVE THIS SYMBOL
MOVE P2,1(P1) ;[402]GET VALUE
MOVEM P2,LASVAL ;SAVE
TRZE T0,SILENT ;[402]FOUND - SILENCE?
JRST LOK1 ;[402] Don't print
PUSHJ P,SPT ;NO - TYPE SYMBOL
LOK1: MOVE T4,TEM9 ;[321] Length of table left to search
MOVEM T1,TEM13 ;[402] Save T1
PUSHJ P,LOOKPG ;LOOKUP FOR PROGRAM NAME
JRST [MOVE T1,TEM13;[402] Restore it
JRST CPOPJ2] ;DOUBLE SKIP - SUCCESS
MOVE T1,TEM13 ;[402] Restore it
LOOK4: JUMPE T5,CPOPJ1 ;MULT DEF
MOVEM T2,LASYM ;UPDATE LAST SYMBOL
MOVE P2,1(T2) ;GET VALUE
ADDI P2,(T5) ;WITH OFFSET
MOVEM P2,LASVAL ;AS LAST VALUE
MOVE T2,SAVT2 ;[402]Restore T2 from LOK2
PUSHJ P,LOOKPG ;GET PROGRAM NAME
JRST CPOPJ1 ;2ND SKIP
RELOOK: MOVE T2,SAVT2 ;[402]RESET (T2)
MOVE T4,TEM9 ;[321] Reset the length of table
PUSH P,[CPOPJ] ;[314] Return
TRZ T0,ID ;ALLOW LOKSYM TO FIND IT
JRST LOK3 ;HERE WE GO AGAIN
;ROUTINE TO LOOKUP FOR PROGRAM NAME
LOOKPG: PUSH P,T1 ;[402] Save long name flag
PUSH P,T4 ;[321] Save these
PUSH P,T2 ;[321] registers
LOOKP2: ADDI T2,2 ;[321] Bump the location
SUBI T4,2 ;[321] Reduce the size
JUMPLE T4,LOOKP3 ;[321] End of table
MOVE P2,(T2) ;GET NEXT ENTRY
TLNE P2,PNAME ;PROGRAM NAME?
JRST LOOKP2 ;[321] No
PUSH P,T5 ;[402] Save T5
PUSHJ P,LOOKLP ;[402] Look for long program name
JFCL ;[402]
CLRFLG PNAMSV ;[402]
POP P,T5 ;[402] Restore T5
TRNN T1,LNAME ;[402] Did we get a Long Name?
JRST LOKP2A ;[402] NO
MOVE P2,T4 ;[402] Yes, T4 = CNT+PTR
SETFLG PNAMSV ;[402]
LOKP2A: MOVEM P2,PNAMSV ;YES - SAVE IT
LOOKP3: POP P,T2 ;[321] Restore the
POP P,T4 ;[321] registers
POP P,T1 ;[402] Restore long name flag
POPJ P, ;END ROUTINE
;[326] Search the symbol table for a value.
;[402] Modified for long symbols
;Calling sequence:
; MOVE T5,Value for which we search
; PUSHJ P,LOKSYM
; Return if not found
; Return if multi-def or offset
; Return if found
LOKSYM: HRLOI T2,377777 ;[321] Really big number for
MOVEM T2,BESTVA ;[321] false offset
SETZM LBESTV ;We haven't done a long symbol search yet
SETZ P1, ;[321] Nothing found yet
MOVEM T5,TEM8 ;[321] Value for which we search
TRNE T1,TYPCMD ;[314] TYPEing?
SKIPN T2,OPENLS ;[314] Yes - Is there an open module?
JRST LOKSM ;[314] No - Search all tables
MOVE T4,OPENLZ ;[321] Size of table
TRO T1,LNAME ;[402] Look for long symbols only
PUSHJ P,LOK2 ;[314] Search open module for long symbol
JRST LOKSY2 ;[314] Not found - Search for short symbol
JRST CPOPJ1 ;[314] Offset or multiple definition
JRST CPOPJ2 ;[314] Found
LOKSY2: MOVE T2,OPENLS ;
MOVE T4,OPENLZ ; Size of table
TRZ T1,LNAME ; Look for short symbols only
PUSHJ P,LOK2 ; Search open module
JRST LOKSM ; Not found - Search all tables
JRST CPOPJ1 ; Offset or multiple definition
JRST CPOPJ2 ; Found
;Search all symbol tables [321] Rewritten
LOKSM: TRO T1,LNAME ; set flag to look for long symbols
PUSHJ P,SYMADR ;[327] Find symbol table
JRST CPOPJ ;[327] No table, so symbol not found
MOVE T5,TEM8 ;Value for which we search
PUSHJ P,LOK2 ;Search that table
JRST LOKSMS ; Not there
CAIA ;Multi-def or offset
JRST CPOPJ2 ;Found
;SAVE VALUES FROM LONG SYMBOL SEARCH
MOVE T5,BESTVA
MOVEM T5,LBESTV
MOVE T5,TEM9
MOVEM T5,LSAVT4
MOVE T5,SAVT2
MOVEM T5,LSAVT2
MOVEM P1,LSAVP1
HRLOI T2,377777 ;Really big number for
MOVEM T2,BESTVA ; false offset
LOKSMS: TRZ T1,LNAME ; clear flag to look for short symbols
PUSHJ P,SYMADR ;[327] Find symbol table
JRST CPOPJ ;[327] No table, so symbol not found
MOVE T5,TEM8 ;Value for which we search
PUSHJ P,LOK2 ;Search that table
JRST CPOPJ ;[327] Not there
CAIA ;Multi-def or offset
JRST CPOPJ2 ;Found
SKIPN LBESTV ;Did we find anything in long symbol search
JRST LOKSM1 ;No
MOVE T5,BESTVA ;Was best short symbol value better than
CAMGE T5,LBESTV ; best long symbol value?
JRST LOKSM1 ;Yes
;long symbol search was better so restore
MOVE T5,LBESTV ;things to the way they were before the
MOVEM T5,BESTVA ;short symbol search
MOVE T5,LSAVT4
MOVEM T5,TEM9
MOVE T5,LSAVT2
MOVEM T5,SAVT2
MOVE P1,LSAVP1
LOKSM1: JUMPE T5,CPOPJ1 ;[327]Multi-defined
LOKSM2: JUMPE P1,CPOPJ ;Nothing found
MOVE T2,P1 ;Best one found
MOVE T4,TEM9 ;Number of unsearched words
MOVE T5,BESTVA ;Best offset
JRST CPOPJ1 ;Return to call+2
;Search one module
; MOVE T2,Pointer into symbol table
; MOVE T4,Number of words to be searched
; MOVE T5,Value for which we search
; PUSHJ P,LOK2
; Return if not found
; Return if multi-def or offset
; Return if exact match
LOK2: PUSHJ P,FIXSYR ;FIX SYM TBL PTR IN (T2)
JUMPLE T4,LOK16 ;[321] If end of table, not found
TRNN T1,LNAME ;[402] Looking for long symbols
JRST NONST ;[402] No - skip long symbol code
; LOOK FOR LONG SYMBOL
MOVEM P1,TEM14 ;[402] SAVE P1
MOVEM T3,TEM3 ;[402]
MOVE T3,(T2) ;[402]
TLZ T3,LOCAL ;[402]Locals only
CAME T3,[SQUOZE 0,.SYMTB] ;[402] .SYMTB in RAD50
JRST LOK3 ;[402] NOT .SYMTB so skip to next entry
MOVE P1,1(T2) ;[402]ptr to secondary symbol table
PUSH P,T4 ;[402] save T4
HRRZ T4,(P1) ;[402]Number of symbols
AOJ P1, ;[402]First entry
LOKLLP: CAMN T5,1(P1) ;[402]
JRST LOK2B ;[402]Match
MOVE P2,1(P1) ;[402]OK - GET VALUE
MOVE S2,T5 ;[402]VALUE WE'RE LOOKING FOR
XOR T5,P2 ;[402]SAME AS SIGN FOR SYMBOL?
JUMPGE T5,LOKSN ;[402]YES. EASY CASE
TXC S2,1B0 ;[402]NO. MAKE SIGNS THE SAME
SUB S2,P2 ;[402]SUBTRACT IS SAFE NOW
TXCA S2,1B0 ;[402]FIX UP SIGN AGAIN
LOKSN: SUB S2,P2 ;[402]GET OFFSET
XOR T5,P2 ;[402]EITHER WAY, RESTORE T5
JUMPL S2,LOK2F ;[402]Ignore if wrong direction
CAML S2,BESTVA ;[402]NO, BUT BETTER VALUE?
JRST LOK2F ;[402]NO
;Better value than before
PUSHJ P,TRLVAR ;[402]VARIABLE ?
JRST [MOVE P2,TRUFST;[402]
CAIN P2,27 ;[402]"M" LABEL?
JRST LOK2F ;[402]YES IGNORE
JRST .+1] ;[402]
PUSH P,T2 ;[402]SAVE T2 AND T5
PUSH P,T5 ;[402]
SKIPN T5,MATHSM ;[402]SPECIFIC SYMBOL??
JRST LOK4BL ;[402]NO
MOVE T2,P1 ;[402]PTR TO CNT+PTR TO SYMBOL
PUSHJ P,CMPSYM ;[402]COMPARE SYMBOLS pointed to by (T2),T5
SKIPA ;[402]IS IT THE ONE WE ARE LOOKING FOR
JRST LOK4BL ;[402]YES
POP P,T5 ;[402]NO -RESTORE T2 and T5
POP P,T2 ;[402]
JRST LOK2F ;[402]IGNORE
LOK4BL: POP P,T5 ;[402]RESTORE T2 and T5
POP P,T2 ;[402]
LOK4AL: MOVEM S2,BESTVA ;[402]BETTER MATCH
MOVEM P1,TEM14 ;[402]Save pointer into table
MOVEM T2,SAVT2 ;[402]Save T2
MOVE T3,(P) ;[402]item on stack = T4
MOVEM T3,TEM9 ;[402]Save length of table
LOK2F: SOJ T4, ;[402]Reduce count of unsearched words
ADDI P1,2 ;[402]Step to next entry
JUMPG T4,LOKLLP ;[402]Loop unless done
JRST LOK2D ;[402]Failure
LOK2B: POP P,T4 ;[402]Restore T4
MOVE T5,(P1) ;[402]
JRST LOK5A ;[402]MATCH
LOK2D: POP P,T4 ;[402] Restore T4
LOK2C: MOVE P1,TEM14 ;[402] Restore P1
MOVE T3,TEM3 ;[402] Restore T3
JRST LOK3 ;[402]Loop to get next secondary symbol table
; LOOK FOR SHORT SYMBOL
NONST: MOVE P2,(T2) ;GET NEXT SYM
TLNE P2,PNAME ;[326] Program name?
TLNE P2,PNAME-<LOCAL!GLOBAL> ;[326] Anything except local/global?
JRST LOK3 ;[326] Yes--Ignore it
MOVE P2,1(T2) ;OK - GET VALUE
MOVE S2,T5 ;[135] VALUE WE'RE LOOKING FOR
;IN ORDER TO PREVENT FORDDT FROM GETTING A FIXED-POINT OVERFLOW
;HERE, WE DO THE SIGN-BIT MAGIC TRICK. IF THE SIGNS OF THE 2 VALUES
;ARE DIFFERENT, WE JUST FLIP THE SIGN BIT OF ONE OF THEM, DO THE
;SUBTRACT, AND FLIP IT AGAIN. WE DON'T CARE ABOUT THE OVERFLOW
;CONDITION, SO IT IS JUST LOST TO POSTERITY.
;THIS PATCH COMPLIMENTS OF PHIL ALMQUIST, CARNEGIE-MELLON UNIV.
XOR T5,P2 ;SAME AS SIGN FOR SYMBOL?
JUMPGE T5,LOKSSN ;YES. EASY CASE
TXC S2,1B0 ;NO. MAKE SIGNS THE SAME
SUB S2,P2 ;SUBTRACT IS SAFE NOW
TXCA S2,1B0 ;FIX UP SIGN AGAIN
LOKSSN: SUB S2,P2 ;[135] GET OFFSET
XOR T5,P2 ;EITHER WAY, RESTORE T5
JUMPL S2,LOK3 ;[314] Ignore if wrong direction
JUMPE S2,LOK5 ;EXACT MATCH?
CAMGE S2,BESTVA ;NO, BUT BETTER VALUE?
JRST LOK4 ;YES
LOK3: ADDI T2,2 ;[321] Step to next entry
SUBI T4,2 ;[321] Reduce number of words left
JUMPG T4,LOK2 ;[321] Loop unless done
JRST LOK16 ;[171] Finish up
;Better value than before
LOK4: PUSHJ P,TRUVAR ;VARIABLE ?
JRST [MOVE P2,TRUFST
CAIN P2,27 ;"M" LABEL?
JRST LOK3 ;YES IGNORE
JRST .+1]
SKIPN P2,MATHSM ;SPECIFIC SYMBOL??
JRST LOK4A ;NO
PUSH P,P1 ;SAVE P1
MOVE P1,(T2) ;GET SYMBOL
TLZ P1,PNAME ;FIX UP A BIT
CAMN P1,P2 ;IS IT THE ONE WE ARE LOOKING FOR
JRST LOK4B ;YES
LOK4C: POP P,P1 ;NO -RESTORE
JRST LOK3 ;IGNORE
LOK4B: POP P,P1 ;
LOK4A: MOVEM S2,BESTVA ;BETTER MATCH
MOVE P1,T2 ;[321] Save pointer into table
MOVEM T2,SAVT2 ;[402]Save T2
MOVEM T4,TEM9 ;[321] Save length of table
JRST LOK3 ;KEEP GOING
;Exact match
LOK5: PUSHJ P,TRUVAR ;F10 SYMBOL?
JRST [TRNE T0,ID ;NO - LABEL - MATCH ALREADY?
JRST LOK12 ; YES - CHECK HIERARCHY
JRST LOK14] ; NO - TAKE IT
SKIPN P2,MATHSM ;ACCEPT ONLY THIS SYMBOL IF SET
JRST LOK7
;Looking for a specific symbol
PUSH P,P1 ;SAVE P1
MOVE P1,(T2) ;GET SYMBOL
TLZ P1,PNAME
CAME P1,P2
JRST LOK4C ;IGNORE IT IF NOT THE SAME
POP P,P1 ;REMOVE POP
MOVE P1,T2
LOK5A: MOVEM T4,TEM9 ;[321] Save size
MOVE P2,(T2) ;LETS TAKE IT AND RUN
TLNE P2,GLOBAL ;GLOBAL?
JRST LOK11 ;YES DONE
JRST CPOPJ2 ;ALSO DONE
;Looking for any symbol
LOK7: TRON T0,ID ;First time?
JRST LOK9 ;Yes--Fix it up
TRO T0,MDLCLF ;SECOND SYM FOUND - MULT. DEF.
MOVE P2,(T2) ;GET SECOND SYMBOL FOUND
TLNN P2,GLOBAL ;SEE IF IT IS A GLOBAL
JRST LOK8A ;OTHER LOCAL - GO SEE IF EQUIVALENT DEFINITION
MOVE P1,T2 ;GLOBAL HAS HIGHER PRIORITY
MOVEM T4,TEM9 ;[321] Save length of table
JRST LOK11 ;DONE
LOK8A: JUMPN S2,CPOPJ1 ;NOT EXACT MATCH
MOVE T5,(P1) ;GET PREVIOUS FOUND
TLZ T5,PNAME ;JUST RADIX-50 NAME
TLZ P2,PNAME ;ALSO FOR NEW FOUND
CAME P2,T5 ;SAME NAME
JRST CPOPJ1 ;NO
JRST LOK11 ;YES - MAY BE COMMON BECAUSE
; SAME NAME + SAME ADDRESS
;First match for this value
LOK9: MOVE P1,T2 ;UPDATE PTR
MOVEM T4,TEM9 ;[321] Save length of table
MOVE P2,(T2) ;GET SYM
TLNE P2,GLOBAL ;GLOBAL?
JRST LOK11 ;YES - DONE
SETZM BESTVA ;BEST MATCH
JRST LOK3 ;AND ON
LOK11: MOVE T5,1(P1) ;[314] The value
JRST CPOPJ2 ;[314] Return
;It is label
LOK12: MOVE P2,LOKFST ;GET THE (LAST) CHAR
EXCH P2,TRUFST ;KEEP TRUFST UPDATED
CAIE P2,27 ;"M"?
CAMG P2,TRUFST ;DOES THIS HAVE HIGHER PRIORITY?
JRST LOK3 ;NO - IGNORE IT
TRZ T0,ID ;YES - USE IT
JRST LOK7 ;
LOK14: MOVE P2,TRUFST ;GET THE LABEL TYPE
CAIN P2,27 ;"M" ?
JRST LOK3 ;YES IGNORE
MOVEM P2,LOKFST ;SAVE IT
JRST LOK7 ;AND USE THIS SYMBOL
;[171] Restart search from beginning
;[314] Done
LOK16: JUMPE P1,CPOPJ ;[104] FAIL IF NONE FOUND
CAMN T5,1(P1) ;EXACT MATCH?
JRST CPOPJ2 ;YES - SUCCEED
MOVE P2,1(P1) ;NO, SO GET BEST VALUE
SUB T5,P2 ;GET OFFSET
JRST CPOPJ1 ;EXIT FOR OFFSET
;Locate the symbol table [327] New
;Calling sequence:
; PUSHJ P,SYMADR
; Return if no table
; Normal return with T2 pointing to table, T4 containing size
SYMADR: PUSH P,T1 ;%SVCNV expects input here
MOVE T1,.JBSYM ;IOWD, global address or zero
PUSHJ P,%SVCNV## ;Use routine in FORLIB
MOVE T4,T2 ;Size of table
MOVE T2,T1 ;Global address of table
POP P,T1 ;Restore this
SKIPE T4 ;Anything found?
AOS (P) ;Yes--Return to call+2
POPJ P,
; ROUTINES TO TYPE A SYMBOL IN THE NON OPEN SECTION
SYMBOL: PUSHJ P,SAV2AC ;SAVE T5,P1
TRNE T0,MDLCLF ;SYMBOL ALREADY TYPED
JRST SYMBL2 ;DISPLAY ALTERNATE NAME
SYMBL3: MOVE T5,(T2) ;GET THE OUTPUT STRING
PJRST SPT1 ;TYPE IT AND RESTORE T5,P1
SYMBL2: LINE
TYPE( equivalent to )
JRST SYMBL3 ;NOW TYPE NAME
; TYPE THE SECTION NAME (ADDRESS OF NAME IS IN T2 )
SECTON: PUSHJ P,SAV2AC ;SAVE T5,P1
SKIPE T5,(T2) ;[202] ANY SECTION NAME?
CAMN T5,SECSAV ;ALREADY TYPED?
POPJ P, ;[202] YES - MUST BE A RANGE, OR NO NAME
MOVEM T5,SECSAV ;SAVE THE NEW ONE BEING TYPED
TRNE T1,COMDAT ;[171] Field in COMMON?
JRST SECT1 ;[171] YES, special typeout
TYPE( in )
JRST SYMBL3 ;NOW TYPE NAME
SECT1: TYPE( in (COMMON)) ;[171] Let user know it's in COMMON
POPJ P, ;[171] DONE
; PRESERVE REGISTERS T5 AND P1
SAV2AC: EXCH T5,(P) ;SAVE T5, AND GET RETURN
MOVEM T5,TRULST ;SAVE AS ESCAPE
MOVE T5,(P) ;RESTORE T5
PUSH P,P1 ;SAVE P1
XMOVEI P1,SAVRET ;[300] INTERCEPT FOR FINAL POPJ
PUSH P,P1 ;SAVE FOR RETURN
MOVE P1,-1(P) ;REINSTATE P1
JRST @TRULST ;PSEUDO POPJ BACK TO USER
SAVRET: POP P,P1 ;RESTORE OLD P1
POP P,T5 ;RESTORE OLD T5
POPJ P, ;FINALLY DO THE USERS POPJ
SUBTTL OUTPUT ROUTINES
;OFFSET TYPES THE SYMBOL WHOSE VALUE IS IN AC T5. SUBSCRIPTS ARE
;HANDLED. THERE IS A SKIP RETURN ON SUCCESS, FAIL IF SYMBOL NOT FOUND.
OFFSET: SKIPN T5,T5 ;[167]Are we looking for a real symbol?
POPJ P, ;[167]NO
MOVEM T5,TEM5 ;[167]Save current symbol value
EXCH T5,SAVLOC ;[202] UPDATE SAVLOC
MOVEM T5,TEM6 ;[202] BUT SAVE OLD VALUE
LDSYM T5,MATHSM ;[402] Get symbol
MOVEM T5,TEM7 ;[223] IN CASE A FORMAL
TRNE P3,C. ;[170]Character?
JRST CHARAY ;[167]YES, different processing
TRNE T0,FORMAL ;[223] FORMAL FLAG ON?
PUSHJ P,OFFFRM ;[223] YES, MAYBE TELL IT'S FORMAL
OFFS2: PUSHJ P,RAYNAM ;[223][167]Does symbol denote array?
JRST OFF1 ;[202][167]Doesn't look that way
;[223] HERE WHEN WE KNOW THE SYMBOL DENOTES AN ARRAY
OFF0: MOVE T5,TEM5 ;[202] GET VALUE OF SYM
TRO T0,SILENT ;SILENCE
SETZM TEM7 ;[223] CLEAR OFFSET SAVE
PUSHJ P,LOOK ;GET SYM PTR
JRST E5 ;
MOVEM T5,TEM7 ;[223] SAVE OFFSET
TRNN T1,LNAME ;[402] Short name?
MOVE P1,T2 ;Yes, GET PTR
MOVE P2,TEM7 ;[223] GET OFFSET
JRST OFF2 ;[202] GO PRINT
;[223]HERE WHEN WE SUSPECT THE SYMBOL IS NOT AN ARRAY OR IS NOT THE BASE
;[223]ADDRESS OF AN ARRAY. NOTE THAT WE CAN GET HERE FOR THE 2ND-NTH SUBSCRIPT
;[223]ON A RANGE TYPEOUT, SINCE THE SYMBOL PASSED TO OFFSET IN THIS CASE IS NOT
;[223]AN "EXACT MATCH." WE CAN ALSO GET HERE FOR MULTIPLY-DEFINED SYMBOLS AND
;[223]SCALARS.
OFF1: MOVE T5,TEM6 ;[202][167]Restore input symbol[SAVLOC]
JUMPE T5,OFF1A ;[202] SAVLOC NOT AVAILABLE
MOVEM T5,SAVLOC ;[202][167]Put it back
PUSHJ P,RAYNAM ;[167]Now see if IT'S an array
;[202]
JRST OFF1A ;NOT AN ARRAY KNOWN
TRNN T0,FORMAL ;[223] FORMAL NOW?
JRST OFF7 ;[202] NO
PUSHJ P,OFFFRM ;[223] YES, TELL (UNLESS ALREADY TOLD),
JRST OFFS2 ;[223] AND TRY AGAIN
CHARAY: PUSHJ P,RAYNAM ;[167]Is it an array?
JRST SCLCHR ;[167]NO
OFFCHR: MOVE P1,CRYSYM ;[157]Load addr/RAD50 name
MOVE P2,CLMOFF ;[157]Load element offset
JRST OFF2 ;[157]Go compute indices
SCLCHR: MOVE P1,CRYSYM ;[160]
PUSHJ P,SPT ;[160]
JRST OFF5A ;[160]
OFF7: MOVE T5,TEM5 ;[110] RESTORE T5
TRO T0,SILENT ;WE DONT WANT TO TYPE THE SYMBOL
PUSHJ P,LOOK ;NOT ARRAY START
POPJ P, ;[110] NOT FOUND
MOVE P2,T5 ;OFFSET - GET IT
JRST OFF2 ;FOUND - GO PRINT
OFF1A: MOVE T5,TEM5 ;TRY TO FIND THE REQUESTED SYMBOL
TRO T0,SILENT ;DONT PRINT NOW
PUSHJ P,LOOK
POPJ P, ;[110] NOT FOUND
SKIPA P2,T5 ;MAY BE AN ARRAY
JRST [TRNN T1,LNAME;[402] Long name?
MOVE P1,T2 ;No, WAS A SINGLE VAR - FOUND
PUSHJ P,SPT ;TYPE NAME
JRST OFF5A] ;TYPE LOC IF NOT CURRENT
MOVEM T2,TEM6 ;KEEP SYMBOL NAME FOUND
MOVEM P2,TEM ;KEEP OFFSET
MOVE T5,TEM5 ;GET BACK ORIGINAL ADDR
SUB T5,P2 ;MINUS OFFSET SHOUD BE ARRAY START
MOVEM T5,SAVLOC ;MAY BE IT IS
PUSHJ P,RAYNAM ;TRY IT
JRST ERR34 ;NOT
MOVE P1,TEM6 ;GET BACK SYMBOL NAME
MOVE P2,TEM ;AND OFFSET
;[223] HERE TO TYPE OUT SUBSCRIPT INFORMATION FOR A SYMBOL WE ARE
;[223] CERTAIN IS AN ARRAY.
OFF2: MOVEM P2,TEM ;SAVE OFFSET
LDFLG MATHSM ;[402] If long name then set long name flag
PUSHJ P,SPT ;PRINT SYMBOL
openp
PUSH P,SAVLOC ;SAVE SAVLOC AROUND OFFSET PRINT
PUSH P,P4 ;AR TOO
MOVEM P,DIMTOT ;AND FREEZE PD LIST
SETZM PUTTER
SETZM COUNT ;PREPARE
MOVE P1,TEM
TRZE T0,DOUBLE ;[112] DOUBLE WORD ARRAY?
LSH P1,-1 ;YES - ONLY HALF OFFSET
MOVEM P1,TEM7 ;SAVE P1
MOVEI T5,1
MOVEM T5,RP ;SET UP RANGE PRODUCT
OFF3: PUSHJ P,GETDIM ;GET DIMENSIONS TEM,TEM1
PUSH P,TEM ;SAVE LOWER VALUE
PUSH P,RP ;SAVE CURRENT RANGE PRODUCT
MOVE T5,TEM1
SUB T5,TEM
AOJ T5, ;FORM RANGE FOR THIS DIM
IMULM T5,RP
AOS COUNT ;INC COUNT OF # OF DIMS
PUSHJ P,MORDIM ;MORE?
CAIA
JRST OFF3 ;YES
MOVE P4,COUNT ;NO
MOVE T4,P ;COPY PD LIST
MOVE P1,TEM7 ;RESTORE P1
OFF4: POP T4,T3 ;GET LAST RP
POP T4,T5 ;LOWER SUBSCRIPT
IDIV P1,T3 ;VALUE OF FIRST ELEMENT
ADD P1,T5 ;[321] CORRECT FOR USERS OFFSET
MOVEM P1,1(T4) ;[321] SAVE FOR PRINTING
EXCH P1,P2 ;GET OFFSET REMAINDER
SOJG P4,OFF4
SKIPA P4,COUNT ;RESET DIM CNT
OFF5: jrst [stype(</,/>)
jrst .+1]
MOVE T5,1(T4) ;[321] FIRST ELEMENT
PUSHJ P,TYP0 ;TYPE IT DECIMAL
ADDI T4,2 ;NEXT ELEMENT
SOJG P4,OFF5
closep
MOVE P,DIMTOT ;RESET PD LIST
POP P,P4
POP P,SAVLOC ;RESTORE
OFF5A: SKIPN SSLOW ;[401] Do we have a substring?
JRST OFF6 ;[401] No
openp ;[401] type "("
PUSH P,T5 ;[401] save it
MOVE T5,SSLOW ;[401] T5 = lower bound
PUSHJ P,TYP0 ;[401] type decimal number in T5
TYPE(:) ;[401] type ":"
MOVE T5,SSUP ;[401] T5 = upper bound
PUSHJ P,TYP0 ;[401] type decimal number in T5
POP P,T5 ;[401] restore it
closep ;[401] type ")"
OFF6: PUSHJ P,CMPPO ;[402] Compare PNAMSV and OPENED
SKIPA ;[402] NO MATCH
JRST CPOPJ1 ;[402] MATCH
MOVEI T2,PNAMSV
PUSHJ P,SECTON ;NO - TYPE IT IF APPROPRIATE
;[202]
JRST CPOPJ1
;[223]ROUTINE TO TELL USER IT'S A FORMAL. RETURNS IMMEDIATELY IF WE
;[223]HAVE ALREADY TOLD THIS. OTHERWISE PRINTS THE FORMAL NAME AND REVERTS
;[223]PROCESSING TO THE ACTUAL PASSED PARAMETER (I.E. WE FORGET IT'S A FORMAL).
OFFFRM: SKIPE MATHSM ;[223] ANY SYMBOL?
SKIPN FRMSAV ;[223] OR FORMAL?
POPJ P, ;[223] NO, RETURN NOW
TYPE (Formal parameter ) ;[223] YES, TELL THE USER
MOVEI P1,TEM7 ;[223] TYPE NAME OF FORMAL ARGUMENT
PUSHJ P,SPT ;[223] SO HE KNOWS
LINE ;[223]
SETZM MATHSM ;[223]FORGET ABOUT SPECIFIC NAME
MOVE T5,FRMSAV ;[223] SETUP SAVLOC WITH ACTUAL
MOVEM T5,SAVLOC ;[223] PASSED PARAMETER
SETZM FRMSAV ;[223] FORGET WE ARE A FORMAL
POPJ P, ;[223] AND RETURN
; SYMBOL OUTPUT SUBROUTINE
SPT: ;RADIX 50 SYMBOL PRINT
TRNN T1,LNAME ;[402] Long symbol?
JRST SPT0 ;[402] No
MOVE T5,(P1) ;[402] Yes, GET SYMBOL
JRST SPT2 ;[402]
SPT0: LDB T5,[POINT 32,0(P1),35] ;GET SYMBOL
JRST SPT2 ;[201] NOT A POSSIBLE ROUTINE NAME
SPT1: SYMSKN PRGNAM ;[402] Long program name?
JRST SPT1B ;[402]
PUSH P,T2 ;[402]
MOVEI T2,PRGNAM ;[402]
TRNE T1,LNAME ;[402] LONG SYMBOL?
PUSHJ P,CMPSYM ;[402] DO WE ALREADY KNOW ABOUT IT
JRST SPT1A ;[402] NO
POP P,T2 ;[402]
JRST SPT8 ;[402]
SPT1A: POP P,T2 ;[402]
SPT1B: CAME T5,PRGNAM ;COMPARE NAME WITH MAIN PROG NAME
CAMN T5,[SQUOZE 0,MAIN.]
JRST SPT8
SPT2: TRNE T1,LNAME ;[402] Long name?
JRST LSPT ;[402] Yes, print long sixbit name
PUSH P,T5 ;[201] SAVE T5 OVER THE NEXT FEW LINES
MOVEI P1,T5 ;SET UP FOR TRULBL
PUSHJ P,TRULBL ;IS THIS A TRUE-LABEL
CAIA ;NO
JRST SPT5 ;YES - SEE IF SOURCE LINE
SPT6: POP P,T5 ;RESTORE T5 = SYMBOL
XMOVEI P1,SPT4 ;[300] SPECIAL TREATMENT FOR LAST CHARACTER
PUSH P,P1 ;SAVE ON STACK
SPT3: TLZ T5,PNAME ;RADIX 50 PART ONLY
IDIVI T5,50
PUSH P,P1 ;[300]
JUMPE T5,[SETOM P1
JRST .+2]
PUSHJ P,SPT3
POP P,T5 ;[300]
;[402] T5 IS A RAD50 CHARACTER - CONVERT TO ASCII
CAMGE T5,[SQUOZE 0,A] ;[402]less than rad50 'A'
JRST [ADDI T5,57 ;[402]We have a digit
JRST SPT3A] ;[402]
CAMG T5,[SQUOZE 0,Z] ;[402]greater than rad50 'Z'
JRST [ADDI T5,66 ;[402]We have a letter
JRST SPT3A] ;[402]
;[402]Check for "."
CAIN T5,[SQUOZE 0,.] ;[402]
JRST [MOVEI T5,"." ;[402]
JRST SPT3A] ;[402]
;[402]We now have either "$" or "%" ("%" should be changed to "_")
SUBI T5,2 ;[402] Convert "$" and "%" to ascii
CAIN T5,"%" ;[402]
MOVEI T5,"_" ;[402]
SPT3A: JUMPL P1,SPT7 ;FIRST TIME ROUND IS SPECIAL
EXCH T5,SAVCHR ;SAVE AS LAST CHARACTER
PJRST TOUT ;DISPLAY CHARACTER
SPT8: TYPE (MAIN PROGRAM)
POPJ P,
SPT4: MOVE T5,SAVCHR ;GET BACK THE LAST CHARACTER
JUMPN P1,CPOPJ ;DO WE TYPE THE LAST CHARACTER
PJRST TOUT ;YES
SPT5: SKIPGE BP0FLG ;[145] ANOTHER SPECIAL BREAKPOINT-0 CASE
JRST SPT50 ;[145] IF BP0, GO DO SPECIAL CODE
MOVEI P1,26 ;GET RADIX 50 'L'
CAMN P1,TRULST ;IS THIS A SOURCE LINE REFFERENCE
jrst [TYPE(L#)
jrst .+1]
JRST SPT6 ;DISPLAY THE SOURCE LINE TAG
SPT50: MOVE P1,TRULST ;[145] GET LAST CHAR
CAIE P1,26 ;[145] "L"?
JRST [TYPE (statement ) ;[145] NO, "p"
JRST SPT6] ;[145]
TYPE (line ) ;[145]
JRST SPT6 ;[145]
SPT7: CAIL T5,"0"
CAILE T5,"9"
TDZA P1,P1 ;ZERO IF FIRST CHAR NOT NUMERIC
HRRZI P1,-1 ;.GT. ZERO IF FIRST CHAR IS NUMERIC
MOVEM T5,SAVCHR ;SAVE LAST CHARACTER
POPJ P,
;[402] Routine to print long sixbit name
;[402] T5 = flg+length+pointer
LSPT: PUSH P,T3 ;Save T3, T4 and T5
PUSH P,T4
PUSH P,T5
MOVE T3,T5 ;T3 = addr of long sixbit string name
TLZ T3,770000 ;clear flag+length leaving 30 bit addr
TLZ T5,LFLG ;clear flag bits
LSH T5,-CNTSFT ;Number of words to print
IMULI T5,6 ;Number of sixbit characters to print
TLNE T3,-1 ;[405]Skip if local address
JRST [IOR T3,[450000000000] ;[405]Global address, make OWGBP to name
JRST .+2] ;[405]
IOR T3,[POINT 6,0] ;Bytepointer to name
LSLP: ILDB T4,T3 ;Get next character
JUMPE T4,LSPT2 ;Don't print following blanks
ADDI T4,40 ;Convert to ascii
putchr (T4) ;Output character
SOJG T5,LSLP ;Decrement loop count and repeat
LSPT2: POP P,T5 ;Restore T3, T4 and T5
POP P,T4
POP P,T3
POPJ P,
SUBTTL GENERAL NUMBER INPUT ROUTINE
; DELIMITERS ARE SPACES TABS OR , OR ) LAST CHAR IN T2
GETNUM: TDZ T0,[XWD OCTF!SIGN!FPF!MF!FEF,POWF]
CLEARM SYL
CLEARM DEN
PUSHJ P,GETSKB ;REMOVE USERS LEADING SPACES OR TABS
PUSHJ P,EITHR3 ;PROCESS
EITHR4: CAIE T2,"." ;[116] POSSIBLY A LOGICAL SYMBOL?
TRZ T1,LGCLEG ;[116] NO, MAKE SURE EVERYONE KNOWS
PUSHJ P,GETNBL ;PROCESS NEXT CHARACTER
JRST .-1 ;UNTIL DELIMITER
GETNBL: XCT GETCHR ;GET NEXT NON BLANK USER CHAR
PUSHJ P,GETSK2 ;TEST FOR DELIMITERS
; ENTRY POINT FROM 'EITHER'
EITHR3: JUMPE T2,POWER ;LAST CHAR WAS A DELIMITER
MOVE T5,[JRST GETOUT] ;[120] IN CASE WE GO TO LOGICL
MOVEM T5,DONE ;[120] THIS IS HOW WE'LL WANT TO RETURN
CAIE T2,"," ;ALLOW , AS # DELIMITER
CAIN T2,")" ;ALLOW ALSO RIGHT PARENS
JRST POWER ; DELIMITER SEEN - CLEAN UP
CAIE T2,"/" ;BAR IS A DELIMITER IN DIMENSION DEFS
CAIN T2,"]" ;LEFT SQUARE BRKT ALSO
JRST POWER ;DELIMITER
CAIE T2,":" ;ACCEPT : FOR DIMENSIONS
CAIN T2,"=" ;ACCEPT = AS DELIMITER
JRST POWER
MOVE T5,T2 ;MORE USEFUL IN T5
CAIN T5,42 ;IS IT " ?
JRST OCTAL ;YES - HOIST THE OCTAL FLAG
CAIE T5,"+" ;BOTH PLUS AND MINUS
CAIN T5,"-" ; DISPATCH TO
JRST SGN ; THE SAME PLACE
CAIN T5,"." ;PERIOD TYPED ?
JRST PERIOD ;THIS MEANS INPUT CANNOT BE OCTAL
CAIE T5,"D"+40 ;[113]
CAIN T5,"D" ;[113] DOUBLE PRECISION NOT ALLOWED HERE
JRST ERR21 ;[113]
CAIE T5,"E"+40 ;[113]
CAIN T5,"E" ;EXPONENT REQUESTED?
JRST E ;FLOATING POINT VALUES ONLY RETURNED
CAIL T5,"0" ;NUMERALS ONLY
CAILE T5,"9" ;
JRST LOGICL ;[116] LET'S SEE IF WE HAVE A LOGICAL SYMBOL
SUBI T5,60 ;FORM OCTAL REPRESENTATION
JRST NUM ;GO DEAL WITH NUMERIC INPUT
LOGICL: TRZN T1,LGCLEG ;[116] ARE LOGICAL SYMBOLS LEGAL?
JRST ERR7 ;[116] NOPE, BAD STUFF
TLZ T0,FPF ;[116] TURN OFF FLOATING POINT FLAG
TRZ T0,POWF ;[116] AND POWER FLAG (SET WHEN "." SEEN)
PUSHJ P,EITHR5 ;[116] LET'S GET THE WHOLE WORD
CAIE T2,"." ;[116] DOES IT END WITH PERIOD?
JRST ERR7 ;[116] NO, CAN'T BE A LOGICAL SYMBOL
CAME T3,[SIXBIT /TRUE/] ;[116] IS IT .TRUE.?
JRST FALSE ;[116] NOPE, COULD BE .FALSE.
SETO T5, ;[116] IT'S .TRUE.! RETURN -1
TRO T1,ISLOGI ;[116] LET 'EM KNOW WE HAVE A LOGICAL
PUSHJ P,LOADCH ;[116] GET NEXT CHARACTER
PUSHJ P,GETSK2 ;[116] TAKE CARE OF DELIMETERS
XCT DONE ;[120] WE ARE DONE!
FALSE: CAME T3,[SIXBIT /FALSE/] ;[116] IS IT .FALSE.?
JRST ERR7 ;[116] NO, JUNK
SETZ T5, ;[116] IT'S .FALSE.! RETURN 0
TRO T1,ISLOGI ;[116] LET 'EM KNOW WE HAVE A LOGICAL
PUSHJ P,LOADCH ;[116] GET NEXT CHARACTER
PUSHJ P,GETSK2 ;[116] TAKE CARE OF DELIMETERS
XCT DONE ;[120] LEAVE NOW
DONE: BLOCK 1 ;[120] RETURN STATEMENT FOR LOGICL
OCTAL: SKIPN SYL ;HAVE ANY SIGNIFICANT CHARACTERS BEEN SEEN
TLOE T0,OCTF ;STAMP THIS AS AN OCTAL NUMBER
JRST ERR7 ;ERROR
POPJ P,
SGN: SKIPE SYL ;HAVE ANY SIGNIFICANT CHARACTERS BEEN SEEN?
JRST ERR7 ;YES - TOO BAD
TLOE T0,SIGN ;HAS A SIGN BEEN SEEN BEFORE?
JRST ERR7 ;YES - REJECT
CAIE T5,"+" ;NO SPECIAL ACTION FOR PLUS
TLO T0,MF ;SET THE MINUS FLAG
POPJ P, ;
NUM: ANDI T5,17 ;T5 HOLDS CHARACTER
TLNE T0,FPF
JRST NM1
MOVE T4,SYL
TLNE T4,700000 ;TEST FOR PENDING WORD OVERFLOW
JRST ERR7 ;BAD VALUE
LSH T4,3
ADD T4,T5
MOVEM T4,SYL
MOVE T4,DEN
IMULI T4,12 ;CONVERT TO DECIMAL
ADD T4,T5
MOVEM T4,DEN
POPJ P,
NM1: MOVEI P1,6 ;FORM FLOATING POINT NUMBER
AOS NM1A
NM1A: MOVEI P2,0
MOVSI T2,201400
NM1A1: TRZE P2,1
FMPR T2,FT(P1)
JUMPE P2,NM1B
LSH P2,-1
SOJG P1,NM1A1
NM1B: MOVSI P1,211000(T5)
FMPR T2,P1 ;COMPUTE VALUE OF NEW DIGIT
FADRB T2,FH ;ADD VALUE INTO FLOATING NO.
MOVEM T2,SYL
TRO T0,POWF ;INDICATE THAT ANSWER WILL BE FLOATED
POPJ P,
POWER: TLNN T0,FEF ;HAS E BEEN SEEN?
JRST POW3 ; NO - MUST BE INTEGER OR OCT AL OR #.#
MOVE T5,SYL
MOVE P2,DEN
CAILE P2,^D38 ;POWERS <38 ONLY
JRST ERR7
MOVEI P1,FT-1
TLZE T0,MF
MOVEI P1,FT01
SKIPA T5,FSV
POW2: LSH P2,-1
TRZE P2,1
FMPR T5,(P1)
JUMPE P2,GETOUT
SOJA P1,POW2
PERIOD: TLNN T0,OCTF ;DO WE HAVE AN OCTAL NO.
TLOE T0,FPF ;BOTH OCTAL AND FPF CANNOT EXIST TOGETHER
JRST ERR7
MOVE T5,DEN
IDIVI T5,400
JUMPE T5,.+2
TLC T5,243000
TLC P1,233000
FAD T5,[0] ;NORMALIZE T5 AND P1
FAD P1,[0]
FADR T5,P1
MOVEM T5,FH
MOVEM T5,SYL ;SAVE FLOATING ANSWER
TRO T0,POWF ;AND REMEMBER WE NOW HAVE REAL
HLLZS NM1A
POPJ P,
E: TLON T0,FEF ;HOIST THE FLOAT FLAG IF NOT UP
TLNN T0,FPF ;REJECT IF E REQUESTED AND NO FPF
JRST ERR7
TRNN T0,POWF ;USER MUST TYPE A DIGIT AFTER THE PERIOD
JRST ERR7
TLZN T0,MF
SKIPA P1,SYL
MOVN P1,SYL
MOVEM P1,FSV
CLEARM SYL
CLEARM DEN
TLZ T0,FPF!SIGN!MF
POPJ P,
POW3: ;ANSWER IN SYL IF #.# OR OCTAL OR INTEGER
TLNN T0,FPF!OCTF ;TEST FOR INTEGER
TLO T0,FPF ;MUST BE INTEGER
TDNN T0,[XWD OCTF,POWF]
TLNN T0,FPF ;DO WE HAVE INTEGER?
SKIPA T5,SYL ;NO - GET OCTAL
MOVE T5,DEN ;GET DECIMAL
TLNE T0,MF ;SHOULD WE RETURN NEGATIVE#
MOVNS T5,T5 ; YES - DO SO
GETOUT: MOVE T2,LSTCHR ;SET USERS LAST CHARACTER
POP P,(P)
POPJ P, ;FINALLY OUT OF GETNUM
SUBTTL OUTPUT ROUTINES
; FLOATING POINT OUTPUT
TFLOT: MOVE T2,T5
JUMPGE T2, TFLOT1
MOVNS T2
MOVEI T5,"-"
PUSHJ P,TOUT
TLZE T2,400000
JRST FP1A
TFLOT1: TLNN T2, 400
PJRST FP7 ;DECIMAL PRINT
MOVEI T3,0
CAMGE T2,FT01
JRST FP4
CAML T2,FT8
AOJA T3,FP4
FP1A: MOVEI T4,0
FP3: MULI T2,400
ASHC T3,-243(T2)
SETZM TEM1 ;INIT 8 DIGIT COUNTER
SKIPE T2,T3 ;DON'T TYPE A LEADING 0
PUSHJ P,FP7 ;PRINT INTEGER PART OF 8 DIGITS
MOVEI T5,"." ;GET A MINUS
PUSHJ P,TOUT ;AND DISPLAY IT
MOVNI T2,10
ADD T2,TEM1
MOVE P1,T4
FP3A: MOVE T5,P1
MULI T5,12
PUSHJ P,FP7B
JUMPE P1,CPOPJ
AOJL T2,FP3A
POPJ P,
FP4: MOVNI T4,6
MOVEI P2,0
FP4A: ASH P2,1
XCT FCP(T3)
JRST FP4B
FMPR T2,@FCP+1(T3)
IORI P2,1
FP4B: AOJN T4,FP4A
PUSH P,P2 ;SAVE EXPONENT
PUSH P,FSGN(T3) ;SAVE "E+" OR "E-"
PUSHJ P,FP3 ;PRINT OUT FFF.FFF PART OF NUMBER
POP P,P1 ;GET "E+" OR "E-" BACK
PUSHJ P,TEXT
POP P,T2 ;GET EXPONENT BACK
FP7: IDIVI T2,12 ;DECIMAL OUTPUT SUBROUTINE
AOS TEM1
PUSH P,T3 ;[303]
JUMPE T2,FP7A1
PUSHJ P,FP7
FP7A1: POP P,T5 ;[303]
FP7B: ADDI T5,260
JRST TOUT
353473426555 ;1.0E32
266434157116 ;1.0E16
FT8: 233575360400 ;1.0E8
216470400000 ;1.0E4
207620000000 ;1.0E2
204500000000 ;1.0E1
FT: 201400000000 ;1.0E0
026637304365 ;1.0E-32
113715126246 ;1.0E-16
146527461671 ;1.0E-8
163643334273 ;1.0E-4
172507534122 ;1.0E-2
FT01: 175631463146 ;1.0E-1
FT0=FT01+1
FCP: CAMLE T2, FT0(T4)
CAMGE T2, FT(T4)
Z FT0(T4)
FSGN: ASCII .E-.
ASCII .E+.
; TTY HANDLERS
TEXT: TLNN P1,774000 ;LEFT JUSTIFIED UNLESS LEFT CHAR IS NULL
LSH P1,35
TEXT2: MOVEI T5,0 ;7 BIT ASCII TEXT OUTPUT SUBROUTINE
LSHC T5,7
PUSHJ P,TOUT
JUMPN P1,TEXT2
POPJ P,
TXT341: MOVEI P2,5 ;FIVE CHARACTERS
TYPE(")
MOVE P1,T5
TXT2: SOSGE P2
JRST TXT3 ;END
MOVEI T5,0
LSHC T5,7
PUSHJ P,ASCOUT
JRST TXT2
TXT3: TYPE(")
POPJ P,
SIXBP: MOVEM T5,LWT
MOVNI P2,6 ;SIXBIT PRINTER
MOVE P1,LWT
SIXBP1: MOVEI T5,0
ROTC T5,6
ADDI T5,40
PUSHJ P,TOUT
AOJL P2,SIXBP1
POPJ P,
FTOC: HRRZ P1,S1 ;NUMERIC OUTPUT SUBROUTINE
CAIN P1,10 ;IS OUPUT RADIX NOT OCTAL
jrst [TYPE(") ;SHOW CURRENT OUTPUT AS OCTAL
jrst .+1]
HRRZ P1,S1 ;IS OUTPUT RADIX DECIMAL?
CAIN P1,12
JRST TOC4 ;YES,TYPE SIGNED WITH PERIOD
TOC0: LSHC T5,-43
LSH P1,-1 ;P1=T5+1
DIVI T5,@S1
PUSH P,P1 ;[300] SAVE REMAINDER
JUMPE T5,.+2
PUSHJ P,TOC0
POP P,T5 ;[300] RETRIEVE REMAINDER
ADDI T5,"0"
PJRST TOUT
TOC4: JUMPGE T5,TOC5 ;TEST FOR NEGATIVE #
TYPE(-)
TOC5: MOVMS T5,T5 ;GET MAGNITUDE
JRST TOC0 ;DO NORMAL RADIX PRINT
TOUT: putchr (T5) ;OUTPUT A CHARACTER
POPJ P,
ife tops20,<
LISTEN: INCHRS T5 ;GET NEXT CHAR, NO IO WAIT
POPJ P, ;NO CHARACTER EXISTED, RETURN
CLRBFI ;CLEAR OUT INPUTBUFFER
JRST CPOPJ1> ;CHAR WAS THERE, SKIP RETURN,end of conditional
ifn tops20,<
listen: push p,T1 ;save T1
push p,T2 ;save T2
hrrzi T1,.priou ;get terminal output designator
rfmod% ;get terminal JFN word
tlze T2,(tt%osp) ;[114]clear ^o
sfmod% ;[114]set new terminal JFN word
hrrzi T1,.priin ;get terminal input designator
sibe% ;check for pending input
caia
jrst rpopj ;no pending input
cfibf% ;clear input buffer
aos (p) ;set up for skip return
rpopj: pop p,T2 ;restore T2
tfpopj: pop p,T1 ;restore T1
popj p,> ;return, end of conditional
ife tops20,<
TTYCLR: SKPINC ;CLEAR ^O, SKIP ON INPUT CHARS
POPJ P, ;NO INPUT CHARS, OR EXEC MODE
CLRBFI ;FLUSH ALL
POPJ P,> ;WAITING INPUT CHARACTERS, end of conditional
ifn tops20,<
ttyclr: pushj p,listen ;let listen do the work
popj p, ;no characters were pending
popj p,> ;pending chars flushed, end of conditional
OUT6: MOVE T5,T2 ;PRINT (T2) AS A SIXBIT WORD
PJRST SIXBP ;PRINT IT
; ROUTINE TO CLEAR OUT REST OF USERS LINE
CLRLIN: PUSHJ P,SAV2AC ;SAVE T5 THRO. CLRLIN
MOVE T2,[PUSHJ P,LOADCH] ;[132] USE THIS ROUTINE TO GET CHARS.
MOVEM T2,GETCHR ;[132]
CLRLI2:
ife tops20,<
SKPINL ;SKIP IF ANY CHARS THERE
POPJ P,> ;LINE CLEAR, end of conditional
ifn tops20,<
push p,T1 ;save T1
movei T1,.priin ;[121] get primary input device
sibe% ;more to come?
caia ;yes
jrst tfpopj ;no
pop p,T1> ;restore T1, end of conditional
PUSHJ P,GCHR ;GET THE NEXT CHAR
SKIPL TERMK ;NOW DONE?
POPJ P, ;YES
CAIN T2," " ;SPACE OR TAB?
JRST CLRLI2 ;IGNORE IT
SKIPE DELCHR ;DELIMITER SAVED FROM ASCII ACCEPT?
CAME T2,DELCHR ;OR DELIMITER FOUND?
JRST CLRLI1 ;NO, PROCEED AS USUAL
SETZM DELCHR ;CLEAR SAVED DELIMITER
JRST CLRLI2 ;AND TRY AGAIN
CLRLI1: SETZM DELCHR ;MAKE SURE IT'S ZERO
LINE
TYPE (<%FDTCHI Characters ignored: ">) ;WARN THE USER
PUSHJ P,OUTL1 ;TYPE THE REST OF THE LINE
TYPE (")
LINE
POPJ P, ;YES - LINE CLEARED
; ROUTINE TO CLEAR OUT USER LINE AND DISPLAY REMAINING TEXT
ENDLIN: SKIPL TERMK ;END OF USER LINE?
POPJ P, ;YES
putchr (LSTCHR) ;DISPLAY USERS LAST CHAR IN ERROR
PJRST OUTLIN ;AND TYPE THE REST OF THE LINE
;PRINT ALL CHARACTERS REMAINING IN THE INPUT BUFFER
OUTLIN: PUSHJ P,GCHR ;GET THE NEXT CHAR
SKIPL TERMK ;DONE?
POPJ P, ;YES
OUTL1: putchr (T2) ;TYPE IT
JRST OUTLIN ;NEXT
GCHR: XCT GETCHR ;GET CHARACTER
PUSHJ P,GETSK2 ;SET UP DELIMETER FLAGS
JUMPN T2,CPOPJ
MOVEI T2," " ;RECONVERT NULLS TO SPACES
POPJ P,
;[177] HERE WHEN AN OTS CALL TAKES THE ERR= BRANCH FROM A DECODE CALL
;[177] VIA BADSYN. THIS ROUTINE PRINTS OUT THE BAD NUMBER THE USER TRIED
;[177] TO PASS TO FOROTS.
ERRLIN: ATYPE (NUMBUF) ;[177] TYPE THE BAD ARGUMENT IN NUMBER BUFFER
SETZB T3,TERMK ;[177] CLEAR DELIMETERS
POPJ P, ;[177] RETURN TO GCHR
TYP0: MOVEI S1,^D10 ;PREPARE FOR DECIMAL PRINT
PJRST FTOC ;DO IT
TYP1: TYPE(?FDTIAT Illegal argument type = )
MOVEI S1,10 ;PRINT DEFAULTING ARG TYPE AS OCTAL
HRRZ T5,T3 ;TOC PRINTS T5
PJRST FTOC ;DISPLAY ARGUMENT TYPE
TYP4: MOVEI S1,10 ;PRINT OCTAL
PJRST FTOC ;PRINT
TYP5: PJRST TXT341 ;SHOW AS ASCII
TYPCS: SETZM CLMRNG ;[162]Reset for TYPN
DMOVE T2,@(T4) ;[162]Get ptr & count
JRST DSPST1 ;[164]Go display it
; F10 ARGUMENT PROCESSING
GETARG: SKIPN T4,SAVACS+16 ;[203] ANY USER ARGBLOCK?
JRST CPOPJ ;[203] NOTHING
HLL T4,-1(T4) ;L.H. =-# OF ARGS ,,R.H. = ADDRESS
JUMPGE T4,CPOPJ ;APPEARS TO BE NO ARGS
CAMGE T4,[777700,,0] ;ARBITRARY LIMIT OF 64 ARGS
POPJ P, ;PREVENT RUN AWAY
LINE
TYPE(Arguments are:)
F10.2: MOVEM T4,SAVT3 ;SAVE T4 DURING OUTPUT
LINE
LDB T3,[POINT 4,(T4),12] ;GET ARGUMENT TYPE
TYPE( = )
PUSHJ P,FOROTS ;GET FOROTS TO TYPE ARGS
MOVE T4,SAVT3 ;RE-INSTATE T4
AOBJN T4,F10.2 ;MOVE TO NEXT ARG
LINE
POPJ P,
DEFINE T(A),< ;;[300]
IFIW A ;;[300]
> ;;[300]
DEFINE TYPES,<
T F10.6 ;0 = UNDEFINED
T F10.6 ;1 = LOGICAL
T F10.6 ;2 = SINGLE PRECISION INTEGER
T TYP1 ;3 = ILLIGAL
T F10.6 ;4 = SINGLE PRECISION REAL
T TYP1 ;5 = ILLEGAL
T TYP4 ;6 = OCTAL
T F10.3 ;7 = LABEL
T F10.6 ;10= DOUBLE PRECISION REAL (D-Floating)
T F10.4 ;11= DOUBLE PRECISION INTEGER
T F10.5 ;12= DOUBLE OCTAL
T F10.6 ;13= [137] DOUBLE PRECISION REAL (G-Floating)
T F10.6 ;14= COMPLEX
; TYP1 ;15= ILLEGAL
T TYPCS ;15= [162]Character string
T TYP1 ;16= ILLEGAL
T TYP5 ;17= ASCII STRING
> ;[300]
TYP10: XLIST ;[300]
TYPES ;[300]
LIST ;[300]
; ROUTINE TO 'TYPE' AN ARGUMENT OF A SUBROUTINE CALLING LIST
; ENTER WITH T5= VALUE OF 1ST. ARG
; T3= ARG TYPE
; T4=POINTER IN SUBROUTINE ARGBLOCK
FOROTS: XMOVEI T5,@(T4) ;[300] GET SECOND ARGUMENT ADDRESS
MOVE T5,1(T5) ;GET SECOND ARGUMENT
MOVEM T5,ARGVAL+1 ;STORE SECOND ARG
MOVE T5,@(T4) ;GET FIRST ARGUMENT
; ENTRY TO 'TYPE' A SINGLE VALUE IN T5 - ARG TYPE IN T3
FOROUT: PUSHJ P,CHKIWI ;[211] RECURSIVE IO IF WE CALL THE OTS?
JRST ERRIWI ;[211] YES, TELL AND RETURN TO COMMAND LOOP.
MOVEM T5,ARGVAL ;SAVE FIRST ARGUMENT FOR TYPING
DPBTYP: DPB T3,[POINT 4,M2.,12] ;PLACE ARG TYPE
JRST @TYP10(T3) ;DISPATCH ACORDING TO ARGUMENT TYPE
F10.6: XMOVEI 16,M1. ;[300] GET ADDRESS OF FORMAT BLOCK
PUSHJ P,OUT.## ;[143]
F10.8: XMOVEI 16,M2. ;[300] GET THE IOLIST ARGBLOCK
PUSHJ P,IOLST.## ;[143] - AND LET FOROTS DO ITS THING
PJRST FORBUF ;MUST CLEAR TTY BUFF SO FOROTS
; EDIT 661 DOESN'T OVERWRITE LINE
F10.3: TYPE( LABEL)
POPJ P,
F10.4: PUSHJ P,TYP0 ;TYPE FIRST INTEGER ARG
TAB
MOVE T5,ARGVAL+1 ;GET SECOND ARG
PJRST TYP0 ;TYPE SECOND ARG AS INTEGER AND EXIT
F10.5: PUSHJ P,TYP4 ;TYPE FIRST ARG AS OCTAL
TAB
MOVE T5,ARGVAL+1 ;GET SECOND OCTAL ARG
PJRST TYP4 ;TYPE NEXT OCTAL ARG AND EXIT
; ENTRY TO READ UP TO TWO WORD ENTRIES - ARG TYPE IN T3
FORINP: DPB T3,[POINT 4,M2.,12] ;[300] PLACE ARG TYPE
MOVEI T4,1 ;[127] SET UP COUNTER
MOVE T5,[POINT 7,NUMBUF] ;[127] AND POINTER TO NUMBER BUFFER
SETOM TERMK ;[127] SET UP TERMINTATOR FLAG
MOVE T3,LSTCHR ;[177] GET LAST CHARACTER READ
FORGET: PUSHJ P,GETSKB ;[177][127] GET A NON-BLANK CHARACTER
CAIE T2,"=" ;[177] JUST READ AN EQUAL SIGN?
JRST FORGOT ;[177] NO, CONTINUE PARSING
CAIN T2,(T3) ;[177] YES. WAS LAST CHAR AN EQ-SIGN?
JRST BADSYN ;[177] YES, LET THIS FAIL RIGHT NOW
MOVEM T2,T3 ;[177] NO, BUT IT IS NOW
JRST FORGET ;[177] GET NEXT NON-BLANK CHARACTER
FORGOT: SKIPGE TERMK ;[177][127] EOL?
JRST GOTCH ;[127] NO.
JRST BADSYN ;[200] YES, NO VALUE TYPED BY USER
GOTCH: IDPB T2,T5 ;[127] STORE IT
PUSHJ P,LOADCH ;[127] GET NEXT CHAR.
SETOM TERMK ;[127]
PUSHJ P,GETSK2 ;[127] CHECK IT OUT
JUMPE T2,FORIN2 ;[127] VALID STUFF?
CAIGE T4,NMBFSZ*5-1 ;[177] YES, SEE IF THERE'S ROOM LEFT IN BUFFER
AOJA T4,GOTCH ;[127] THERE'S ROOM, DUMP IT
TYPE (<%FDTECI Buffer full excess characters ignored>) ;[127]
LINE ;[127] ERROR, NOT ENOUGH ROOM
FORIN2: SETZ T2, ;[177] ENSURE NULL BYTE IN NUMBUF
IDPB T2,T5 ;[177] SO ERR= CAN PRINT OUT ITS CONTENTS
MOVE T2,[PUSHJ P,ERRLIN] ;[177] USE THIS ROUTINE TO GET CHARS
MOVEM T2,GETCHR ;[177] IN CASE OF ERR= RETURN
SETOM TERMK ;[177]
MOVEM T4,M4. ;[127] SET UP CHARACTER COUNT
XMOVEI 16,M4. ;[300] USE FORMAT(G,G) FOR READING
PUSHJ P,DEC.## ;[143]
PJRST F10.8 ;[111] ACTION
FORBUF: XMOVEI 16,M3. ;ARG BLOCK
PUSHJ P,OUT.## ;CALL OUT.
PJRST FIN.## ;DO IT AND RETURN
;CHKIWI - Determine whether a pending FORDDT FOROTS call will result in
; an "I/O within I/O" error from the OTS. This may occur if the
; user has an IOLST function call, puts a breakpoint in the function,
; and then attempts to have FORDDT do something useful, like TYPE,
; which will immediately get an IWI error since we are still processing
; the original IOLST call.
;
; This routine calls the FO$UDB FOROP routine which returns the
; contents of %UDBAD, which will be non-zero if IOLST processing is
; currently in progress.
;
; Returns +1 if IOLST processing in progress, %UDBAD non-zero.
; Returns +2 if no IOLST in progress, %UDBAD zero.
;[211] Create this routine
CHKIWI: PUSH P,T1 ;Save flags
PUSH P,T0 ; and temporary flags
SETZ S2, ;Clear return argument
MOVEI T0,FO$UDB ;FOROP function code
XMOVEI T1,S2 ;Return address
PUSHJ P,FOROP.## ;Get %UDBAD
POP P,T0 ;Restore ACS
POP P,T1
JUMPE S2,CPOPJ1 ;+2 return if no IWI condition
POPJ P, ;+1 if IWI threatens
;ERRIWI - Routine to print out a error when a recursive IOLST call
; is pending. Warn the user that the command he has just issued
; cannot be honored, and return to the main command loop.
;
;[211] Create this routine
ERRIWI: LINE
TYPE (?FDTIWI IOLST call currently in progress:
Cannot process ACCEPT or TYPE until current IOLST is completed.)
PUSHJ P,TTYCLR ;Clear any input
JRST RET ;Return
;WRNIWI - Routine called at breakpoint processing (and CALL FORDDT entries)
; to warn that an IOLST call is in progress and ACCEPT and TYPE
; commands won't work.
; Returns +1 after issuing the warning.
;
;[211] Create this routine
WRNIWI: TYPE (%FDTIWI IOLST call in progress at this breakpoint:
Will not be able to process ACCEPT or TYPE until IOLST is completed.)
LINE ;Follow with a CRLF
POPJ P, ;Return
;ARG BLOCK FOR CALLS TO FOROTS
-6,,0 ;[300] SIX ARGUMENTS FOLLOW
M1.: 401100,,tty ;[300] OUTPUT TO TTY =-1
404340,,end ;[300] END=
405340,,err ;[300] ERR= RETURN (possibly should be 0,,RET)
402340,,FORMAT ;[300] ASCII,,FORMAT
403100,,fi2 ;[300] TWO WORDS OF FORMAT INFO
400100,,0
-3,,0 ;[300]
M2.: 401100,,ARGVAL ;[300] DATA 0-8/ARGTYP 9-12/ARGADDRESS 13-35
M2.I: 404100,,0 ;[300] CALL FIN - MAY BE USED FOR COMPLEX
M2.F: 404100,,0 ;[300] CALL FIN
ARGVAL: BLOCK 2 ;STORAGE FOR DOUBLE WORD ARGUMENTS
FORMAT: ASCII /('+'G$,G$)/ ;[144] SUPPRESS CR AFTER OUTPUT
-5,,0
M3.: 401100,,tty ;[300] TTY =-1
404100,,end ;[300] END=
405100,,err ;[300] ERR= RETURN (possibly should be 0,,RET)
402340,,FORM2 ;[300]
403100,,fi2 ;[300]
FORM2: ASCII .(1H+$).
-6,,0 ;[127][111] 6 ARGS
M4.: Z ;[127][111] NO. OF CHARS TO BE DECODED
404100,,end ;[300] END=
405100,,err ;[300] ERR= RETURN (possibly should be 0,,RET)
402340,,FMREAD ;[300] FORMAT(G,G) FOR READ
403000,,1 ;[300] 1 WORD OF FORMAT
412100,,NUMBUF ;[300] BUFFER LOCATION
FMREAD: ASCII/(G,G)/ ;[127][111] FORMAT FOR READING
tty: -1 ;[300] device
end: 0 ;[300] end=
err: JRST BADSYN ;[312] err=
fi1: 1 ;[300] 1 format word
fi2: 2 ;[300] 2 format words
SUBTTL GENERAL SUBROUTINES
;CHKADR CHECKS THE LOCATION IN THE RH(T5) FOR VALIDITY AS A USER
;ADDRESS. RETURNS ARE:
;
; PUSHJ P,CHKADR ;WITH LOCATION IN T5
; <ILLEGAL ADDRESS>
;[300] <HISEG ADDRESS> or <EXTENDED ADDRESS>
; <LOSEG ADDRESS>
CHKADR:
IFN TOPS20,<
SKIPE EXTEND ;[300] ARE WE EXTENDED?
JRST CPOPJ1 ;[300] YES, JUST ASSUME ITS A HIGH-SEG ADDRESS
>
PUSH P,T5 ;SAVE T5 FOLKS !
MOVEI S2,(T5)
CAIGE S2,.JBDA ;ABOVE .JBDA
JRST TPOPJ ;FAIL - ILLEGAL
CAMG S2,.JBREL ;BELOW HERE IS OK TOO
JRST TPOPJ2
MOVE T5,T2 ;SAVE (T2)
PUSHJ P,GSTAH ;GET THE START ADDR OF THE HISEG
EXCH T5,T2
CAIGE S2,10(T5) ;
JRST TPOPJ
HRRZ T5,.JBHRL ;GET TOP OF HISEG
CAILE S2,(T5) ;
JRST TPOPJ
JRST TPOPJ1 ;DONE
TPOPJ: POP P,T5 ;RESTORE T5
POPJ P, ;AND RETURN
TPOPJ1: POP P,T5 ;RESTORE T5
JRST CPOPJ1 ;AND GIVE SKIP RETURN
TPOPJ2: POP P,T5 ;RESTORE T5
JRST CPOPJ2 ;AND GIVE DOUBLE SKIP RETURN
CKWRIT: PUSHJ P,CHKADR ;[163]Check address
JRST [TYPE (<%Trying to write to illegal address; wrong mode???>)
JRST RET ];[163]Give user another chance
TRNA ;[300] SKIP AND CHECK IF EXTENDED
POPJ P, ;[163]Let user go ahead
CKWREX:
IFN TOPS20,<
SKIPN EXTEND ;[300] WAS THIS AN EXTENDED ADDRESS?
JRST [
>
TYPE (<%Trying to write in high segment; wrong mode???>)
JRST RET
IFN TOPS20,<
] ;[300] NO, GIVE USER ANOTHER CHANCE
PUSH P,T1 ;[300] SAVE REGS FOR JSYS
PUSH P,T2
MOVE T2,T5 ;[300] GET ADDRESS INTO REG
LSH T2,-11 ;[300] FORM PAGE NUMBER FROM ADDRESS
HRRZI T1,(T2) ;[300] PUT INTO T1
HRLI T1,.FHSLF ;[300] GET PROCESS HANDLE INTO LEFT HALF
RPACS% ;[300] GET ACCESS BITS INTO T2
TLNE T2,(PA%PEX) ;[312] IF NO PAGE EXISTS, A WRITE CREATES IT
TLNE T2,(PA%WT!PA%CPY) ;[300] CAN WE WRITE TO THIS PAGE?
JRST WREXDN ;[300] YES, ALL OK
AND T2,[PA%WT!PA%RD!PA%CPY!PA%EX]
;[300] CLEAR OUT ANY UNNEEDED BITS
TLO T2,(PA%CPY) ;[300] GET COPY-ON-WRITE ACCESS FOR PAGE
SPACS%
WREXDN: POP P,T2 ;[300] RESTORE T2
POP P,T1 ;[300] RESTORE FLAGS
POPJ P, ;[300] AND RETURN OK
>
CKREAD: PUSHJ P,CHKADR ;[163]Check address
JRST [TYPE (<%Trying to read from illegal address; wrong mode???>)
JRST RET ];[163]Give user another chance
POPJ P, ;[163]Let user try reading high segment
POPJ P, ;[163]Let user go ahead
CKBPTR: DMOVE P1,(T5) ;[163]Load presumptive descriptor
JUMPLE P2,BSIZER ;[163]"%Null string length;wrong mode?"
LDB T5,[POINT 6,P1,05] ;[163]Bits left in word
CAILE T5,44 ;[300] IS IT AN OWGBP?
JRST [CAIL T5,61 ;[300] YES, IS IT WITHIN RANGE FOR ASCII?
CAILE T5,66 ;[300]
JRST BPTRER ;[300] NO, GIVE ERROR
POPJ P,] ;[300] ALL OK
TLNE P1,(1B13) ;[172]Error if indirect bit set
JRST BPTRER ;[172]
IBP P1 ;[163]Bump pointer
LDB T5,[POINT 6,P1,11] ;[163]Get byte size
CAIE T5,BYTSIZ ;[163]Does it look like a byte pointer?
JRST BPTRER ;[163]NO
LDB T5,[POINT 6,P1,05] ;[163]Bits left in word
IDIVI T5,BYTSIZ ;[163]Put remainder in T3
;[163] this destroys P1
CAIE T5+1,BYTEXT ;[163]Bytes properly aligned?
JRST BPTRER ;[163]NO
POPJ P, ;[163]No obvious errors, return
BPTRER: TYPE (<%Improper byte pointer; wrong mode?>)
JRST RET ;[163]Give user another chance
BSIZER: TYPE (<%Null character string; Wrong type???>)
JRST RET ;[163]Give user another chance
BYTSIZ==7 ;[BL]Byte size
BYTPWD==36/BYTSIZ ;[BL]Bytes per word
;BYTEXT==36-(BYTSIZ*BYTPWD) ;[BL]Unused bits in word
BYTEXT==1
;REINOP - REINSTATE OPENED PROGRAM - THIS ROUTINE IS CALLED AFTER
;A GROUP REQUEST HAS BEEN EXHAUSTED TO RE-OPEN THE PROGRAM THAT WAS
;OPEN AT THE BEGINNING O THE REQUEST.
REINOP: LDFLG OLDOPN ;[402] Set long name flag if necessary
SKIPN T4,OLDOPN ;GET THE OLD NAME
POPJ P, ;NONE - OK
SETZM OLDOPN
CAMN T4,OPENED ;SAME AS THE CURRENT?
POPJ P,
MOVEM T4,SYM ;NO - SAVE IT
IMPOPN: PUSHJ P,SETNAM ;SET IT AND DONE
MOVE T5,OPENED ;WHAT IS THE CURRENTLY OPEN SECTION
LINE
stype(.[Implicit OPEN .)
MOVE T5,SYM ;GET SYMBOL
PUSHJ P,SPT1 ;TYPE PROGRAM NAME
type(])
LINE
POPJ P,
;ROUTINE TO READ WORDS FROM ASCII STRING FROM TTY
;FILTERS OUT TAB & SPACE
;STOPS ON ANY NON-ALPHA NUMERIC, CALLER MUST CHECK FOR LEGAL BREAK
;SET FLAGS FOR LEGAL LINE TERMINATORS
;
; CALL PUSHJ P,TTYIN
;RETURN WITH SIXBIT WORD IN T3 LEFT JUSTIFIED, BREAK IN T2
;
;CFLIU = CORE FILE IN USE FLAG
;OFCFL = OUTPUT FROM CORE FILE FLAG
;
;N.B. CLEAR GETCHR FOR FIRST CORE FILE ACCESS
; ALWAYS CLEAR CFLIU IMMEDIATELY AFTER LINE END
I2CFIL: HRRZ T2,CFLPTR ;CURRENT POSITION IN CORE FILE
SUBI T2,CFSIZ-1 ;[132] REMOVE OFFSET
SUB T2,CFLST ;[132] PREVENT CORE FILE OVERFLOW
JUMPL T2,I2CFL2 ;[132] IF WE'RE NOT IN LAST WORD GO AHEAD
MOVE T2,CFLPTR ;[132] GET CORE FILE POINTER
TLZ T2,LFLG ;[402] clear flag bits
LSH T2,-CNTSFT ;[402] GET OFFSET INTO WORD
CAILE T2,10 ;[132] JUST ONE BYTE LEFT?
JRST I2CFL2 ;[132] NO, GO AHEAD
MOVEI T2,12 ;[132] MAKE SURE <LF> IS LAST CHAR IN BUFFER
IDPB T2,CFLPTR ;[132]
JRST ERR12 ;[132]
I2CFL2: PUSHJ P,LOADCH ;[132] GET USERS CHARACTER
IDPB T2,CFLPTR ;STORE IT IN CORE FILE FOR FUTURE ACCESS
POPJ P, ;
CFLST: Z ;HOLDS START ADDRESS OF CORE FILE
CFLPTR: Z
CFLBUF: XWD 050000,0 ;HOLDS CORE FILE FOR TYPE REQUEST
BLOCK CFSIZ-1
GETCHR: Z ;EXCECUTED TO READ OR WRITE CHARACTERS
TTYIN: MOVE T5,[pushj p,loadch]
TLNN T0,CFLIU ;DO WE WISH TO USE A CORE FILE?
JRST XCTSET ;NO - JUST SET UP FOR NORMAL TTY INPUT
SKIPE GETCHR ;YES - FIRST CHAR OF LINE?
JRST TTYSET ; NO - DO NOT TOUCH POINTERS
MOVE T5,[POINT 7,CFLBUF]
MOVEM T5,CFLPTR ;SET UP GENERAL CORE FILE POINTER
HRRZM T5,CFLST ; HOLDS START OF CURRENT CORE FILE
TLNN T0,OFCFL ;OUTPUTTING TO CORE FILE?
SKIPA T5,[PUSHJ P,I2CFIL] ;YES
MOVE T5,[ILDB T2,CFLPTR]
XCTSET: MOVEM T5,GETCHR ;SET UP FOR FUTURE XCT
TTYSET: SETOM TERMK ;PREPARE TERMINATOR FLAG
PUSHJ P,GETSKB ;SKIP LEADING BLANKS & TABS
EITHR5: TRZ T1,LNAME ;[402] NO LONG SYM NAME
MOVEI T3,0 ;SET WORD TO ZERO FOR RETURN
MOVE T4,[XWD 440600,T3] ;SET SIXBIT BYTE POINTER
;LOOP TO ACCUMULATE AFTER LEADING SPACES & TABS
GETWLP: JUMPE T2,CPOPJ ;EXIT IF TERMINATOR FOUND
CAIL T2,"0" ;LESS THAN 0 ?
CAILE T2,"9" ;LESS THAN OR EQUAL TO 9 ?
JRST GETWD2 ;YES - SEE IF LETTER
JRST GETWD3 ;NO - NUMBER,STORE
; HERE IF NOT A NUMBER
GETWD2: CAIN T2,"_" ;[402] Underline?
JRST GETWD3 ;[402] Yes
CAIN T2,"$" ;[402] Dollar sign?
JRST GETWD3 ;[402] Yes
CAILE T2,"Z"+40 ;ABOVE LOWER CASE RANGE ?
PJRST GETSK1 ;YES - SET BREAK
CAIL T2,"A"+40 ;LOWER CASE ?
TRC T2,40 ;YES - CONVERT TO UPPER CASE
CAIL T2,"A" ;LESS THAN A ?
CAILE T2,"Z" ;LESS THAN OR EQUAL TO Z ?
PJRST GETSK2 ;NON-ALPHA OR NUMERIC IS A DELIMITER
;& RETURN TO CALLER
; HERE IF A LETTER OR NUMBER - CONVERT TO SIXBIT & STORE
GETWD3: SUBI T2,40 ;CONVER TO SIXBIT
TRNE T1,LNAME ;[402] WE HAVE A LONG SYMBOL NAME
JRST GETWD5 ;[402] STORE NEXT CHARACTER IN LONG NAME
TLNN T4,770000 ;[402] OVERFLOWED T3 YET ?
JRST GETWD4 ;[402] YES
IDPB T2,T4 ;NO STORE NEXT SIXBIT CHR.
XCT GETCHR ;GET NEXT CHARACTER
JRST GETWLP ;& CHECK IT
GETWD4: TRO T1,LNAME ;[402] WE HAVE A LONG SYMBOL NAME
MOVEM T3,LSYMBF ;[402] STORE FIRST WORD IN LSYMBF
MOVE P1,[XWD LSYMBF+1,LSYMBF+2] ;[402] CLEAR OUT REST OF LSYMBF
CLEARM LSYMBF+1 ;[402]
BLT P1,LSYMBF+5 ;[402]
MOVE P1,[XWD 440600,LSYMBF+1] ;[402] SET UP BP INTO LSYMBF
GETWD5: IDPB T2,P1 ;[402] STORE SIXBIT CHR.
XCT GETCHR ;[402] GET NEXT CHARACTER
JRST GETWLP ;[402] & CHECK IT
; ROUTINE TO SETUP FOR TRANSFER TO AN EXTERNAL TASK
; GOLOC WILL CONTAIN THE DISPATCH ADDRESS IF SYMBOL FOUND
; ENTER WITH RADIX50 SYMBOL IN T5
; NON-SKIP EXIT IF UNKNOWN SYMBOL
; SKIP EXIT IF OK
FINDST: EXCH T5,SYM ;SAVE FOR EVALUATION BY 'EVAL'
MOVEM T5,SYL ;SAVE SYM
MOVSI T5,GLOBAL ;ONLY GLOBALS
MOVEM T5,SYMASK
PUSHJ P,FINDG ;[321] Find the global
POPJ P, ;NO SUCH SYMBOL
MOVEM T5,GOLOC ;[321] SAVE ADDRESS FOR DISPATCH IN GOLOC
MOVE T5,SYL ;GET THE OLD SYM
MOVEM T5,SYM ;RE-INSTATE SYM
JRST CPOPJ1 ;GOOD RETURN
; ROUTINE TO TRANSFER CONTROL TO AN EXTERNAL TASK
; ASSUMES GOLOC HAS BEEN SET UP BY USE OF SKIPIF MACRO
EXTASK: PUSHJ P,INSRTB ;PUT IN PAUSE REQUESTS
JSP T5,RESTOR ;RESTORE USERS ACS
JRST @GOLOC ;OF YOU GO
; REMOVE BLANKS & TABS
GETSKB: XCT GETCHR ;GET NEXT CHARACTER
GETSK1: CAIE T2," " ;SPACE ?
CAIN T2,11 ;TAB ?
JRST GETSKB ;YES - GET NEXT CHR
GETSK2: CAIN T2,15 ;NO - FOUND NON-BLANK
JRST GETSKB ;IGNORE CR.
CAIE T2,12 ;TEST FOR LINE FEED
CAIN T2,14 ;FORM HAS THE SAME ACTION
JRST TERMLF ;YES - ACTION
CAIE T2,13 ;CONTRL K = EOL
CAIN T2,7 ;BELL - WILL DELIMIT
JRST TERMLF ; NO EXTRA LF
CAIN T2,33 ;TEST FOR ALTMODE
JRST TERNAM ;YES - ACTION
CAIE T2,175
CAIN T2,176
JRST TERNAM
CAIN T2,32 ;TEST FOR ^Z
JRST TERMCZ ;YES - ACTION
CAIE T2," " ;TEST - SPACE
CAIN T2,11 ;ACCEPT TAB
JRST TERMSP ;YES - ACTION
CAIN T2,"!" ;DELIMITER FOR COMMENT
JRST CLRCOM ;YES
MOVEM T2,LSTCHR ;SAVE USERS LAST CHARACTER
POPJ P, ;NO - RETURN
; SET END OF LINE CHR FLAGS
TERNAM: LINE
AOS TERMK ;SET TERMINATOR FLAGS
TERMLF: AOS TERMK
TERMCZ: AOS TERMK
TERMSP: SETZB T2,LSTCHR ;ZERO CHR
POPJ P, ;RETURN
LSTCHR: Z ;USERS LAST CHARACTER
; ROUTINE TO SKIP OVER THE COMMENT
; COMMENT FORMAT IS: ! COMMENT... TO END-OF-LINE
; OR: ! COMMENT !
CLRCOM: TRCE T1,COMDEL ;FIRST !
JRST GETSKB ;NO - END COMMENT - GET NEXT CH
CLRCO1: SETOM TERMK ;PREPARE TEST FOR END OF COMMENT
PUSHJ P,GETSKB ;GET NEXT CH
TRNN T1,COMDEL ;DID WE FIND SECOND !
POPJ P, ;YES - WE GOT NEXT COMMAND CH
JUMPN T2,CLRCO1 ;IF VALID CHAR IGNORE (PART OF COMMENT)
SKIPGE TERMK ;EOL FOUND
JRST CLRCO1 ;NO CONTINUE
TRZ T1,COMDEL ;NOT IN COMMENT PROCESS ANYMORE
POPJ P, ;RETURN TO CALLER
ife tops20,<
loadch: inchwl T2
popj p,>
ifn tops20,<
loadch: push p,T1 ;save T1
pbin% ;read byte from terminal
move T2,T1 ;put it where it belongs
pop p,T1 ;restore T1
popj p,> ;return, end of conditional
ife tops20,<
readcm: closeb
closeb
type( )
pjrst ttyin>
ifn tops20,<
RDPROG: MOVE T5,[PERCSB,,TEMCSB] ;[133] BLT IN COMMAND STATE BLOCK
BLT T5,TEMCSB+.CMGJB ;[133]
HRRZI T5,RDPRG3 ;[133] HACK A COUPLE WORDS IN THE BLOCK
HRRZM T5,TEMCSB ;[133]
MOVE T5,[POINT 7,[ASCIZ /Program name: /]] ;[133]
MOVEM T5,TEMCSB+2 ;[133]
RDPRG2: HRRZI T1,TEMCSB ;[133] INITIALIZE LINE, PROMPT
HRRZI T2,FUNINI ;[133]
COMND% ;[133]
RDPRG3: HRRZI T1,TEMCSB ;[133] READ IN PROGRAM NAME
HRRZI T2,FUNPRG ;[133]
COMND% ;[133]
ERJMP CMDER2 ;[133] ERROR, GO SAY WHY
TLNN T1,(CM%EOC) ;[133]
JRST RDPRG3 ;[133]
HRROI T1,PARBUF ;[133] DO RESCAN SO TTYIN CAN NOW
RSCAN% ;[133] READ BUFFER
HALTF% ;[133]
SETZ T1, ;[133]
RSCAN% ;[133]
HALTF% ;[133]
JRST TTYIN ;[133]
CMDER2: HRROI T1,[ASCIZ /?FDTJSE /] ;[133] ERROR READING PROGRAM NAME
PSOUT% ;[133]
MOVEI T1,.PRIOU ;[133]
HRLOI T2,.FHSLF ;[133]
SETZ 3, ;[133]
ERSTR% ;[133]
JFCL ;[133]
JFCL ;[133]
JRST RDPRG2 ;[133]
readcm: push p,T1
push p,T2
kparse: move T5,[percsb,,temcsb]
blt T5,temcsb+.cmgjb
repars: hrrzi T1,temcsb
hrrzi T2,funini
comnd%
lparse: hrrzi T1,temcsb
hrrzi T2,funkey
comnd%
erjmp cmderr ;[114] error, go say why
tlne T1,(cm%nop)
jrst cmderr ;[114] error, go say why
tlne T1,(cm%eoc)
jrst cgo
hrrzi T1,lparse
hrrzm T1,temcsb
cloop: hrrzi T1,temcsb
hrrzi T2,fungar
comnd%
erjmp cmderr ;[114] error, go say why
tlnn T1,(cm%eoc)
jrst cloop
;[140]This routine removes the trailing
;[140] space from a command line with no args
;[140]TXTIN IS A POINTER TO PARBUF
;[140]TXTOUT IS A POINTER TO NEWBUF
cgo: PUSH P,P1 ;[140]USE P1 AS SCRATCH AC
PUSH P,P2 ;[140]USE P2 AS SCRATCH AC
MOVE P1,[POINT 7,PARBUF] ;[140]INITIALIZE BYTE POINTER TO PARBUF
MOVEM P1,TXTIN
MOVE P1,[POINT 7,NEWBUF] ;[140]INITIALIZE BYTE POINTER TO NEWBUF
MOVEM P1,TXTOUT
LOOKSP: ILDB P1,TXTIN ;[140]GET A CHAR FROM COMMAND LINE
CAIN P1,12 ;[140]TEST FOR LINE FEED
JRST DORSCN ;[140]DO THE RSCAN WITH EXISTING BUFFER(PARBUF)
CAIN P1,14 ;[140]TEST FOR FORM FEED
JRST DORSCN ;[140]DO THE RSCAN WITH EXISTING BUFFER(PARBUF)
CAIN P1," " ;[140]TEST FOR A SPACE
JRST SPFND ;[140]SPACE FOUND
IDPB P1,TXTOUT ;[140]NOT A SPACE, WRITE CHAR TO NEW BUFFER
JRST LOOKSP ;[140]CONTINUE TRANSFER OF CHARS
SPFND: ILDB P1,TXTIN ;[140]GET A CHARACTER
CAIN P1," " ;[140]TEST FOR A SPACE
JRST SPFND ;[140]SPACE FOUND, IGNORE
CAIN P1,11 ;[140]TEST FOR A TAB
JRST SPFND ;[140]TAB FOUND, IGNORE
CAIN P1,15 ;[140]TEST FOR CARRIAGE RETURN
JRST CLRSC3 ;[140]FOUND, WRITE IT AND LF
CAIN P1,12 ;[140]TEST FOR LINE FEED
JRST CLRSCN ;[140]FOUND, SET UP CALL TO RSCAN WITH NEWBUF
CAIN P1,14 ;[140]TEST FOR FORM FEED
JRST CLRSCN ;[140]FOUND, SET UP CALL TO RSCAN WITH NEWBUF
CAIN P1,"!" ;[140]TEST FOR COMMENT DELIMITER
JRST FLUSHC ;[140]COMMENT FOUND-SKIP OVER IT
;[140]IF WE'RE HERE, MUST HAVE A COMMAND ARG
;[140]TRANSFER REMAINING PART OF LINE VERBATIM
MOVEI P2," " ;[140]BUT FIRST, WRITE A SPACE
IDPB P2,TXTOUT ;[140] TO SEPARATE COMMAND FROM ARG
TRANSF: IDPB P1,TXTOUT ;[140]NOW WRITE FIRST CHAR OF ARG OUT
ILDB P1,TXTIN ;[140]GET NEXT CHAR OF COMMAND LINE
CAIN P1,12 ;[140]TEST FOR LINE FEED
JRST LFORFF ;[140]FOUND, STORE LF OR FF IN NEW BUFFER
CAIE P1,14 ;[140]TEST FOR FORM FEED
JRST TRANSF ;[140]NOT FOUND, WRITE CHAR OUT
;[140]CONTINUE TRANSFER UNTIL A LF/FF IS FOUND
LFORFF: IDPB P1,TXTOUT ;[140]STORE LF OR FF IN NEW BUFFER
JRST CLRSC2 ;[140]SET UP CALL TO RSCAN WITH NEW BUFFER
FLUSHC: ILDB P1,TXTIN ;[140]GET FIRST CHAR OF COMMENT
CAIN P1,12 ;[140]TEST FOR LINE FEED
JRST CLRSCN ;[140]FOUND,SET UP CALL TO RSCAN WITH NEWBUF
CAIN P1,14 ;[140]TEST FOR FORM FEED
JRST CLRSCN ;[140]FOUND,SET UP CALL TO RSCAN WITH NEWBUF
CAIN P1,"!" ;[140]TEST FOR END OF COMMENT
JRST SPFND ;[140]FOUND, GET NEXT CHARACTER
JRST FLUSHC ;[140]CONTINUE SKIPPING OVER COMMENT
CLRSC3: IDPB P1,TXTOUT ;[140]WRITE OUT CR
MOVEI P1,12 ;[140]GET SET TO WRITE OUT LF TO NEWBUF
CLRSCN: IDPB P1,TXTOUT ;[140]WRITE OUT LINE FEED TO NEWBUF(NEW BUFFER)
CLRSC2: MOVEI P1,0 ;[140]WRITE OUT NULL BYTE TO NEW BUFFER
IDPB P1,TXTOUT
MOVE P1,[XWD NEWBUF,PARBUF] ;[140]TRANSFER (NEWBUF) TO (PARBUF)
BLT P1,PARBUF+^D19 ;[140] FOR FORDDT'S PARSING MECHANISM
DORSCN: HRROI 1,PARBUF ;[140]SET UP PTR TO DO RSCAN
POP P,P2 ;[140]RESTORE P2
POP P,P1 ;[140]RESTORE P1
rscan%
haltf%
setz T1,
rscan%
haltf%
pop p,T2
pop p,T1
pjrst ttyin
cmderr: hrroi 1,[asciz /?FDTJSE /] ;[126] start with prefix message
psout% ;[126] type it
movei 1,.priou ;[114] send message to terminal
hrloi 2,.fhslf ;[114] this fork,,last error
setz 3, ;[114] no char limit
erstr% ;[114] type error message
jfcl
jfcl
jrst repars ;[114] continue parsing
>
; SUBROUTINE TO READ EITHER A SYMBOL OR A CONSTANT FROM USER
; PUSHJ P,EITHER
; RETURN WITH CONSTANT IN T5
; RETURN SYMBOL VALUE IN T5
; IN ALL CASES T2=USERS LAST CHARACTER
;
; ADDITIONALY ENTER AT SIXIN TO ACCEPT LEFT JUSTIFIED SIXBIT
; IF USERS LEADING CHARACTER IS ALPHA
SIXIN: TRO T1,ALPHA ;THIS MODIFIES EITHER
EITHER: SETOM TERMK
CLEARM SYL
CLEARM DEN
TDZ T0,[XWD FPF!FEF!MF!SIGN!OCTF,POWF] ;REMOVE THE UNWANTED FLAGS
EITHR2: XCT GETCHR ;READ USER INPUT
CAIE T2," " ;TILL NO BLANKS
CAIN T2,11 ;OR TABS
JRST EITHR2
PUSHJ P,GETSK2 ;TEST FOR DELIMITER
JUMPE T2,BADSYN
CAIL T2,"A"+40 ;ACCEPT LOWER CASE
CAILE T2,"Z"+40 ;CHARACTERS
JRST .+2 ;IS NOT
TRC T2,40 ;IS - CONVERT TO UPPER CASE
CAIL T2,"A"
CAILE T2,"Z"
;**** NUMERIC INPUT ****
JRST [TRZ T1,ALPHA ;NO LONGER NEEDED
XCT GETNUM ;CLEAR FLAGS
PUSHJ P,EITHR3 ;MUST BE A CONSTANT
JRST EITHR4] ;NON SKIP RETURN
TRZE T1,ALPHA ;ARE WE TRAPPING ALPHA
JRST SIXIN2 ;YES
;**** SYMBOLIC INPUT ****
;SIMULATE A CALL OF SYMIN
RECURS <DIMTOT,T0,PUTTER,RP,SAVLOC,SYM,MATHSM,TEM,TEM1,DIMCNT,S4,FRMSAV>
TRZ T0,DOUBLE ;ONLY THE BASE ARRAY IS ALLOWED TO BE REAL*8
PUSHJ P,EITHR5 ;SYMBOL
PUSHJ P,SYM2 ;ALLOW FOR OFFSET
JRST ERR6 ;NOT DEFINED
JRST BADSYN
SRUCER ;POP BACK ALL SAVED LOCATIONS
JRST CPOPJ1 ;SYMBOL VALUE SKIP RETURN
SIXIN2: PUSHJ P,EITHR5 ;CONTINUE AS TTYIN
JRST CPOPJ1 ;DO A SYMBOL RETURN
;ROUTINE TO CONVERT FROM RADIX 50 TO SIXBIT ;[402] New
; Inputs addr of Radix50 in T5
R50SIX: PUSH P,T2
PUSH P,P1
CAIE T5,OPENED
JRST R50SX1
MOVE T2,[POINT 6,TMPOPN];SET UP BYTE POINTER FOR SIXBIT
XMOVEI P1,TMPOPN
SETZM TMPOPN ;Clear for sixbit
JRST R50SX2
R50SX1: MOVE T2,[POINT 6,TMPNAM];SET UP BYTE POINTER FOR SIXBIT
XMOVEI P1,TMPNAM
SETZM TMPNAM ;Clear for sixbit
R50SX2: PUSH P,P1 ;Save addr where sixbit will be put stored
MOVE T5,(T5) ;Get radix50 in T5
TLZ T5,PNAME ;Clear flags
PUSHJ P,R50S1 ;Convert leaving sixbit in T3
POP P,T5 ;Store address of sixbit name in T5
TLO T5,10000 ;Set count to 1 word
POP P,P1
POP P,T2
POPJ P,
R50S1: PUSH P,T5
R50S6: POP P,T5 ;RESTORE T5 = SYMBOL
XMOVEI P1,R50S4 ;SPECIAL TREATMENT FOR LAST CHARACTER
PUSH P,P1 ;SAVE ON STACK
R50S3: TLZ T5,PNAME ;RADIX 50 PART ONLY
IDIVI T5,50
PUSH P,P1
JUMPE T5,[SETOM P1
JRST .+2]
PUSHJ P,R50S3
POP P,T5 ;[300]
;T5 IS A RAD50 CHARACTER - CONVERT TO SIXBIT
CAMGE T5,[SQUOZE 0,A] ;less than rad50 'A'
JRST [ADDI T5,17 ;We have a digit
JRST SIXB] ;
CAMG T5,[SQUOZE 0,Z] ;greater than rad50 'Z'
JRST [ADDI T5,26 ;We have a letter
JRST SIXB] ;
;Check for "."
CAIN T5,[SQUOZE 0,.]
JRST [MOVEI T5,"."-" ";We have a dot
JRST SIXB] ;
;We now have either "$" or "%" ("%" should be changed to "_")
SUBI T5,42 ; Convert "$" and "%" to sixbit
CAIN T5,"%"-" " ;
MOVEI T5,"_"-" " ;We have an underline
SIXB: JUMPL P1,R50S7 ;FIRST TIME ROUND IS SPECIAL
EXCH T5,SAVCHR ;SAVE AS LAST CHARACTER
PJRST SSIXB ;DISPLAY CHARACTER
R50S4: MOVE T5,SAVCHR ;GET BACK THE LAST CHARACTER
; JUMPN P1,CPOPJ ;DO WE TYPE THE LAST CHARACTER
PJRST SSIXB ;YES
R50S7: CAIL T5,"0"
CAILE T5,"9"
TDZA P1,P1 ;ZERO IF FIRST CHAR NOT NUMERIC
HRRZI P1,-1 ;.GT. ZERO IF FIRST CHAR IS NUMERIC
MOVEM T5,SAVCHR ;SAVE LAST CHARACTER
POPJ P,
SSIXB: IDPB T5,T2 ;Store sixbit character
POPJ P,
;ROUTINE TO CONVERT FROM SIXBIT TO RADIX 50
; CALL PUSHJ P,SIX250 WITH 6BT IN T3
; RETURNS HERE WITH RAD 50 IN T4
; N.B. USES: T2/T3/T4/T5/P1
SIX250: MOVE T2,[POINT 6,T3] ;SET UP BYTE POINTER FOR 6BT
SETZI T4, ;CLEAR FOR RAD 50
MOVEI P1,50 ;SET UP TO FORM RADIX 50
SIXMOR: ILDB T5,T2 ;GET NEXT 6BT BYTE
JUMPE T5,CPOPJ ;EXIT IF ZERO=LAST BYTE
CAIL T5,20 ;ACCEPT NUMERALS
CAILE T5,31 ;
JRST NOTNUM ;[402] NOT NUMERIC MAY BE ALPHA
SUBI T5,17 ;CONVERT TO RAD 50
JRST R50CHR ;STORE
NOTNUM: CAIGE T5,41 ;[402] IS IT ALPHA
JRST .+3 ;[402] No to small
CAIG T5,72 ;[402]
JRST LETR ;[402] Yes it is a letter
CAIN T5,77 ;[402] Is it "_"
JRST [MOVEI T5,47 ;[402] translate "_" to rad50 "%"
JRST R50CHR] ;[402]
CAIE T5,4 ;[402] Is it "$"
JRST BADSYN ;CANT CONVERT
MOVE T5,[SQUOZE 0,$] ;[402] We have "$" - make it rad50
JRST R50CHR ;[402]
LETR: SUBI T5,41-13 ;MAKE RAD 50
R50CHR: IMULI T4,(P1) ;MOVE UP LAST ENTRY
ADDI T4,(T5) ;UP DATE WITH NEW CHARACTER
TLNE T2,770000 ;DONE 6 BYTES?
JRST SIXMOR ; NO
POPJ P, ; YES
; ROUTINE TO CHECK THAT WE HAVE A LEGAL FORTRAN VARIABLE
; AND CONVERTS FROM 6 BIT LEFT JUSTIFIED IN T3 TO RAD 50 IN T4
VALID: MOVE T2,[POINT 6,T3] ;GET FIRST CHARACTER
ILDB T4,T2 ; IN T4
CAIL T4,41 ;
CAILE T4,72 ;ALPHA ONLY
JRST ERR5 ; NOT F40
PUSH P,T2 ;[402] save T2
TRNE T1,LNAME ;[402] Did we get a long name?
JRST VALID1 ;[402] Yes
SKIPN SSTAB ;[402] Do we have a secondary symbol table?
JRST VAL0 ;[402] No - no long names
HLRZ T2,@SSTAB ;[402] Flag in left half of @SSTAB = 0
;[402] if we have an incomplete symbol table
SKIPE T2 ;[402] Do we have a complete symbol table
JRST VAL1 ;[402] YES - LONG NAME
;[402] WE HAVE SHORT SYMBOL
VAL0: POP P,T2 ;[402] No, convert to rad 50
JRST SIX250 ;[402]
VAL1: ;[402] CHANGE SHORT SYMBOL INTO LONG SYMBOL
TRO T1,LNAME ;[402] WE HAVE A LONG SYMBOL NAME
MOVEM T3,LSYMBF ;[402] STORE FIRST WORD IN LSYMBF
MOVE P1,[XWD LSYMBF+1,LSYMBF+2] ;[402] CLEAR OUT REST OF LSYMBF
CLEARM LSYMBF+1 ;[402]
BLT P1,LSYMBF+5 ;[402]
MOVE P1,[POINT 6,LSYMBF+1] ;[402] SET UP BP INTO LSYMBF
;[402] WE HAVE LONG SYMBOL
VALID1: MOVEI T2,1 ;[402]
FLLCNT: SKIPE LSYMBF(T2) ;[402]Count number of words in T2
JRST [AOJ T2, ;[402]
JRST FLLCNT] ;[402]
LSH T2,CNTSFT ;[402]
XMOVEI T4,LSYMBF ;[402]ptr to name
IOR T4,T2 ;[402]T4 = length+ptr
POP P,T2 ;[402] restore t2
POPJ P, ;[402]
; SUBROUTINE TO CHECK THAT ALL 6BIT CHARACTERS IN T3 ARE NUMERIC
; CALL PUSHJ P,ALLNUM
; NOT ALL NUMERIC
; ALL NUMERIC WITH P APPENDED IF A LABEL OR # IF SOURCE LINE
ALLNUM: MOVE T4,[POINT 6,T3] ;GET POINTER TO INPUT
ALLMOR: ILDB T2,T4 ;GET NEXT 6BIT CHAR
JUMPE T2,ALLEX ;ALL DONE
CAIL T2,20 ;TEST WITHIN RANGE
CAILE T2,31 ; OF NUMERALS 6BT
JRST ALLIN ;NO - SEE IF WE HAVE A SOURCE LINE
TLNE T4,770000 ;ALL 6 CHARS NUMERIC??????
JRST ALLMOR ; NO - SO DO MORE
JRST BADSYN ; YES - OO NASTY
ALLIN: TLZE T0,LABEL ;ARE WE ALREADY PROCESSING LABEL INFO.
JRST BADSYN ;YES - ANOTHER # MUST BE REJECTED
MOVEI T2,"#" ;SEE IF THE USER IS TRYING TO GIVE LINE#
CAME T2,LSTCHR ;WAS A # HIS LAST CHARACTER
JRST CPOPJ ;NO USEFUL CHARACTERS TYPED - MAYBE GROUP#
JRST BADSYN ;YES - COMPLAIN ABOUT PRECEDING GARBAGE
ALLEX: TLZN T0,LABEL ;ARE WE PROCESSING SOURCE LINES
JRST ALLFRM ;NO - SEE IF A FORMAT
MOVEI T2,'L' ;YES - GET THE SOURCE LINE TAG
DPB T2,T4 ;CONVERT TO THE FORM FORTRAN RECOGNISES
JRST CPOPJ1 ;EXIT AS ALL NUMERIC FROM USER
ALLFRM: MOVEI T2,'P' ;SET UP FOR A LABEL
DPB T2,T4 ;CONVERT TO THE STANDARD FORTRAN FORM
JRST CPOPJ1 ;DO AN ALL NUMERIC EXIT
; ROUTINE TO GET NEXT USER SYMBOL AND RETURN
; THE RADIX 50 SYMBOL NAME IN SYM
; SYMBOL = NAME[V1/V2,..](V3,..), . .
; 7 DELIMITERS ARE ALLOWED AFTER SYMBOL ] ) / . , - =
; V1-V2 V1, V1(V2) V1(V2/V3) V1[V2] V1= V1.LT.V2
; ^ ^ ^ ^ ^ ^ ^
; CALL PUSHJ P,SYMIN
; RETURN NOT FOUND
; STATEMENT NO.
; VARIABLE T5=VALUE OF SYMBOL
; T2=LAST CHARACTER
; SUBFLG IS SET IF ARRAY NAME ONLY FOUND
SYMIN: TLZ T0,LABEL ;CLEAR LABEL PROCESSING FLAG
SETZM MATHSM ;CLEAR SYMBOL SAVE
SETZM CRYSYM ;[217] AND POSSIBLE CHARACTER ARRAY
PUSHJ P,TTYIN ;GET USER SYMBOL
JUMPN T3,SYM12 ;NO CHARACTERS - MAYBE SOURCE LINE OR GROUP SPEC.
CAIE T2,"#" ;IS THE USER ATTEMPTING TO SPECIFY A SOURCE LINE
JRST SYM4 ;NO! - WELL MAYBE A GROUP REQUEST
TLO T0,LABEL ;REMEMBER THIS IS A SOURCE LINE REQUEST
PUSHJ P,TTYIN ;GET USERS NEXT INFO.
JUMPE T3,BADSYN ;ZERO CHARACTERS HERE IS BAD
SYM12: PUSHJ P,ALLNUM ;SEE IF USER TYPED ALL NUMERIC
JRST SYM2 ;NO - MUST BE A VARIABLE
MOVE T2,LSTCHR ;REINSTATE USERS LAST CHAR
CAIE T2,"," ;SEE IF A KNOWN DELIMITER FOLLOWS
JUMPN T2,BADSYN ;ANY OTHER CHARACTER IS ILLEGAL
PUSHJ P,SIX250 ;CONVERT SYMBOL TO RADIX 50
TLOA T0,LABEL ;SET THE LABEL PROCESSING FLAG
; MULTIPLY RECURSIVE CALLS ARE MADE TO HERE BY ROUTINE EITHER
SYM2: PUSHJ P,VALID ;TEST FOR A TRUE F40 VARIABLE FROM USER
STSYM T4,MATHSM ;[402]SAVE FOR LOOK
MOVEM T4,SYM ;EVAL NEEDS IT HERE
TRZE T1,DCEVAL ; ? CALL EVAL
POPJ P, ;NO DON'T
PUSHJ P,EVAL ;'EVAL'UATE THE SYMBOL NAME
POPJ P, ;SYMBOL NOT FOUND
SKIPN CRYSYM ;[217] ALREADY HAVE A SAVE?
MOVEM P1,CRYSYM ;[217][157]No. Save addr/RAD50 name
MOVEM T5,SAVLOC ;SAVE THE VALUE OF THE SYMBOL
TLNE T0,LABEL ;DID WE HAVE A LABEL?
JRST SYM3 ;YES - GO PROCESS
CLEARM SUBSCR ;ZERO THE OFFSET
PUSH P,T1 ;[402]Save T1
PUSHJ P,RAYNAM ;DO WE KNOW ABOUT THIS ARRAY
JRST SYM2A ;NOT DEFINED
POP P,T1 ;[402]
TRO T1,IMPRNG!ARRAY.;FLAG AS A POSSIBLE RANGE CONDITION
CAIA ;[402]
SYM2A: POP P,T1 ;[402]
MOVE T2,LSTCHR ;GET BACK LAST CHAR SEEN
SYM7: JUMPE T2,SYM3 ;SEE IF WE HAD A LEGAL DELIMITER
CAIE T2,"[" ;[ MEANS WE HAVE AN ARRAY DEFINITION TO FOLLOW
JRST SYM13 ;OBVIOUSLY NOT AN ARRAY DEFINITION
TLO T0,LFTSQB ;FLAG A [ SEEN - ] MUST END DEFINITION
PUSHJ P,DIMIN ;GET NEW DEFINITION
PUSHJ P,GETSKB ;MOVE ON TO NEXT CHARACTER
JRST SYM7 ;GO BACK TO PROCESS MORE INPUT
SYM13: CAIE T2,"(" ;THE ONLY OTHER ALLOWED CHARACTER IS (
JRST SYM6 ;CHECK FOR OTHER DELIMITERS
TRZ T1,IMPRNG ;NO LONGER AN IMPLIED RANGE
SETZM DIMTOT ;CLEAR FOR TOTAL ELEMENT COUNT
SETZM PUTTER ; AND VARIOUS WORDS IN CASE
; SETZM RANGE ;[157]Reset range stuff
; SETZM CLMRNG ;[157]
; SETZM RANLIM ;[157]
MOVEI T5,1 ; WE GET AN ARRAY DEFINITION
MOVEM T5,RP
PUSHJ P,RAYNAM ;HAS THIS SYMBOL AN ARRAY REFERENCE?
JRST SYM11 ;[401] CHECK FOR SUBSTRING
TRO T0,SUBFLG ;YES - REMEMBER TO CHECK ITS SUBSCRIPTS
SYM10: PUSHJ P,EITHER ;GET EITHER SYMBOL OR # FROM USER
CAIA ;NUMERIC
MOVE T5,(T5) ;SYMBOL - GET VALUE
TRNE T0,SUBFLG ;DO WE CHECK SUBSCRIPTS FOR THIS ARRAY
JRST SYM8 ; PROCESS SUBSCRIPTS
JUMPL T5,.+2 ;AUTO CORRECTION ON -VE #
SUBI T5,1 ;CORRECT FOR A=A(1)
; NO MORE SUBSCRIPTS - CHECK DELIMITERS
SYM9: MOVEM T5,SUBSCR ;SAVE THE NEW OFFSET, WATCH ILL MEM REFS
CAIE T2,")" ;RIGHT PARENS MUST DELIMIT THE NO.
JRST BADSYN ; THIS WONT DO EITHER!
TRZE T0,SUBFLG ;ARE WE CHECKING SUBSCRIPTS?
PUSHJ P,SUBCHK ;YES - CHECK THERE ARE NO MORE TO FOLLOW
XCT GETCHR ;GET NEXT CHARACTER
PUSHJ P,GETSK2 ;GET NEXT CHARACTER
CAIE T2,"(" ;[401]
JRST SYM6
;[401] Get lower bound of substring
SYM11: PUSHJ P,EITHER ;[401]GET EITHER SYMBOL OR # FROM USER
JRST [JUMPN T5,SYM11A ;[401]DID WE GET A CONSTANT?
MOVEI T5,1 ;[401]LOWER BOUND WAS NOT SPECIFIE
JRST SYM11A] ;[401]DEFAULT VALUE IS 1
MOVE T5,(T5) ;[401]SYMBOL - GET VALUE
SYM11A: MOVEM T5,SSLOW ;[401]Save for lower bound OFFSET
MOVE T2,LSTCHR ;[401] GET BACK LAST CHAR SEEN
CAIE T2,":" ;[401] SUBSTRING NEEDS ":" AFTER LOWER BOUND
JRST BADSYN ;[401]
;[401] get upper bound
PUSHJ P,EITHER ;[401]GET EITHER SYMBOL OR # FROM USER
JRST [MOVEM T4,TEM4 ;[401] save T4
MOVE T4,SAVLOC ;[401] base variable for substring
MOVE T4,1(T4) ;[401] char count
JUMPN T5,SYM11B ;[401]DID WE GET A CONSTANT?
MOVE T5,T4 ;[401]UPPER BOUND WAS NOT SPECIFIED
JRST SYM11B] ;[401]DEFAULT VALUE IS descripter length
MOVE T5,(T5) ;[401]SYMBOL - GET VALUE
MOVEM T4,TEM4 ;[401] save T4
MOVE T4,SAVLOC ;[401] base variable for substring
MOVE T4,1(T4) ;[401] char count
SYM11B: MOVEM T5,SSUP ;[401]Save for upper bound OFFSET
;[401] check for upper bound out of range
CAMGE T5,SSLOW ;[401] upper bound >= lower bound
JRST BADBND ;[401] upper bound too small
CAMLE T5,T4 ;[401] check upper bound is not too big
JRST BADBND ;[401] upper bound too big
;[401] check for lower bound out of range
SKIPG SSLOW ;[403] lower bound > 0
JRST BADBND ;[403] No, lower bound too small
MOVE T4,TEM4 ;[401] restore T4
MOVE T5,SAVLOC ;[401]
MOVE T2,LSTCHR ;[401]GET BACK LAST CHAR SEEN
CAIE T2,")" ;[401]RIGHT PARENS MUST DELIMIT THE NO.
JRST BADSYN ;[401] THIS WONT DO EITHER!
XCT GETCHR ;[401]GET NEXT CHARACTER
PUSHJ P,GETSK2 ;[401]GET NEXT CHARACTER
SKIPE SUBSCR ;[401]
JRST SYM6 ;[401]
JUMPE T2,CPOPJ2 ;[401]
CAIE T2,"," ;[401]WE ALLOW COMMA OR DOT
CAIN T2,"." ;[401]
JRST CPOPJ2 ;[401]ACCEPT DELIMITER
CAIN T2,"=" ;[401]
JRST CPOPJ2 ;[401]ACCEPT DELIMITER
CAIE T2,"/" ;[401]
CAIN T2,":" ;[401]EQUIV TO "/"
SKIPA ;[401]
JRST BADSYN ;[401]
;[401]NO - THEN THE / SHOULD MEAN A PRINT MODIFIER
TRZE T1,ACCPT ;[401]UNLESS AN ACCEPT IS IN PROGRESS
JRST CPOPJ2 ;[401]TEST FOR AN IMPLIED RANGE
PUSHJ P,OPTION ;[401]GET THE PRINT MODIFIERS
JRST BADSYN ;[401]NUMERICS
JRST CPOPJ2 ;[401]
SYM6: JUMPE T2,SYM3 ;DELIMITER IS GOOD
CAIE T2,"," ;WE ALLOW COMMA OR MINUS AT THIS STAGE
CAIN T2,"-" ;
JRST SYM3 ;ACCEPT DELIMITER
CAIE T2,"." ;DOT IS ALLOWED FOR .LT. IN IF'S
CAIN T2,"=" ;= IS ALLOWED FOR ACCEPT (INLINE)
JRST SYM3
CAIE T2,"]" ;] IS A DELIMITER FOR [A(1)]
CAIN T2,")" ;) IS A DELIMITER FOR SUBSCRIPTS
JRST SYM3 ;
CAIE T2,"/" ; / IS A DELIMITER FOR DIMENSIONS
CAIN T2,":" ; EQUIV TO "/"
CAIA
JRST BADSYN ;ALL ELSE LOOSES
TRNE T0,SUBFLG!SURGFL ;IF HANDLING SUBSCRIPTS
JRST SYM3 ;YES
;NO - THEN THE / SHOULD MEAN A PRINT MODIFIER
TRZE T1,ACCPT ;UNLESS AN ACCEPT IS IN PROGRESS
JRST SYM3 ;TEST FOR AN IMPLIED RANGE
PUSHJ P,OPTION ;GET THE PRINT MODIFIERS
JRST BADSYN ;NUMERICS ????
JRST SYM3
; TIDY UP BEFORE EXIT
SYM3: MOVE T5,SAVLOC ;GET THE SYMBOL VALUE
TRZE T0,FORMAL ;WAS THE BASE A FORMAL ARRAY PARAMETER
;[BL] Character arrays will never be FORMALS /ahm/
SKIPE T5,FRMSAV ;YES - START AT THE FORMAL ADDRESS
CAIA
JRST ERR38 ;UNLESS IT'S ZERO
MOVE T2,LSTCHR ;RESTORE USERS LAST CHARACTER
TLZE T0,LABEL ;SKIP IF SYMBOL+SUBSCRIP TO PROCESS
JRST CPOPJ1 ;STATEMENT EXIT
ADD T5,SUBSCR ;CORRECT SYMBOL VALUE TO WHAT USER ASKED FOR
TRZE T0,DOUBLE ;[112] IS THIS A DOUBLE WORD ARRAY
ADD T5,SUBSCR ;YES - SO GIVE HIM DOUBLE
TRNN T0,CHARS ;[157]Character string?
JRST CPOPJ2 ;[157]NO
MOVE T5,SAVLOC ;[157]T5 has been munged
MOVE T3,SUBSCR ;[157]Get offset
MOVEM T3,CLMOFF ;[157]Save for OFFSET
JRST CPOPJ2 ;AND LET HIM HAVE IT!
; HERE TO HANDLE ARRAY SUBSCRIPTS
SYM8: MOVEM T5,S1 ;SAVE TEMPORARILY
PUSHJ P,GETDIM ;GET RANGE OF CURRENT DIMENSION
MOVE T5,S1 ;PREPARE TO TEST UPPER SUBSCRIPT LIMIT
SUB T5,TEM1 ;IF IN RANGE - SHOULD BE NEGATIVE
JUMPG T5,ERR23 ;IF NOT COMPLAIN - SUBSCRIPT ERROR
MOVE T5,S1 ;GET USERS SUBSCRIPT VALUE
SUB T5,TEM ;REMOVE OFFSET
JUMPL T5,ERR23 ; SHOULD BE POSITIVE AFTER REMOVING OFFSET
IMUL T5,RP ;INCREASE BY CURRENT RANGE PRODUCT
ADDB T5,DIMTOT ;STORE TOTAL ELEMENT COUNT
MOVE T2,LSTCHR ; AND LAST USER CHARACTER
CAIE T2,"," ;MORE SUBSCRIPTS?
JRST SYM9 ;NO - RETURN TO NORMAL PROCESSING
MOVE S1,TEM1 ;PREPARE TO UPDATE
SUB S1,TEM ; RANGE PRODUCT
AOJ S1, ; WITH NEW RANGE
IMULM S1,RP ; LIKE SO
JRST SYM10 ;LOOK FOR NEW SUBSCRIPT
; ROUTINE OPTION
; TO READ THE USERS PRINT MODIFIER SWITCH SETTINGS
; CALL PUSHJ P,OPTION
; RETURN1 NUMERIC FOUND = GROUP
; RETURN2 P3(RH)=PRINT OPTIONS T2=USERS LAST CHAR.
OPTION: TRO P3,ANYMOD ;FLAG FIRST TIME THROUGH THIS SCAN
OPTN2: PUSHJ P,SIXIN ;ACCEPT SIXBIT
POPJ P, ;NON SKIP RETURN WITH NUMERIC IN T5
JUMPE T3,BADSYN ;NO CHARACTERS
TRZE P3,ANYMOD ;FIRST MODIFIER?
HLLZ P3,P3 ;CLEAR FOR NEW MODIFIERS
LDB T3,[POINT 6,T3,5] ;GET THE FIRST CHARACTER OF THE SWITCH
CAIN T3,'A' ;ASCII?
TRO P3,A.!ANYMOD ;
CAIN T3,'O' ;OCTAL
TRO P3,O.!ANYMOD ;
CAIN T3,'R' ;RASCII
TRO P3,R.!ANYMOD ;
CAIN T3,'S' ;SOURCE LINE TRACE OPTION?
TRO P3,S.!ANYMOD ;
CAIN T3,'C' ;[157][164]Character string?
TRO P3,C.!ANYMOD ;[157][164]
TRZ P3,B. ;[120] IGNORE /BIG FOR THE REST
CAIN T3,'X' ;[157]COMPLEX?
TRO P3,X.!ANYMOD ;[157]
CAIN T3,'D' ;DOUBLE
TRO P3,D.!ANYMOD ;
CAIN T3,'F' ;FLOATING
TRO P3,F.!ANYMOD ;
CAIN T3,'I' ;INTEGER
TRO P3,I.!ANYMOD ;
CAIN T3,'L' ;[120] LOGICAL
TRO P3,L.!ANYMOD ;[120]
CAIN T3,'B' ;[120] 'BIG' ?
TRO P3,B.!ANYMOD ;[120] 'BIG' OPTION
CAIN T3,'E' ;TRACE ENTRIES OPTION
TRO P3,E.!ANYMOD ;
TRZN P3,ANYMOD ;ANY MODIFIERS SEE - NO MEANS:
JRST BADSYN ;NO KNOWN MODIFIER
JUMPE T2,OPTN3 ;END OF OPTIONS FLAGS IN T5
CAIN T2,"," ;ALSO END OF OPTIONS DELIMITER
JRST OPTN3 ;SKIP RETURN
CAIE T2,"/" ;MORE MODIFIERS ?
JRST BADSYN ;NO - NO OTHER MODIFIERS ALLOWED
PJRST OPTN2 ;GET MORE
OPTN3: TRNN P3,C.!A.!X.!D.!F.!I.!O.!R.!L.
;[120] [157][164]ANY PRINT MODIFIERS SET UP?
TRO P3,F. ;NO - SO SET UP FLOATING AS DEFUALT
JRST CPOPJ1 ;GOOD RETURN
; SUBROUTINE TO DETERMINE IF WE HAVE AN ACCEPTABLE LABEL
; ENTER WITH THE ADDRESS OF RAD50 SYMBOL IN P1
; CALL PUSHJ P,TRULBL
; RETURN NOT GOOD
; RETURN ACCEPTABLE LABEL . . I.E. LABEL = ###X WHERE X .EQ. P OR L
; TRULST = LAST CHARACTER OF LABEL
TRULBL: PUSHJ P,SAV2AC ;SAVE AC T3 T5,P1
TRZ T1,GUDLBL ;CLEAR THE GOOD LABEL FLAG
MOVE T5,(P1) ;GET THE SYMBOL
CAIG T5,50 ;SINGLE CHARACTER CAN NOT BE A LABEL
POPJ P, ;RESTORE T5,P1
TLZ T5,PNAME ;SYMBOL NAME ONLY
IDIVI T5,50 ;GET LAST CHARACTER
MOVEM P1,TRULST ;SAVE FOR LATER
TRU3: JUMPE T5,TRU6 ;ALL CHARACTERS SEPERATED IF T5=0
IDIVI T5,50 ;GET NEXT CHAR.
CAIL P1,1 ;IS THIS CHARACTER
CAILE P1,12 ; NUMERIC?
POPJ P, ; NO - LABEL NOT VALID
JRST TRU3 ;YES - GET NEXT CHARACTER
TRU6: TRO T1,GUDLBL ;FLAG A GOOD LABEL SO FAR
MOVE P1,TRULST ;GET BACK LAST CHARACTER
CAIE P1,26 ;WAS THE LAST CHARACTER AN 'L'
CAIN P1,32 ;OR A 'P'
AOS -3(P) ;EITHER WILL BE ACCEPTABLE - SO SKIP
POPJ P, ;IF NEITHER THEN REJECT LABEL
; SUBROUTINE TO DETERMINE IF THE SYMBOL JUST FOUND IS A TRUE
; F10 VARIABLE
; ENTER WITH THE ADDRESS OF RADIX 50 SYMBOL IN P1
; CALL PUSHJ P,TRUVAR
; RETURN1 NOT A GOOD VARIABLE
; RETURN2 STANDARD F10 VARIABLE
TRUVAR: PUSHJ P,SAV2AC ;SAVE ACS P1,T5
TRNE T1,LNAME ;[402] Long symbol
JRST TLVAR ;[402] Yes
MOVE T5,(T2) ;GET THE SYMBOL
TLZ T5,PNAME ;SYMBOL NAME ONLY
IDIVI T5,50 ;GET THE FIRST CHARACTER
MOVEM T5+1,TRUFST ;SAVE IT
JRST TRUV2
TRUV1: JUMPE T5,TRUV3 ;LOOKED AT ALL CHARACTERS OF SYMBOL?
IDIVI T5,50 ;NO - GET NEXT CHARACTER
TRUV2: CAIGE P1,1 ;ENSURE WE HAVE ONLY NUMERIC OR
CAMG T5,[SQUOZE 0,$] ;[402] ALPH CHARS, percent or dollar sign
JRST TRUV1 ;OK SO FAR
POPJ P, ;BAD CHARACTER FOR VARIABLE
TRUV3: CAML P1,[SQUOZE 0,A] ;CHECK THAT THIS FIRST CHARACTER OF
AOS -3(P) ; THE SYMBOL IS ALPHA
POPJ P, ;OTHERWISE JUST NON SKIP RETURN
MOVE T5,(T2) ;GET THE SYMBOL
TLZ T5,PNAME ;SYMBOL NAME ONLY
IDIVI T5,50 ;GET THE FIRST CHARACTER
MOVEM T5+1,TRUFST ;SAVE IT
JRST TRUV2
;[402] Determine if long symbol just found is a true variable
TRLVAR: PUSHJ P,SAV2AC ;SAVE ACS P1,T5
MOVE T5,(P1) ;GET THE CNT+PTR to SYMBOL
SKIPA
TLVAR: MOVE T5,(T2) ;GET THE CNT+PTR to SYMBOL
PUSH P,T3 ;Save T3 and T4
PUSH P,T4
MOVE T3,T5
TLZ T3,LFLG ;clear flag bits
LSH T3,-CNTSFT ;Get word count-1 in T3
IMULI T3,6 ;character count
MOVE T4,[POINT 6,(T5)] ;Get Bytepointer to symbol
ILDB P1,T4 ;Get first character
MOVEM P1,TRUFST ;Save it
SOJ T3, ;Decrement character count
CAMGE P1,41 ;>= A
JRST TRULV4 ;Non-alphabetic
CAMLE P1,72 ;<= Z
JRST TRULV4 ;Non-alphabetic
TRULV1: ILDB P1,T4 ;Get next character
SOJLE P1,TRULV3 ;DONE if end of last word
JUMPE P1,TRULV3 ; or no more character in this word
TRULV2: CAMGE P1,20 ; >= 0
JRST [CAIN P1,4 ;IS IT DOLLAR SIGN - OK SO FAR
JRST TRULV1 ;YES
JRST TRULV4] ;NO - BAD CHARACTER FOR VARIABLE
CAMG P1,31 ; <= 9
JRST TRULV1 ;IT IS NUMERIC - OK SO FAR
CAMGE P1,41 ; >= A
JRST TRULV4 ;BAD CHARACTER FOR VARIABLE
CAMG P1,72 ; <= Z
JRST TRULV1 ;IT IS ALPHA - OK SO FAR
CAIN P1,77 ;IS IT UNDERLINE?
JRST TRULV1 ;YES - OK SO FAR
JRST TRULV4 ;BAD CHARACTER FOR VARIABLE
TRULV3: AOS -5(P) ;GOOD SYMBOL
TRULV4: POP P,T4
POP P,T3
POPJ P, ;OTHERWISE JUST NON SKIP RETURN
; ROUTINE TO DISPLAY ASCII TEXT AS '.....'
; ENTER WITH EACH CHARACTER IN T5
ASCOUT: JUMPE T5,ASCNUL ;HAVE WE A NULL?
CAIN T5,177 ;DELETE IS SPECIAL
JRST ASCDEL ;TYPE <DEL>
CAIL T5,173 ;MAYBE AN ESCAPE CHARACTER
JRST ASCAPE ;YES
CAIL T5,40 ;LESS THAN 40 = CONTROL CHARACTER
IFN TOPS20,<
JRST ASCASC ;NEVER FLAG IF RUNNING UNDER TOPS20
>;END IFN TOPS20
IFE TOPS20,<
JRST ASCUP ;PERHAPS LOWER CASE?
>;END IFE TOPS20
type(^)
ADDI T5,100 ;MAKE ASCII
ASCASC: putchr (T5) ;TYPE AS ASCII
POPJ P, ;DONE
IFE TOPS20,<
ASCUP: SKIPE TTYLC ;IF TTY LC IS ON, DON'T FLAG
CAIG T5,140 ;LOWER CASE?
JRST ASCASC ;JUST GOOD OLD ASCII
type(')
JRST ASCASC ;TYPE AS ASCII
>;END IFE TOPS20
ASCNUL: type(<<NUL>>)
POPJ P,
ASCDEL: type(<<DEL>>)
POPJ P,
ASCAPE: openb
PUSH P,P1 ;SAVE AROUND OCTAL PRINT
PUSHJ P,TYP4 ;TYPE OCTAL
POP P,P1 ;RESTORE REMAINDER OF OUTPUT
closeb
POPJ P,
; ROUTINE TO ACCEPT THE MAIN PROGRAM NAME FROM USER
; UP TO 31 CHARACTERS
; CALL PUSHJ P,GETPRG
; RETURN1 NEVER
; RETURN2 RADIX 50 PROGRAM NAME IN T5 (name <= 6characters)
; CNT,,PTR IN T5 (long names)
GETPRG:
IFE TOPS20,< ;[133]
LINE
TYPE(Program name: )
PUSHJ P,TTYIN> ;[133]GET THE INPUT
IFN TOPS20,< ;[133]
PUSHJ P,RDPROG> ;[133] GET THE PROGRAM NAME
SKIPN T3 ;?IS THERE A SYMBOL
JRST BADPRG ;[133] NO - ERROR
PUSHJ P,VALID ;CHECK FOR BEGINNING LETTER AND CONVERT
;TO RADIX 50
MOVEM T4,SYM ;Symbol to be found
TRNE T1,LNAME ;[402] Looking for long symbol name?
JRST [MOVSI T2,LPNAME ;[321] Search for
MOVEM T2,SYMASK ;[321] the
PUSHJ P,FINDLG;[402] Yes
JRST NFND ;[402] Not found
JRST FND] ;[402]
MOVSI T2,GLOBAL ;[321] Search for
MOVEM T2,SYMASK ;[321] the
PUSHJ P,FINDG ;[321] global
NFND: JRST [PUSHJ P,DISP9 ;NOT THERE
PUSHJ P,CLRLIN ;[133] GET RID OF ANY JUNK
JRST GETPRG] ;TRY AGAIN
FND: HLRZ T2,(T5) ;WHERE IS THE USER ATTEMPTING TO START
CAIE T2,(JFCL) ; - ON A JFCL = F10 START
JRST ERR10 ;YOU CANT START HERE
JRST CPOPJ1 ;SKIP RETURN
SUBTTL ERROR ROUTINES
;BAD SYNTAX GIVEN BY USER
;OUTPUTS MESSAGE & REPROMPTS ,ALSO CLEARS TYPE IN BUFFER
;CALL PJRST BADSYN
BADSYN: LINE
TYPE(?FDTIAF Illegal argument format )
PUSHJ P,ENDLIN ;TYPE OUT REST OF USER LINE
LINE
TYPE(Type H for help)
LINE
JRST RET
NOLONG: LINE
TYPE(?FDTNLS Long symbols truncated - Program not compiled with DEBUG switch ) ;[402]
LINE ;[402]
JRST CPOPJ ;[402]
BADBND: LINE ;[401]
TYPE(?FDTIAF Substring bounds out of range ) ;[401]
PUSHJ P,CLRLIN ;[401]clear any junk
LINE ;[401]
JRST RET ;[401]
BADPRG: TYPE(?FDTIPN Illegal program name) ;[133]
PUSHJ P,CLRLIN ;[133] CLEAR ANY JUNK
JRST GETPRG ;[133] TRY AGAIN
ERR1: LINE
TYPE(?FDTMSN More subscripts needed)
JRST DIM1 ;TYPE THE DIMENSIONS FOR ARRAY(SAVLOC)
ERR2: TYPE(?FDTBOI Bad octal input )
JRST ERRR7 ;SHOW REST OF BAD LINE
ERR3: LINE
TYPE (<?FDTLGU >)
PUSHJ P,TYPRAY ;TYPE THE OFFENDING ARRAY NAME
TYPE(< lower subscript .GE. upper>)
JRST RET
ERR4: TYPE(<%FDTNST Not 'START'ed>) ;'START' INITS FORDDT AND RESETS THE OTS
JRST RET
ERR5: TYPE (<?FDTNFV >)
MOVE T2,T3 ;GET USERS SYMBOL
PUSHJ P,OUT6 ;DISPLAY
TYPE (< is not a FORTRAN variable>)
LINE
SKIPE PRGNAM ;RETURN TO GETPRG IF NO PROGRAM NAME YET
JRST RET
PUSHJ P,CLRLIN
JRST GETPRG
ERR6: PUSHJ P,DISP9 ;
JRST RET
DISP9: TYPE (<?FDTBDF >)
MOVE T5,SYM ;SET UP FOR RADIX 50 PRINT
PUSHJ P,SPT2 ;[201] RADIX 50 PRINT
TRNN T0,MDLCLF ;MULTIPLY DEFINED?
JRST [type(< is undefined>)
JRST dispx]
TYPE(< is multiply defined>)
dispx: POPJ P,
ERR7: TYPE(<?FDTINV Invalid value >)
ERRR7: PUSHJ P,ENDLIN ;TYPE REST OF USER LINE
JRST RET
ERR8: TYPE(<?FDTNFS Cannot find FORTRAN start address for >)
MOVE T5,SYM
PUSHJ P,SPT1
JRST BEGIN2 ;TRY AGAIN
ERR9: TYPE(<?FDTPRO Too many PAUSE requests>)
JRST RET
ERR10: TYPE(<?FDTCSH Cannot 'START' here>)
PUSHJ P,CLRLIN
JRST GETPRG ;TRY ANOTHER PROGRAM NAME
ERR11: TYPE(<?FDTNDT DDT not loaded>)
JRST RET
ERR12: TYPE(<?FDTCFO Core file overflow>)
JRST RET
ERR13: TYPE(<?FDTFCX Format capacity exceeded >)
ER13: TYPE(<please re-type>)
JRST RET
ERR14: TYPE(<?FDTICC Compare of two constants is not allowed>)
JRST RET
ERR15: TYPE(<?FDTIGN Invalid group number>)
JRST RET
ERR16: TYPE (<?FDTLNF >)
MOVEI P1,SYM
PUSHJ P,SPT
TYPE (< is not a format statement>)
POPJ P,
ERR17: TYPE (<?FDTNSP >)
LDSYM T5,PNAMSV ;[402]
PUSHJ P,SPT1
TYPE(< no such PAUSE>)
JRST RET
ERR18: TYPE(<?FDTCCN Cannot continue>)
JRST RET
ERR19: TYPE(<?FDTNPH Can't insert a PAUSE here>)
JRST RET
ERR20: TYPE(<%FDTNSL No symbols loaded>)
POPJ P,
ERR21: TYPE(?FDTDNA Double precision comparisons not allowed) ;[113]
PUSHJ P,CLRLIN ;[113]
JRST RET ;[113]
ERR22: LINE
TYPE(?FDTTMS Too many subscripts)
PUSHJ P,CLRLIN ;[403]ZERO REMAINDER OR USER LINE
JRST RET ;[403]TYPE THE DIMENSIONS FOR THE (SAVLOC) ARRAY
ERR23: LINE ;SUBSCRIPT OUT OF RANGE
TYPE(?FDTSER Subscript error)
PUSHJ P,CLRLIN ;ZERO REMAINDER OR USER LINE
JRST RET ;[403]DISPLAY ARRAY DIMENSIONS
ERR24: TYPE(?FDTNAL Not allowed) ;ATTEMP TO MODIFY NON LOCAL VARIABLES
JRST RET ;OR START ON A FORMAT STATEMENT
ERR26: TYPE (?FDTNUD )
MOVE T5,SYM
PUSHJ P,SPT1
TYPE( not a user defined array)
JRST RET
ERR27: LINE
TYPE (<?FDTSTL >)
PUSHJ P,TYPRAY ;TYPE THE OFFENDING ARRAY NAME
TYPE(< size too large>)
JRST RET
ERR28: TYPE(<%FDTSCA Supersedes compiled array dimension>)
JRST PUTOK ;NOW PLACE THE NEW DEFINITION
ERR30: TYPE(<?FDTNAR Not after a re-enter>)
JRST RET
ERR31: LINE
TYPE(<%FDTXPA Attempt to exceed program area with >)
MOVE T5,SYM ;DISPLAY BASE SYMBOL
PUSHJ P,SPT2 ;[201] DISPLAY SYMBOL
AOS T5,SUBSCR ;SHOW USER WHAT SUBSRIPT HE ATTEMPTED TO USE
TYPE(<[>)
PUSHJ P,TFLOT ;TYPE IT
TYPE(])
JRST RET
ERR32: type(?FDTPAR Parentheses required)
JRST ER13
ERR33: LINE
TYPE (<?FDTFNR >)
MOVE T5,SYM ;GET THE ARRAY NAME
PUSHJ P,SPT2 ;[201] TYPE IT
TYPE(< is a formal and may not be re-defined>)
PUSHJ P,FLUSHA ;FLUSH THE LOT
JRST RET
ERR34: TYPE (<%FDTNAA >) ;[106]
MOVEI P1,SYM
PUSHJ P,SPT ;TYPE SYMBOL
TYPE (< is not an array>)
JRST RET
ERR35: TYPE (<%FDTSPO Variable is single precision only>)
JRST RET
ERR36: TYPE (<?FDTNGF Cannot GOTO a FORMAT statement>)
JRST RET
ERR37: LINE
TYPE (?FDTITM Illegal TYPE modifier - S)
JRST RET
ERR38: TYPE (?FDTFNI Formal not initialized)
JRST RET
ERR39: LINE
TYPE (?FDTRGR Recursive group reference)
JRST RET
ERR40: LINE
TYPE (?FDTIRS Illegal range specification)
JRST RET
ERR41: LINE
TYPE (?FDTMCD Compile program with the DEBUG switch to type a format statement)
JRST RET
ERR42: LINE ;[401]
TYPE (?FDTACA ACCEPTing character variable with mode A or R) ;[401]
JRST RET ;[401]
; THIS PAGE HOLDS ERROR MESSAGES FOR INTERNAL ERRORS OF FORDDT. KEEP
;SIMILAR MESSAGES ON THIS PAGE SO THAT THEY ARE EASY TO LOCATE.
E1: TYPE (?FDTIER Internal FORDDT error - 1)
JRST WT5
E2: TYPE (?FDTIER Internal FORDDT error - 2)
JRST BREAK4
;*E3: TYPE (?FDTIER Internal FORDDT error - 3)
;*E4: TYPE (?FDTIER Internal FORDDT error - 4)
E5: TYPE (?FDTIER Internal FORDDT error - 5)
JRST DMFLSH ;REMOVE RECENT ADDITIONS TO DIMTAB
E6: TYPE (?FDTIER Internal FORDDT error - 6)
JRST RE.L3
E7: TAB
TYPE (?FDTIER Internal FORDDT error - 7)
JRST STEP6
E8: LINE
TYPE (?FDTIER Internal FORDDT error - 8)
JRST RET
;[321] E9: TYPE (?FDTIER Internal FORDDT error - 9)
;[321] JRST RET
;COMMAND ERRORS
ERROR: type(?FDTURC Unrecognized command )
MOVE T2,T3 ;PREPARE TO TYPE USER COMMAND
PUSHJ P,OUT6 ;TYPE IT
line ;TIDY
JRST RET ;RESTORE ACS AND RETURN TO MAIN LOOP
NOTUNQ: type(?FDTCNU The command )
MOVE T2,T3 ;PREPARE TO TYPE USER COMMAND
PUSHJ P,OUT6 ;TYPE IT
type( is not unique)
line ;TIDY UP
JRST RET ;RESTORE ACS & RETURN TO MAIN LOOP
SUBTTL PROMPT MESSAGES
CRLF: ASCIZ /
/
;[327] Removed BLDVEC
SUBTTL VARIABLE STORAGE
NMBFSZ==^D13 ;[177][127] BUFFER SIZE
NUMBUF: BLOCK NMBFSZ ;[127] STORAGE BUFFER FOR NUMBER TO BE DECODED
STKYFL: TRLINE ;STICKY FLAGS REMAIN SET WHEN F IS CLEARED
FRMSAV: BLOCK 1 ;REFFERS TO THE FORMAL ARRAY BASE
RANGE: BLOCK 1 ;INDICATES RANGE OF VALUES A(1)-A(?)
SYMSAV: BLOCK 1 ;SAVE EVAL POINTER TO LAST SYMBOL
SYL: BLOCK 1
LWT: BLOCK 1
DEN: BLOCK 1
DIMCNT: BLOCK 1 ;COUNT OF THE # OF DIMENSIONS FOR F10 ARRAY
ESCAPE: -1 ;NON ZERO MEANS NO ^C IN EFFECT SO ESCAPE ALLOWED
REENTR: 0 ;NON-ZERO IF REENTER HAS BEEN DONE
STARTU: 0 ;[316] User's start address
IFN TOPS20,<
EXTEND: Z ;[300] FLAG TO INDICATE RUNNING IN A NON-ZERO SECTION
DDTVEC: BLOCK 2 ;[300] 2 WORD ENTRY VECTOR HOLDING LOCATION
;[300] ARGUMENT BLOCK FOR GET JSYS
GTBLK: GT%BAS ;[300] .GFLAG
Z ;[300] .GLOW
Z ;[300] .GHIGH
Z ;[300] .GBASE
>
;[327] Removed FOSYM.,FNDVEC,FNDVSZ
JOBSA: BLOCK 1 ;THESE THREE LOCATIONS ARE USED TO PRESERVE
JOBSYM: BLOCK 1 ; THE INITIAL STATE OF THE PROGRAM - SO THAT
; OVERLAYS CAN BE DETECTED
JOBNAM: BLOCK 1 ;SIXBIT NAME OF PROGRAM OR OVERLAY
IFE TOPS20,<
TTYLC: BLOCK 1 ;RETURNED BY .TOLCT TRMOP. LOWERCASE SET/UNSET
>;END IFE TOPS20
MODFLG: F. ;HOLDS THE CURRENT TYPE OPTION FLAGS
JOBBRK: BLOCK 1 ;STORES THE CURRENT EXECUTION POINTER
PRGM: BLOCK 1
SAVCHR: BLOCK 1 ;TEMP SAVE OF CHARACTER
TRUFST: BLOCK 1 ;SAVE FIRST CHARACTER OF A SYMBOL
LOKFST: BLOCK 1 ;DITTO EXCEPT USED BY LOOK
TRULST: BLOCK 1 ;SAVE LAST CHARACTER OF A SYMBOL
TROFFS: BLOCK 1 ;[215] TRACE OFFSET WHEN NO LOCALS
MATHSM: BLOCK SYMSPC ;[402]USED BY "LOOK" TO RESOLVE MULTIPLE DEF
LSYMBF: BLOCK 7 ;[402] HOLDS LONG NAME IN 6BIT +1 NULL WORD
SYM: BLOCK 1
SYMASK: BLOCK 1 ;MASK FOR SYM TBL SYMBOL (FOR FINDG)
BESTVA: BLOCK 1 ;BEST VALUE FOUND FOR LOKSYM
LASYM: BLOCK 1 ;LAST SYMBOL FOUND BY LOKSYM
LASVAL: BLOCK 1 ;LAST VALUE CALLED TO LOKSYM
OJBSYM: BLOCK 1 ;'OUR JBSYM' USED FOR SYM TABLE ROUTINES
SAVT3: BLOCK 1 ;TEMPORARY SAVE OF T4
PRGNAM: BLOCK SYMSPC ;[402]SET TO NAME OF CURRENT MAIN PROGRAM
;CAIA APPEARS HERE
HELLO: PUSH 17,0 ;IDENTIFIES HELLO MACRO USEAGES
BASRAY: BLOCK 1 ;ARRAY BASE NAME(VALUE)
SAVLOC: BLOCK 1 ;GENERAL SAVE LOCATION
QLPNT: BLOCK 1 ;USED IN "QLIST" AS POINTER TO A SYMBOL
QLPNAM: BLOCK 1 ;[402] PTR TO LONG PROGRAM NAME IN "QLIST"
STPCNT: BLOCK 1 ;STEP COUNT - HOW MANY LINES TO TRACE
OPENED: SQUOZE 0,MAIN. ;HOLDS CURRENTLEY OPENED PROGRAM NAME
BLOCK SYMSPC-1 ;[402]
SSTAB: BLOCK 1 ;[402] PTR TO SECONDARY SYMBOL TABLE
OPENLS: BLOCK 1 ;HOLDS SUB-SET OF JBSYM FOR OPENED PROGRAM
OPENLZ: BLOCK 1 ;[321] Length of OPEN module symbol table
OLDOPN: BLOCK SYMSPC ;PROG THAT WAS OPEN BEFORE GROUP REQUEST
GOLOCF: BLOCK 1 ;[300] FLAG WORD OF DBL-WD PC
GOLOC: BLOCK 1 ;HOLDS E.T.V. TO EXTERNAL ROUTINES
SSLOW: BLOCK 1 ;[401] LOWER SUBSTRING BOUND
SSUP: BLOCK 1 ;[401] UPPER SUBSTRING BOUND
SUBSCR: BLOCK 1 ;HOLDS ARRAY SUBSCRIPT VALUE
COUNT: BLOCK 1
JOBOPC: BLOCK 1 ;HOLDS .JBOPC IF WE ARE IN A RE-ENTER
PNAMSV: BLOCK SYMSPC ;STORES NAME OF SECTION OF NEAREST MATCH TO SYMBOL
RANLIM: BLOCK 1 ;HOLDS CURRENT PROGRESS IN A RANGE CONDITION
TABCNT: BLOCK 1 ;COUNTS THE # OF LABELS/LINE IN TRACE
COMAND: BLOCK 1 ;HOLDS USER COMMAND SIXBIT
PUTTER: BLOCK 1 ;STORES END OF CURRENT DIMENSION LIST
DIMTOT: BLOCK 1 ;STORES TOTAL ELEMENT COUNT
RP: BLOCK 1 ;HOLDS RANGE PRODUCT FOR ARRAY ELEMENT CALCULATION
SECSAV: BLOCK 1 ;HOLDS SECTION NAME
FSV: BLOCK 1
FH: BLOCK 1
SAVPI: BLOCK 1
B0ADR: BLOCK 3 ;[313] FOR BREAKPOINT ZERO
B1ADR: BLOCK 1
B1SKP: BLOCK 1
B1CNT: BLOCK 1
BPNCR2=.-B1ADR ;[300]
BLOCK NBP*BPNCR2-BPNCR2 ;[300]
BNADR=.-3
AUTOPI: BLOCK 1
;[157]**********DO NOT SEPARATE CLMPTR & CLMSIZ******************
ORIGLM: BLOCK 1 ;[157]Save first element ptr
ORIGOF: BLOCK 1 ;[157]Original element offset
CLMPTR: BLOCK 1 ;[157]Character array element BP
CLMSIZ: BLOCK 1 ;[157]Character element size
CLMOFF: BLOCK 1 ;[157]Char.elem...offset from array base
CLMRNG: BLOCK 1 ;[157]Char.elem...upper range offset
CRYSYM: BLOCK 1 ;[157]Addr Rad50 name of array
F10RP: BLOCK 1 ;[163]switch to indicate /debug dimension info
SAVACS: BLOCK 20 ;[325]User's ACs saved here
SARS: BLOCK 1
TEM: BLOCK 1
TEM1: BLOCK 1
TEM2: BLOCK 1
TEM3: BLOCK 1 ;TEMP STORAGE
TEM4: BLOCK 1 ;TEMP STORAGE
TEM5: BLOCK 1 ;TEMP STORAGE
TEM6: BLOCK 1 ;TEMP STORAGE
TEM7: BLOCK 1 ;TEMP STORAGE
TEM8: BLOCK 1 ;[321] Search value for LOKSYM
TEM9: BLOCK 1 ;[321] Table length for LOKSYM
TEM10: BLOCK 1 ;[340] Temp in START and ACCEPT
TEM11: BLOCK 1 ;[340] Temp in PAUSE and ACCEPT
TEM12: BLOCK 1 ;[402] Temp in LOOKLP
TEM13: BLOCK 1 ;[402] Temp in LOK2
TEM14: BLOCK 1 ;[402] Temp in LOK2
SAVT2: BLOCK 1 ;[402] Temp in LOK2 - holds value of T2
LSAVT2: BLOCK 1 ;[402] Temp in LOK2 - LONG eqv of SAVT2
LSAVT4: BLOCK 1 ;[402] Temp in LOK2 - LONG eqv of TEM9
LBESTV: BLOCK 1 ;[402] Temp in LOK2 - LONG eqv of BESTVA
LSAVP1: BLOCK 1 ;[402] Temp in LOK2 - LONG eqv of P1
TMPNAM: BLOCK 1 ;[402] Holds PNAMSV converted to 6bit from R50
TMPOPN: BLOCK 1 ;[402] Holds OPENED converted to 6bit from R50
TMPSAV: BLOCK 2 ;[313] TMP IN INSRTB
IFN TOPS20,<
TMPSV1: BLOCK 1 ;[313] TMP IN INSRTB
>
PAUFLG: BLOCK 1 ;[331] ZERO IF NOT A PAUSE ON ERROR
;[331] ELSE CONTAINS ADDR OF ERROR IN USER PGM
BP0FLG: BLOCK 1 ;[145] NON-ZERO = USER "CALL"ED FORDDT
;[145] - = BEFORE FIRST PROMPT,
;[145] + = AFTER FIRST PROMPT
STPVAL: BLOCK 1 ;HOLDS THE DEFAULT TRACE COUNT
PDL: BLOCK PDSIZ+1 ;[327] Push-down list for initialization
TERMK: BLOCK 1 ;FLAG FOR LINE TERMINATOR
;-1=SP 0=^Z 1=LF 2=ALTMODE
DELCHR: 0 ;SAVED DELIMITER FOR ASCII ACCEPT AND CLRLIN
IFE TOPS20,< ;[115]
MRGACS: BLOCK 20 ;[115] ACS DURING MERGE UUO
> ;[115]
ifn tops20,<
percsb: lparse ;[114]command state block (permanent)
.priin,,.priou
point 7,[byte(7)76,76,0]
point 7,parbuf
point 7,parbuf
^d80
^d80
point 7,paratm
^d80
0
temcsb: block 12 ;command state block (temporary)
parbuf: block 20 ;parsing buffer
paratm: block 20 ;atom buffer
NEWBUF: BLOCK 20 ;[140]MODIFIED PARSING BUFFER
TXTOUT: BLOCK 1 ;[140]POINTER TO NEWBUF-USED IN COMMAND
;[140] SCANNING.
TXTIN: BLOCK 1 ;[140]POINTER TO PARBUF-ALSO USED IN
;[140] COMMAND SCANNING.
FUNPRG: <.CMTXT>B8!CM%HPP!CM%SDH ;[133] BLOCK FOR READING PROGRAM NAME
0
POINT 7,[ASCIZ /Program name as specified in PROGRAM statement/]
0
funini: <.cmini>b8 ;init block for parse
0
0
0
funkey: <.cmkey>b8 ;keyword block for parse
keytab
0
0
fungar: <.cmtxt>b8!cm%hpp!cm%sdh ;rest of line block for parse
0
point 7,[asciz/command arguments/]
0
keytab: 24,,24 ;keyword table
[asciz/ACCEPT/],,0
[asciz/CHARACTER/],,0
[asciz/CONTINUE/],,0
[asciz/DDT/],,0
[asciz/DIMENSION/],,0
[asciz/DOUBLE/],,0
[asciz/GOTO/],,0
[asciz/GROUP/],,0
[asciz/HELP/],,0
[asciz/LOCATE/],,0
[asciz/MODE/],,0
[asciz/NEXT/],,0
[asciz/OPEN/],,0
[asciz/PAUSE/],,0
[asciz/REMOVE/],,0
[asciz/START/],,0
[asciz/STOP/],,0
[asciz/STRACE/],,0
[asciz/TYPE/],,0
[asciz/WHAT/],,0
> ;end of conditional
XLIST ;LITERALS
LIT
LIST
-1,,0 ;[404] Argument list for ERRSET
ERRARG: 400300,,[377777777777] ;[404] Maximum number of error
;[404] messages from ERRSET.
IFN DEBUG <
PATCH: BLOCK 50 ;PATCHING SPACE
>
IF2,<
PURGE ERJMP,JRSTF,RESET,SAVE,XMOVEI
>
;IFE DEBUG <XPUNGE> ;DELETE SYMBOLS
IFE TOPS20,<
DDTEND: END SFDDT> ;Tops-10 doesn't have entry vectors
IFN TOPS20,<
DDTEND: END 3,,ENTVEC> ;Tops-20 has entry vectors