Trailing-Edge
-
PDP-10 Archives
-
FORTRAN-10_V7wLink_Feb83
-
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 ,7(176)
SUBTTL P.E.T. HARDING/DBT/FLD/MD/JMT/MA/SJW/JNG/DCE/BPK/CKS/DCC/BAH/BL 11-Jan-83
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1973, 1983
;
;
;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==176 ;EDIT NO
VERSION==7 ;MAJOR VERSION NO
VMINOR==0 ;MINOR VERSION NO
VWHO==0 ;WHO LAST EDITED
.JBDDT=74
.JBREN=124
.JBVER=137
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
; 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 [SETMI] ;[147] define XMOVEI for -10
> ;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
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 Revision History *****
\;END OF COMMENT
SUBTTL DEFINITIONS
;DEFINE ACCUMULATORS
ENTRY FORDDT,FDDT.,.F10,%FDDT
EXTERN .JBREL,.JBHRL,.JBSYM,.JBHSM,.JBSA,.JBUSY,.JBOPC,.JBDA
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
;DEFINE SYMBOL TABLE SYMBOL TYPES
GLOBAL==040000 ;GLOBAL SYMBOL
LOCAL==100000
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%CHR==15 ;[157] Character
FO$HSP==4 ;[142] FOR RETURNING HISEG SYBOL TABLE PTR.
; DEFINE SYSTEM PARAMETERS
IFNDEF NBP,<NBP==^D10> ;NUMBER OF PUASE REQUESTS
IFNDEF GPMAX,<GPMAX==10> ;NUMBER OF GROUP STRINGS (MAX 35 )
IFNDEF PDSIZ,<PDSIZ==10*GPMAX+40> ;DEFINE PDL SIZE TO ALLOW ALL GROUPS TOGETHER
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 TWO WORD PAIRS
USED TO HOLD ARRAY DIMENSION DATA
\
;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 ;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
FPRNM== 000002 ; FIND PROGRAM NAME (FOR FNDSYM)
FLCLNM==000001 ; FIND LOCAL IN CURRENT OPEN PROGRAM (FOR FNDSYM)
;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 LOKSYM AND FNDSYM - 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
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 TF ***
;
; TF 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
; *** FLAG TMOD ***
;
; DEFINE THE PRINT OPTION FLAGS USED IN LEFT & RIGHT OF TMOD
; RIGHT HAND - DEFAULT USER SETTING
; LEFT 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
;[157]C.==000100 ;TYPE COMPLEX FORM
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 F - "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
; ? E9 INTERNAL INCONSISTENCY (FNDSYM)
; THESE ERRORS SHOULD NEVER OCCUR - BUT COULD INDICATE THAT
; THE SYMBOL TABLE HAD BEEN MODIFIED(OVERLAYED?) OR SOMETHING
SUBTTL MACRO'S
DEFINE SETPDL ;SETUP PDL STACK
< MOVE P,[IOWD PDSIZ,PDL] >
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,tf
hrroi tf,[asciz/x/]
psout%
pop p,tf >
define atype(x)
< push p,tf
hrroi tf,x
psout%
pop p,tf >
define stype(x)
< push p,tf
hrroi tf,[asciz x]
psout%
pop p,tf >
define line
< push p,tf
hrroi tf,[byte(7)15,12,0]
psout%
pop p,tf >
define openp
< push p,tf
hrrzi tf,"("
pbout%
pop p,tf >
define closep
< push p,tf
hrrzi tf,")"
pbout%
pop p,tf >
define openb
< push p,tf
hrrzi tf,74
pbout%
pop p,tf >
define closeb
< push p,tf
hrrzi tf,76
pbout%
pop p,tf >
define tab
< push p,tf
hrrzi tf,11
pbout%
pop p,tf >
define putchr(x)
< push p,tf
move tf,x
pbout%
pop p,tf >
> ;end of conditional
DEFINE SKIPIF(STRING) ;IS STRING LOADED? - SKIP IF IT IS
< MOVE T,[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 T,[SQUOZE 0,NAME]
MOVEM T,SYM
TLO F,FPRNM
PUSHJ P,FNDSYM >
; 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 T
< 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]
; This is the entry point when FORDDT is first run. All
; initialization procedures are performed, including a call
; to FOROTS' RESET.
SFDDT: JSR SAVE ;[145] SAVE THE WORLD
PUSHJ P,REMOVB ;REMOVE ANY STANDING PAUSE REQUESTS
LINE
TYPE(STARTING FORTRAN DDT)
LINE
MOVEI T,RE.ENT ;AND SET UP THE RE-ENTER ADDRESS
MOVEM T,.JBREN ;SO THAT FUTURE RE ENTERS WILL WORK
JSP 16,RESET.## ;[143] INITIALISE THE FOROTS SYSTEM
0,,0 ;[142] DUMMY RESET ARG
FORDD1: PUSHJ P,GHSSYP ;[142] ANY HISEG SYMBOLS?
SKIPGE .JBSYM ;NO, ANY LOSEG SYMBOLS?
CAIA
PUSHJ P,ERR20 ;NO - WARN USER
PUSHJ P,SETLST ;SETUP SYM TABLE LISTS
HRRZ T,.JBSA ;REMEMBER THE START ADDRESS
MOVEM T,JOBSA ; AND THE
MOVE T,.JBSYM ; SYMBOL TABLE DETAILS AT THE-
MOVEM T,JOBSYM ; TIME FORDDT IS ENTERED
ife tops20,< ;This hack doesn't work under TOPS20
MOVE T,[XWD -1,3] ;GET THE CURRENT JOB
GETTAB T, ; NAME
CAIA ;DON'T PANIC IF NO JOB NAME
MOVEM T,JOBNAM ;AND SAVE,
;THIS WILL SERVE TO DETECT OVERLAYS
SETZM TTYLC ;[151] DEFAULT TO DON'T FLAG LOWERCASE
MOVNI T6,1 ;[151] GET CURRENT JOB'S CONTROLLING TERMINAL UDX
TRMNO. T6, ;[151]
JRST FORDD2 ;[151] ERROR. DEFAULT TO NO FLAGGING OF LOWERCASE
MOVEI T5,.TOLCT ;[151] TRMOP. FUNCTION TO READ LOWERCASE SETTING
MOVE T,[2,,T5] ;[151] SET UP TRMOP. CALL
TRMOP. T, ;[151]
JRST FORDD2 ;[151] ERROR. ASSUME LOWERCASE. DOESN'T FLAG LC
MOVEM T,TTYLC ;[151] STORE THE SETTING
FORDD2: ;[151]
> ;END OF IFE TOPS20
HRRZI T,[JRST RET] ;GUARD AGAINST CONTINUE AFTER CNTRL C
HRRM T,PROC0
MOVEI T,1 ;RESET THE INITIAL TRACE VALUE
MOVEM T,STPVAL ; TO ONE
MOVE T,STARTU
HLLZM T,STARTU ;RESET - SO 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: SETPDL
SKIPIF (CEXIT.) ;
SETZM T ;NO CLUDGE CONECTIONS IN THIS PROG
HRRM T,HELLO ;SET UP FOR HELLO MACRO DETECTOR
MOVE F,STKYFL ;REINSTATE THE FLAG REGISTER
;[137] This routine provides g-floating
;[137] capability to those programs
;[137] compiled with the /gfl switch.
TRZ F,GFLOAT ;[137] Default to d-floating mode.
TRO TF,FGLONL ;[137] Search for globals only in sym table
MOVE TT1,[SQUOZE 0,..GFL.] ;[137] Store "..GFL." in SYM for EVAL
MOVEM TT1,SYM
PUSHJ P,EVAL ;[137] Search symbol table for "..GFL."
JRST FSET ;[137] Not found, mode is d-floating; done
MOVE F,STKYFL ;[137] Found, reinstate the flag reg(in case
;[137] F was modified by EVAL)
TRO F,GFLOAT ;[137] Set GFLOAT flag to get g-floating
MOVEM F,STKYFL ;[137] Update sticky flag store.
FSET: MOVSI T,(JFCL) ;RESET THE TRACE ENTRY
MOVEM T,FDDT. ;
MOVE T,M2.F ;GET THE FOROTS FIN CALL
MOVEM T,M2.I ;RE-INSTATE IN FORMAT - AFTER COMPLEX INPUT
; SET THE DEFAULT TYPING FORMAT TO FLOATING - ALSO SET STKYFL
MODRET: HRRZI T,F. ;SET UP TO TYPE FLOATING FORM
MOVEM T,MODFLG ;SAVE AS THE STANDARD DEFAULT
MODRT2: HRRZ T,STARTU ;[176]SEE IF ALREADY STARTED;
JUMPN T,RET ;YES LEAVE ANY OPENED SECTIONS ALONE
SKIPE PRGNAM ;HAS ANY SECTION BEEN OPENED?
JRST RET ;YES - SO NOT FIRST TIME THROUGH
PROGIF (MAIN.) ;SKIP IF MAIN. IS LOADED
BEGIN2: PUSHJ P,GETPRG ;NOT FOUND - GET THE MAIN PROGRAM NAME
MOVE T3,[SQUOZE 0,MAIN.]
TLZ T3,PNAME ;[155]strip bits in case it's a global
MOVEM T3,PRGNAM ;DEFAULT MAIN PROG NAME IS MAIN.
MOVEM T3,SYM ;SET SO SETNAM CAN OPEN THE MAIN PROGRAM
PUSHJ P,SETNAM ;'OPEN' THE MAIN PROGRAM
SUBTTL USER INPUT
RET: HRRZ TMOD,MODFLG ;SET UP THE DEFAULT TYPING OPTIONS ONLY
AND F,[STIKYS] ;MAKE SURE WE SAVE THE GOOD FLAGS
MOVEM F,STKYFL ; IN THE STICKY STORE
SETZI TF, ;RESET THE TEMPORARY FLAGS
SKIPGE TERMK ;END OF LAST LINE SEEN?
PUSHJ P,CLRLIN ;CLEAR OUT THE REST OF USERS LINE
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,tf ;save tf
push p,r ;save r
hrrzi tf,.priou ;get terminal output designator
rfmod% ;get terminal JFN word
tlz r,(tt%osp) ;clear ^o effects
hrrzi tf,.priou ;get terminal output designator
sfmod% ;set new JFN word
pop p,r ;restore r
pop p,tf> ;restore tf, end of conditional
LINE
PUSHJ P,OVRLAY ;HAS AN OVERLAY OCCURED
pushj p,readcm ;prompt and read user command
JUMPE T2,RET ;NO SIGNIFICANT INFORMATION
MOVEM T2,COMAND ;SAVE USER COMAND
JUMPN T1,BADSYN ;COMMAND TERMINOLOGICAL INEXACTITUDE
SKIPGE T1,TERMK ; SPACE IS NOT EOL
TLZA F,EOL ;CLEAR EOL FLAG
TLO F,EOL ;SET EOL FLAG
;NOW SEE WHAT USER WANTS!
; ENTER WITH SIXBIT USER COMMAND IN T2
;
; EXIT TO COMMAND IF RECOGNISED AND UNIQUE, OTHERWISE
; DISPATCH TO UNKNOWN OR COMMAND NOT UNIQUE ROUTINES
; N.B. T1 = DISPATCH ADDRESS
; T2 = USER COMMAND NAME
; T3 = OFFICIAL COMMAND NAME
COMCON: MOVE T2,COMAND ;GET USER COMMAND IN T2
MOVEI P3,DISP ;START OF DISPATCH TABLE
MOVE P4,[XWD -DISPL,COMTAB] ;STEP THRO COMMANDS
MOVE T1,T2 ;COPY USER COMMAND
SETOI T4, ;SET ALL ONES MASK
LSH T4,-6 ;SET MASK IN
LSH T1,6 ; T4 TO LENGTH OF
JUMPN T1,.-2 ; USER COMMAND
MOVEI AR,0 ;NO. OF NON-UNIQUE OCURRENCES
MOVE T1,P4 ;AOBJN FOR COMMAND TABLE
COMLP: MOVE T3,(T1) ;GET NEXT COMMAND
TDZ T3,T4 ;MASK OUT FOR MATCH WITH USER
CAMN T2,(T1) ;EXACT MATCH?
JRST COMFND ; YES - THIS IS IT
CAME T2,T3 ;MATCH SO FAR
JRST COMNEQ ;NO MATCH AT ALL
AOS AR ;FLAG ANOTHER MATCH
HRL P3,T1 ;MARK LAST INDEX
COMNEQ: AOBJN T1,COMLP ;TRIED ALL KNOWN COMMANDS?
JUMPN AR,.+2 ;UNKNOWN?
AOS T1 ;SET FOR NONE UNIQUE
CAIN AR,1 ;WAS THE COMMAND UNIQUE?
HLR T1,P3 ;YES - REMEMBER THIS INDEX
COMFND: MOVE T3,(T1) ;SAVE OFFICIAL COMMAND NAME
SUBI T1,(P4) ;INDEX DOWN DISPATCH
ADDI P3,(T1) ;INDEX INTO DISPATCH
MOVE T1,(P3) ;GET DISPATCH ADDRESS
JRST @T1 ; DISPATCH
SUBTTL COMMAND DECODER
DEFINE C(A,B)
< SIXBIT/A/ >
COMTAB: XLIST ;NAMES
NAMES
LIST
DISPL=.-COMTAB
DEFINE C(A,B)
< EXP B >
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: HRRZ T,STARTU ;USER MUST INITIALISE WITH START
JUMPE T,ERR4 ;MUST TYPE START FIRST
SKIPN ESCAPE ;ARE WE ALLOWING ESCAPES
JRST ERR30 ;NO TRACE
MOVE T,P ;SAVE FORDDT STACK PIONTER
MOVE T1,16 ;SAVE FORDDT REG 16??
MOVE P,SAVACS+17 ;[147] SET UP FORTRAN STACK
MOVE 16,SAVACS+16 ;[147] - AND REG 16
PUSHJ P,TRACE.## ;[143] DO A FORTRAN TRACE
MOVE P,T ;MUST RESTORE FORDDT STACK
MOVE 16,T1 ;AND 16
JRST RET ;END OF TRACE
; START FUNCTION
START: MOVSI T,(JFCL) ;RESET THE TRACE ENTRY
MOVEM T,FDDT. ;
PUSHJ P,CLRLIN ;FLUSH OUT LINE BUFFER
START2: MOVE T,PRGNAM ;GET THE MAIN PROGRAM NAME
MOVEM T,SYM ;SAVE FOR EVAL
;[155] TLO F,FPRNM ;LOOK FOR PROGRAM NAMES
; change to look for global symbol. HISEG now contains
; character descriptors before executable code.
TLO F,FGLSNM ;[155]Look for the global
MOVSI T1,GLOBAL ;[157]Global prefix
MOVEM T1,SYMASK ;[157]Reset mask in case it's been munged
PUSHJ P,FNDSYM ;FIND THE START
JRST ERR8 ;NO START ADDRESS
HRRM T,STARTU ;SAVE FOR GO
MOVEM F,STKYFL ;MAKE THE FOROTS FLAG STICK
PUSHJ P,RE.NTR ;ALLOW RE-ENTERS AGAIN
PUSHJ P,INSRTB ;PUT IN BREAKPOINTS
JSP T,RESTORE
SETZI 16, ;MAKE F40 STRACE WORK
STARTU: JRST .-. ;START USER PROGRAM
; GOTO STATEMENT LABEL OR SYMBOL CONTENTS
GOTO: JUMPL F,START4 ;NO ARGUMENTS = START AT LAST GOTO
PUSHJ P,SYMIN ;GET USERS ARGUMENT
JRST ERR6 ;NONE SUCH
CAIA ;NUMERIC
MOVE T,(T) ;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: HRRZ T,STARTU ;GET START ADDRESS
HRRZ T1,STARTU ;SEE IF A START HAS BEEN DONE
JUMPE T1,ERR4 ;NO, REFUSE STARTS AND GOTO'S
MOVEM T,GOLOC ;SET UP FOR EXTASK
;[170] SETOI T1,
MOVE T1,AC17 ;[170]Get user P
MOVSI T,(POPJ P,) ;HAVE WE STOPPED AFTER A NEXT?
;[170] CAMN T,LEAV ;IF SO LEAV WILL BE A POPJ P,
;[170] SUBM T1,AC17 ;SOBJN!!!!
CAMN T,@LEAV ;[170]Have we stopped after NEXT?
POP T1,T ;[170]YES, POP the user return addr
MOVEM T1,AC17 ;[170]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 (T)
JRST ERR24 ;NOT ALLOWED
PUSHJ P,RE.NTR ;ALLOW RE-ENTERS AGAIN
MOVSI T,(JFCL) ;RESET THE TRACE ENTRY
MOVEM T,FDDT. ;
PUSHJ P,EXTASK ;TRANSFER TO EXTERNAL TASK
; OPEN
OPEN: JUMPL F,OPEN2 ;ASSUME MAIN PROG IF JUST 'OPEN'
PUSHJ P,TTYIN ;WHAT NEXT
JUMPN T1,BADSYN ;MUST BE LINE END DELIMITER
JUMPE T2,BADSYN ;MUST HAVE SOME CHARACTERS
PUSHJ P,VALID ;CHECK VALIDITY & GET RAD50 IN T3
OPEN3: MOVEM T3,SYM ;SAVE FOR 'OPEN'
PUSHJ P,SETNAM ;DO THE OPEN
JRST RET ;WHAT NEXT
OPEN2: MOVE T3,PRGNAM ;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
HRRZM T,GOLOC ;SAVE ADDRESS
JRST EXTASK ;TRANSFER TO EXTERNAL TASK
MAPDDT: MOVE T,[.PAGCA,,700] ;[115] CHECK FOR PAGE 700
PAGE. T, ;[115] IS IT THERE?
JRST ERR11 ;[115] NO PAGE UUO, NO VMDDT
TLNN T,(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 T,['SYS ' ;[115] SET UP TO GET DDT
'VMDDT '
EXP 0,0,0,0]
MERGE. T, ;[115] GET IT
JRST [MOVSI 17,MRGACS ;[115] CAN'T, TOUGH
BLT 17,17
JRST ERR11]
MOVE T,[775777,,700000] ;[122] SET .JBDDT
SETDDT T, ;[122]
MOVSI 17,MRGACS ;[115] PUT ACS BACK
BLT 17,17
GODDT: MOVEI T,700000 ;[115] SET ADDRESS
MOVEM T,GOLOC
JRST EXTASK ;[115] GO CALL EXTERNAL TASK
>
IFN TOPS20,<
DDT: MOVE 1,[.FHSLF,,770] ;[114] LOOK AT PAGE 770
RPACS% ;[114] GET PAGE ACCESS BITS
TXNN 2,PA%PEX ;[114] DOES PAGE 770 EXIST?
JRST MAPDDT ;[114] NO, GO MAP IN UDDT.EXE
MOVE 1,770000 ;[114] GET DDT ENTRY VECTOR
CAMN 1,[JRST 770002] ;[114] IS IT REALLY DDT?
JRST GODDT ;[114] YES, JUMP TO IT
MAPDDT: MOVEI 1,.FHSLF ;[114] GET ENTRY VECTOR LOC
GEVEC%
PUSH P,2 ;[114] SAVE SINCE GET WRECKS IT
MOVX 1,GJ%SHT+GJ%OLD ;[114] SHORT FORM, FILE MUST EXIST
HRROI 2,[ASCIZ /SYS:UDDT.EXE/] ;[114] DDT
GTJFN% ;[114] FIND IT
ERJMP ERR11 ;[114] NOT THERE, CAN'T HELP
HRLI 1,.FHSLF ;[114] MAP INTO THIS FORK
GET% ;[114] READ IN DDT
ERJMP ERR11 ;[114] CAN'T
DMOVE 1,116 ;[114] GET SYMBOL TABLE POINTERS
MOVEM 1,@770001 ;[114] STORE FOR DDT
MOVEM 2,@770002
POP P,2 ;[114] GET ENTRY VECTOR BACK
MOVEI 1,.FHSLF ;[114] THIS FORK
SEVEC% ;[114] RESTORE ENTRY VECTOR
GODDT: TYPE (<To return to FORDDT, type "%FDDT<ESC>G">)
LINE
MOVEI T1,770000 ;[114] GET DDT START ADDRESS
MOVEM T1,GOLOC ;[114] SAVE
JRST EXTASK ;[114] GO CALL EXTERNAL TASK
>;[114] END IFN TOPS20
; EXIT FUNCTION
EX.: JUMPGE F,EX.R ;IS THE USER REQUESTING A MONITOR RETURN
HRRZ T,STARTU ;NO - SEE IF A START HAS BEEN DONE
JUMPN T,.+2
jrst ex.a ;JUST A NORMAL EXIT
MOVE T,STARTU ;REMOVE START ADDRESS SO-
HLLZM T,STARTU ;NO CONTINUES OR RE-ENTERS
SETZM TEM ;SET UP ARG BLOCK
SETZM TEM1 ; TO EXIT FOROTS
PUSHJ P,INSRTB ;REPLACE PAUSES
JSP T,RESTORE ;RESTORE USERS ACS
MOVEI 16,TEM ;GET EXIT ARGBLOCK
PUSHJ P,EXIT.## ;[143] DO A FOROTS EXIT
EX.R: PUSHJ P,TTYIN ;GET NEXT INPUT
JUMPN T2,BADSYN ;LOOKING FOR / - NOCHARACTERS ALLOWED
JUMPE T1,BADSYN ;BETTER BE /
CAIE T1,"/"
JRST BADSYN ;SORRY
PUSHJ P,TTYIN ;LOOK FOR RETURN
JUMPN T1,BADSYN ;NO MORE CHARACTERS ALLOWED
JUMPE T2,BADSYN ;NO CHARACTERS IN INPUT????
LSHC T1,6 ;GET FIRST CHARACTER
CAIE T1,' R' ;LOOK FOR 'RETURN' - IMPLIED BY R
JRST BADSYN ;WE DONT UNDERSTAND ANY OTHER CHARACTER
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
OVRLAY: MOVE T,.JBSYM ;GET THE SYMBOL TABLE PARAMETERS
EXCH T,JOBSYM ;SAVE NEW SYMBOL POINTERS
JUMPE T,OVRL4 ;OLD VALUE COULD BE ZERO IF NOT INITED
CAME T,JOBSYM ;COMPARE WITH LAST KNOWN VALUE
JRST OVRL2 ;SOMETHING CHANGED!!
OVRL4: HRRZ T,.JBSA ;GET THE START ADDRESS
EXCH T,JOBSA ;SAVE NEW - AND FIND OLD START ADDRESS
JUMPE T,CPOPJ ;EXIT IF OLD START NOT SET-UP
CAMN T,JOBSA ;HAS THIS CHANGED
POPJ P, ;ALL IS WELL
OVRL2: LINE
TYPE(<%FDTPOV Program overlayed>)
ife tops20,< ;this doesn't work under TOPS20
MOVE T,[XWD -1,3] ;SET FOR PROGRAM NAME
GETTAB T,> ;FIND THE CURRENT NAME,end of conditional
JRST OVRL3 ;SECRETIVE TYPE??
SKIPN JOBNAM ;HAS ANY NAME BEEN STORED?
MOVEM T,JOBNAM ;NO - REMEMBER THIS
CAMN T,JOBNAM ;OVERLAYED BY SYSTEM WHICH DOSN'T CHANGE NAME?
JRST OVRL3 ;YES
MOVEM T,JOBNAM ;REMEMBER NEW NAME
TYPE( by )
PUSHJ P,SIXBP ;OUTPUT PROGRAM NAME
OVRL3: TYPE( ***)
LINE
SKIPN T,JOBOPC ;ANY RE-ENTER ADDRESS?
MOVE T,BCOM ;IF NOT BCOM SHOULD BE USER BREAK
HRRZ T,T ;JUST THE ADDRESS THANK YOU
PJRST WHERE ;TELL WHERE - END OF OVERLAY
; RE-ENTER LOGIC
RE.ENT: SKIPE REENTR ;ARE WE ALREADY REENTERED?
JRST ER.ENT ;YES. REPORT
MOVEM P,SAVLOC ;FREE UP A SPARE REG
HRRZ P,.JBOPC ;GET THE BREAK P.C.
SKIPE ESCAPE ;RE-ENTERS ALLOWED ONCE(SEE ER.ENT)
JRST RE.BRK ;DONT DESTROY USER PROFILE
MOVE P,SAVLOC ;RE-INSTATE THE OLD REG
JSR SAVE ;SAVE THE EXTERNAL PROG STATUS
PUSHJ P,REMOVB ;AND REMOVE THE PAUSES
MOVE T,.JBOPC ;GET THE PROG P.C.
MOVEM T,JOBOPC ;STORE AND FLAG THAT WE ARE HANDLING RE-ENTER
MOVEM T,JOBBRK ;SAVE THE JOB BREAK LOCATION
HRRM T,STARTU ;ALLOW CONTINUES TO WORK
SETOM REENTR ;SET FLAG THAT WE HAVE REENTERED
SKIPE PRGM ;HAS ANY SECTION BEEN OPENED
JRST RE.LOC ;YES
PROGIF(MAIN.) ;NO - SO OPEN MAIN PROG
CAIA ;NO SECTION CALLED MAIN.
PUSHJ P,SETNAM ;OPEN MAIN PROG IF FOUND
; 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,tf
hrrzi tf,.priou
cfobf%
pop p,tf >
TYPE([ Program suspended )
HRRZ T,JOBBRK ;SET UP THE ACTUAL SUSPEND POINT
PUSHJ P,WHERE ;TELL USER WHERE HE IS SUSSPENDED
TYPE(Open section: )
MOVE T,OPENED ;WHAT IS THE CURRENTLY OPEN SECTION
PUSHJ P,SPT1 ;TYPE THAT
TYPE ( ])
MOVE F,STKYFL ;RESET THE FLAG REGISTER
JRST RET ;RETURN TO NORMAL WORKING
ER.ENT: SETPDL ;RESET THE PDL
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: SETPDL ;RESTORE THE STACK
HRRZ T,STARTU ;HAS A START BEEN DONE
JUMPE T,RE.RET ;NO - JUST RETURN TO FORDDT USER MODE
MOVE T,BCOM ;GET THE PAUSE POINT
MOVEI T,-1(T) ;CORRECT FOR JSA
ANDI T,-1 ;JUST THE ADDRESS PORTION
MOVEM T,JOBBRK ;SAVE THE JOB BREAK FOR RE.LOC
JRST RE.LOC ;DISPLAY PROGRAM EXECUTION SUSPENSION
; ROUTINE TO DISPLAY WHERE THE PROGRAM IS SUSPENDED
WHERE: SKIPN .JBHRL ;SKIP IF WE HAVE A HIGH SEG.
JRST RE.L2
CAMLE T,.JBREL ;ARE WE SUSPENDED OVER THE LOW SEG.
JRST [TYPE(in high segment)
JRST RE.L2]
TYPE(in low segment)
RE.L2: TYPE( at )
TLO F,FGLSNM ;GLOBALS ARE OK
PUSHJ P,LOOK ;DO A SYSMBOL 'LOOK'-UP
JRST E6 ;
CAIA ;NOTHING TYPED
JRST RE.L3A ;FOUND AND TYPED
MOVEM T,TEM ;REMEMBER NEAREST REFERENCE
PUSHJ P,SPT ;TYPE THE SYMBOL
TYPE( + )
MOVE T,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 )
MOVE T,PNAMSV ;GET THE SECTION NAME
PUSHJ P,SPT1 ;DISPLAY THAT
RE.L3: LINE ;
POPJ P, ;
; PAUSE LOGIC
PAUSE: JUMPL F,PSEALL ;DISPLAY ALL PAUSES IF NO ARGUMENTS
TRO TF,FGLONL ;FIND GLOBAL SYMBOL ONLY
PUSHJ P,SYMIN ;GET THE NEXT SYMBOL IN SYM
JRST ERR6 ;NONE SUCH!
CAIA ;STATEMENT # FROM USER
JRST PAUS10 ;SYMBOL - MEANS STOP AT ROUTINE
PAUS11: HRRZM T,TEM1 ;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 T1,BADSYN ;DO WE HAVE A LEGAL DELIMITER
JUMPE T2,PAUS5 ;[136] DID WE REALLY GET ANYTHING?
CAMN T2,[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 T2,[SIXBIT/AFTER/] ;FORCE USER TO TYPE WHOLE WORD
JRST PAUS4 ;AFTER REQUESTED
CAME T2,[SIXBIT/IF/] ;WAS IT 'IF'?
JRST BADSYN ;ANYTHING ELSE MEANS TROUBLE
TLZ F,CONS ;CLEAR CONSTANT SEEN FLAG
TRO TF,LGCLEG ;[116] LET EITHER KNOW WE MAY GET LOGICALS
PUSHJ P,EITHER ;NUMBER OR SYMBOL SHOULD FOLLOW
PUSHJ P,NUMB ;CONSTANT SEEN
MOVEM T,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 TF,ISLOGI ;[116] IS IT A LOGICAL CONSTANT
JRST [SETZ T, ;[116] YES, SET FLAG IN COND0
TLO T,LFTLOG ;[116]
MOVEM T,COND0 ;[116]
JRST .+1] ;[116]
JUMPN T1,.+2 ;DELIMITER?
PUSHJ P,GETSKB ;NEXT CHARACTER
CAIE T1,"." ;MUST BE . OF .EQ. ETC
JRST BADSYN
PUSHJ P,TTYIN ;GET SIXBIT STRING
CAIE T1,"." ;MUST AGAIN BE TERMINATED BY .
JRST BADSYN
HLRZS T2,T2 ;MORE USEFUL IN RIGHT HALF
CAIN T2,'LT '
JRST TEST1
CAIN T2,'LE '
JRST TEST2
CAIN T2,'EQ '
JRST TEST3
CAIN T2,'NE '
JRST TEST4
CAIN T2,'GT '
JRST TEST5
CAIN T2,'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 TF,LGCLEG ;[116] LET EITHER KNOW LOGICALS ARE LEGAL
PUSHJ P,EITHER
PUSHJ P,NUMB ;SAVE AS A NUMBER
MOVEM T,COND2 ;SAVE THE LOCATION
TRZE TF,ISLOGI ;[116] DID WE GET A LOGICAL CONSTANT?
JRST [SETZ T, ;[116] YUP, SET COND0 FLAG
TLO T,RHTLOG ;[116]
ORM T,COND0 ;[116]
JRST .+1] ;[116]
MOVE T,[JSR COND]
MOVEM T,TEM ;FORM THE (CONDITIONAL TEST) LOCATION LINK
PAUS5: SKIPA T,[Z 1] ;PROCEDE COUNT=1
PAUS4: PUSHJ P,EITHER ;GET USERS PROCEDE COUNT IN T
CAIA ;CONSTANT GIVEN
MOVE T,(T) ;SYMBOL - GET CONTENTS
JUMPL T,BADSYN ;DO NOT ALLOW NEGATIVE PROCEDE COUNTS
EXCH T,TEM1 ;GET BACK BREAKPOINT ADDRESS
SKIPL TERMK ;WAS THAT ALL
JRST PAUS6 ; YES
MOVEM T,SAVLOC ;SAVE PAUSE ADDRESS TEPORARILY
PUSHJ P,TTYIN ;GET SIXBIT USER INPUT
JUMPN T1,BADSYN
MOVE T,SAVLOC ;[136] RESTORE PAUSE ADDR., IN CASE WE'RE DONE
JUMPE T2,PAUS6 ;[136] WAS THERE REALLY ANYTHING THERE?
CAME T2,[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 T,PAUS3 ;ASSUME ZERO MEANS NO INPUT
CAIN T1,"/" ;A / HERE DENOTES THAT A GROUP# FOLLOWS
JRST PAUS8 ;TRY FOR THE NUMBER AGAIN
PAUS3: CAIL T,1 ;MAKE SURE HE GETS
CAILE T,GPMAX ; ONLY A VALID GROUP #
JRST ERR15 ;COMPLAIN ABOUT GROUP #
HRL T,T ;SET UP FOR AUTO TYPE
HRR T,SAVLOC ;GET BACK PAUSE ADDRESS
TLO F,AUTO ;SET THE AUTO PROCEDE FLAG
PAUS6: PUSHJ P,ONFORM ;SKIP IF NOT A FORMAT AT (T)
JRST ERR19
PUSHJ P,BPS1 ;PLACE ALL PARAMETERS TO EFFECT A PAUSE
JRST RET ;DONE!
PAUS7: SETZI T, ;CLEAR PROCEDE COUNT
EXCH T,TEM1 ;GET PAUSE PLACE
MOVEM T,SAVLOC ;STORE PAUSE LOCATION
JRST PAUS8
PAUS10: MOVE T1,@SYMSAV ;GET SYMBOL
TLNE T1,700000 ;IS THIS A PROGRAM NAME OR GLOBAL
JRST ERR19 ;NO SO DONT ALLOW
SKIPE SUBSCR ;NOR MUST THERE BE AN OFFSET
JRST ERR19
MOVE T1,1(T) ;DOES THIS ROUTINE INVOKE THE 'HELLO' MACRO?
CAMN T1,HELLO ;YES IT DOES - STOP 2 ON
ADDI T,2 ;
JRST PAUS11
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 F,CONS ;SET CONSTANT SEEN FLAG IF NOT ALREADY SET
JRST ERR14
MOVEM T,COND3 ;SAVE VALUE OF CONSTANT
MOVEI T,COND3 ;SAVE ADDRESS OF CONSTANT
POPJ P,
; ROUTINE TO CHECK IF A FORTRAN FORMAT EXISTS AT
; THE ADDRESS POINTED TO BY T
; RETURN 1 IF IT IS A FORMAT
; RETURN 2 IF NOT A FORMAT
ONFORM: LDB W1,[POINT 7,(T),6] ;
CAIN W1,"(" ;TRUE IF FIRST CHAR IS AN OPEN PAREN
POPJ P,
JRST CPOPJ1 ;FOUND A FORMAT STATEMENT REFFERENCE
; CONTINUE LOGIC
CONTIN: MOVSI T,(JFCL) ;RESET THE TRACE ENTRY
MOVEM T,FDDT. ;
HRRZ T,STARTU ;HAS START BEEN SEEN
JUMPE T,ERR4 ;NO - PLEASE TYPE START
SKIPE T,JOBOPC ;ARE WE IN A RE-ENTER CONDITION
JRST CONT2 ;YES - DEAL WITH IT
MOVEI T,[POPJ P,] ;POPJ P, IS THE EXIT AFTER A 'NEXT'
CAMN T,LEAV ;DID WE DO A 'NEXT' LAST TIME
JRST PROCED ;YES - DO NOT TAKE ARGS - RETURN WITH A POPJ
JUMPL F,PROCED ;CONTINUE 1
PUSHJ P,EITHER ; NO - GET ARGUMENT
CAIA ;NUMBER TYPED
MOVE T,(T) ;SYMBOL TYPED - GET CONTENTS
JUMPL T,BADSYN ;DO NOT ALLOW NEGATIVE PROCEDE SETTINGS
JRST PROCDX ;SET UP A PROCEDE COUNT
CONT2: MOVE T,JOBOPC ;GET THE CONTINUE P.C.
MOVEM T,GOLOC ;PREPARE TO CONTINUE
PUSHJ P,RE.NTR ;ALLOW RE-ENTERS AGAIN
PUSHJ P,INSRTB ;PUT BACK PAUSES
JSP T,RESTORE ;RESTORE USER ACS
JRSTF @GOLOC ;DO AN OFFICIAL RE-ENTER
;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 AC1,[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,AC0 ;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 AC1,^D264 ;ALLOCATE ENOUGH FOR TWO 128 WORD BUFFERS
MOVEM AC1,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 AC0 ;A POSITIVE VALUE?
JRST ALCFAL ;NO, ALLOCATION FAILED
MOVEM AC0,ALCBLK+1 ;SAVE ADDR FOR DECOR
;Set up the buffer header blocks.
AOS AC2,AC0 ;POINT TO 2ND WORD OF BUFFER HDR
HRLZI AC1,^D129 ;SIZE OF BUFFER+1
HRR AC1,AC2 ;TACK ON ADDRESS OF 1ST BUFFER HDR+1
MOVEM AC1,^D131(AC2) ;PUT IT IN WORD 2 OF 2ND BUFFER HDR
ADDI AC1,^D131 ;ADDR OF 2ND BUFFER HDR+1
MOVEM AC1,(AC2) ;PUT IT IN WORD 2 OF 1ST BUFFER HDR
;Try to find the help file.
SETZB AC2,AC5 ;SET UP A COUNTER AND ZERO AC2
GETHLP: SKIPA AC3,['HLP '] ;GET HLP:
GETSYS: MOVSI AC3,'SYS' ;OR GET SYS:
MOVEI AC4,HLPCTB ;ADDRESS OF BUFFER CONTROL BLOCK
OPEN DSK,AC2 ;OPEN THE DEVICE CHANNEL
JRST HLPNHF ;LOSE...
MOVE AC1,[EXP BF.VBR] ;SET UP THE BUFFER CONTROL BLOCK
MOVEM AC1,HLPCTB ;SIGNIFY VIRGIN BUFFER
HRRM AC0,HLPCTB ;GIVE ADDRESS OF 2ND WORD OF 1ST BUFFER
SETZM HLPCTB+1 ;ZERO NEXT TWO LOCATIONS
SETZM HLPCTB+2
MOVE AC1,[SIXBIT/FORDDT/] ;FILE NAME
MOVSI AC2,'HLP' ;EXTENSION
SETZB AC3,AC4 ;ZERO NEXT TWO
LOOKUP DSK,AC1 ;LOOKUP FORDDT.HLP
TLZA AC2,-1 ;CLEAR JUNK, WE BLEW IT
JRST NXTBUF ;GOOD--GO READ FILE
CAIE AC2,ERSNF% ;SFD NOT FOUND?
CAIN AC2,ERSLE% ;SEARCH LIST EMPTY?
JRST NXTSTR ;ONE OF THE ABOVE
CAILE AC2,ERIPP% ;INCORRECT PPN OR FILE NOT FOUND?
JRST HLPNHF ;HORRIBLE DISK ERROR
NXTSTR: SETZM AC2 ;CLEAR PHYSICAL BIT
AOS AC5 ;TRY NEXT CASE
TRNE AC5,1 ;SEE IF ODD
TXO AC2,UU.PHS ;YES--TRY PHYSICAL ONLY
JRST @[GETHLP ;TRY HLP: AGAIN
GETSYS ;THEN LOGICAL SYS:
GETSYS ;THEN PHYSICAL SYS:
HLPNHF]-1(AC5) ;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 AC1,HLPCTB+1 ;POINT TO 1ST DATA LOC IN BUFFER
AOS AC1 ; ''
OUTSTR @AC1 ;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,AC0 ;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,AC0 ;SAVE THE FLAGS
;Use FOROTS' ALCOR and DECOR routines for
;allocating and deallocating the buffer space.
MOVEI AC1,^D128 ;ALLOCATE ONE BLOCK FOR THE FILE
MOVEM AC1,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 AC0 ;A POSITIVE VALUE?
JRST ALCFAL ;NO, ALLOCATION FAILED
MOVEM AC0,ALCBLK+1 ;SAVE ADDR FOR DECOR
MOVEI AC3,4 ;NUMBER OF ATTEMPTS AT FINDING FILE
GETHLP: MOVE AC4,[POINT 7,[ASCIZ/HLP:/]] ;GET THE HLP: POINTER
MOVEM AC4,GTJBLK+2 ;PUT IT IN THE GTJFN BLOCK
JRST GETIT
GETSYS: MOVE AC4,[POINT 7,[ASCIZ/SYS:/]] ;GET THE SYS: POINTER
MOVEM AC4,GTJBLK+2 ;PUT IT IN THE GTJFN BLOCK
GETIT: HRROI AC2,FILENM ;GET POINTER TO 'FORDDT'
MOVEI AC1,GTJBLK ;LONG FORM GTJFN BLOCK
GTJFN% ;GET FORDDT.HLP
JRST NXTSTR ;LOSE TEMPORARILY
HRRM AC1,JFN ;SAVE THE JFN
MOVE AC2,[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 AC1,JFN ;GET JFN
HRROI AC2,@ALCBLK+1 ;POINTER FOR TEXT BUFFER
MOVEI AC3,^D639 ;HELP TEXT BUFFER SIZE IN CHARS (128*5-1)
SIN% ;FILL THE BUFFER
ERJMP HLPDON ;DON'T CARE ABOUT THIS ERROR
SETZ AC1, ;NEED A ZERO BYTE
IDPB AC1,AC2 ;MAKE SURE ZERO THE LAST BYTE
HRROI AC1,@ALCBLK+1 ;POINT TO BUFFER
PSOUT% ;OUTPUT ASCIZ STRING
JRST PRINT ;IF THERE'S MORE, GO GET IT
NXTSTR: MOVE AC4,GTJBLK ;GET THE FLAGS
TXOE AC4,GJ%PHY ;TURN ON PHYSICAL DEVICE BIT
TXZ AC4,GJ%PHY ;CLEAR PHYSICAL BIT
MOVEM AC4,GTJBLK ;PUT IT BACK IN GTJFN BLOCK
SOJLE AC3,HLPNHF ;SEE IF ANY DEVICES LEFT
CAIG AC3,2 ;TIME TO TRY SYS:?
JRST GETSYS ;YES, USE SYS:
JRST GETHLP ;NO, USE HLP:
HLPDON: SETZ AC1, ;NEED A ZERO BYTE
IDPB AC1,AC2 ;MAKE SURE ZERO THE LAST BYTE
HRROI AC1,@ALCBLK+1 ;POINT TO BUFFER
PSOUT% ;OUTPUT ASCIZ STRING
HRROI AC1,CRLF ;OUTPUT CRLF
PSOUT%
MOVE AC1,JFN
CLOSF% ;GET RID OF THE JFN
JFCL ;NOT LIKELY
JRST HLPRET ;AND RETURN
HLPIOE: MOVE AC1,JFN ;WE STILL HAVE TO RELEASE THE JFN
CLOSF%
JFCL ;NOT LIKELY
HRROI AC1,[ASCIZ/%FDTEOH Error opening help file/]
SKIPA
HLPNHF: HRROI AC1,[ASCIZ /%FDTNHF Cannot find help file/]
PSOUT%
HRROI AC1,[ASCIZ/; I'm sorry I can't help you/]
PSOUT%
HRROI AC1,CRLF
PSOUT%
HLPRET: MOVEI L,ALCBLK ;NEED TO DEALLOCATE BUFFER SPACE
PUSHJ P,DECOR.## ;DO IT
POP P,AC0 ;RESTORE FLAGS
JRST RET ;ALL DONE
ALCFAL: HRROI AC1,[ASCIZ/%FDTCAB Cannot allocate buffer for help file/]
PSOUT%
HRROI AC1,CRLF
PSOUT%
POP P,AC0 ;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
> ;end IFN TOPS20 (internal -20 help code)
-1,,0 ;NUMBER OF ARGUMENTS TO ALCOR
ALCBLK: ALCBLK+1 ;POINTER TO ARGUMENT
BLOCK 1 ;NUMBER OF WORDS NEEDED
> ;end IFE EXTHLP (internal help code)
; REMOVE LOGIC
RESET: JUMPL F,RESET5 ;'RESET' - RESET ALL PAUSES
TRO TF,FGLONL ;FIND GLOBAL ONLY IF NOT LABEL
PUSHJ P,SYMIN ; NO - MUST BE ANOTHER SYMBOL TO FOLLOW
JRST ERR6 ;SOME ONE SLIPPED UP
JFCL ;STATEMENT #
RESET6: MOVEI R,B1ADR ;LOOK THRO PAUSE POINTS FOR THE RIGHT ONE
RESET3: HRRZ W,(R) ;GET THE PAUSE CONTENTS
CAIN W,(T) ;IS THIS IT?
JRST RESET2 ; YES - REMOVE IT!
ADDI R,3 ; NO - TRY ANOTHER
CAIG R,BNADR ;TRIED ALL POINTS YET?
JRST RESET3 ; NO - FIND THE NEXT
JRST ERR17 ;NO - NOT AN ARRAY NAME - YOU LOSE
RESET2: MOVE W,1(T) ;DOES THIS ROUTINE USE THE HELLO MACRO
CAMN W,HELLO ;
ADDI T,1 ;YES IT DOES - SO STOP 2 ON
ADDI T,1 ;STOP 1 ON FOR NORMAL ROUTINES
CLEARM (R) ;CLEAR LOCATION OF PAUSE
CLEARM 1(R) ;CLEAR CONDITIONAL CLAUSE
CLEARM 2(R) ;CLEAR PROCEDE COUNT
JRST RET ;REMOVED!
RESET5: CAME T2,[SIXBIT/REMOVE/] ;DO NOT ALLOW ABREVIATIONS OF REMOVE
JRST BADSYN ;THIS ANNOYS MANY USERS
PJRST BPS ;RESET ALL PAUSES
; ACCEPT LOGIC = ACCEPT NAME/X #
ACCEPT: JUMPL F,BADSYN ;ACCEPT ALONE IS MEANINGLESS!
SETZM ARGVAL+1 ;CLEAR IN CASE LONG INPUT
SKIPN ESCAPE ;ESCAPE TO FOROTS?
JRST ERR30 ;SORRY
TRO TF,ACCPT ;ACCEPT IN PROGRESS
PUSHJ P,SYMIN ;GET USERS SYMBOL
JRST ERR6 ;SORRY - WE DONT HAVE IT!
JRST ACC2 ;STATEMENT # = FORMAT
MOVEM T,TEM2 ;STORE FOR UPDATE
;[157]***For character, T/TEM2=descriptor of array base=SAVLOC
TRNE TF,IMPRNG ;IS THIS AN IMPLIED RANGE?
PUSHJ P,DISP14 ;YES SETUP RANLIM/RANGE IN CASE OF A RANGE
PUSHJ P,EVAL ;SETUP SYMSAV TO POINT TO RAD50 SYMBOL
JFCL ;CAN'T HAPPEN!!?
MOVE T,SYMSAV ;GET THE SYMBOL POINTER
HLRZ T,(T) ;GET RADIX 50 FORM AND FLAGS
TRNN T,LOCAL ;ALLOW ONLY LOCAL VARIABLS TO CHANGE
JRST ERR24 ;YOU LOOSE
MOVE T1,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 T1,ACCF ;SPACE DELIMITER ASSUMES REAL TO FOLLOW
CAIN T1,"=" ;ALLOW = AS DELIMITER
JRST ACCF
CAIN T1,"-" ;A - MEANS A RANGE OF VALUES TO SET
JRST ACC23 ;
CAIE T1,"/" ; WE EXPECT ONLY / FROM NOW ON
JRST BADSYN ;ANYTHING ELSE LOOSES
ACC22: PUSHJ P,TTYIN ;READ ARGUMENT TYPE REQUIRED BY USER
JUMPE T2,BADSYN ;NO CHARACTERS - BAD
LDB T,[POINT 6,T2,5];GET 1ST. CHARACTER TO IDENTIFT ARG TYPE
CAIN T,'B' ;[120] BIG SWITCH ?
TLOA TMOD,B. ;[120] YES - SET IT AND LOOK FOR ANOTHER SWITCH
MOVEM T,TEM ;[120] NOT 'BIG', SAVE SWITCH IN CASE B FOLLOWS
JUMPE T1,ACC21 ;NOTHING FOLLOWS
CAIN T1,"=" ; ALLOW = AS DELIMITER
JRST ACC21 ;PROCESS FORMAT
CAIE T1,"/" ;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: MOVE T,TEM ;GET THE CURRENT FORMAT REQUEST
SKIPE RANGE ;[156]looking for a range?
JRST ACC21A ;[156]YES
SETZM CLMRNG ;[163]In case character
JRST ACC21B ;[163]Go get input
ACC21A: TLNE TMOD,B. ;[156]/BIG?
TLNN F,DOUBLE ;[156]and double precision?
JRST ACC21B ;[156]NO
CAIE T,'A' ;[156]ASCII?
CAIN T,'R' ;[156]or RASCII?
AOS RANGE ;[156]YES. Don't lose second word
ACC21B: CAIN T,'S' ;SYMBOLIC?
JRST ACCS ;DO SYMBOL INPUT
CAIN T,'A' ;ASCII?
JRST ACCA ;PROCESS ASCII
CAIN T,'R' ;RASCII?
JRST RASCII ;PROCESS RIGHT JUSTIFIED ASCII
CAIN T,'O' ;OCTAL?
JRST ACCO ;PROCESS OCTAL
CAIN T,'C' ;[157]Character?
JRST ACCC ;[157] YES. Process string
TLZ TMOD,B. ;[120] IGNORE /BIG FOR THE REST
CAIN T,'F' ;FLOATING?
JRST ACCF ;PROCESS A FLOATING INPUT
CAIN T,'D' ;REAL*8?
JRST ACCD ;PROCESS REAL*8
CAIN T,'I' ;INTEGER?
JRST ACCI ;PROCESS INTEGER INPUT
CAIN T,'X' ;[157]COMPLEX?
JRST ACCX ;[157]PROCESS COMPLEX INPUT
CAIN T,'L' ;[120] LOGICAL?
JRST ACCL ;[120] PROCESS LOGICAL INPUT
JRST BADSYN ;NO OTHER TYPES SUPPORTED
; ACCEPT A RANGE PROCESSING = ACCEPT NAME(X)-
ACC23: MOVE T,TEM2 ;SAVE THE FIRST VALUE SOMEWHERE SAFE
MOVEM T,RANGE ;SAVE THE FIRST VALUE OF A RANGE
MOVE T,CLMOFF ;[157]Get beginning offset
MOVEM T,CLMRNG ;[157]Save it in case this is /C
TLZ F,GRPFL ;MAKE SURE WE DONT DO GROUP LOGIC
;OR ACCEPT ANY PRINT MODIFIERS
PUSH P,MATHSM ;SAVE CURRENT SYMBOL
PUSHJ P,SYMIN ;GET THE NEXT VALUE
JRST ERR6 ;DOSNT EXIST
JRST BADSYN ;NUMERICS????
POP P,T3 ;GET FIRST SYMBOL BACK
CAME T3,MATHSM ;ARE THEY THE SAME
JRST ERR40 ;NO - SORRY
TRNN F,CHARS ;[157]Character?
JRST CKRANG ;[157]NO
; clmrng=first offset given
; clmoff=offset just received
MOVE T1,CLMOFF ;[157]Get the lower offset
CAMLE T1,CLMRNG ;[157]Is lower .le. upper?
EXCH T1,CLMRNG ;[157]NO. Make it so
MOVEM T1,CLMOFF ;[157]Restore lower offset
MOVE T,SAVLOC ;[157]Restore sym
JRST ACCONT ;[157]And continue
CKRANG: CAML T,RANGE ;SORT OUT THE RANGE ORDER
EXCH T,RANGE ;WRONG WAY ROUND
MOVEM T,TEM2 ;LOWER VALIUE IN RANLIM, HI IN RANGE
ACCONT: PUSHJ P,EVAL ;GET SYMBOL IN SYMSAV
JFCL ;
MOVE T,SYMSAV ;GET THE SYMBOL POINTER
HLRZ T,(T) ;GET SYMBOL FLAGS
TRNN T,LOCAL ;MODIFY LOCALS ONLY
JRST ERR24 ;NOT ALLOWED
MOVE T1,LSTCHR ;RESTORE USERS LAST CHARACTER
CAIN T1,"/" ;MAYBE FORMAT SPECIFIER
JRST ACC22 ;YES - GO FIND THEM
JUMPE T1,ACCF ;SPACE IMPLIES REAL*4
JRST BADSYN ;DONT ACCEPT ANYTHING ELSE HERE
; *** FLOATING INPUT ***
ACCF: TLO TMOD,F. ;DISPLAY TO USER AS FLOATING
MOVEI T2,4 ;ARG TYPE REAL FOR FOROTS
PUSHJ P,FORINP ;YES - ASK FOROTS FOR INPUT
; HERE TO PLACE ALL ACCEPTED VALUES
ACC10: MOVE T,ARGVAL ;LETS SEE WHAT FOROTS HAS BEEN UP TO
ACC13: EXCH T,TEM2 ;[163]Save input value
PUSHJ P,CKWRIT ;[163]Validity check
EXCH T,TEM2 ;[163]Regain value
MOVEM T,@TEM2 ;PLACE VALUE WHERE USER REQUESTED
MOVEM T,ARGVAL ;SOME PRINT OPTIONS NEED THIS
AOS T1,TEM2 ;NEXT ARRAY LOCATION
TLNN TMOD,X.!B.!D. ;[120] [157]IF EITHER COMPLEX REAL*8 OR BIG OR -
TRNE F,DOUBLE ;[112] WE HAVE A DOUBLE WORD ARRAY?
CAIA ;THEN WE PLACE TWO ARGUMENTS
JRST ACC14 ;IF NOT THEN CHECK THE RANGE CONDITION
TRO F,SILENT ;QUIET
PUSH P,MATHSM ;SAVE CURRENT SYMBOL
MOVE T,[SQUOZE 0,.VEND] ;END OF VARIABLE AREA
MOVEM T,MATHSM ;ONLY ACCEPTABLE SYMBOL
MOVE T,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
CAIA ;OFFSET - OK
; JRST ACC37 ; NONE - OK
; JRST ACC37 ; OFFSET - OK
; MOVE T,(W1) ;GET SYMBOL
; TLZ T,PNAME ;NO BITS
; CAMN T,[SQUOZE 0,.VEND] ;END OF VARIABLE AREA?
JRST ERR35 ;YES - ERROR
;ACC37:
POP P,T
MOVEM T,MATHSM ;RESTORE CURRENT SYMBOL
MOVE T,ARGVAL+1 ;GET THE 2ND WORD
MOVEM T,@TEM2 ; - AND PLACE IN NEXT LOCATION
AOS T1,TEM2 ;YES - SO NEXT DOUBLE WORD
ACC14: SKIPN RANGE ;ACCEPT A RANGE ?
JRST ACCPUT ;NO - UNLESS IMPLIED
TLNE TMOD,A. ;SPECIAL TREATMENT FOR ASCII ARRAYS
JRST [CAMG T1,RANGE ;END OF ARRAY?
JRST ACC12 ;GET SOME MORE
JRST RET ] ;QUIT
CAMG T1,RANGE ;ALL DONE ?
JRST ACC10 ;NO - KEEP GOING
JRST RET ;ALL OVER
; VARIABLE 'ACCEPT'ED - NOW CONFIRM TO USER
ACCPUT: SOS T,TEM2 ;REMOVE OFFSET FROM ACC13
ACPUT1: SETZM TERMK ;PREPARE FOR -
SETZM RANGE ; INPUT CONFIRMATION
TRZN F,DOUBLE ;CHECK FOR ANY -
TLNE TMOD,X.!B.!D. ;[120] [157] DOUBLE WORD WORKING
SOS T,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: TLO TMOD,D. ;DISPLAY TO USER AS REAL*8
MOVEI T2,TP%DPR ;[137]Set up for default D-float arg type=10
TRNE F,GFLOAT ;[137]If D-float, skip to FOROTS call.
MOVEI T2,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: TLO TMOD,I. ;DISPLAY TO USER AS INTEGER
MOVEI T2,2 ;GET ARG TYPE INTEGER FOR FOROTS
PUSHJ P,FORINP ;GO TO FOROTS
JRST ACC10 ;PLACE ARG FOR USER
; *** COMPLEX INPUT ***
ACCX: TLO TMOD,X.!B. ;[120] [157] DISPLAY TO USER AS VCOMPLEX
ACC11: PUSHJ P,GETSKB ;GET SIGNIFIGANT CHARACTER
CAIE T1,"(" ;MAKE SURE ITS A (
JRST ERR32 ; ( REQUIRED
MOVE T,[1200,,ARGVAL+1] ;WHERE TO PUT IMAGINARY OF COMPLEX
MOVEM T,M2.I ;SET UP THE FORMAT
MOVEI T2,4 ;SET UP FOR TYPE REAL INPUT
PUSHJ P,FORINP ;LET FOROTS GET THE REAL PART
MOVE T,M2.F ;RECOVER THE FIN CALL
MOVEM T,M2.I ;AND REMOVE THE COMPLEX SETTING
JRST ACC10 ;GO PLACE THE RESULTS
; *** SYMBOLIC INPUT ***
ACCS: TLNE TMOD,B. ;[120] IF 'BIG' SET THEN
TLOA TMOD,X. ;[157]DISPLAY TO USER AS TWO REAL*4
TLO TMOD,F. ;ELSE DISPLAY JUST ONE REAL*4
PUSH P,MATHSM ;SAVE MATHSM
PUSH P,SAVLOC ;SAVE SAVLOC AROUND CALL
PUSHJ P,SYMIN ;GET A USER SYMBOL
JRST ERR6 ;CAN'T FIND IT!
JRST BADSYN ;DONT GIVE ME STATEMENT #
POP P,SAVLOC ;RESTORE SAVLOC
POP P,MATHSM ;RESTORE
MOVE T1,(T) ;I'LL ACCEPT THAT ONE
MOVEM T1,ARGVAL ;SAVE THE FIRST WORD VALUE
TLNN TMOD,B. ;[120] DOUBLE WORD WORKING?
JRST ACC10 ;NO JUST PLACE SINGLE VALUE
MOVE T,1(T) ;GET SECOND VALUE
MOVEM T,ARGVAL+1 ;STORE THAT
JRST ACC10 ; AND EVEN STORE IT
; *** ASCII INPUT RIGHT JUSTIFIED ***
RASCII: TLO TMOD,R. ;DISPLAY TO USER AS RASCII
JRST ACC1 ;DO ASCII INPUT TO T
;[120] ** LOGICAL INPUT **
ACCL: TLO TMOD,L. ;[120] DISPLAY TO USER AS LOGICAL
MOVE T1,[POPJ P,] ;[120] HOW WE WANT TO RETURN FROM LOGICL
MOVEM T1,DONE ;[120]
TRO TF,LGCLEG ;[120] LET 'EM WE'RE EXPECTING A LOGICAL
PUSHJ P,GETSKB ;[120] GET NEXT CHAR.
CAIE T1,"." ;[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: TLO TMOD,A. ;DISPLAY TO USER AS ASCII
MOVE T,[ASCII . .] ;BLANK SECOND WORD FOR POSSIBLE
MOVEM T,ARGVAL+1 ;LONG OR DOUBLE
SKIPN RANGE ;[120] IGNORE /BIG IF ACCEPTING LONG ASCII
JRST ACC1 ;OK IF NOT A RANGE
TLZ TMOD,B. ;[120] CLEAR /B FLAG
TRZ F,DOUBLE ;CLEAR DOUBLE
ACC1: PUSHJ P,GETSKB ;GETA SIGNIFICANT USER CHARACTER
SKIPL TERMK ;EOL?
JRST BADSYN ;YES - SYNTAX ERROR
MOVEI T5,(T1) ;SAVE IN T2
ACC12: SETZM ARGVAL ;CLEAR FOR DOUBLE LENGTH ASCII
TRZE TF,ADELIM ; IF SET WE CLEAR THE REST OF THE ARRAY
JRST ACCA2 ;
ACC24: MOVE T,[ASCII . .] ;T BUILDS ASCII INPUT
TLNE TMOD,R. ;BUILD WITH ZERO IF RASCII
SETZI T,
MOVE T6,[POINT 7,T] ;STORES BYTES IN T
ACC15: pushj p,loadch ;NEXT ASCII CHARACTER
CAIN T1,(T5) ;TEXT DELIMITER FOUND?
JRST ACC18 ;YES - CHECK FOR A SECOND
TRZE TF,ADELIM ;WAS THE LAST CHARACTER OUR DELIMITER
JRST [PUSH P,T1 ;YES
MOVE T1,[pushj p,loadch];FOR GETSKB
MOVEM T1,GETCHR
POP P,T1
PUSHJ P,GETSK2 ;CHECK FOR COMMENT
PUSHJ P,CLRLIN ; WIND UP
JRST ACC17]
ACC19: IDPB T1,T6 ;SAVE USERS TEXT
TLNE T6,760000 ;FILLED T?
JRST ACC15 ;NO - TAKE MORE
CAIA ;DONT CONFUSE THE INDEFINATE ACCEPT
ACC17: TRO TF,ADELIM ;SET TO CLEAR REST OF ARRAY IF IN A RANGE
TRNE F,DOUBLE ;TEST FOR ANY DOUBLE WORD -
JRST ACC2WD ; WORKING -
TLNN TMOD,B. ;[120] IMPLIED BY REAL*8 OR B.
JRST ACC20 ;STORE FINAL SINGLE VALUE IN T
; DOUBLE WORD WORKING
ACC2WD: SKIPN ARGVAL ;IS THE FIRST VALUE STOREF?
JRST ACC3WD ;NO
MOVEM T,ARGVAL+1 ;YES STORE SECOND
JRST ACC25 ;PLACE BOTH VALUES
ACC3WD: MOVEM T,ARGVAL ;HOLD FIRST OF PAIR
TRNN TF,ADELIM ;ANY MORE TO COME
JRST ACC24 ;YES - GO FIND IT
ACC25: HRRZM T5,DELCHR ;SAVE DELIMITER FOR CLRLIN
PUSHJ P,CLRLIN ;CLEAR REST OF LINE
TLNN TMOD,R. ;ARE WE ACCEPTING RIGHT JUSTIFIED TEXT
JRST ACC10 ;RELAX JUST ASCII
MOVE T1,ARGVAL ;GET BACK THE DOUBLE WORD
JUMPE T1,ACC10 ;NO TEXT?????
MOVE T2,ARGVAL+1 ;INTO A LONG SHIFT FORM
LSH T1,-1 ;FIRST MAKE A CONTINUOUS STRING OF TEXT
LSHC T1,-1 ;GET READY FOR 7BIT CHARACTER SHIFTS
ACC27: LDB T3,[POINT 7,T2,35]
JUMPN T3,ACC26 ;TEST FOR SUCCESSFUL RIGHT JUSTIFICATION
LSHC T1,-7 ;NOT YET MOVE DOWN
JRST ACC27 ;TRY AGAIN
ACC26: LSH T1,1 ;ASCII-ISE
TLZE T2,400000 ;SHOULD THERE BE A LOWER BIT FOR T1
TRO T1,1 ;YES - PUT IT IN
MOVEM T1,ARGVAL ;STORE TOP VALUE
MOVEM T2,ARGVAL+1 ;AND FINALLY LAST VALUE
JRST ACC10 ;AND GIVE THEM TO THE USER
ACC18: TRON TF,ADELIM ;FLAG THIS AS OUR DELIMITER
JRST ACC15 ;SEE IF NEXT CHARACTER IS SAME
TRZ TF,ADELIM ;YES IT IS -
JRST ACC19 ;PASS ON JUST ONE
ACCA2: TLZ TMOD,A.!R. ;REMOVE THE TEXT FLAGS
MOVE T,[ASCII . .] ;FILL THE REST OF THE ARRAY
MOVEM T,ARGVAL ;WITH SPACES
MOVEM T,ARGVAL+1
JRST ACC13
; FINISHED TEXT INPUT
ACC20: HRRZM T5,DELCHR ;SAVE DELIMITER FOR CLRLIN
SKIPN RANGE ;IF NOT IN A RANGE SETTING -
PUSHJ P,CLRLIN ;THEN CLEAR THE REST OF THE USER INPUT
TLNN TMOD,R. ;LEFT OR RIGHT JUSTIFY
JRST ACC13 ;LEFT
LDB T1,[POINT 6,T6,5] ;RIGHT - GET THE T3 POINTER RESIDUE
SETCA T1, ;RIGHT SHIFT
LSH T,1(T1) ; NOW
JRST ACC13 ;NOW PLACE TEXT
; *** CHARACTER STRING INPUT *** ;[157]
ACCC: ;[157]
TLO TMOD,C. ;[157]Display to user properly
PUSHJ P,GETSKB ;[157]Look for quote
SKIPL TERMK ;[157]EOL?
JRST BADSYN ;[157]YES. Syntax error
ACCC1: CAIE T1,"'" ;[157]Single quote?
JRST [TYPE (<%Character string must begin with single quote>)
JRST RET] ;[157]Try again
DMOVE T1,@SAVLOC ;[157]Get descriptor
MOVE T3,T2 ;[163]Save length for descriptor check & loop
IMUL T2,CLMOFF ;[157]Compute for ADJBP
ADJBP T2,T1 ;[157]Get BP to element
MOVEM T2,ORIGLM ;[157]Save starting address
MOVEI T,T2 ;[163]T=location of descriptor to validate
PUSHJ P,CKBPTR ;[163]Validate descriptor; return if OK
MOVE T,T2 ;[163]T=address to validate
PUSHJ P,CKWRIT ;[163]Check destination; return if OK
INSTRL: PUSHJ P,LOADCH ;[157]Get next character
CAIE T1,"'" ;[157]Quote?
JRST PUTBYT ;[157]NO. Store it.
PUSHJ P,LOADCH ;[157]YES. see if there is another
CAIN T1,"'" ;[157]Another quote?
JRST PUTBYT ;[157]YES. Store one only!
DMOVEM T2,TEM4 ;[157]Save pointer & count
MOVE T4,[PUSHJ P,LOADCH] ;[157]for GETSKB
MOVEM T4,GETCHR ;[157]Tell GETCHR how to get input
PUSHJ P,GETSK1 ;[157]Check for comment
PUSHJ P,CLRLIN ;[157]Clear extraneous input
DMOVE T2,TEM4 ;[157]Restore pointer & count
JRST ENDSTR ;[157]End of this string
BYT2T5==^D29 ;[BL]Bits left if BP points to firstbyte in word
PUTBYT: IBP T2 ;[163]Destination address
MOVE T,T2 ;[163]T=address to validate
LDB T5,[POINT 6,T2,05] ;[163]Get byte position within word
CAIN T5,BYT2T5 ;[163]First byte in this word?
PUSHJ P,CKWRIT ;[163]YES. Validate destination; here +1 if OK
DPB T1,T2 ;[163]Store byte
SOJG T3,INSTRL ;[157]Loop thru input string
MOVEI T4,"'" ;[157]Anticipated delimiter
MOVEM T4,DELCHR ;[157]Save for CLRLIN
ENDSTR: MOVEI T4," " ;[157]Fill character
FILSTR: SOJL T3,NDSTR1 ;[157]Jump if string full
IDPB T4,T2 ;[157]Store a space
JRST FILSTR ;[157]Loop till full
NDSTR1: MOVE T3,CLMRNG ;[157]Relative location of last element
SUB T3,CLMOFF ;[157]Elements to fill
JUMPLE T3,ENDCK ;[157]NONE.....
MOVE T4,SAVLOC ;[157]Addr/descriptor
MOVE T4,1(T4) ;[157]Get count
IMULI T4,(T3) ;[157]Total bytes to move
MOVE T3,ORIGLM ;[157]Get source addr
RNGLUP: ILDB T5,T3 ;[157]Load byte
IDPB T5,T2 ;[157]Store it
SOJG T4,RNGLUP ;[157]
ENDCK: MOVE T4,[pushj p,loadch];FOR GETSKB
MOVEM T4,GETCHR
PUSHJ P,GETSK1 ;[157]CHECK FOR COMMENT
SKIPL TERMK ;[157]Line terminator?
JRST ENDCK2 ;[157]YES. Go check for range
PUSHJ P,CLRLIN ;[157]Show user error
JRST RET ;[157] and return
ENDCK2: MOVE T,SAVLOC ;[157]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: TLO TMOD,O. ;DISPLAY TO USER AS OCTAL
SETZI T, ;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 W1,W2 ;CLEAR BUILD AREA
MOVEI T,^D12 ;INITIALIZE COUNT
TLNE TMOD,B. ;[120] CHECK BIG
MOVEI T,^D24 ;[120] DOUBLE IT FOR BIG
CAIA
ACC29: PUSHJ P,GETSKB ;GET NEXT CHARACTER
SKIPL TERMK ;END OF LINE?
JRST ACC16 ;
CAIE T1,"+" ;PLUS?
JRST ACC31
TLNE F,MF ;YES - MINUS SEEN?
JRST BADSYN
JRST ACC29 ;NO - IGNORE THE +
ACC31: CAIN T1,42 ;DOUBLE QUOTE?
JRST ACC29 ;YES - IGNORE
CAIE T1,"-"
JRST ACC16 ;NOT A "-"
TLC F,MF ;COMPLEMENT FLAG
JRST ACC29 ;GET NEXT CHARACTER
ACC16: SUBI T1,60 ;OCTALISE
JUMPL T1,ERR2 ;CHARACTER MUST OF COURSE -
CAIL T1,10 ; BE OCTAL
JRST ERR2 ;NOT OCTAL - COMPLAIN
LSHC W1,3 ;BUILD OCTAL VALUE IN T
IOR W2,T1 ;
SOJE T,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: TLNN TMOD,B. ;[120] BIG WORKING?
JRST ACC30 ;AS YOU WERE - STORE OCTAL
MOVEM W1,ARGVAL ;STORE LONG OCTAL
MOVEM W2,ARGVAL+1
JRST ACC32
ACC30: MOVEM W2,ARGVAL ;STORE SINGLE OCTAL
; HERE AT END OF INPUT
ACC32: PUSHJ P,CLRLIN ;CLEAR THE LINE
TLZN F,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: 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 W1,T3 ;FORMAT START
MOVE W2,T1 ;FORMAT END
; HERE WITH A RECOGNISED FORMAT REFFERENCE SET UP
ACC3: MOVE T,[POINT 7,(W1)]
pushj p,loadch ;GET A USER CHARACTER
CAIE T1," " ;BLANKS
CAIN T1,11 ; AND TABS IGNORED TO START WITH
JRST ACC3
MOVE T2,[pushj p,loadch]
MOVEM T2,GETCHR ;SET TO READ FROM USER
PUSHJ P,GETSK2
CAIE T1,"(" ;FIRST FORMAT CHARACTER MUST BE (
JUMPA T1,BADSYN
ACC4: ILDB T2,T ;INCREMENT POINTER NOW
HRRM T,.+1
CAIG W2,(W1) ;HAVE WE EXHAUSTED THE FORMAT
JRST [JUMPE T1,RET
JRST ERR13] ;YES
DPB T1,T ;STORE NEXT CHARACTER
JUMPE T1,ACC4
ACC6: pushj p,loadch ;GET ANOTHER USER FORMAT CHARACTER
CAIE T1," " ;NOW ALLOW
CAIN T1,11 ;BLANKS AND TABS AS USER WANTS
CAIA
PUSHJ P,GETSK2
JUMPN T1,ACC7 ;NOT THE LAST CHARACTER YET IF NON ZERO
CAIE T3,")" ;LAST USER CHARACTER MUST BE A )
JRST ERR32 ; IT WASN'T SO COMPLAIN
ACC7: MOVE T3,T1 ;REMEMBER THE LST USER CHARACTER
CAIE T1,37 ;DOES USER WANT LINE CONTINUATION = ^_
JRST ACC4 ;NO - NORMAL
ACC5: pushj p,loadch ;ACCEPT ANOTHER USER CHARACTER
CAIN T1,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
SETZM CURGRP ;CLEAR CURRENT GROUP STACK FLAGS
TRO TF,TYPCMD ;[171] Remember it's a TYPE command
TLO F,CFLIU!GRPFL ;SET CORE FILE IN USE - ALLOW GROUPS
CLEARM GETCHR ;THIS IS THE FIRST ACCESS TO CORE FILE THIS LINE
TLNE F,EOL ;USER GAVE ANY ARGUMENTS?
TLOA F,OFCFL ;NO - GET THEM FROM CORE FILE
TLZ F,OFCFL ;YES - PUT THEM INTO CORE FILE
PUSHJ P,DISP4 ;DISPLAY ROUTINE
TLZ F,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]
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 T2,[POINT 7,(T3)]
MOVEI W1,SYM ;SET UP FOR SYMBOL PRINT
PUSHJ P,SPT ;PRINT SYMBOL=STATEMENT #
TYPE( FORMAT)
DISP6: ILDB T,T2 ;GET A CHARACTER FROM THE FORMAT TEXT
HRRM T2,.+1 ;GET NO OF WORDS DONE
CAIG T1,(T3) ;ALL DONE?
JRST DISP5 ;DONE WITH FORMAT
putchr (T) ;TYPE IT
JRST DISP6 ;MORE TO DO - BACK FOR MORE
; SET UP ACCESS TO A FORMAT STATEMENT T3=START T1=END
; SKIP ON SUCCESS.
FRMSET: MOVEI T3,(T) ;SHOULD POINT TO A JRST
LINE
LDB T,[POINT 7,(T3),6] ;GET FIRST CHARACTER OF FORMAT
CAIE T,"(" ;FIRST CHARACTER MUST BE A (
PJRST ERR16 ;USER LOSES
MOVE T,T3 ;ACCEPTED START OF FORMAT -
MOVEM T,SAVLOC ; NOW FIND END OF F10 FORMAT
HRREI T,-12 ;CHANGE LABEL+P TO LABEL+F
ADDM T,SYM ;LIKE SO
PUSH P,T3 ;SAVE (T3)
PUSHJ P,EVAL ;LOCATE THE FORMAT END
JRST ERR41 ;CANT FIND FORMAT END
POP P,T3 ;RESTORE
MOVEI T1,1(T) ;SET UP END OF FORMAT IN T1
JRST CPOPJ1 ;T3 START - T1 END . . . ALL SET UP
VAL2: TAB
MOVE T,RANLIM ;GET THE CURRENT VALUE POINTER
MOVE T,1(T) ;GET THE NEXT VALUE
POPJ P,
; IMPLIED RANGE I.E. TYPE ARRAY
DISP2: CAIN T1,"-"
JRST DISP1 ;GET LIMIT OF RANGE
TRZN TF,IMPRNG ;IS THIS A SIMULATED RANGE
JRST DISP10 ; NO - JUST NORMAL
DISP11: PUSHJ P,DISP14 ;SET UP RANGE WITH UPPER LIMIT
TLOA F,GRPFL ;PERMIT GROUP LOGIC AGAIN
DISP0: HRL TMOD,TMOD ;UNFUDDLES THE MODIFIERS FOR A RANGE
; ONE-SHOT TYPE REQUEST
; ENTER WITH SYMBOL VALUE IN T
; ENSURE TERMK,RANGE=0
DISP10:
MOVEM T,LWT ;SAVE SYMBOL VALUE
MOVE T,(T) ;GET CONTENTS OF SYMBOLIC ADDRESS
EXCH T,LWT ;SAVE CONTENTS AND GET SYMBOL VALUE
;SAVE SYMBOL VALUE IN CASE WE DO A RANGE
MOVEM T,RANLIM ;SAVE FOR RANGE NAME ID SUPRESSION
TLNE TMOD,-1 ;[173]ANY LOCAL MODIFIERS?
MOVS TMOD,TMOD ;[173]YES - USE THEM
TRO TMOD,ANYMOD ;[173]FLAG FIRST PRINT ON LINE
PUSHJ P,OFFSET ;TYPE USERS SYMBOL
JRST DISP9
SETZM FRMSAV ;[167]Reset formal
EXCH T,SYM ;GET BACK SYMBOL CONTENTS
;[173] TLNE TMOD,-1 ;ANY LOCAL MODIFIERS?
;[173] MOVS TMOD,TMOD ;YES - USE THEM
;[173] TRO TMOD,ANYMOD ;FLAG FIRST PRINT ON LINE
TRNN TMOD,C. ;[157]Character string?
JRST TYPF ;[157]NO. Next test
; *** TYPE CHARACTER ***
DMOVE T1,@SAVLOC ;[157]Load ptr & length
MOVE T3,T2 ;[163]Save string length
IMUL T3,CLMOFF ;[157]Compute for ADJBP
JUMPE T3,CHKPTR ;[157]All set up if first element(CLMOFF=0)
ADJBP T3,T1 ;[157]Create BP to element
MOVE T1,T3 ;[157]Get the adjusted pointer
CHKPTR: MOVEI T,T1 ;[163]T=Location of descriptor to validate
PUSHJ P,CKBPTR ;[163]Validate; return if OK
MOVE T,T1 ;[163]T=address to validate
PUSHJ P,CKREAD ;[163]Validate;return if OK
CKBIG: TRNE TMOD,B. ;[157]Display whole string?
JRST TYPEC ;[157]YES. skip size check
CAILE T2,^D256 ;[157]Large string?
;*** flag
MOVEI T2,^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 T1 ;[163]Destination address
MOVE T,T1 ;[163]T=location of address to validate
LDB T3,[POINT 6,T1,05] ;[163]Get byte position within word
CAIN T3,BYT2T5 ;[163]First byte in this word?
PUSHJ P,CKREAD ;[163]YES. Validate source; return here if OK
LDB T,T1 ;[163]Store byte
CAIN T,"'" ;[157]Single quote?
PUSHJ P,ASCOUT ;[157]YES. double it
PUSHJ P,ASCOUT ;[157]Display it
SOJG T2,BYTLUP ;[157]Loop til thru
TYPE (') ;[157]Concluding quote
POPJ P,
;*** check for truncated string?
; *** TYPE FLOATING ***
TYPF: TRNN TMOD,F. ;TEST THE FLOATING FLAG
JRST TYPD ;NO REAL TRY DOUBLE REAL
JUSTIFY
MOVEI T2,4 ;ARG TYPE REAL FOR FOROTS
PUSHJ P,FOROUT ;ONE ARG OUTPUT
; *** TYPE DOUBLE REAL ***
TYPD: TRNN TMOD,D. ;TEST FOR DOUBLE REAL
JRST TYPX ;NO FLOATING TRY COMPLEX
JUSTIFY
MOVE T2,RANLIM ;GET ARG POINTER
MOVE T,1(T2) ;GET SECOND ARG
MOVEM T,ARGVAL+1 ;SAVE 2ND. HALF FOR FOROTS
MOVE T,(T2) ;RE-INSTATE IST.ARG IN T
MOVEI T2,TP%DPR ;[137]Set up for default D-float arg type=10
TRNE F,GFLOAT ;[137]If D-float, skip to FOROTS call.
MOVEI T2,TP%DPX ;[137] else, we have G-float, set are type=13
PUSHJ P,FOROUT ;OUTPUT REAL*8
; *** TYPE COMPLEX ***
TYPX: TRNN TMOD,X. ;[157]TEST FOR COMPLEX TYPE OUT
JRST TYPI ;NO COMLEX TRY FOR INTEGER
JUSTIFY
MOVE T2,RANLIM ;GET ARG POINTER
MOVE T,1(T2) ;GET SECOND ARG
MOVEM T,ARGVAL+1 ;SAVE 2ND HALF FOR FOROTS
MOVE T,(T2) ;REINSTATE 1ST ARG IN T
MOVEI T2,14 ;SET UP ARGTYPE FOR COMPLEX
PUSHJ P,FOROUT ;ONE ARG OUTPUT
; ** TYPE INTEGER ***
TYPI: TRNN TMOD,I. ;TYPE AS INTEGER?
JRST TYPO ;NO - TRY OCTAL
JUSTIFY
MOVEI ODF,^D10 ;PREPARE FOR DECIMAL TYPE OUT
PUSHJ P,FTOC ;CONSTANT PRINT
; *** TYPE OCTAL ***
TYPO: TRNN TMOD,O. ;TYPE AS OCTAL?
JRST TYPA ;NO - TRY ASCII
JUSTIFY
MOVEI ODF,10 ;PREPARE FOR OCTAL PRINT
PUSHJ P,FTOC ;PRINT IN OCTAL
TRNN TMOD,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 TMOD,A. ;TYPE AS ASCII?
JRST TYPR ;NO - SEE IF RIGH JUSTIFIED ASCII
JUSTIFY
PUSHJ P,TXT341 ;THROW UP ASCII
TRNN TMOD,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 TMOD,R. ;TYPE AS ASCII RIGHT JUSTIFY
JRST TYPL ;[120] NO - TRY OCTAL
JUSTIFY
TYPE(R) ;RASCII IDENTIFIER
LSH T,1 ;MAKE LEFT JUSTIFIED ASCII
PUSHJ P,TXT341 ;TYPE AS USUAL
TRNN TMOD,B. ;[120] DOUBLE RASCII?
JRST TYPL ;[120] NO
PUSHJ P,VAL2 ;GET NEXT VALUE
LSH T,1 ;FAKE ASCII
PUSHJ P,TXT341 ;TYPE AS ASCII
TYPL: TRNN TMOD,L. ;[120] TYPE AS LOGICAL?
JRST TYPS ;[120] NO - SEE IF IN RANGE
JUSTIFY ;[120]
JUMPGE T,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 TMOD,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 TMOD,C. ;[157]Character string?
JRST TYPC ;[157]YES.
AOS T,RANLIM ; YES INCREMENT VARIABLE
TRNE F,DOUBLE ;[112] IS THIS A DOUBLE WORD ARRAY RANGE
AOS T,RANLIM ;DOUBLE WORD ARRAYS GO UP BY TWO
CAMG T,RANGE ;TO LIMIT OF RANGE
JRST DISP0 ;AND TYPE ALL REQUIRED
JRST DISP5 ;[157]DONE. Go clean up
TYPC: MOVE T,RANLIM ;[157]Restore base
AOS T1,CLMOFF ;[157]Count this element
CAMG T1,CLMRNG ;[157]Was that the last?
JRST DISP0 ;[157]NO. Go type next element
DISP5: TLNE TMOD,-1 ;LOCAL MODIFIERS?
HLRZ TMOD,TMOD ;YES - REMOVE THEM
SKIPGE TERMK ;END OF USER INPUT LINE YET?
JRST DISP4 ; NO - KEEP GOING
POPJ P, ; YES - END OF TYPE COMMAND
JUSTFY: TRZN TMOD,ANYMOD ;SEE IF FIRST OUTPUT THIS VARIABLE
jrst [LINE
jrst .+1]
TYPE( = )
MOVE T,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 T,RANGE ;REMEMBER START OF RANGE
MOVE T,CLMOFF ;[157]Get beginning offset
MOVEM T,CLMRNG ;[157]Save it in case this is /C
TLZ F,GRPFL ;NO GROUP REQUESTS HERE OR PRINT MODIFIERS
PUSH P,MATHSM ;SAVE CURRENT SYMBOL
PUSHJ P,SYMIN ;GET NEXT SYMBOL
JRST DISP9 ;BAD LABEL
JRST BADSYN ;STATEMENT NO. ????
POP P,T3 ;GET FIRST SYMBOL BACK
CAME T3,MATHSM ;ARE THEY THE SAME
JRST ERR40 ;NO - SORRY
TRZE F,SUBFLG ;WAS THERE AN IMPLIED RANGE
JRST DISP11 ;YES - GO DEAL WITH IT
CAML T,RANGE ;SORT OUT SYMBOL ORDER
EXCH T,RANGE ;CHANGE THEIR ORDER
CAIN T1,"-" ;"-" IS A DELIMITER BUT IS BAD HERE
JRST BADSYN
TLO F,GRPFL ;O.K. FOR GROUPS AGAIN
;[170] TLNN TMOD,C. ;[157]Character?
TRNN TMOD,C. ;[170]character?
JRST DISP10 ;NOW TYPE RANGE
; clmrng=first offset given
; clmoff=offset just received
MOVE T1,CLMOFF ;[157]Get the lower offset
CAMLE T1,CLMRNG ;[157]Is lower .le. upper?
EXCH T1,CLMRNG ;[157]NO. Make it so
MOVEM T1,CLMOFF ;[157]Restore lower offset
JRST DISP10 ;[157]Go type for the user
SYM4: TLNE F,GRPFL ;ARE WE ALLOWING CORE STRINGS
CAIE T1,"/" ;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
SKIPL TERMK ;EOL?
JRST BADSYN ;CAN'T HAVE THAT!
PJRST SYMIN ;RESUME SYMIN ACTIVITIES
; HANDLE GROUP REQUESTS
SYM14: CAIL T,1
CAILE T,GPMAX ;WHICH MUST BE IN RANGE
JRST ERR15 ;NO GOOD
CAIE T1,"," ;ALLOW COMMA AS DELIMITER
JUMPN T1,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 F,GRPFL ;IS GROUP LOGIC IN ACTION
JRST RET ;ASSUME NUL INPUT GO BACK TO USER
POP P,(P) ;REMOVE THE SYMIN PUSH
JUMPE T1,DISP5 ;EMPTY GROUP?
JRST BADSYN ;MUST BE BAD SYNTAX
; ROUTINE TO DETERMINE THE LENGTH OF AN IMPLIED RANGE
DISP14: MOVEM T,RANLIM ;SAVE THE BASE ARRAY REFFERENCE
SETZM PUTTER ;SET FOR RAYNAM
PUSHJ P,GET.RP ;GET THE RANGE PRODUCT FOR THIS ARRAY
MOVE T,DIMTOT ;
SOJ T, ;
MOVEM T,CLMRNG ;[157]In case character
ADD T,RANLIM ;FORM UPPER RANGE LIMIT
MOVEM T,RANGE ;SAVE THE RANGE
MOVE T,RANLIM ;GET THE START ADDRESS
POPJ P,
; ENTRY POINT FOR A GROUP 'TYPE' REQUEST
; PUSHJ P,SYM5
; WITH GROUP # 1-GPMAX IN T
; AND TERMK=0
SYM5: TRZE TF,DCOPFG ;DON'T OPEN PROG?
JRST SYM16 ;NO - DON'T
SKIPN T3,GRP2(T) ;GET GROUP'S PROG
JRST SYM16 ;NULL - IGNORE IT
CAMN T3,OPENED ;IS IT CURRENT?
JRST SYM16 ;YES
MOVEM T3,SYM ;NO - SAVE IT
MOVE T3,OPENED
MOVEM T3,OLDOPN ;AND SAVE OLD OPENED
PUSH P,T ;SAVE (T)
PUSHJ P,IMPOPN ;DO THE OPEN AND MESSAGE
POP P,T ;RESTORE (T)
SYM16:
; CHECK FOR GROUP RECURSION
MOVEI T3,1
LSH T3,(T) ;SET UP MASK BIT
TDOE T3,CURGRP ;CHECK AND SET
JRST ERR39 ;GROUP ALREADY ACTIVE - ERROR
MOVEM T3,CURGRP ;SAVE STATE
PUSH P,T ;SAVE T
IMULI T,CFSIZ ;GET RELEVANT GROUP SECTION
ADD T,[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 T,CFLPTR ;SET UP NEW POINTER
HRRZM T,CFLST ;DEFINE NEW STRING LIMIT
MOVE T,[ILDB T1,CFLPTR] ;GET POINTER TO NEW INFORMATION
MOVEM T,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,T ;GET NUMBER BACK
MOVEI T3,1
LSH T3,(T) ;SET UP MASK
TDC T3,CURGRP ;CLEAR THIS GROUP FLAG
MOVEM T3,CURGRP ;SAVE IT
PJRST DISP5 ;SEE IF THERE IS AN ORIGINAL USER
;STRING TO PROCESS
DISP3: PJRST DISP9 ;CANNOT FIND SYMBOL
;OPEN LOGIC
SETNAM: TLO F,FPRNM ; FIND PROGRAM NAME
PUSHJ P,FNDSYM ;
JRST ERR6 ; NO SUCH NAME
HLRE T,(R) ; GET (XWD -LEN,...)
HRLM T,OPENLS
ADDI T,1(R) ; POINT TO BEG OF PROGS SYMBOLS
HRRM T,OPENLS ;
MOVE T,SYM
MOVEM T,OPENED ; PROGRAM NAME OPENED
POPJ P, ;
; DIMENSION LOGIC
DEFINE PAIRS(K)
< K=K+2
XWD 0,K ;START OF STRING,NEXT IN STRING
XWD 0,0 ;PARAMETER WORD>
K=DIMTAB
DIMTAB: XLIST ;DEFINE TABLE OF TWO WORD PAIRS
REPEAT DIMSIZ-1,<PAIRS(K)>
XWD 0,0 ;END OF LIST IS SPECIAL
XWD 0,0
LIST
NUMPRS=DIMFRE-DIMTAB ;THE NUMBER OF AVAILABLE WORDS
NUMPRS=NUMPRS/2 ;DEFINES THE # OF 'PAIRS' AVAILABLE
DIMFRE: XWD K,DIMTAB ;END, AND START OF FREE SPACE
DIMNAM: XWD 0,0 ;END, AND START OF LIST OF ARRAY NAMES
; ROUTINE TO OBTAIN A FREE TWO WORD PAIR
; CALL PUSHJ P,GET2WD
; RETURN - ADDRESS OF 'PAIR' IN T
GET2WD: HRRZ T,DIMFRE ;GET THE START OF THE FREE LIST
HRRZ T1,(T) ;FIND THE LOCATION OF THE NEXT 'PAIR'
JUMPE T1,GETNON ;END OF LIST REACHED
HRRM T1,DIMFRE ;REMOVE THIS 'PAIR' FROM THE LIST
POPJ P, ;RETURN WITH GOOD 'PAIR' ADDRESS IN T
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 'PAIR' TO THE FREE LIST
; CALL PUSHJ P,PUT2WD
; ENTER WITH ADDRESS OF 'PAIR' IN T
; RETURN
PUT2WD: HLRZ T1,DIMFRE ;GET THE ADDRESS OF THE END OF THE LIST
HRRM T,(T1) ;APPEND THE NEW 'PAIR'
SETZM (T) ;NEW 'PAIR' BECOMES END OF LIST
HRLM T,DIMFRE ;RECORD THE 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 . . . T=ADDRESS OF ARRAY, T2=LAST ARRAY
; F10RAY IN TF IS SET IF F10 DEFINED
RAYNAM: TRZ F,FORMAL!F10RAY ;[105] ASSUME NEITHER HOLDS
SETZM FRMSAV ;[167]Reset formal value
HRRZI T2,DIMNAM ;SET UP FOR FIRST ARRAY
HRRZ T,DIMNAM ;IS THERE AN ENTRY AT ALL?
RAY: JUMPE T,RAY3 ;T2 WILL POINT TO THE END OF THE LIST
HRRZ T1,1(T) ;THIS IS AN ARRAY BLOCK - GET THE NAME(VALUE)
CAMN T1,SAVLOC ;ARE WE REDEFINING CURRENT NAME?
JRST RAY2 ; YES - REMOVE THE ENTRY FIRST
MOVE T2,T ;T2 WILL POINT TO THE CURRENT GOOD ENTRY
HRRZ T,(T) ;FIND THE NEXT 'PAIR' ADDRESS
JRST RAY
RAY2:
SKIPL T3,1(T) ;[157]IS THE DOUBLE PRECISION BIT ON = 400000,,0
TRZA F,DOUBLE ;NO - MAKE SURE 'DOUBLE' IS OFF
TRO F,DOUBLE ;YES - SET THE DOUBLE FLAG
TLNE T3,200000 ;[157]Character array?
TRO F,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,T ;SAVE BOTH T AND-
PUSH P,T2 ; T2 AROUND EVAL
MOVE T,SAVLOC
TRO F,SILENT ;DON'T PRINT SYMBOL
PUSHJ P,LOOK ;SETS UP W1 FROM T
JRST RAYPOP ;
JRST RAYPOP ;DOSENT EXIST
POP P,T2 ;RETURN T2
POP P,T ; AND T
MOVE RAY.,W1 ;GET THE ARRAY SYMBOL
MOVE T1,(RAY.) ; AND SEE IF WE HAVE AN F10 ARRAY -
TLZ T1,PNAME ; DEFINITION -
IOR T1,[XWD 500000,0]; THIS IS THE SAME SYMBOL
CAME T1,2(RAY.) ; WITH FLAGS 50 SET
POPJ P, ;NO - NOT AN F10 DEFINITION
TRO F,F10RAY ;YES - FLAG THIS AS AN F10 ARRAY
MOVE RAY.,3(RAY.) ;SET POINTER TO ARRAY TABLE INFORMATION
LDB T1,[POINT 4,1(RAY.),12]
TRZ F,DOUBLE ;[162]MAKE SURE DOUBLE IS OFF
CAIE T1,TP%DPR ;[112] [161]Double word array?
CAIN T1,TP%DPX ;[162]NO. G-Floating double array?
TROA F,DOUBLE ;[162]YES FLAG IT & reset character flag
CAIE T1,TP%CHR ;[161]Character array?
TRZA F,CHARS ;[161]NO
TRO F,CHARS ;[161]YES
;[161] LDB T1,[POINT 9,1(RAY.),8]
LDB T1,[POINT 7,1(RAY.),8] ;[161]
MOVEM T1,DIMCNT ;SET UP THE NUMBER OF DIMENSIONS
LDB T1,[POINT 1,1(RAY.),13]
JUMPN T1,RAY4 ;PASSING FORMAL ARRAY ARGUMENTS?
RAY5: HRRZI RAY.,3(RAY.) ;SET TO POINT TO THE FIRST DIMENSION
JRST CPOPJ1
RAYPOP: POP P,T1 ;MUST RESET T2-
POP P,T ; AND T BEFORE
POPJ P, ; GIVING A NO FOUND EXIT
RAY4: TRO F,FORMAL ;FLAG FORMAL WORKING
HRRZI T,@1(RAY.) ;GET THE ACTUAL ARRAY BASE
MOVEM T,FRMSAV ;SAVE THE FORMAL REFFERENCE
JRST RAY5 ;
; 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,F ;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 F,FORMAL ;ATTEMPT TO RE-DIMENSION A FORMAL PARAMETER
JRST ERR33 ;NO YOU DON'T
TRNN F,F10RAY ;F10 DEFINED ARRAY?
JRST PUTCHK ;RESET ALL
JRST ERR28 ;WARN OF F10 REDEFINITION
PUTOK: POP P,F ;RESTORE FLAGS FROM ABOVE
PUSHJ P,GET2WD ;GET A 'PAIR' - END OF NAMES = T2
MOVEM T,T3 ;SAVE FOR NAME DEFINITION - T3
PUSHJ P,GET2WD ;GET A 'PAIR' FOR DIMENSION DEFINITION
;ENSURE WE HAVE 2 'PAIRS' FREE NOW
;SAVE PAIN IN 'FLUSHING' LATER
HRRM T3,(T2) ;SAY HELLO TO NEW MEMBER
SETZM (T3) ;NEW MEMBER BECOMES END OF CHAIN
MOVE T1,SAVLOC ;GET THE NEW MEMBERS NAME
TRNE F,DOUBLE ;IS THIS A DOUBLE WORD ARRAY
TLO T1,400000 ;YES - SAVE THE FACT
TRNE F,CHARS ;[157]Character array?
TLO T1,200000 ;[157]YES.
MOVEM T1,1(T3) ;ACCEPT THE NEW MEMBER TO THE FAMILY
HRLM T,(T3) ;NEW MEMBERS ARE GIVEN A DIMENSION LIST
PUSHJ P,PUTSUB ;STORE THE SUBSCRIPTS
JRST CPOPJ1 ;JUMP OVER POSSIBLE PUTDIM ENTRY
PUTSUB: MOVE T1,TEM1 ;GET THE UPPER SUBSCRIPT
SUB T1,TEM ;FORM THE DIMENSION RANGE < 256K
HRLZM T1,(T) ;SAVE IN LINK LOCATION OF PAIR
; AND DENOTE END OF PRESENT DIMENSION LIST
MOVE T1,TEM ;GET THE LOWER SUBSCRIPT
MOVEM T1,1(T) ;SAVE FOR FUTURE REFERENCE
MOVEM T,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,GET2WD ;GET A FREE 'PAIR'
MOVE T1,PUTTER ;FIND WHERE THE LAST DIMENSION WAS STORED
HRRM T,(T1) ;LINK NEW 'PAIR' TO OLD 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 T,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 F,F10RAY ;F10 DEFINED?
JRST GET3 ;YES
HLRZ T,(T) ;GET THE START OF DIMENSION LIST
JRST GET5 ;FIRST TIME IS SPECIAL
GET4: TRNE F,F10RAY ;F10 ARRAY DEFINITION?
JRST GET3 ;YES
HRRZ T,(T) ;GET NEXT DIMENSION IF ANY
GET5: JUMPE T,ERR22 ;END OF LIST - TOO MANY DIMENSIONS EXPECTED
MOVEM T,PUTTER ;SAVE LINK TO NEXT DIMENSION
MOVE T2,1(T) ;GET THE LOWER SUBSCRIPT
MOVEM T2,TEM ;SAVE THE LOWER SUBSCRIPT
HLRZ T2,(T) ;GET THE RANGE OF THIS DIMENSION
ADD T2,TEM ;FORM THE UPPER SUBSCRIPT
MOVEM T2,TEM1 ;SAVE AS THE UPPER SUBSCRIPT
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 T,@(RAY.) ;GET THE LOWER BOUND
MOVEM T,TEM ;SAVE LOWER
MOVE T,@1(RAY.) ;GET THE UPPER BOUND
MOVEM T,TEM1 ;SAVE LOWER
HRRZI RAY.,3(RAY.) ;RAY. 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 T3,SAVLOC ;GET THE NEW ARRAY NAME(VALUE)
EXCH T3,BASRAY ;SAVE AND START AT BASE-ARRAY NAME
PUSHJ P,RAYNAM ;SET UP POINTERS TO BASE-ARRAY
POPJ P, ; ????
MOVEM T3,BASRAY ;RESET BASE ARRAY AND CURRENT NAME
TRNE F,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 T,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 F,F10RAY ;IS THIS AN F10 DEFINED ARRAY
SKIPA T3,[EXP SAVLOC-1] ;IF SO FOOL TYPDIM
MOVE T3,T ;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 F,FLSHAL ;SET UP TO FLUSH ALL FROM BASE-ARRAY
MOVE T,BASRAY ;GET THE BASE ARRAY VALUE
MOVEM T,SAVLOC ;AND SET UP FOR RAYNAM
PUSHJ P,RAYNAM ;RESET F10RAY FLAG TO NEW BASRAY SETTING
POPJ P, ;?????
FLUSH: TRNN F,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
;T2=POINTS TO LAST ARRAY NAME BLOCK
;T= CURRENT ARRAY NAME BLOCK
FLUSH2: HLRZ T3,(T) ;GET DIMENSION LIST ADDRESS
HRRZ T1,(T) ;GET NEXT MEMBER ADDRESS
HRRM T1,(T2) ;LOOP OUT THE OFFENDING ARRAY NAME ENTRY
PUSHJ P,PUT2WD ;RETURN A PAIR
PUSHJ P,DELIST ;DELETE THE LIST STARTING AT C(T3)
TRNN F,FLSHAL ;HARD FLUSH?
POPJ P, ;JUST ONE ARRAY FOR NOW
HRRZ T,(T2) ;GET NEXT ARRAY REFERENCE IF ANY
JUMPE T,CPOPJ ;EXIT IF END OF LIST
JRST FLUSH2 ;MORE TO DO
;ROUTINE TO DELETE A LIST - STARTING IN T3
DELIST: SKIPN T,T3 ;TEST FOR END OF LIST - RETURN PAIR IN T
POPJ P, ;END OF LIST
HRRZ T3,(T3) ;GET NEXT PAIR ADDRESS
PUSHJ P,PUT2WD ;RETURN THE OLD PAIR
PJRST DELIST ;FOLLOW THROUGH TO END OF LIST
DIM5: PUSHJ P,DIMOUT ;DISPLAY ALL ARRAY INFO.
LINE
JRST RET
; DIMENSION LOGIC
CARRAY: TROA F,CHARS ;[157]Character array
DUBLE: TRO F,DOUBLE ;[112] FLAG THIS AS A DOUBLE WORD ARRAY
DIM: JUMPL F,DIM5 ;OUTPUT ALL DIMENSION SPECS
PUSHJ P,TTYIN ;GET NEXT USER STRING
JUMPE T2,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
MOVEM T3,MATHSM ;THATS WHAT USER TYPED
MOVEM T3,SYM ;SAVE FOR 'EVAL'UATION
PUSHJ P,EVAL ;EVALUATE SYMBOL
JRST ERR6 ;WE DON'T HAVE IT
MOVEM T,SAVLOC ;SAVE ARRAY NAME VALUE
MOVE T1,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 T1,"(" ; [ DENOTES START OF DIMENSION DEFINITION
JRST DIM14 ;COMMAND - WILL NOW BE NON ZERO
CAIE T1,"[" ; ( IS AN ALTERNATIVE TO [
JRST DIM7
TLO F,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 T1,"/" ;A / IS ACCEPTABLE TO REMOVE ARRAYS
JRST BADSYN ;ANYTHING ELSE WONT DO
PUSHJ P,TTYIN ;GET NEXT INPUT
JUMPN T1,BADSYN ;MUST BE LINE END NOW
JUMPE T2,BADSYN ;NO CHARACTERS??
LSHC T1,6 ;GET THE FIRST SWITCH CHARACTER
CAIE T1,'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 F,BASENM ;HAS A BASE NAME BEEN ACCEPTED
JRST DIM0 ;YES - DON'T FLUSH YET
SETZM F10RP ;[163]Reset
PUSH P,F ;PROTECT THE DOUBLE FLAG AWHILE
PUSHJ P,RAYNAM ;HAVE WE HAD THIS BASE ARRAY BEFORE
JRST DIMBAS ;[163]No references to this array
TRNE F,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 F,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 T,DIMTOT ;[163]Load the range product
MOVEM T,F10RP ;[163]Save it
; where & when should f10rp be reset????
SETZM DIMTOT ;[163]Clear
bpw==5
DIMBAS: MOVE T,SAVLOC ;GET THE ARRAY VALUE
MOVEM T,BASRAY ;MARK THIS AS OUR BASE ARRAY
POP P,F ;RE-INSTATE THE DOUBLE FLAG IF THERE
DIM0: TRO F,SURGFL ;FLAG THIS CALL AS SUBSCRIPT GATHERING
PUSHJ P,EITHER ;READ A SUBSCRIPT
CAIA ;CONSTANT
MOVE T,(T) ;VARIABLE - GET VALUE
TRZ F,SURGFL ;CLEAR SUBSCRIPT RANGE ACCEPT FLAG
MOVEM T,TEM1 ;SAVE TEMPORARILY AS UPPER SUBSRIPT
PUSHJ P,NXTCHR ;MOVE TO NEXT CHARACTER
CAIN T1,"," ;COMMA IS THE USUAL DELIMITER
JRST DIMCOM ;PROCESS A COMMA
CAIE T1,":" ;A : IS AS GOOD AS A BAR=/
CAIN T1,"/" ;BAR IS THE SUBSCRIPT SEPARATOR
JRST DIMBAR ;PROCESS A BAR
TLNN F,LFTSQB ;SKIP IF WE HAD A [ TO START
ADDI T1,"]"-")" ;ACCEPTABLE DELIMITER IF )
CAIN T1,"]" ;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 F,DIMEND ;FLAG THAT THIS IS THE END OF THE LIST
DIMCOM: TLZE F,BAR ;HAVE HAD TWO SUBSCRIPTS?
JRST DIM2 ;YES - CHECK THE ORDER
MOVEI T,1 ;ADJUST LOWER SUBSCRIPT TO BE 1
MOVEM T,TEM ;LOWER SCR IN TEM
DIM2: MOVE T,TEM1 ;GET THE SECOND SUBSCRIPT
CAMGE T,TEM ;ENSURE THAT IT IS GREATER THAN THE FIRST
JRST ERR3 ;TELL USER ABAOUT THE ERROR
SUB T,TEM ;FIND THE RANGE
CAIG T,777777 ;CANT HAVE ARRAYS OWNING WHOLE OF CORE
JRST DIM3 ;SUBSCRIPTS OK
JRST ERR27 ;BAD SUBSCRIPTS
DIM3: SKIPN DIMTOT ;IS THIS THE FIRST SETTING FOR THIS ARRAY
PUSHJ P,PUTNAM ;YES - USE PUTNAM
PUSHJ P,PUTDIM ;N0 - ADD ANOTHER DIMENSION
MOVE T,TEM1 ;GET UPPER SUBSCRIPT
SUB T,TEM ;FORM RANGE
AOJ T, ;MUST HAVE AT LEAST ONE
SKIPN DIMTOT ;IS THIS THE FIRST DIMENSION
AOS DIMTOT ;YES - MAKE FIRST RANGE DEFAULT = ONE
IMULM T,DIMTOT ;FORM TOTAL SUBSCRIPT COUNT IN DIMTOT
TLNN F,DIMEND ;WAS A LEFT SQUARE BRACKET SEEN LAST?
JRST DIM0 ;NO - BACK FOR MORE
MOVE T,DIMTOT ;[163]Get our computed range product
TRNE F,DOUBLE ;[163]Double-word array?
ADDB T,DIMTOT ;[163]YES!
MOVE T,SAVLOC ;GET THE ARRAY VALUE
NOTCH: SKIPN T,F10RP ;[163]Was there a compiler definition?
POPJ P, ;[163]NO! test impossible
CAML T,DIMTOT ;[163]Compiler have less than user wants?
POPJ P, ;[163]NO! 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 T,SAVLOC ;GET THE OFFENDING ARRAY NAME
TRZ F,SILENT ;SPEAK-UP
PUSHJ P,LOOK ;SHOW THE USER
JFCL
JFCL
POPJ P,
DIMBAR: TLOE F,BAR ;FLAG A BAR IF NOT ALREADY SET
JRST BADSYN
MOVE T,TEM1 ;MOVE FIRST SUBSCRIPT TO APPROPRIATE PALCE
MOVEM T,TEM ; IN TEM
JRST DIM0 ;LOOK FOR SECOND SUBSCRIPT
NXTCHR: SKIPL TERMK ;END OF LINE?
JRST BADSYN ;YES - SHOULD'T BE
JUMPN T1,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,tf ;save tf
push p,r ;save r
hrrzi tf,.priou ;get terminal output designator
rfmod% ;get terminal JFN word
tlz r,(tt%osp) ;clear ^o effects
hrrzi tf,.priou ;get terminal output designator
sfmod% ;set new JFN word
pop p,r ;restore r
pop p,tf> ;restore tf, end of conditional
LINE
SKIPN T3,DIMNAM ;START AT HEAD OF ARRAY NAMES
jrst [TYPE(No )
jrst .+1]
TYPE(Array specifications)
LINE
JUMPE T3,CPOPJ ;EXIT IF NOTHING TO PRINT
LINE
;[163] TYPE(USED MAX ARRAY DIMENSIONS)
TYPE(USED ARRAY DIMENSIONS)
LINE
HRRZI T3,DIMNAM ;START AT HEAD OF ARRAY NAMES
TYPNXT: HRRZ T3,(T3) ;FIND NEXT ARRAY REFERENCE
JUMPE T3,CPOPJ ;ALL PROCESSED?
PUSHJ P,TYPDIM ;NO - TYPE DIMENSIONS
JRST TYPNXT ;LOOK FOR MORE
; TYPE THE DIMENSION LIST FOR THE ARRAY 'PAIR' IN T3
TYPDIM: PUSH P,T3 ;SAVE T3 ROUND LOOK-UP
LINE
HRRZ T,1(T3) ;GET THE ARRAY NAME VALUE
MOVEM T,SAVLOC ;SAVE THE ARRAY REFERENCE
PUSHJ P,GET.RP ;GET THE RANGE PRODUCT = DIMTOT
MOVE T,DIMTOT ;GET TOTAL ELEMENT COUNT
TRNN F,CHARS ;[163]Character array?
JRST TYPLO ;[163]NO
MOVE T1,SAVLOC ;[163]Address/array descriptor
IMUL T,1(T1) ;[163]Length of array in bytes
TYPLO: PUSHJ P,TYP0 ;AND DISPLAY IT
TAB
; TYPE([)
MOVE T,SAVLOC ;GET THE USER ARRAY NAME
TRO F,SILENT!NEARST ;DO NOT PRINT IF EXACT MATCH & FIND NEAREST SYMBOL
PUSHJ P,LOOK ;SEE IF THE ARRAY EXISTS
JRST E5 ;CANNOT FIND IT!
JFCL ;NOT EXACT
;EXACT MATCH RETURN
;[bl] SUB T,SAVLOC ;REMOVE BASE ARRAY OFFSET
;[bl] PUSHJ P,TYP0 ;DISPLAY
;[bl] type(])
tab
SETZM PUTTER ;RESET FOR RESCAN OF ARRAY'S DIMENSIONS
MOVE T,SAVLOC ;GET THE ARRAY NAME VALUE
TRZ F,SILENT!NEARST ;TURN ON PRINT SUPPRESS SWITCH & NEAREST
PUSHJ P,LOOK ;DO A LOOK UP ON C(T)
JFCL ;NOT FOUND
JRST E5 ; OR NOT EXACT??
TAB
TYPE([)
DIM10: PUSHJ P,GETDIM ;GET THE SUBSCRIPTS FOR THE NEXT DIMENSION IN TEM,TEM1
MOVE T,TEM ;GET THE LOWER SUBSCRIPT
PUSHJ P,TYP0 ;AND TYPE IT
stype(":")
MOVE T,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,T3 ;GET BACK ARRAY REFERENCE
TRNE F,F10RAY ;F10 ORIGINATED?
jrst [TYPE( - F10 ORIGINATED)
jrst .+1]
TRNE F,DOUBLE ;REAL*8
jrst [TYPE( DP)
jrst .+1]
TRNE F,CHARS ;[157]Character?
JRST [TYPE( CH)
JRST FRMLCK] ;[157]
TRNN F,DOUBLE ;REAL*4
jrst [TYPE( SP)
jrst .+1]
FRMLCK: TRNE F,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 F,F10RAY ;F10 DEFINED ARRAY?
JRST MORD2 ;YES
SKIPN T,PUTTER ;EXIT IF PUTTER = 0
POPJ P, ;NO MORE TO COME
HRRZ T,(T) ;NO MORE IF NEXT IN LINE = 0
JUMPE T,CPOPJ ;T 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 T,TEM1 ;GET THE UPPER SUBSCRIPT SU
SUB T,TEM ;FORM SU-SL
AOJ T, ;FORM SU-SL+1
SKIPN DIMTOT ;FIRST TIME IS SPECIAL
AOS DIMTOT
IMULM T,DIMTOT ;FORM TOTAL SPACE DECLARED FOR THIS ARRAY
PUSHJ P,MORDIM ;SEE IF THERE ARE ANY MORE DIMENSIONS
SKIPA T,DIMTOT ; NO - ALL DONE
JRST DIM11 ;YES - BACK FOR MORE
TRNE F,DOUBLE ;[112] IS THIS ARRAY DOUBLE WORD
ADDM T,DIMTOT ;YES - DOUBLE UP THE RANGE ACCESSED
POPJ P, ;WE NOW HAVE THE TRUE SCOPE OF THE ARRAY
; GROUP LOGIC
GROUP: JUMPL F,GRPALL ;DISPLAY ALL GROUPS
PUSHJ P,GETNUM ;WHICH GROUP IS THE USER SETTING?
JUMPLE T,ERR15 ;NOT VALID
CAILE T,GPMAX ;GPMAX IS THE MOST HE SHOULD ASK FOR
JRST ERR15
MOVE T1,OPENED
MOVEM T1,GRP2(T) ;THIS GROUP BELONGS TO THIS SECTION
IMULI T,CFSIZ ;END OF GROUP AREA
SKIPL TERMK
JRST [PUSHJ P,GRTYP ;FORGETFULL USER WANTS TO SEE GROUP CONTENTS
JRST RET]
ADD T,[POINT 7,GRP1-CFSIZ]
MOVEM T,CFLPTR ;WHERE TO STORE NEW STRING
HRRZM T,CFLST ;GUARD AGAINST OVERFLOW
MOVE T,[PUSHJ P,I2CFIL]
MOVEM T,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 T1,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 T
GRTYP: HRRZM T,T2 ;
ADD T,[POINT 7,GRP1-CFSIZ,6] ;[132]
MOVE T1,[ILDB T1,T]
MOVEM T1,GETCHR ; INPUT FROM GROUP FILE
GRPNXT: SETOM TERMK ;SET UP FOR DELIMETER TEST
LDB T1,T ;[132] GET NEXT CHAR FROM STRING
PUSHJ P,GETSK2 ;END OF STRING?
JUMPN T1,.+2
MOVEI T1, " " ;SPACE IS SPECIAL
SKIPL TERMK
POPJ P, ;YES - IF TERMINAL CHARACTER TERMK +VE
putchr (T1) ;SHOW CHARACTER
IBP T ;[132] POSITION FOR NEXT BYTE
HRRZM T,T3
CAIE T3,GRP1(T2) ;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
CURGRP: BLOCK 1 ;BITS TO FLAG CURRENT GROUP STACK
;IN ORDER TO CATCH RECURSION
; WHAT LOGIC
WHAT: LINE
TYPE(Open section: )
MOVE T,OPENED
PUSHJ P,SPT1 ;TYPE NAME OF OPEN SECTION
LINE
SKIPA T,[0] ;FLAG DISPLAY OF EVERYTHING
PSEALL: SETO T, ;FLAG DISPLAY OF PAUSES ONLY
PUSH P,T ;SAVE FLAG
MOVEI T,^D10
MOVEM T,ODF ;SET RADIX 10 AS STANDARD IN 'WHAT'
MOVEI T,B1ADR ;START OF PAUSES
WT10: SKIPE (T)
JRST WT9 ;THERE IS AT LEAST ONE PAUSE SET
ADDI T,1 ;NO PAUSES SEEN SO FAR
CAIG T,BNADR ;ALL PAUSES EXAMINED?
JRST WT10 ;NO
LINE
TYPE(No pause requests)
JRST WT11
WT9: LINE
TYPE(GROUP AFTER PAUSE LOCATED IN)
LINE
MOVEI AR,B1ADR ;GET START OF PAUSES
WT6: HRRZ T,(AR) ;GET THE PAUSE ADDRESS
JUMPE T,WT5 ;OMIT IF NO PAUSE SETTING
; TYPING OPTION = GROUP
HLRZ T,(AR) ;GET THE 'TYPING' OPTION
JUMPE T,WT12 ;WAS TYPING REQUESTED?
HLRZ T,(AR) ;YES - GET GROUP #
PUSHJ P,FTOC ;DISPLAY GROUP #
; PROCEDE SETTING
WT12: TAB
MOVE T,1(AR) ;GET CONDITIONAL SETTING
JUMPE T,WT2 ;NO CONDITIONALS
stype("N/A") ;NOT APLICABLE DUE TO CONDITIONAL
JRST WT13 ;DISPLAY GROUP
WT2: MOVE T,2(AR) ;GET PROCEDE COUNT
PUSHJ P,FTOC ;TYPE THE PROCEDE COUNT
; PAUSE IDENTIFICATION
WT13: TAB
HRRZ T,(AR) ;GET PAUSE ADDRESS
JUMPE T,WT5 ;NO PAUSE SET UP HERE
TLO F,FGLSNM ;GLOBALS OK
PUSHJ P,LOOK ;LOOKUP SYMBOL
JRST E1 ;NOT THERE??
PUSHJ P,SPT ;TYPE SUBROUTINE NAME
TAB ;ADD PROGRAM NAME WHERE PAUSE IS
SKIPE T,PNAMSV ;WAS A PG NAME FOUND?
PUSHJ P,SPT1 ;YES TYPE IT
; ANY CONDITIONALS?
SKIPE 1(AR) ;IS THIS A CONDITIONAL PAUSE?
JRST WT14 ; YES
WT5: SKIPE (AR)
jrst [LINE
jrst .+1]
ADDI AR,3 ;MOVE ON TO NEXT PAUSE
CAIG AR,BNADR ;DONE ALL PAUSES?
JRST WT6 ;NO - BACK FOR MORE
JRST WT11 ;FINISHED PAUSE DISPLAY - DO GROUPS
; TYPE PARAMETERS OF CONDITIONAL PAUSE
WT14: TAB
TYPE(IF )
HRRZ T1,AR ;GET CURRENT PAUSE ADDRESS
SUBI T1,B1ADR ;REMOVE OFFSETT
IDIVI T1,3 ;FORM PAUSE#
LSH T1,2 ;FORM INDEX TO TESTAB
MOVEM T1,WT16 ;SAVE T1 TEMPORARILY
MOVE T,TESTAB(T1) ;[116] GET LOGICAL FLAGS
TLNE T,LFTLOG ;[116] IS ARG. LOGICAL?
JRST WTLLOG ;[116] YES, TAKE CARE OF IT
MOVE T,TESTAB+1(T1) ;GET FIRST ARG ADDRESS
CAIN T,TESTAB+3(T1) ;IS IT A CONSTANT?
JRST [MOVE T,(T) ;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 T1,WT16 ;RE-INSTATE T1
MOVE T,TESTAB(T1) ;GET CONDITIONAL TYPE
TYPE( .)
atype(TYPTST(T)) ;TYPE THE CONDITION
TLNE T,RHTLOG ;[116] IS THIS ARG. LOGICAL?
JRST WTRLOG ;[116] YES, TAKE CARE OF IT
MOVE T,TESTAB+2(T1) ;GET SECOND ARG ADDRESS
CAIN T,TESTAB+3(T1) ;IS THIS A CONSTANT?
JRST [MOVE T,(T) ;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 T,@TESTAB+1(T1) ;[124][116] GET VALUE
JUMPL T,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 T,@TESTAB+2(T1) ;[124][116] GET VALUE
JUMPL T,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,T ;GET DISPLAY FLAG BACK
JUMPL T,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 AR,GPMAX ;CHECK IF ANY ARE USED
GROU1: SKIPE GRP2(AR) ;USED?
JRST GROU2 ;YES
SOJG AR,GROU1 ;NO, TRY NEXT
LINE
TYPE (No group specifications)
POPJ P,
GROU2: MOVEI AR,1 ;SET UP FOR FIRST GROUP
JRST WT7.5 ;
WT7: SKIPN GRP2(AR) ;THIS ONE USED?
JRST WT7.3 ;NO - IGNORE IT
LINE
TLO F,CFLIU!OFCFL ;MAKE REQUEST FOR CORE FILE USE
TYPE(GROUP )
MOVE T,AR
MOVEI ODF,12 ;DECIMAL BASE FOR GROUP NUMBERS
PUSHJ P,FTOC ;TYPE GROUP #
type(:)
tab
MOVEI T,(AR) ;GET GROUP # BACK
IMULI T,CFSIZ ;POINT TO ACTUAL LOCATION OF GROUP START
PUSHJ P,GRTYP ;DISPLAY GROUP CONTENTS
WT7.3: ADDI AR,1 ;BUMP GROUP NUMBER
WT7.5: CAIG AR,GPMAX ;DONE ALL GROUPS?
JRST WT7 ;NO - BACK FOR MORE
WT8: TLZ F,CFLIU!OFCFL ;REMOVE DANGEROUS FLAGS
POPJ P, ;
; NEXT LOGIC - STEPS THROUGH STATEMENT LABELS(S),
; SOURCE LINES(L) OR SUBROUTINE ENTRIES(E)
NEXT: JUMPL F,STEP2 ;NO ARGUMENTS USES DEFAULTS
PUSHJ P,EITHER ;ACCEPT EITHER A NUMERIC OR VARIABLE
CAIA ;NUMERIC
MOVE T,(T) ;GET VARIABLE CONTENTS
JUMPE T,.+2 ;ZERO = LAST VALUE SUPPLIED
MOVEM T,STPVAL ;STORE THE NEW STEP VALUE
CAIE T1,"/" ;TRACE OPTION FOLLOWS?
JRST STEP2 ;NO SWITCHES
PUSHJ P,OPTION ;FIND WHICH
JRST BADSYN ;NO GROUP REQUESTS HERE
TRNN TMOD,L.!S.!E. ;ANY TRACE OPTIONS SELECTED?
JRST STEP2 ;NO JUST 'NEXT'
TRZ F,TRLABL!TRLINE ;FIRST RESET THE TRACE FLAGS
TRZE TMOD,L. ;DO WE TRACE LINES?
TRO F,TRLINE ;YES
TRZE TMOD,S. ;DO WE TRACE LABELS?
TRO F,TRLABL ;YES
STEP2: MOVEM F,STKYFL ;RECORD THE STICKY FLAGS
MOVE T,STPVAL ;GET THE STEP VALUE
MOVEM T,STPCNT ;AND SET UP THE STEP COUNT
MOVE T,[PUSHJ P,STEP4] ;PREPARE TO SET UP THE TRACE FEATURE
MOVEM T,FDDT. ;LIKE-SO
HRRZ T,STARTU ;HAS A 'START' BEEN DONE
JUMPE T,START2 ;SIMULATE A START WITH TRACE ON
SKIPE T,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
HRRZ T,AC17 ;GET THE FORTRAN PDL POINTER TO FIND THE PUSHJ
HRRZ T,(T) ;FIND WHERE WE ARE TRACING
SOJ T, ;P.C. = STOPS ONE ON
MOVEM T,BCOM ;SET UP FOR RE.BRK
SETZM SYM ;ACCEPT FIRST SYMBOL FOUND IN 'LOOK'UP
SETOM ESCAPE ;ALLOW ESCAPES
TRO F,SILENT ;RIG FOR SILENT RUNNING
TLO F,FGLSNM ;GLOBALS ARE OK
PUSHJ P,LOOK ;'LOOK'-UP THE INTERCEPT
JRST E7 ;JUST HAS TO BE THERE
JRST E7 ; AN OFFSET IS EVEN WORSE
PUSHJ P,STEP11 ;OPEN AND NAME SECTION IF NEW
TRNN F,TRLINE!TRLABL ;REQUESTED TO TRACE ENTRIES ONLY?
JRST STEP7 ;YES
STEP13: MOVEM W1,W2 ;SAVE THE NOW RECOGNISED SYMBOL(LINE)
MOVE T,TRUFST ;GET THE LAST CHARACTER OF THE LABEL
CAIN T,32 ;"P"?
TRNN F,TRLABL ;AND TRACING LABELS?
CAIA
JRST STEP5 ;YES - OK
TRNN F,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 T,10 ;SET FOR 8 LABELS/LINE
MOVEM T,TABCNT ;RECORD IN TABCNT
JRST .+1]
TAB
MOVE W1,W2 ;GET BACK THE NEW FOUND SOURCE LINE
PUSHJ P,SPT ;AND PROUDLY DISPLAY IT
SKIPL STPCNT ;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 T,RESTORE ;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: MOVEI T,[POPJ P,] ;MAKE SURE WE DO A POPJ RETURN
MOVEM T,LEAV ;PLACE IT IN THE LEAVE LOCATION
HRRM T,PROC0 ;TO MAKE SURE WE DO A POPJ RETURN TO FORTRAN
JRST RET ;NORMAL WORKING
; XCT REFFERENCE FOUND BUT NOT 'P' OR 'L'
STEP12: TRZN TF,GUDLBL ;DID WE FIND A GOOD NUMERIC LABEL?
JRST STEP7 ;NO - THEN IT MUST BE A SUBROUTINE
MOVE T,BCOM ;WHAT ARE WE 'LOOK'ING FOR
TRO F,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 T & W1
PUSHJ P,OVRLAY ;LOOK FOR AND TELL WHERE & IF AN OVERLAY HAPPENED
MOVE T,PNAMSV ;WHAT WAS THE SECTION IN WHICH IT WAS FOUND
CAMN T,OPENED ;DO WE ALREADY NOW ABOUT IT
POPJ P, ;YES JUST EXIT - AND RESET T,W1
MOVEM T,SYM ;SET UP FOR SETNAM
PUSHJ P,SETNAM ;AND OPEN THIS SECTION FOR EFFICIENT SEARCHES
LINE
type([)
PUSHJ P,SPT1 ;DISPLAY THE SECTION NAME
type(])
tab
TRNN F,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 T,W1
; Q LOGIC
Q: LINE
JUMPL F,BADSYN ;MUST HAVE AN ARGUMENT
TRO TF,DCEVAL ;DON'T CALL EVAL
PUSHJ P,SYMIN ;GET A SYMBOL REFERENCE
TRZ F,ID ;SYMBOL FOUND FLAG
SKIPGE R,.JBSYM ;FIRST CHECK LOSEG TABLE
JRST QLIST1
QLIST0: PUSHJ P,GHSSYP ;NOW TRY HISEG TBL
JRST QLIST9 ;DONE
MOVE R,TT ;GET LIST
QLIST1: SETZM QLPNT ;ZERO FLAG SHOWING REFERENCE
QLIST2: PUSHJ P,FIXSYR ;UPDATE PTR
JUMPGE R,QLIST4 ;[104] GIVE UP IF OFF END OF TABLE
MOVE T,(R) ;PICK UP SYMBOL
JUMPE T,QLIST3
TLZN T,PNAME ;A PROGRAM NAME?
JRST QLIST6 ;YES
CAMN T,SYM ;NO, IS AN OCCURANCE FOUND?
HRRZM R,QLPNT ;YES, REMEMBER WHERE
QLIST3: ADD R,[XWD 2,2] ;POINT TO NEXT ENTRY
JUMPL R,QLIST2 ;AND GO IF MORE
QLIST4: TRNN R,1B18 ;[104] TABLE EXHAUSTED - LOSEG?
JRST QLIST0 ;YES - TRY HISEG
QLIST9: TRZE F,ID ;ANY FOUND
JRST RET ;DONE
JRST ERR6 ;NO - ERROR
QLIST6: SKIPN QLPNT ;FOUND THE SYMBOL?
JRST QLIST3 ;NO
TRO F,ID
PUSHJ P,SPT1 ;YES, PRINT THE PROGRAM NAME
MOVE T,@QLPNT ;GET THE SYMBOL BACK AND
TLNE T,GLOBAL ; TEST FOR A GLOBAL SYMBOL
JRST QLIST8 ; THIS IS A GLOBAL SYMBOL
QLIST7: TYPE( )
SETZM QLPNT ;RESET FLAG
JRST QLIST3 ; AND SEARCH THE NEXT SET OF SYMBOLS
QLIST8: type( )
openp
MOVE T,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 F,MODRET ;'MODE' ALONE - MEANS RESUME STANDARD SETTING
SETZI W1, ;NO - PREPARE FOR A MODE CHANGE
MODNXT: PUSHJ P,TTYIN ;GET AN ARGUMENT FROM USER
JUMPE T2,BADSYN
LDB T2,[POINT 6,T2,5] ;GET FIRST CHARACTER OF USERS ARGUMENT
CAIN T2,'F'
JRST [TRO W1,F.
JRST MODMOR]
CAIN T2,'D'
JRST [TRO W1,D.
JRST MODMOR]
CAIN T2,'I'
JRST [TRO W1,I.
JRST MODMOR]
CAIN T2,'O'
JRST [TRO W1,O.
JRST MODMOR]
CAIN T2,'R'
JRST [TRO W1,R.
JRST MODMOR]
CAIN T2,'X' ;[157]Complex?
JRST [TRO W1,X. ;[157]
JRST MODMOR]
CAIN T2,'C' ;[157]Character string?
JRST [TRO W1,C. ;[157],[164]
JRST MODMOR] ;[157]
CAIN T2,'L' ;[120]
JRST [TRO W1,L. ;[120]
JRST MODMOR] ;[120]
CAIE T2,'A'
JRST BADSYN
TRO W1,A.
MODMOR: SKIPL TERMK
JRST MODSET ;END OF USER LINE SET MODES
JUMPE T1,MODNXT ;SPACE IS A DELIMITER
CAIE T1,"," ;COMMA IS THE ONLY ARG SEPARATOR
JRST BADSYN
JRST MODNXT ;GET MORE ARGUMENTS
MODSET: MOVEM W1,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: MOVEI R,SYM ;CHECK SYM
PUSHJ P,TRUVAR ;LABEL OR STATEMENT #?
TROA TF,SYMLAB ;YES
TRZ TF,SYMLAB
TRZE TF,FGLONL ;LOOKING FOR GLOBALS ONLY?
TRNE TF,SYMLAB ;AND THIS IS NOT A LABEL?
CAIA
JRST EVAL1 ;YES
TLO F,FLCLNM ; FIND LOCAL NAME
PUSHJ P,FNDSYM ;
CAIA
JRST EVAL2 ; FOUND
TRNE TF,SYMLAB ;IS IT A LABEL?
POPJ P, ;YES - FAIL
MOVSI R,LOCAL ;YES, LOOK FOR OUTSIDE LOCALS
EVAL0: TLO F,FGLSNM ;THROUGH THE WHOLE TABLE
MOVEM R,SYMASK ;
PUSHJ P,FNDSYM
POPJ P, ; FAIL
EVAL2: HRRZM R,SYMSAV ;ALWAYS SAVE POINTER
MOVE W1,R ;
;[BL] WHAT GOOD IS THIS?????
MOVE W2,1(R)
SKIPA T,1(R) ;GET VALUE OF SYMBOL
CPOPJ2: AOS (P) ;SKIP TWICE
CPOPJ1: AOS (P) ;FOUND SYMBOL, SKIP
TLZ F,FGLSNM ;KILL FLAG
CPOPJ: POPJ P,
EVAL1: MOVSI R,GLOBAL!DELO ;[141] GLOBALS ONLY(ALSO DELETED GLOBALS)
JRST EVAL0 ;GO
; GHSSYP LOOKS TO SEE IF THERE IS A HISEG FOR THIS CORE IMAGE; IF
;SO, IT GETS THE POINTER TO THE HISEG SYMBOL TABLE IN T. THERE IS
;A SKIP RETURN ON SUCCESS.
;
; AC'S USED: R, T
GHSSYP: PUSH P,1 ;[142] SAVE FLAGS
PUSH P,0 ;[146] Save AC0
MOVEI 0,FO$HSP ;[146] Function code in AC0
XMOVEI 1,TT ;[146] Address in AC1
PUSHJ P,FOROP.## ;[143] GET HI-SEG SYMBOL TABLE POINTER
POP P,0 ;[146] Restore AC0
POP P,1 ;[142] RESTORE FLAGS
JUMPE TT,CPOPJ ;FAIL IF NO TBL
JRST CPOPJ1 ;OK
; GET HISEG START ADDRESS IN (R)
ife tops20,<
GSTAH: MOVE R,[XWD -1,.GTSGN]
GETTAB R, ; GET HISEG INDEX
HALT . ; *****
HRLZI R, (R) ; GET INDEX
HRRI R,.GTUPM
GETTAB R, ; GET HISEG START
HRLZI R,400000 ;PRE-507 MONITOR - FUDGE VALUE
HLRZ R,R
POPJ P,> ;End of conditional
ifn tops20,<
gstah: skipn r,.jbhso ;[123]get page of high segment
movei r,400 ;[123]not set, guess 400
lsh r,11 ;get address of high segment
popj p,> ;return,end of conditional
;THIS ROUTINE SETS UP IGNORE LISTS FOR SYMBOL TABLE LOOKUPS.
SETLST: MOVEI AR,0 ;COUNT
SKIPN R,.JBSYM ;LOSEG FIRST
CAIA
PUSHJ P,SETL ;SET UP THAT PART
PUSHJ P,GHSSYP ;NOW THE HISEG TABLE
POPJ P, ;NONE
SETL: MOVE W2,(R) ;GET NEXT ENTRY
TLNN W2,PNAME ;PRIG NAME?
JRST SETL1 ;YES
SETL0: ADD R,[2,,2] ;NO
JUMPL R,SETL ;CHECK NEXT
POPJ P, ;DONE
SETL1: CAME W2,[SQUOZE 0,UDDT] ;IGNORE THESE PROGRAMS
CAMN W2,[SQUOZE 0,FORDDT]
JRST SETL2
CAME W2,[SQUOZE 0,JOBDAT]
JRST SETL0 ;NO
SETL2: HLRE T2,1(R) ;GET THE -LENGTH
ADDI T2,2(R) ;BEG OF SYMBOLS FOR PROGRAM
HRRZM T2,SYMLST(AR) ;
HLRE T2,1(R)
MOVM T2,T2 ;GET LENGTH
HRLM T2,SYMLST(AR) ;SAVE THAT TOO
AOJA AR,SETL0 ;NEXT
;FIX (R) AS PTR TO SYMBOL TABLE.
FIXSYR: MOVEI W2,(R) ;GET ADDR POINTED TO
MOVEI TT,PSYLST-1 ;GET # OF IGNORED PROGRAMS
FIXS1: HRRZ T3,SYMLST(TT) ;NEXT LOCATION
CAIN T3,(W2) ;PART OF AN IGNORED PROG?
JRST FIXS2
SOJGE TT,FIXS1 ;NO - TRY NEXT
POPJ P, ;NONE - LET IT GO
FIXS2: HLRZ T3,SYMLST(TT) ;GET LENGTH OF IGNORED SYMBOLS
HLL T3,SYMLST(TT) ;LENGTH,,LENGTH
ADD R,T3 ;UPDATE PTR
POPJ P, ;DONE
SYMLST: BLOCK 5 ;# OF POSSIBLE PROGRAMS TO IGNORE (CONSERVATIVE)
PSYLST==.-SYMLST ;LENGTH
;FNDSYM: FIND A SYMBOL IN THE SYMBOL TABLE. ACCORDING TO THE FOLLOWING
;BITS: FPRNM - FIND PROGRAM NAME
; FLCLNM - FIND LOCAL NAME
; FGLSNM - FIND GLOBAL (ANYWHERE IN TABLE) (SYMASK CONTROLS
; THE TYPES OF SYMBOLS ALLOWED)
;
; THE SYMBOL (IN RADIX50) IS GIVEN IN SYM, AC R IS LEFT POINTING TO
;THE ENTRY THAT MATCHED.
FNDSYM: SETZI W1,
TLZN F,FPRNM ;LOOK FOR PROGRAM NAME?
JRST FNDS3 ;NO
MOVE R,.JBSYM ; CHECK LOSEG TABLE FIRST
MOVEM R,OJBSYM
PUSHJ P,FINDS ; TRY
CAIA ; NO GOOD
JRST CPOPJ1
PUSHJ P,GHSSYP ;GET HISEG SYM TBL PTR
POPJ P, ;FAIL
MOVEM TT,OJBSYM
JRST FINDS ;TRY
FNDS3: TLZN F,FLCLNM ;LOOKING FOR A LOCAL?
JRST FNDS5 ;NO
SKIPN R,OPENLS ; YES - GET PROG SYM LIST
POPJ P, ;NO PROGRAM OPENED, OR NO SYMS FOR PROG
FNDS4: MOVE W,(R) ;GET NEXT SYM
TLNN W,PNAME ;PROGRAM NAME?
;[171] JRST FNDS45 ;YES - IGNORE
JRST FNDS46 ;[171] YES - IGNORE
TLZ W,LOCAL ;LOCALS ONLY
CAMN W,SYM ;FOUND?
JRST FNDS9 ;YES
FNDS45: ADD R,[XWD 2,2] ; NO, UPDATE PTR
JUMPL R,FNDS4
POPJ P, ;NOT FOUND
FNDS46: TRNE TF,TYPCMD ;[171] 'TYPE'?
POPJ P, ;[171] YES, return no match
JRST FNDS45 ;[171] Continue search
FNDS5: TLZN F,FGLSNM ;LOOKING FOR A GLOBAL?
JRST E9 ;ERROR - NO SPEC
MOVE R,.JBSYM
JUMPE R,FNDS6
PUSHJ P,FNDS7 ;LOOK FOR SYM IN LOSEG SYM TABLE
CAIA ;N.G.
JRST FNDS9 ;FOUND IT - SET T
FNDS6: PUSHJ P,GHSSYP ;GET HISEG SYM TABLE PTR
POPJ P, ;
JUMPE TT,CPOPJ ;
MOVE R,TT
FNDS7: PUSHJ P,FIXSYR ;FIX PTR IN (R)
JUMPGE R,FNDS13 ;[104] GET OUT IF OFF END OF TABLE
MOVE W,(R) ;GET NEXT SYM
TLNN W,PNAME ;PROGRAM NAME?
JRST FNDS8 ;YES - IGNORE
;[BL] watch for resetting of this mask!!!!!!!
TDZ W,SYMASK ;CLEAR LEGAL BITS
CAMN W,SYM ;MATCH?
JRST FNDS11 ;YES
FNDS8: ADD R,[XWD 2,2]
JUMPL R,FNDS7 ;TRY NEXT
FNDS13: JUMPE W1,CPOPJ ;[104] FAIL IF NOTHING FOUND
SKIPA R,W1 ;USE LOC OF MATCH
FNDS10: SKIPA T,(R) ;GET VALUE (FOR FINDS)
FNDS9: MOVE T,1(R) ;GET VALUE OF SYMBOL
JRST CPOPJ1 ;SUCCESS
FNDS11: MOVE W,(R) ;GET SYMBOL
TLNE W,GLOBAL ;GLOBAL?
JRST FNDS9 ;YES - USE IT
JUMPN W1,FNDS12 ;MATCH ALREADY?
MOVE W1,R ;NO - MARK THIS ONE
MOVE S,1(W1) ;[171] Save value
JRST FNDS8 ;GO AHEAD
FNDS12: TRO F,MDLCLF ;MULT. DEF.
TRNN TF,TYPCMD ;[171]Exit if not 'TYPE'
POPJ P, ;FAIL
MOVE W,1(R) ;[171] Find value of symbol
CAME W,S ;[171] Match previous symbol?
JRST FNDS8 ;[171] No, keep looking
TRO TF,COMDAT ;[171] YES remember it's in COMMON
MOVE R,W1 ;[171] Restore first match address
JRST FNDS9 ;[171] DONE
; THIS ROUTINE SEARCHES THE SYMBOL TABLE IN A BACKWARDS DIRECTION
;LOOKING ONLY FOR PROGRAM NAMES.
FINDS: HLRE R,OJBSYM ; GET -# OF ENTRIES
JUMPE R,CPOPJ ;IGNORE IF TABLE EMPTY
MOVM R,R
ADD R,OJBSYM ;POINTER TO END OF TABLE
MOVEI R,-1(R)
FNDS1: MOVE W,-1(R) ;GET NEXT PROG NAME
CAMN W,SYM ;IS THIS IT?
JRST FNDS10 ;YES
HLRE W,(R) ; NO, GET LEN OF SYMBOLS
JUMPGE W,CPOPJ ;[102] IF TABLE ZEROED, GET OUT
ADD R,W ;POINT TO PREVIOUS PROG
HRRZ W,OJBSYM
CAILE W,(R) ;[107] DONE?
POPJ P, ;YES - NO FOUND
JRST FNDS1 ; NO - TRY NEXT
SUBTTL ENTER AND LEAVE FORDDT LOGIC
; SAVE THE ACS AND PI SYSTEM
SAVE: 0 ;SAVE THE ACS AND PI SYSTEM
SKIPN SARS
JRST SAV1
AOS SAVE
JRST SAV5
SAV1: MOVEM 17,AC17
HRRZI 17,SAVACS ;[147]
BLT 17,SAVACS+16 ;[147]
MOVE T, SAVE
HLLM T, SAVPI
SETPDL
SAV5: MOVE F,STKYFL ;INIT THE FLAG REGISTER
SETOM SARS ;FLAG PROTECTING SAVED REGISTERS
SETPDL
JRST @SAVE
; RESTORE ACS AND PI SYSTEM
RESTOR: HRRM T,SAVE
MOVE T,SAVPI
TLZ T,010037 ;DON'T TRY TO RESTORE USER MODE FLAG
HLLM T, SAVE
HRLZI 17,SAVACS ;[147]
BLT 17,17
SETZM SARS
JRST 2,@SAVE
; PAUSE LOGIC
BP0: 0 ;[145] USERS PC FROM FAKED JSR
JSA T,BCOM ;[145] SAVE T AND GO TO BCOM
TRN ;[145] BREAKPOINT INSTRUCTION
BP1: XLIST ;TABLE FOR ENTRY FROM BREAKPOINTS
REPEAT NBP,< 0 ;JSR TO HERE FOR A PAUSE
JSA T, BCOM
0 ;HOLDS INSTRUCTION WHILE PAUSE IS IN PLACE>
LIST
B1INS=BP1+2
BPN=.-3
; CONDITIONAL LOGIC
TESTAB: XLIST
REPEAT NBP,< 0 ;NUMBER OF TEST
0 ;ADDRESS OF ARG1
0 ;ADDRESS OF ARG2
0 ;CONSTANT VALUE>
LIST
COMPAR: CAML T2,T3
CAMLE T2,T3
CAME T2,T3
CAMN T2,T3
CAMG T2,T3
CAMGE T2,T3
COND: 0
JSR CONSAV ;SAVE RELEVANT REGS
AOS COND ;PREPARE FOR SKIP RETURNS
HRRZ T,BCOM3
SUBI T,B1ADR+1
IDIVI T,3
LSH T,2
MOVE T1,TESTAB(T)
MOVE T2,@TESTAB+1(T)
MOVE T3,@TESTAB+2(T)
XCT COMPAR(T1)
AOS COND
JSR CONSAV ;REINSTATE USERS ACS
JRST @COND
CONSAV: 0
EXCH T,CONSV0
EXCH T1,CONSV1
EXCH T2,CONSV2
EXCH T3,CONSV3
JRST @CONSAV
CONSV0: Z
CONSV1: Z
CONSV2: Z
CONSV3: Z
BCOM: 0
POP T,LEAV ;MOVE INSTRUCTION TO LEAV
MOVEI T,B1SKP-B1INS+1(T)
HRRM T,BCOM3 ;CONDITIONAL BREAK SETUP
MOVEI T,B1CNT-B1SKP(T)
HRRM T,BCOM2 ;PROCEDE COUNTER SETUP
MOVE T,BP1-B1CNT(T) ;GET PC WORD
HLLM T,LEAV1 ;SAVE FLAGS FOR RESTORING
EXCH T,BCOM ; ALSO SAVE PC WORD IN BCOM
BCOM3: SKIPE B1SKP ;ADDR MOD TO LOOK AT COND. INST.
XCT @.-1
BCOM2: SOSG B1CNT ;ADDR MOD TO LOOK AT PROCEED COUNTER
JRST BREAK
MOVEM T,SAVACS+T ;[147]
HRRZ T,BCOM3 ;ADDRESS OF CONDITIONAL
HLRZ T,-1(T) ;SEE IF A 'TYPING' REQUESTED
JUMPN T,BCOM1 ;'TYPING' REQUESTED
LDB T,[POINT 9,LEAV,8] ;GET INSTRUCTION
CAIL T,264 ;JSR
CAILE T,266 ;JSA,JSP
TRNN T,700 ;UUO
JRST PROC1 ;MUST BE INTERPRETED
CAIE T,260 ;PUSHJ
CAIN T,256 ;XCT
JRST PROC1 ;MUST BE INTERPRETED
MOVE T,SAVACS+T ;[147]
JRST 2,@LEAV1 ;RESTORE FLAGS, GO TO LEAV
LEAV1: XWD 0,LEAV
BCOM1: MOVE T,SAVACS+T ;[147] RESTORE T
JSR SAVE ;SAVE ACS
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 F,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,FORBUF ;[145] LET FOROTS CLEAR ITS BUFFER
SOS T,BCOM3
HRRZS T ;GET ADR OF CONDITIONAL BREAK INST
SUBI T,B1ADR-3 ;CHANGE TO ADDRESS OF $0B
IDIVI T,3 ;QUOTIENT IS BREAK POINT NUMBER
HRRM T,BREAK2 ;SAVE BREAK POINT #
;NOW DISPLAY BREAK INFORMATION
SETZI TF, ;
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
BRKAT: MOVE T,BCOM ;[145]
HLLM T, SAVPI ;SAVE PROCESSOR FLAGS
MOVEI T,-1(T)
ANDI T,-1 ;ADDRESS PORTION ONLY THANK YOU
TRO F,SILENT ;SILENCE
TLO F,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 T,TEM ;[145] REMEMBER NEAREST REFERENCE
PUSHJ P,SPT ;[145] TYPE SYMBOL
TYPE ( + ) ;[145]
MOVE T,TEM ;[145] TYPE OFFSET
PUSHJ P,TYP4 ;[145] IN OCTAL
JRST BPSEC ;[145]
BPOK: MOVE T,(R) ;[145] GET SYMBOL
TLNE T,GLOBAL ;GLOBAL?
JRST BREAK6 ;YES - THIS IMPLIES A ROUTINE
PUSHJ P,SPT1 ;NO, SO PRINT IT
BPSEC: TYPE( in ) ;[145]
MOVE T,PNAMSV ;GET NAME OF SYMBOL'S SECTION
MOVEM T,SYM ;SAVE IT
PUSHJ P,SPT1 ;AND TYPE IT
MOVE T,PNAMSV
CAME T,OPENED ;THIS PROGRAM OPENED?
JRST BREAK7 ;NO - DO IT
SKIPGE BP0FLG ;[145] IF FROM BREAKPOINT 0,
JRST BP0RET ;[145] DONE
BREAK4: LINE
HRRZ T,@BCOM3
HRRM T,PROC0 ;SETUP ADDRESS OF BREAK
HLRZ T,@BCOM3
JUMPE T,BREAK1 ;TEST FOR REGISTER TO EXAMINE
MOVE TMOD,MODFLG ;REMEMBER TO SET UP THE PRINT FLAGS
TLO F,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 F,GRPFL!CFLIU!OFCFL ;REMOVE FLAG, IT MAY CAUSE TROUBLE
BREAK1: MOVSI S,400000
BREAK2: ROT S,.-. ;ROT BY # OF BREAK POINT
TLZE F,AUTO ;DO WE HAVE A TRUE BREAK CONDITION?
ANDCAM S,AUTOPI ;YES - END OF 'TYPING' LOGIC
TDNN S,AUTOPI ;DONT PROCEED IF NOT AUTOMATIC
JRST RET ;DONT PROCEED
JRST PROCD1
BP0E2: SKIPN BP0FLG ;[145] IN BREAKPOINT 0?
JRST E2 ;[145] NO, ERROR
MOVEI T,@BCOM ;[145] TYPE IT IN OCTAL
SUBI T1,1 ;[145]
PUSHJ P,TYP4 ;[145]
BP0RET: LINE ;[145]
MOVNS BP0FLG ;[145] MAKE IT POSITIVE NOW
JRST RET ;[145] INITIALIZE SOME FLAGS ETC.
BREAK6: MOVEM R,SAVLOC ;NAME OR ROUTINE
TYPE (routine )
PUSHJ P,SPT ;TYPE ROUTINE NAME
PUSHJ P,GETARG ;DISPLAY ANY ARGS
SKIPGE BP0FLG ;[145] DONE IF FROM BREAKPOINT 0
JRST BP0RET ;[145]
MOVE T,PNAMSV ;GET PROGRAM NAME
BREAK7: MOVEM T,SYM ;SAVE IT
PUSHJ P,IMPOPN ;AND OPEN IT
SKIPGE BP0FLG ;[145] IF FROM BREAKPOINT 0,
JRST BP0RET ;[145] DONE
JRST BREAK4
PROCED: MOVEI T,1 ;SET UP FOR PROCEDE OF 1
SKIPG @BCOM2 ;DO NOT CHANGE VALUE IF ALREADY SET
PROCDX: MOVEM T,@BCOM2 ;STORE IN B#CNT
HRRZ R,BCOM3
SETZM TEM ;DO NOT RE-INSERT 'CONDITIONAL' INFO.
HLRZ S,(R)
JUMPE S,.+2 ;SET THE AUTO PROCEDE FLAG
TLO F,AUTO ;IF THIS IS A 'TYPING' REQUEST
PUSHJ P,AUTOP
PROCD1: LINE
PROC0: HRRZI R,[JRST RET] ;MODIFIED 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 T,LEAV
PROC00: CLEARM BP0FLG ;[145] WON'T NEED THIS ANYMORE
PUSHJ P,INSRTB
JRST PROC2
PROC1: MOVE T,SAVACS+T ;[147]
JSR SAVE
JFCL
MOVE T,BCOM ;STORE FLAGS WHERE "RESTORE"
HLLM T,SAVPI ; CAN FIND THEM
PROC2: MOVEI W,100
MOVEM W,TEM1 ;SETUP MAX LOOP COUNT
JRST IXCT5
IXCT4: SUBI T,041 ;IS UUO "INIT"?
JUMPE T,BPLUP
AOJGE T,IXCT6 ;DONT PROCEDE FOR INIT
;DONT INTERPRET FOR SYSTEM UUOS
MOVEM R,40 ;INTERPRET FOR NON-SYSTEM UUOS
MOVEI R,41
IXCT: SOSL TEM1
PUSHJ P,FETCH
JRST BPLUP ;BREAKPOINT LOOPING OR FETCH FAILED
MOVEM T,LEAV
IXCT5:; SETZM ESCAPE ;NO ESCAPES FROM FORDDT
LDB T,[POINT 9,LEAV,8] ;GET INSTRUCTION
CAIN T,254 ;DON'T DO ANYTHING TO JRST
JRST IXCT6
HRLZI 17,SAVACS ;[147]
BLT 17,17
MOVEI T,@LEAV
DPB T,[POINT 23,LEAV,35] ;STORE EFFECTIVE ADDRESS
LDB W1,[POINT 4,LEAV,12] ;PICK UP AC FIELD
LDB T,[POINT 9,LEAV,8] ;PICK UP INSTRUCTION FIELD
SETPDL
CAIN T,260
JRST IPUSHJ ;INTERPRET PUSHJ
CAIN T,264
JRST IJSR ;INTERPRET JSR
CAIN T,265
JRST IJSP ;INTERPRET JSP
CAIN T,266
JRST IJSA ;INTERPRET JSA
MOVE R,LEAV
TRNN T,700
JRST IXCT4 ;INTERPRET UUO
CAIN T,256
JRST IXCT ;INTERPRET XCT
IXCT6: JSP T,RESTORE
LEAV: 0 ;INSTRUCTION MODIFIED
JRST @BCOM
AOS BCOM
JRST @BCOM
BPLUP: PUSHJ P,REMOVB ;BREAKPOINT PROCEED ERROR
BPLUP1: JSR SAVE
JFCL
JRST ERR18
IPUSHJ: DPB W1,[POINT 4,CPUSHP,12] ;STORE AC FIELD INTO A PUSH
HLL T,SAVPI ;PICK UP FLAGS
HLLM T,BCOM ;SET UP THE OLD PC WORD
MOVSI T,(1B4) ;TURN OFF BIS FLAG IN NEW PC WORD
ANDCAM T,SAVPI
JSP T,RESTORE ;RESTORE THE MACHINE STATE
CPUSHP: PUSH .-.,BCOM ;GETS MODIFIED IN AC FIELD
JRST @LEAV ;JUMP TO "E" OF THE PUSHJ
IJSA: MOVE T,BCOM ;INTERPRET JSA
HRL T,LEAV
EXCH T,SAVACS(W1) ;[147]
JRST IJSR2
IJSR: MOVE T,BCOM ;INTERPRET JSR
HLL T,SAVPI ;SET UP THE OLD PC WORD
MOVSI W,(1B4) ;TURN OFF BIS IN NEW PC WORD
ANDCAM W,SAVPI
IJSR2: MOVE R,LEAV
PUSHJ P,DEPMEM
JRST BPLUP ;ERROR, CAN'T STORE
AOSA T,LEAV
IJSR3: MOVE T,LEAV
JRST RESTORE
IJSP: MOVE W,BCOM ;INTERPRET JSP
HLL W,SAVPI ;PICK UP PC WORD FLAGS
MOVEM W,SAVACS(W1) ;[147] INSERT OLD PC WORD INTO AC
MOVSI T,(1B4) ;TURN OFF BIS FLAG IN NEW PC WORD
ANDCAM T,SAVPI
JRST IJSR3
; INSERT PAUSES REQUESTS
INSRTB: MOVE S,[JSR BP1]
INSRT1: SKIPE R,B1ADR-BP1(S)
PUSHJ P,FETCH
JRST INSRT3
MOVEM T,B1INS-BP1(S)
MOVE T,S
PUSHJ P,DEPMEM
JFCL ;HERE ONLY IF CAN'T WRITE IN HIGH SEG
INSRT3: ADDI S,3
CAMG S,[JSR BPN]
JRST INSRT1
POPJ P,
;REMOVE PAUSE REQUESTS
REMOVB: MOVEI S,BNADR
REMOV1: MOVE T,B1INS-B1ADR(S)
SKIPE R,(S)
PUSHJ P,DEPMEM
JFCL ;HERE ONLY IF NO WRITE IN HIGH SEG
SUBI S,3
CAIL S,B1ADR
JRST REMOV1
POPJ P, ;
; HERE TO SET PAUSE BREAKS
BPS: MOVE T,[XWD B1ADR,B1ADR+1] ; CLEAR ALL PAUSES
CLEARM B1ADR
BLT T,AUTOPI ;CLEAR OUT ALL PAUSES AND AUTO PROCEDE REGESTER
JRST RET
BPS1: MOVE R,T
PUSHJ P,FETCH ;CAN PAUSE BE INSERTED HERE?
JRST ERR19 ;NO
PUSHJ P,DMEMER ; AGAIN NO
MOVE T,R ;PUT THE PAUSE ADR BACK IN T
SETZM SAVLOC ;STORES AVAILABLE PAUSE SLOT
MOVEI R,B1ADR ;START OF PAUSE ARGUMENTS
BPS4: HRRZ W,(R) ;GET ADDRESS OF PAUSE IF ALREADY SET
CAIN W,(T) ;SEE IF ALREADY SET
JRST BPS5 ;YES - USE THIS
SKIPN (R) ;IS IT FREE?
HRRM R,SAVLOC ;YES - REMEMBER WHERE
ADDI R,3 ;LOOK AT NEXT
CAIG R,BNADR ;ALL EXAMINED?
JRST BPS4 ;NO GO ON IN CASE THIS ADDRESS USED ALREADY
SKIPN R,SAVLOC ;WHERE THERE ANY FREE?
JRST ERR9 ;NO - UNLUCKY USER
BPS5: MOVEM T,(R) ;SET UP PAUSE ADDRESS
MOVE T,TEM ;GET CONDITIONAL IF ANY L.H. = WHAT TO TYPE
MOVEM T,1(R)
MOVE T,TEM1 ;GET THE PROCEDE COUNT
MOVEM T,2(R) ;PLACE WHERE IT DOES THE MOST GOOD
AUTOP: SUBI R,B1ADR ;AUTO PROCEDE SETUP SUBROUTINE
IDIVI R,3
MOVEI S,1
LSH S,(R)
ANDCAM S,AUTOPI
TLNE F,AUTO ;DID USER ASK FOR AUTO PROCEDE?
IORM S,AUTOPI ;YES - LET HIM HAVE IT
HRRZ T,TEM ;DID USER ASK FOR A CONDITIONAL
JUMPE T,CPOPJ ;NO - ALL DONE
LSH R,2 ;FORM INDEX TO TEST TABLES
ADDI R,TESTAB
MOVE T,COND0
MOVEM T,(R) ;SAVE TEST NO.
MOVE T,COND1
CAIN T,COND3 ;SHOULD THIS BE A CONSTANT
MOVEI T,3(R) ;YES CORRECT IT
MOVEM T,1(R) ;SAVE ADDRESS OF FIRST ARG
MOVE T,COND2
CAIN T,COND3
MOVEI T,3(R) ;SAVE ADDRESS OF SECOND ARG
MOVEM T,2(R) ;SAVE ADDRESS OF SECOND ARG
MOVE T,COND3 ;GET CONSTANT IF ANY
MOVEM T,3(R) ;AND SAVE
POPJ P,
SUBTTL MEMORY MANAGER SUBROUTINES
;DEPOSIT INTO MEMORY SUBROUTINE
DEPMEM: EXCH R,T ;CHECK (T)
PUSHJ P,CHKADR ;LEGAL ADDRESS?
POPJ P, ;NO - ILLEGAL
JRST DEP4 ;YES BUT IN HI SEGMENT
EXCH R,T
TRNN R,777760
JRST DEPAC ;DEPOSIT IN AC
MOVEM T,(R)
JRST CPOPJ1 ;SKIP RETURN
DEPAC: MOVEM T,SAVACS(R) ;[147] DEPOSIT IN AC
JRST CPOPJ1 ;SKIP RETURN
ife tops20,<
DEP4: EXCH R,T
MOVEI TT1,0
SETUWP TT1, ;IS HI SEGMENT PROTECTED? TURN OFF
POPJ P, ;PROTECTED, NO SKIP RETURN
MOVEM T,(R) ;STORE WORD IN HI SEGMENT
TRNE TT1,1 ;WAS WRITE PROTECT ON?
SETUWP TT1, ;YES, TURN IT BACK ON
JFCL
JRST CPOPJ1> ;skip return, end of conditional
ifn tops20,<
dep4: exch r,t ;restore r and t
push p,tf ;save regs for JSYS
push p,r
lsh r,-11 ;form page number from address
hrrzi tf,(r) ;put into AC1
hrli tf,400000 ;get process handle into left half
push p,tf ;save this argument, just in case!
rpacs% ;get access bits into AC2
tlne tf,(pa%wt) ;can we write to this page?
jrst dep5 ;yes, go do it
move tf,(p) ;no, get saved argument
and r,[pa%wt!pa%rd!pa%cpy!pa%ex]
;clear unneeded bits
tlo r,(pa%cpy) ;get cw access for page
spacs%
hrroi tf,[asciz/
%FDTWSP Writing to shared page
/] ;prepare to warn him once
aosn pagwrn ;skip if he has already been warned
psout% ;send warning
dep5: pop p,r ;flush extra stack level
pop p,r ;restore r
pop p,tf ;restore flags
movem t,(r) ;save away t
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 R,T ;CHECK (T)
PUSHJ P,CHKADR ;LEGAL ADDRESS?
POPJ P, ;NO
JFCL ;HIGH OR LOW OK FOR FETCH
EXCH R,T
TRNN R,777760 ;ACCUMULATOR?
SKIPA T,SAVACS(R) ;[147] YES
MOVE T,(R) ;NO
JRST CPOPJ1 ;SKIP RETURN ONLY FOR LEGAL ADDRESS
SUBTTL BINARY TO SYMBOLIC CONVERSION
; PUSHJ P,LOOK ;AC T 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 T
; RETURN 3 ;EXACT MATCH FOUND AND PRINTED IF R=0
; ;R=SYMBOL VALUE IF SILENT FLAG ON
; ;T = SYMBOL VALUE BEING 'LOOKED' UP
; ;W1 = ADDRESS OF BEST SYMBOL SO FAR
; ;TRULST=LAST CHARACTER IF LABEL FOUND
LOOK: SETZM PNAMSV ;RESET PROGRAM NAME OF SYMBOL
TRZ F,MDLCLF!ID ;[157]Clear flags
MOVEI R,377777
TRNE F,NEARST ;
MOVNI R,377777
MOVEM R,BESTVA ;SETUP FALSE OFFSET
PUSHJ P,LOKSYM ;CHECK IT
LOOK0: POPJ P, ;NOTHING FOUND
JRST LOOK4 ;MULT. DEF. OR OFFSET
MOVE R,W1 ;PTR TO SYMBOL
MOVEM R,LASYM ;SAVE THIS SYMBOL
MOVE W2,1(R) ;GET VALUE
MOVEM W2,LASVAL ;SAVE
TRZN F,SILENT ;FOUND - SILENCE?
PUSHJ P,SPT ;NO - TYPE SYMBOL
PUSHJ P,LOOKPG ;LOOKUP FOR PROGRAM NAME
JRST CPOPJ2 ;DOUBLE SKIP - SUCCESS
LOOK4: JUMPE T,CPOPJ1 ;MULT DEF
MOVEM R,LASYM ;UPDATE LAST SYMBOL
MOVE W2,1(R) ;GET VALUE
ADDI W2,(T) ;WITH OFFSET
MOVEM W2,LASVAL ;AS LAST VALUE
PUSHJ P,LOOKPG ;GET PROGRAM NAME
JRST CPOPJ1 ;2ND SKIP
RELOOK: MOVE R,W1 ;RESET (R)
PUSH P,[LOOK0] ;RETURN
TRZ F,ID ;ALLOW LOKSYM TO FIND IT
JRST LOK3 ;HERE WE GO AGAIN
;ROUTINE TO LOOKUP FOR PROGRAM NAME
LOOKPG:
PUSH P,R ; SAVE R
LOOK2: ADD R,[2,,2]
JUMPGE R,LOOK3 ;END OF TABLE
MOVE W2,(R) ;GET NEXT ENTRY
TLNE W2,PNAME ;PROGRAM NAME?
JRST LOOK2 ;NO
MOVEM W2,PNAMSV ;YES - SAVE IT
LOOK3: POP P,R ;RESTORE R
POPJ P, ;END ROUTINE
;THIS ROUTINE SEARCHES THE SYMBOL TABLE SPECIFIED BY FLAG FGLSNM FOR
;THE VALUE SUPPLIED IN AC T. THERE IS A FAIL RETURN FOR SYMBOL NOT
;FOUND OR MULT. DEF. LOCAL.
LOKSYM: SETZB W1,TEM3
MOVEM T,TEM8 ;STORE VALUE
MOVE R,.JBSYM ;USE LOSEG TBL
TRNN TF,TYPCMD ;[171] TYPEing?
JRST LOKSM ;[171] NO search all of lowseg
SKIPE R,OPENLS ;[171] YES, search from current module
TLO F,FLCLNM ;[171] Flag locals only
LOKSM: ;[171]
PUSHJ P,LOK2 ;
JRST LOK1 ;NOT FOUND
CAIA ;OFFSET OR MULT DEF.
JRST CPOPJ2 ;FOUND
TRNE F,MDLCLF ;MULT. DEF.?
JRST CPOPJ1 ;FAIL - 2ND SKIP
MOVEM T,TEM3 ;OFFSET - SAVE IT
MOVEM W1,TEM4 ;SAVE PTR
LOK1: PUSHJ P,GHSSYP ;GET HISEG SYM TBL PTR
JRST [SKIPN TEM3 ;OFFSET FOUND?
JRST CPOPJ ;NO - FAIL
JRST LOK15] ;YES - USE IT
MOVE T,TEM8 ;RESTORE VALUE
MOVEI R,(TT) ;
PUSHJ P,LOK2
JRST CPOPJ ;NOTHING FOUND
CAIA
JRST CPOPJ2 ;EXACT MATCH
JUMPE T,CPOPJ1 ;2ND SKIP ON MULT DEF
TRNN F,NEARST ;LOOKING FOR THE NEAREST ABOVE?
JRST LOK13 ;NO
CAML T,TEM3 ;YES - NEW VALUE CLOSER?
JRST CPOPJ1 ;YES
JRST LOK15 ;NO - USE THE OLD VALUE
LOK13: SKIPE TEM3 ;OFFSET FOUND FOR LOSEG TBL?
CAMG T,TEM3 ;YES - A BETTER ONE?
JRST CPOPJ1 ;NO
LOK15: MOVE T,TEM3 ;YES - UPDATE VALUES
MOVE W1,TEM4
MOVE R,TEM4
JRST CPOPJ1 ;2ND SKIP
LOK2: PUSHJ P,FIXSYR ;FIX SYM TBL PTR IN (R)
JUMPGE R,LOK16 ;[104] IF OFF END OF TABLE, GET OUT
MOVE W2,(R) ;GET NEXT SYM
TLNN W2,PNAME ;IGNORE PROG NAMES
;[171] JRST LOK3
JRST LOK3A ;[171] Jump over this entry
TLNE W2,GLOBAL ;GLOBAL?
TLNE F,FGLSNM ;GLOBALS OK?
TLZA W2,LOCAL!GLOBAL ;YES - ZERO BITS
JRST LOK3 ;NO - PASS IT
TLNE W2,PNAME ;SHOULD BE CLEAR NOW
JRST LOK3
MOVE W2,1(R) ;OK - GET VALUE
MOVE TT,T ;[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 T,W2 ;SAME AS SIGN FOR SYMBOL?
JUMPGE T,LOKSSN ;YES. EASY CASE
TXC TT,1B0 ;NO. MAKE SIGNS THE SAME
SUB TT,W2 ;SUBTRACT IS SAFE NOW
TXCA TT,1B0 ;FIX UP SIGN AGAIN
LOKSSN: SUB TT,W2 ;[135] GET OFFSET
XOR T,W2 ;EITHER WAY, RESTORE T
JUMPL TT,LOK6 ;IGNORE IF WRONG DIRECTION
JUMPE TT,LOK5 ;EXACT MATCH?
CAMGE TT,BESTVA ;NO, BUT BETTER VALUE?
JRST LOK4 ;YES
LOK3: ADD R,[2,,2] ;TRY NEXT ENTRY
JUMPL R,LOK2 ;
JRST LOK16 ;[171] Finish up
LOK3A: TRNE TF,TYPCMD ;[171] 'TYPE'?
TLZN F,FLCLNM ;[171] And looking for local symbol?
JRST LOK3 ;[171] NO keep looking
MOVE R,.JBSYM ;[171] IF 'TYPE' we're finished searching
JRST LOK2 ;[171] Open module but no match,
;[171] Restart search from beginning
LOK16: JUMPE W1,CPOPJ ;[104] FAIL IF NONE FOUND
TRNE F,NEARST ;FOR NEAREST?
JRST LOK10 ;YES
CAMN T,1(W1) ;EXACT MATCH?
JRST CPOPJ2 ;YES - SUCCEED
MOVE W2,1(W1) ;NO, SO GET BEST VALUE
SUB T,W2 ;GET OFFSET
JRST CPOPJ1 ;EXIT FOR OFFSET
LOK4: TRNE F,NEARST ;NEAREST?
JRST LOK3 ;YES - THIS ISN'T IT
PUSHJ P,TRUVAR ;VARIABLE ?
JRST [MOVE W2,TRUFST
CAIN W2,27 ;"M" LABEL?
JRST LOK3 ;YES IGNORE
JRST .+1]
SKIPN W2,MATHSM ;SPECIFIC SYMBOL??
JRST LOK4A ;NO
PUSH P,W1 ;SAVE W1
MOVE W1,(R) ;GET SYMBOL
TLZ W1,PNAME ;FIX UP A BIT
CAMN W1,W2 ;IS IT THE ONE WE ARE LOOKING FOR
JRST LOK4B ;YES
LOK4C: POP P,W1 ;NO -RESTORE
JRST LOK3 ;IGNORE
LOK4B: POP P,W1
LOK4A: MOVEM TT,BESTVA ;BETTER MATCH
MOVE W1,R
JRST LOK3 ;KEEP GOING
LOK5: TRNE F,NEARST ;NEAREST ONLY?
JRST LOK3 ;YES - PASS IT BY
PUSHJ P,TRUVAR ;YES - F10 SYMBOL?
JRST [TRNE F,ID ;NO - LABEL - MATCH ALREADY?
JRST LOK12 ; YES - CHECK HIERARCHY
JRST LOK14] ; NO - TAKE IT
SKIPN W2,MATHSM ;ACCEPT ONLY THIS SYMBOL IF SET
JRST LOK7
PUSH P,W1 ;SAVE W1
MOVE W1,(R) ;GET SYMBOL
TLZ W1,PNAME
CAME W1,W2
JRST LOK4C ;IGNORE IT IF NOT THE SAME
POP P,W1 ;REMOVE POP
MOVE W1,R
MOVE W2,(R) ;LETS TAKE IT AND RUN
TLNE W2,GLOBAL ;GLOBAL?
JRST LOK11 ;YES DONE
JRST CPOPJ2 ;ALSO DONE
LOK7: TRON F,ID ;USE THIS SYMBOL
JRST LOK9 ;FIX UP
LOK8: TRO F,MDLCLF ;SECOND SYM FOUND - MULT. DEF.
MOVE W2,(R) ;GET SECOND SYMBOL FOUND
TLNN W2,GLOBAL ;SEE IF IT IS A GLOBAL
JRST LOK8A ;OTHER LOCAL - GO SEE IF EQUIVALENT DEFINITION
MOVE W1,R ;GLOBAL HAS HIGHER PRIORITY
JRST LOK11 ;DONE
LOK8A: JUMPN TT,CPOPJ1 ;NOT EXACT MATCH
MOVE T,(W1) ;GET PREVIOUS FOUND
TLZ T,PNAME ;JUST RADIX-50 NAME
TLZ W2,PNAME ;ALSO FOR NEW FOUND
CAME W2,T ;SAME NAME
JRST CPOPJ1 ;NO
JRST LOK11 ;YES - MAY BE COMMON BECAUSE
; SAME NAME + SAME ADDRESS
LOK9: MOVE W1,R ;UPDATE PTR
MOVE W2,(R) ;GET SYM
TLNE W2,GLOBAL ;GLOBAL?
JRST LOK11 ;YES - DONE
SETZM BESTVA ;BEST MATCH
JRST LOK3 ;AND ON
LOK6: TRNN F,NEARST ;LOOKING FOR NEAREST?
JRST LOK3 ;NO - IGNORE
CAMG TT,BESTVA ;CLOSER MATCH?
JRST LOK3
MOVEM TT,BESTVA ;YES - UPDATE BEST VALUE
MOVE W1,R ;SAVE PTR
JRST LOK3 ;AND GO ON
LOK11: SKIPA T,1(W1)
LOK10: SKIPA T,1(W1) ;GET VALUE
AOS (P) ;DOUBLE SKIP HERE
JRST CPOPJ1 ;ALL THATS NEEDED
LOK12: MOVE W2,LOKFST ;GET THE (LAST) CHAR
EXCH W2,TRUFST ;KEEP TRUFST UPDATED
CAIE W2,27 ;"M"?
CAMG W2,TRUFST ;DOES THIS HAVE HIGHER PRIORITY?
JRST LOK3 ;NO - IGNORE IT
TRZ F,ID ;YES - USE IT
JRST LOK7 ;
LOK14: MOVE W2,TRUFST ;GET THE LABEL TYPE
CAIN W2,27 ;"M" ?
JRST LOK3 ;YES IGNORE
MOVEM W2,LOKFST ;SAVE IT
JRST LOK7 ;AND USE THIS SYMBOL
; ROUTINES TO TYPE A SYMBOL IN THE NON OPEN SECTION
SYMBOL: PUSHJ P,SAV2AC ;SAVE T,W1
TRNE F,MDLCLF ;SYMBOL ALREADY TYPED
JRST SYMBL2 ;DISPLAY ALTERNATE NAME
SYMBL3: MOVE T,(R) ;GET THE OUTPUT STRING
PJRST SPT1 ;TYPE IT AND RESTORE T,W1
SYMBL2: LINE
TYPE( equivalent to )
JRST SYMBL3 ;NOW TYPE NAME
; TYPE THE SECTION NAME (ADDRESS OF NAME IS IN R )
SECTON: PUSHJ P,SAV2AC ;SAVE T,W1
MOVE T,(R) ;GET NAME OF SECTION
CAMN T,SECSAV ;ALREADY TYPED?
POPJ P, ;YES - MUST BE A RANGE
MOVEM T,SECSAV ;SAVE THE NEW ONE BEING TYPED
TRNE TF,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 T AND W1
SAV2AC: EXCH T,(P) ;SAVE T, AND GET RETURN
MOVEM T,TRULST ;SAVE AS ESCAPE
MOVE T,(P) ;RESTORE T
PUSH P,W1 ;SAVE W1
MOVEI W1,SAVRET ;INTERCEPT FOR FINAL POPJ
PUSH P,W1 ;SAVE FOR RETURN
MOVE W1,-1(P) ;REINSTATE W1
JRST @TRULST ;PSEUDO POPJ BACK TO USER
SAVRET: POP P,W1 ;RESTORE OLD W1
POP P,T ;RESTORE OLD T
POPJ P, ;FINALLY DO THE USERS POPJ
SUBTTL OUTPUT ROUTINES
;OFFSET TYPES THE SYMBOL WHOSE VALUE IS IN AC T. SUBSCRIPTS ARE
;HANDLED. THERE IS A SKIP RETURN ON SUCCESS, FAIL IF SYMBOL NOT FOUND.
OFFSET: SKIPN T,T ;[167]Are we looking for a real symbol?
POPJ P, ;[167]NO
MOVEM T,TEM5 ;[167]Save current symbol value
CAMN T,FRMSAV ;[167]Are we looking for a formal?
JRST OFF1 ;[167]YES
EXCH T,SAVLOC ;[167]T=input symbol, SAVLOC=suspected array
MOVEM T,TEM6 ;[167]Save SAVLOC
;[170] TLNE TMOD,C. ;[167]Character?
TRNE TMOD,C. ;[170]Character?
JRST CHARAY ;[167]YES, different processing
PUSHJ P,RAYNAM ;[167]Does symbol denote array?
JRST OFF1A ;[167]Doesn't look that way
;OFFSET: MOVEM T,TEM5
; EXCH T,SAVLOC ;UPDATE SAVLOC
; MOVEM T,TEM6 ;BUT SAVE OLD VALUE
; PUSHJ P,RAYNAM ;IS (SAVLOC) AN ARRAY START ADDRESS?
; JRST OFF1 ;NO
; TLNE TMOD,C. ;[160]Character string?
; JRST OFFCHR ;[160]YES.
MOVE T,TEM5 ;GET VALUE OF SYM
TRO F,SILENT ;SILENCE
PUSHJ P,LOOK ;GET SYM PTR
JRST E5 ;
JFCL
MOVE W1,R ;GET PTR
MOVEI W2,0 ;YES, OFFSET IS ONE
JRST OFF2 ;GO
;OFF1: TLNE TMOD,C. ;[160]Character string?
; JRST SCLCHR ;[160]YES.
; MOVE T,TEM6
; JUMPE T,OFF1A ;SAVLOC NOT AVAILABLE
;[BL] means that call came from conditional pause
OFF1: ;MOVE T,TEM6 ;[167]Restore input symbol[SAVLOC]
; MOVEM T,SAVLOC ;[167]Put it back
PUSHJ P,RAYNAM ;[167]Now see if IT'S an array
; MOVEM T,SAVLOC ;RESTORE SAVLOC
; PUSHJ P,RAYNAM ;SET UP DOUBLE IF APPROPRIATE
; JRST OFF1A ;NOT AN ARRAY KNOWN
TRNE F,FORMAL ;[110] A FORMAL ARRAY?
JRST OFF6 ;[110] YES, GO TYPE SPECIALLY
CHARAY: PUSHJ P,RAYNAM ;[167]Is it an array?
JRST SCLCHR ;[167]NO
OFFCHR: MOVE W1,CRYSYM ;[157]Load addr/RAD50 name
MOVE W2,CLMOFF ;[157]Load element offset
JRST OFF2 ;[157]Go compute indices
SCLCHR: MOVE W1,CRYSYM ;[160]
PUSHJ P,SPT ;[160]
JRST OFF5A ;[160]
OFF7: MOVE T,TEM5 ;[110] RESTORE T
TRO F,SILENT ;WE DONT WANT TO TYPE THE SYMBOL
PUSHJ P,LOOK ;NOT ARRAY START
POPJ P, ;[110] NOT FOUND
MOVE W2,T ;OFFSET - GET IT
JRST OFF2 ;FOUND - GO PRINT
OFF1A: MOVE T,TEM5 ;TRY TO FIND THE REQUESTED SYMBOL
TRO F,SILENT ;DONT PRINT NOW
PUSHJ P,LOOK
POPJ P, ;[110] NOT FOUND
SKIPA W2,T ;MAY BE AN ARRAY
JRST [MOVE W1,R ;WAS A SINGLE VAR - FOUND
PUSHJ P,SPT ;TYPE NAME
JRST OFF5A] ;TYPE LOC IF NOT CURRENT
MOVEM R,TEM6 ;KEEP SYMBOL NAME FOUND
MOVEM W2,TEM ;KEEP OFFSET
MOVE T,TEM5 ;GET BACK ORIGINAL ADDR
SUB T,W2 ;MINUS OFFSET SHOUD BE ARRAY START
MOVEM T,SAVLOC ;MAY BE IT IS
PUSHJ P,RAYNAM ;TRY IT
JRST ERR34 ;NOT
MOVE W1,TEM6 ;GET BACK SYMBOL NAME
MOVE W2,TEM ;AND OFFSET
;;;; JRST OFF2 ;GO PRINT IT
OFF2: MOVEM W2,TEM ;SAVE OFFSET
PUSHJ P,SPT ;PRINT SYMBOL
openp
PUSH P,SAVLOC ;SAVE SAVLOC AROUND OFFSET PRINT
PUSH P,AR ;AR TOO
MOVEM P,DIMTOT ;AND FREEZE PD LIST
SETZM PUTTER
SETZM COUNT ;PREPARE
MOVE W1,TEM
TRZE F,DOUBLE ;[112] DOUBLE WORD ARRAY?
LSH W1,-1 ;YES - ONLY HALF OFFSET
MOVEM W1,TEM7 ;SAVE W1
MOVEI T,1
MOVEM T,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 T,TEM1
SUB T,TEM
AOJ T, ;FORM RANGE FOR THIS DIM
IMULM T,RP
AOS COUNT ;INC COUNT OF # OF DIMS
PUSHJ P,MORDIM ;MORE?
CAIA
JRST OFF3 ;YES
MOVE AR,COUNT ;NO
MOVE T3,P ;COPY PD LIST
MOVE W1,TEM7 ;RESTORE W1
OFF4: POP T3,T2 ;GET LAST RP
POP T3,T ;LOWER SUBSCRIPT
IDIV W1,T2 ;VALUE OF FIRST ELEMENT
ADDI W1,(T) ;CORRECT FOR USERS OFFSET
HRRZM W1,1(T3) ;SAVE FOR PRINTING
EXCH W1,W2 ;GET OFFSET REMAINDER
SOJG AR,OFF4
SKIPA AR,COUNT ;RESET DIM CNT
OFF5: jrst [stype(</,/>)
jrst .+1]
HRRE T,1(T3) ;FIRST ELEMENT
PUSHJ P,TYP0 ;TYPE IT DECIMAL
ADDI T3,2 ;NEXT ELEMENT
SOJG AR,OFF5
closep
MOVE P,DIMTOT ;RESET PD LIST
POP P,AR
POP P,SAVLOC ;RESTORE
OFF5A: MOVE T,PNAMSV ;GET SECTION NAME OF SYM
CAMN T,OPENED ;IS IT CURRENT?
JRST CPOPJ1
MOVEI R,PNAMSV
PUSHJ P,SECTON ;NO - TYPE IT IF APPROPRIATE
SETZM FRMSAV ;[167]Reset formal
JRST CPOPJ1
OFF6: SKIPE MATHSM ;[110] ANY NAME TO TYPE?
SKIPN FRMSAV ;IS THERE A FORMAL NAME
JRST OFF7 ;[110] NO, NOT FOUND
TYPE (Formal parameter ) ;TELL THE USER
MOVEI W1,MATHSM ;TYPE NAME OF FORMAL ARGUMENT
PUSHJ P,SPT ;SO HE KNOWS
LINE
SETZM MATHSM ;FORGET ABOUT SPECIFIC NAME
MOVE T,FRMSAV ;GET ADDRESS OF ACTUAL PAR.
TRO F,SILENT ;[110] NO SYMBOL TYPEOUT
PUSHJ P,LOOK ;TRY IT
JRST OFF7 ;[110] NOT FOUND
SKIPA W2,T ;OFFSET - GET IT
JRST [MOVE W1,R ;EXACT ADDR FOUND - TYPE NAME
PUSHJ P,SPT ;
JRST OFF5A] ;IF REQUIRED TYPE NAME OF SECTION
JRST OFF2 ;CONTINUE
; SYMBOL OUTPUT SUBROUTINE
SPT: ;RADIX 50 SYMBOL PRINT
LDB T,[POINT 32,0(W1),35] ;GET SYMBOL
SPT1: CAME T,PRGNAM ;COMPARE NAME WITH MAIN PROG NAME
CAMN T,[SQUOZE 0,MAIN.]
JRST SPT8
PUSH P,T ;SAVE T OVER THE NEXT FEW LINES
MOVEI W1,T ;SET UP FOR TRULBL
PUSHJ P,TRULBL ;IS THIS A TRUE-LABEL
CAIA ;NO
JRST SPT5 ;YES - SEE IF SOURCE LINE
SPT6: POP P,T ;RESTORE T = SYMBOL
MOVEI W1,SPT4 ;SPECIAL TREATMENT FOR LAST CHARACTER
PUSH P,W1 ;SAVE ON STACK
SPT3: TLZ T,PNAME ;RADIX 50 PART ONLY
IDIVI T,50
HRLM W1,0(P)
JUMPE T,[SETOM W1
JRST .+2]
PUSHJ P,SPT3
HLRZ T,(P)
ADDI T,260-1
CAILE T,271
ADDI T,301-272
CAILE T,332
SUBI T,334-244
CAIN T,243
MOVEI T,256
ANDI T,177 ;USE 7 BIT CODE
JUMPL W1,SPT7 ;FIRST TIME ROUND IS SPECIAL
EXCH T,SAVCHR ;SAVE AS LAST CHARACTER
PJRST TOUT ;DISPLAY CHARACTER
SPT8: TYPE (MAIN PROGRAM)
POPJ P,
SPT4: MOVE T,SAVCHR ;GET BACK THE LAST CHARACTER
JUMPN W1,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 W1,26 ;GET RADIX 50 'L'
CAMN W1,TRULST ;IS THIS A SOURCE LINE REFFERENCE
jrst [TYPE(L#)
jrst .+1]
JRST SPT6 ;DISPLAY THE SOURCE LINE TAG
SPT50: MOVE W1,TRULST ;[145] GET LAST CHAR
CAIE W1,26 ;[145] "L"?
JRST [TYPE (statement ) ;[145] NO, "p"
JRST SPT6] ;[145]
TYPE (line ) ;[145]
JRST SPT6 ;[145]
SPT7: CAIL T,"0"
CAILE T,"9"
TDZA W1,W1 ;ZERO IF FIRST CHAR NOT NUMERIC
HRRZI W1,-1 ;.GT. ZERO IF FIRST CHAR IS NUMERIC
MOVEM T,SAVCHR ;SAVE LAST CHARACTER
POPJ P,
SUBTTL GENERAL NUMBER INPUT ROUTINE
; DELIMITERS ARE SPACES TABS OR , OR ) LAST CHAR IN T1
GETNUM: TDZ F,[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 T1,"." ;[116] POSSIBLY A LOGICAL SYMBOL?
TRZ TF,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 T1,POWER ;LAST CHAR WAS A DELIMITER
MOVE T,[JRST GETOUT] ;[120] IN CASE WE GO TO LOGICL
MOVEM T,DONE ;[120] THIS IS HOW WE'LL WANT TO RETURN
CAIE T1,"," ;ALLOW , AS # DELIMITER
CAIN T1,")" ;ALLOW ALSO RIGHT PARENS
JRST POWER ; DELIMITER SEEN - CLEAN UP
CAIE T1,"/" ;BAR IS A DELIMITER IN DIMENSION DEFS
CAIN T1,"]" ;LEFT SQUARE BRKT ALSO
JRST POWER ;DELIMITER
CAIE T1,":" ;ACCEPT : FOR DIMENSIONS
CAIN T1,"=" ;ACCEPT = AS DELIMITER
JRST POWER
MOVE T,T1 ;MORE USEFUL IN T
CAIN T,42 ;IS IT " ?
JRST OCTAL ;YES - HOIST THE OCTAL FLAG
CAIE T,"+" ;BOTH PLUS AND MINUS
CAIN T,"-" ; DISPATCH TO
JRST SGN ; THE SAME PLACE
CAIN T,"." ;PERIOD TYPED ?
JRST PERIOD ;THIS MEANS INPUT CANNOT BE OCTAL
CAIE T,"D"+40 ;[113]
CAIN T,"D" ;[113] DOUBLE PRECISION NOT ALLOWED HERE
JRST ERR21 ;[113]
CAIE T,"E"+40 ;[113]
CAIN T,"E" ;EXPONENT REQUESTED?
JRST E ;FLOATING POINT VALUES ONLY RETURNED
CAIL T,"0" ;NUMERALS ONLY
CAILE T,"9" ;
JRST LOGICL ;[116] LET'S SEE IF WE HAVE A LOGICAL SYMBOL
SUBI T,60 ;FORM OCTAL REPRESENTATION
JRST NUM ;GO DEAL WITH NUMERIC INPUT
LOGICL: TRZN TF,LGCLEG ;[116] ARE LOGICAL SYMBOLS LEGAL?
JRST ERR7 ;[116] NOPE, BAD STUFF
TLZ F,FPF ;[116] TURN OFF FLOATING POINT FLAG
TRZ F,POWF ;[116] AND POWER FLAG (SET WHEN "." SEEN)
PUSHJ P,EITHR5 ;[116] LET'S GET THE WHOLE WORD
CAIE T1,"." ;[116] DOES IT END WITH PERIOD?
JRST ERR7 ;[116] NO, CAN'T BE A LOGICAL SYMBOL
CAME T2,[SIXBIT /TRUE/] ;[116] IS IT .TRUE.?
JRST FALSE ;[116] NOPE, COULD BE .FALSE.
SETO T, ;[116] IT'S .TRUE.! RETURN -1
TRO TF,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 T2,[SIXBIT /FALSE/] ;[116] IS IT .FALSE.?
JRST ERR7 ;[116] NO, JUNK
SETZ T, ;[116] IT'S .FALSE.! RETURN 0
TRO TF,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 F,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 F,SIGN ;HAS A SIGN BEEN SEEN BEFORE?
JRST ERR7 ;YES - REJECT
CAIE T,"+" ;NO SPECIAL ACTION FOR PLUS
TLO F,MF ;SET THE MINUS FLAG
POPJ P, ;
NUM: ANDI T,17 ;T HOLDS CHARACTER
TLNE F,FPF
JRST NM1
MOVE W,SYL
TLNE W,700000 ;TEST FOR PENDING WORD OVERFLOW
JRST ERR7 ;BAD VALUE
LSH W,3
ADD W,T
MOVEM W,SYL
MOVE W,DEN
IMULI W,12 ;CONVERT TO DECIMAL
ADD W,T
MOVEM W,DEN
POPJ P,
NM1: MOVEI W1,6 ;FORM FLOATING POINT NUMBER
AOS NM1A
NM1A: MOVEI W2,0
MOVSI R,201400
NM1A1: TRZE W2,1
FMPR R,FT(W1)
JUMPE W2,NM1B
LSH W2,-1
SOJG W1,NM1A1
NM1B: MOVSI W1,211000(T)
FMPR R,W1 ;COMPUTE VALUE OF NEW DIGIT
FADRB R,FH ;ADD VALUE INTO FLOATING NO.
MOVEM R,SYL
TRO F,POWF ;INDICATE THAT ANSWER WILL BE FLOATED
POPJ P,
POWER: TLNN F,FEF ;HAS E BEEN SEEN?
JRST POW3 ; NO - MUST BE INTEGER OR OCT AL OR #.#
MOVE T,SYL
MOVE W2,DEN
CAILE W2,^D38 ;POWERS <38 ONLY
JRST ERR7
MOVEI W1,FT-1
TLZE F,MF
MOVEI W1,FT01
SKIPA T,FSV
POW2: LSH W2,-1
TRZE W2,1
FMPR T,(W1)
JUMPE W2,GETOUT
SOJA W1,POW2
PERIOD: TLNN F,OCTF ;DO WE HAVE AN OCTAL NO.
TLOE F,FPF ;BOTH OCTAL AND FPF CANNOT EXIST TOGETHER
JRST ERR7
MOVE T,DEN
IDIVI T,400
JUMPE T,.+2
TLC T,243000
TLC W1,233000
FAD T,[0] ;NORMALIZE T AND W1
FAD W1,[0]
FADR T,W1
MOVEM T,FH
MOVEM T,SYL ;SAVE FLOATING ANSWER
TRO F,POWF ;AND REMEMBER WE NOW HAVE REAL
HLLZS NM1A
POPJ P,
E: TLON F,FEF ;HOIST THE FLOAT FLAG IF NOT UP
TLNN F,FPF ;REJECT IF E REQUESTED AND NO FPF
JRST ERR7
TRNN F,POWF ;USER MUST TYPE A DIGIT AFTER THE PERIOD
JRST ERR7
TLZN F,MF
SKIPA W1,SYL
MOVN W1,SYL
MOVEM W1,FSV
CLEARM SYL
CLEARM DEN
TLZ F,FPF!SIGN!MF
POPJ P,
POW3: ;ANSWER IN SYL IF #.# OR OCTAL OR INTEGER
TLNN F,FPF!OCTF ;TEST FOR INTEGER
TLO F,FPF ;MUST BE INTEGER
TDNN F,[XWD OCTF,POWF]
TLNN F,FPF ;DO WE HAVE INTEGER?
SKIPA T,SYL ;NO - GET OCTAL
MOVE T,DEN ;GET DECIMAL
TLNE F,MF ;SHOULD WE RETURN NEGATIVE#
MOVNS T,T ; YES - DO SO
GETOUT: MOVE T1,LSTCHR ;SET USERS LAST CHARACTER
POP P,(P)
POPJ P, ;FINALLY OUT OF GETNUM
SUBTTL OUTPUT ROUTINES
; FLOATING POINT OUTPUT
TFLOT: MOVE A,T
JUMPGE A, TFLOT1
MOVNS A
MOVEI T,"-"
PUSHJ P,TOUT
TLZE A,400000
JRST FP1A
TFLOT1: TLNN A, 400
PJRST FP7 ;DECIMAL PRINT
MOVEI B,0
CAMGE A,FT01
JRST FP4
CAML A,FT8
AOJA B,FP4
FP1A: MOVEI C,0
FP3: MULI A,400
ASHC B,-243(A)
SETZM TEM1 ;INIT 8 DIGIT COUNTER
SKIPE A,B ;DON'T TYPE A LEADING 0
PUSHJ P,FP7 ;PRINT INTEGER PART OF 8 DIGITS
MOVEI T,"." ;GET A MINUS
PUSHJ P,TOUT ;AND DISPLAY IT
MOVNI A,10
ADD A,TEM1
MOVE W1,C
FP3A: MOVE T,W1
MULI T,12
PUSHJ P,FP7B
JUMPE W1,CPOPJ
AOJL A,FP3A
POPJ P,
FP4: MOVNI C,6 ;
MOVEI W2,0
FP4A: ASH W2,1
XCT FCP(B)
JRST FP4B
FMPR A,@FCP+1(B)
IORI W2,1
FP4B: AOJN C,FP4A
PUSH P,W2 ;SAVE EXPONENT
PUSH P,FSGN(B) ;SAVE "E+" OR "E-"
PUSHJ P,FP3 ;PRINT OUT FFF.FFF PART OF NUMBER
POP P,W1 ;GET "E+" OR "E-" BACK
PUSHJ P,TEXT
POP P,A ;GET EXPONENT BACK
FP7: IDIVI A,12 ;DECIMAL OUTPUT SUBROUTINE
AOS TEM1
HRLM B,(P)
JUMPE A,FP7A1
PUSHJ P,FP7
FP7A1: HLRZ T,(P)
FP7B: ADDI T,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 A, FT0(C)
CAMGE A, FT(C)
Z FT0(C)
FSGN: ASCII .E-.
ASCII .E+.
; TTY HANDLERS
TEXT: TLNN W1,774000 ;LEFT JUSTIFIED UNLESS LEFT CHAR IS NULL
LSH W1,35
TEXT2: MOVEI T,0 ;7 BIT ASCII TEXT OUTPUT SUBROUTINE
LSHC T,7
PUSHJ P,TOUT
JUMPN W1,TEXT2
POPJ P,
TXT341: MOVEI W2,5 ;FIVE CHARACTERS
TYPE(")
MOVE W1,T
TXT2: SOSGE W2
JRST TXT3 ;END
MOVEI T,0
LSHC T,7
PUSHJ P,ASCOUT
JRST TXT2
TXT3: TYPE(")
POPJ P,
SIXBP: MOVEM T,LWT
MOVNI W2,6 ;SIXBIT PRINTER
MOVE W1,LWT
SIXBP1: MOVEI T,0
ROTC T,6
ADDI T,40
PUSHJ P,TOUT
AOJL W2,SIXBP1
POPJ P,
FTOC: HRRZ W1,ODF ;NUMERIC OUTPUT SUBROUTINE
CAIN W1,10 ;IS OUPUT RADIX NOT OCTAL
jrst [TYPE(") ;SHOW CURRENT OUTPUT AS OCTAL
jrst .+1]
HRRZ W1,ODF ;IS OUTPUT RADIX DECIMAL?
CAIN W1,12
JRST TOC4 ;YES,TYPE SIGNED WITH PERIOD
TOC0: LSHC T,-43
LSH W1,-1 ;W1=T+1
DIVI T,@ODF
HRLM W1,0(P)
JUMPE T,.+2
PUSHJ P,TOC0
HLRZ T,0(P)
ADDI T,"0"
PJRST TOUT
TOC4: JUMPGE T,TOC5 ;TEST FOR NEGATIVE #
TYPE(-)
TOC5: MOVMS T,T ;GET MAGNITUDE
JRST TOC0 ;DO NORMAL RADIX PRINT
TOUT: putchr (T) ;OUTPUT A CHARACTER
POPJ P,
ife tops20,<
LISTEN: INCHRS T ;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,tf ;save tf
push p,r ;save r
hrrzi tf,.priou ;get terminal output designator
rfmod% ;get terminal JFN word
tlze r,(tt%osp) ;[114]clear ^o
sfmod% ;[114]set new terminal JFN word
hrrzi tf,.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,r ;restore r
tfpopj: pop p,tf ;restore tf
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 T,T1 ;PRINT (T1) AS A SIXBIT WORD
PJRST SIXBP ;PRINT IT
; ROUTINE TO CLEAR OUT REST OF USERS LINE
CLRLIN: PUSHJ P,SAV2AC ;SAVE T THRO. CLRLIN
MOVE T1,[PUSHJ P,LOADCH] ;[132] USE THIS ROUTINE TO GET CHARS.
MOVEM T1,GETCHR ;[132]
CLRLI2:
ife tops20,<
SKPINL ;SKIP IF ANY CHARS THERE
POPJ P,> ;LINE CLEAR, end of conditional
ifn tops20,<
push p,tf ;save tf
movei tf,.priin ;[121] get primary input device
sibe% ;more to come?
caia ;yes
jrst tfpopj ;no
pop p,tf> ;restore tf, end of conditional
PUSHJ P,GCHR ;GET THE NEXT CHAR
SKIPL TERMK ;NOW DONE?
POPJ P, ;YES
CAIN T1," " ;SPACE OR TAB?
JRST CLRLI2 ;IGNORE IT
SKIPE DELCHR ;DELIMITER SAVED FROM ASCII ACCEPT?
CAME T1,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 (T1) ;TYPE IT
JRST OUTLIN ;NEXT
GCHR: XCT GETCHR ;GET CHARACTER
PUSHJ P,GETSK2 ;SET UP DELIMETER FLAGS
JUMPN T1,CPOPJ
MOVEI T1," " ;RECONVERT NULLS TO SPACES
POPJ P,
TYP0: MOVEI ODF,^D10 ;PREPARE FOR DECIMAL PRINT
PJRST FTOC ;DO IT
TYP1: TYPE(?FDTIAT Illegal argument type = )
MOVEI ODF,10 ;PRINT DEFAULTING ARG TYPE AS OCTAL
HRRZ T,T2 ;TOC PRINTS T
PJRST FTOC ;DISPLAY ARGUMENT TYPE
TYP4: MOVEI ODF,10 ;PRINT OCTAL
PJRST FTOC ;PRINT
TYP5: PJRST TXT341 ;SHOW AS ASCII
TYPCS: SETZM CLMRNG ;[162]Reset for TYPN
DMOVE T1,@(T3) ;[162]Get ptr & count
JRST DSPST1 ;[164]Go display it
; F10 ARGUMENT PROCESSING
GETARG: HRR T3,SAVACS+16 ;[147] GET USERS AC 16 I.E. ARG BLOCK?
HLL T3,-1(T3) ;L.H. =-# OF ARGS ,,R.H. = ADDRESS
JUMPGE T3,CPOPJ ;APPEARS TO BE NO ARGS
CAMGE T3,[777700,,0] ;ARBITRARY LIMIT OF 64 ARGS
POPJ P, ;PREVENT RUN AWAY
LINE
TYPE(Arguments are:)
F10.2: MOVEM T3,SAVT3 ;SAVE T3 DURING OUTPUT
LINE
LDB T2,[POINT 4,(T3),12] ;GET ARGUMENT TYPE
TYPE( = )
PUSHJ P,FOROTS ;GET FOROTS TO TYPE ARGS
MOVE T3,SAVT3 ;RE-INSTATE T3
AOBJN T3,F10.2 ;MOVE TO NEXT ARG
LINE
POPJ P,
TYP10: F10.6 ;0 = UNDEFINED
F10.6 ;1 = LOGICAL
F10.6 ;2 = SINGLE PRECISION INTEGER
TYP1 ;3 = ILLIGAL
F10.6 ;4 = SINGLE PRECISION REAL
TYP1 ;5 = ILLEGAL
TYP4 ;6 = OCTAL
F10.3 ;7 = LABEL
F10.6 ;10= DOUBLE PRECISION REAL (D-Floating)
F10.4 ;11= DOUBLE PRECISION INTEGER
F10.5 ;12= DOUBLE OCTAL
F10.6 ;13= [137] DOUBLE PRECISION REAL (G-Floating)
F10.6 ;14= COMPLEX
; TYP1 ;15= ILLEGAL
TYPCS ;15= [162]Character string
TYP1 ;16= ILLEGAL
TYP5 ;17= ASCII STRING
; ROUTINE TO 'TYPE' AN ARGUMENT OF A SUBROUTINE CALLING LIST
; ENTER WITH T= VALUE OF 1ST. ARG
; T2= ARG TYPE
; T3=POINTER IN SUBROUTINE ARGBLOCK
;[BL]EXTENDED ADDRESSING?
FOROTS: MOVEI T,@(T3) ;GET SECOND ARGUMENT ADDRESS
MOVE T,1(T) ;GET SECOND ARGUMENT
MOVEM T,ARGVAL+1 ;STORE SECOND ARG
MOVE T,@(T3) ;GET FIRST ARGUMENT
; ENTRY TO 'TYPE' A SINGLE VALUE IN T - ARG TYPE IN T2
FOROUT: MOVEM T,ARGVAL ;SAVE FIRST ARGUMENT FOR TYPING
DPBTYP: DPB T2,[POINT 4,M2.,12] ;PLACE ARG TYPE
JRST @TYP10(T2) ;DISPATCH ACORDING TO ARGUMENT TYPE
F10.6: MOVEI 16,M1. ;[143] GET ADDRESS OF FORMAT BLOCK
PUSHJ P,OUT.## ;[143]
F10.8: MOVEI 16,M2. ;[143] 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 T,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 T,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 T2
FORINP: XCT DPBTYP ;PLACE ARGUMENT TYPE FOR INPUT
MOVEI T3,1 ;[127] SET UP COUNTER
MOVE T,[POINT 7,NUMBUF] ;[127] AND POINTER TO NUMBER BUFFER
SETOM TERMK ;[127] SET UP TERMINTATOR FLAG
PUSHJ P,GETSKB ;[127] GET A NON-BLANK CHARACTER
SKIPGE TERMK ;[127] EOL?
JRST GOTCH ;[127] NO.
SETZM ARGVAL ;[127] YES, NO NEED FOR FOROTS
SETZM ARGVAL+1 ;[127] JUST SET VALUE TO ZERO
POPJ P, ;[127] AND RETURN
GOTCH: IDPB T1,T ;[127] STORE IT
PUSHJ P,LOADCH ;[127] GET NEXT CHAR.
SETOM TERMK ;[127]
PUSHJ P,GETSK2 ;[127] CHECK IT OUT
JUMPE T1,FORIN2 ;[127] VALID STUFF?
CAIGE T3,NMBFSZ*5 ;[127] YES, SEE IF THERE'S ROOM LEFT IN BUFFER
AOJA T3,GOTCH ;[127] THERE'S ROOM, DUMP IT
TYPE (<%FDTECI Buffer full excess characters ignored>) ;[127]
LINE ;[127] ERROR, NOT ENOUGH ROOM
FORIN2: MOVEM T3,M4. ;[127] SET UP CHARACTER COUNT
MOVEI 16,M4. ;[111] USE FORMAT(G,G) FOR READING
PUSHJ P,DEC.## ;[143]
PJRST F10.8 ;[111] ACTION
FORBUF: MOVEI 16,M3. ;ARG BLOCK
PUSHJ P,OUT.## ;CALL OUT.
PJRST FIN.## ;DO IT AND RETURN
;ARG BLOCK FOR CALLS TO FOROTS
777773,,0 ;FIVE ARGUMENTS FOLLOW
M1.: 0,,-1 ;OUTPUT TO TTY =-1
0,,0 ;END=
0,,0 ;ERR= POSSIBLY SHOULD BE 0,,RET
340,,FORMAT ;ASCII,,FORMAT
0,,2 ;TWO WORDS OF FORMAT INFO
0,,0 ; ?
M2.: 1200,,ARGVAL ;DATA 0-8/ARGTYP 9-12/ARGADDRESS 13-35
M2.I: 4000,,0 ;CALL FIN - MAY BE USED FOR COMPLEX
M2.F: 4000,,0 ;CALL FIN
ARGVAL: BLOCK 2 ;STORAGE FOR DOUBLE WORD ARGUMENTS
FORMAT: ASCII /('+'G$,G$)/ ;[144] SUPPRESS CR AFTER OUTPUT
-5,,0
M3.: 0,,-1
0
0
340,,FORM2
0,,2
FORM2: ASCII .(1H+$).
-6,,0 ;[127][111] 6 ARGS
M4.: Z ;[127][111] NO. OF CHARS TO BE DECODED
0,,0 ;[111] END=
0,,0 ;[111] ERR=
340,,FMREAD ;[111] FORMAT(G,G) FOR READ
0,,1 ;[127][111] 1 WORD OF FORMAT
100,,NUMBUF ;[127] BUFFER LOCATION
FMREAD: ASCII/(G,G)/ ;[127][111] FORMAT FOR READING
SUBTTL GENERAL SUBROUTINES
;CHKADR CHECKS THE LOCATION IN THE RH(T) FOR VALIDITY AS A USER
;ADDRESS. RETURNS ARE:
;
; PUSHJ P,CHKADR ;WITH LOCATION IN T
; <ILLEGAL ADDRESS>
; <HISEG ADDRESS>
; <LOSEG ADDRESS>
CHKADR: PUSH P,T ;SAVE T FOLKS !
MOVEI TT,(T)
CAIGE TT,.JBDA ;ABOVE .JBDA
JRST TPOPJ ;FAIL - ILLEGAL
CAMG TT,.JBREL ;BELOW HERE IS OK TOO
JRST TPOPJ2
MOVE T4,R ;SAVE (R)
PUSHJ P,GSTAH ;GET THE START ADDR OF THE HISEG
EXCH T4,R
CAIGE TT,10(T4) ;
JRST TPOPJ
HRRZ T4,.JBHRL ;GET TOP OF HISEG
CAILE TT,(T4) ;
JRST TPOPJ
JRST TPOPJ1 ;DONE
TPOPJ: POP P,T ;RESTORE T
POPJ P, ;AND RETURN
TPOPJ1: POP P,T ;RESTORE T
JRST CPOPJ1 ;AND GIVE SKIP RETURN
TPOPJ2: POP P,T ;RESTORE T
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
JRST [TYPE (<%Trying to write in high segment; wrong mode???>)
JRST RET ];[163]Give user another chance
POPJ P, ;[163]Let user go ahead
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 T5,(T) ;[163]Load presumptive descriptor
JUMPLE T6,BSIZER ;[163]"%Null string length;wrong mode?"
;[166] TRNE T5,1B13 ;[165]Error if indirect bit set
;[166] JRST BPTRER ;[163]
TLNE T5,(1B13) ;[172]Error if indirect bit set
JRST BPTRER ;[172]
IBP T5 ;[163]Bump pointer
LDB T,[POINT 6,T5,11] ;[163]Get byte size
CAIE T,BYTSIZ ;[163]Does it look like a byte pointer?
JRST BPTRER ;[163]NO
LDB T,[POINT 6,T5,05] ;[163]Bits left in word
IDIVI T,BYTSIZ ;[163]Put remainder in T2
;[163]Since T=T4, this destroys T5
CAIE T+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: SKIPN T3,OLDOPN ;GET THE OLD NAME
POPJ P, ;NONE - OK
SETZM OLDOPN
CAMN T3,OPENED ;SAME AS THE CURRENT?
POPJ P,
MOVEM T3,SYM ;NO - SAVE IT
IMPOPN: LINE
stype(.[Implicit OPEN .)
MOVE T,SYM ;GET SYMBOL
PUSHJ P,SPT1 ;TYPE PROGRAM NAME
type(])
LINE
PJRST SETNAM ;SET IT AND DONE
;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 T2 LEFT JUSTIFIED, BREAK IN T1
;
;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 T1,CFLPTR ;CURRENT POSITION IN CORE FILE
SUBI T1,CFSIZ-1 ;[132] REMOVE OFFSET
SUB T1,CFLST ;[132] PREVENT CORE FILE OVERFLOW
JUMPL T1,I2CFL2 ;[132] IF WE'RE NOT IN LAST WORD GO AHEAD
MOVE T1,CFLPTR ;[132] GET CORE FILE POINTER
LSH T1,^D-30 ;[132] GET OFFSET INTO WORD
CAILE T1,10 ;[132] JUST ONE BYTE LEFT?
JRST I2CFL2 ;[132] NO, GO AHEAD
MOVEI T1,12 ;[132] MAKE SURE <LF> IS LAST CHAR IN BUFFER
IDPB T1,CFLPTR ;[132]
JRST ERR12 ;[132]
I2CFL2: PUSHJ P,LOADCH ;[132] GET USERS CHARACTER
IDPB T1,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 T,[pushj p,loadch]
TLNN F,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 T,[POINT 7,CFLBUF]
MOVEM T,CFLPTR ;SET UP GENERAL CORE FILE POINTER
HRRZM T,CFLST ; HOLDS START OF CURRENT CORE FILE
TLNN F,OFCFL ;OUTPUTTING TO CORE FILE?
SKIPA T,[PUSHJ P,I2CFIL] ;YES
MOVE T,[ILDB T1,CFLPTR]
XCTSET: MOVEM T,GETCHR ;SET UP FOR FUTURE XCT
TTYSET: SETOM TERMK ;PREPARE TERMINATOR FLAG
PUSHJ P,GETSKB ;SKIP LEADING BLANKS & TABS
EITHR5: MOVEI T2,0 ;SET WORD TO ZERO FOR RETURN
MOVE T3,[XWD 440600,T2] ;SET SIXBIT BYTE POINTER
;LOOP TO ACCUMULATE AFTER LEADING SPACES & TABS
GETWLP: JUMPE T1,CPOPJ ;EXIT IF TERMINATOR FOUND
CAIL T1,"0" ;LESS THAN 0 ?
CAILE T1,"9" ;LESS THAN OR EQUAL TO 9 ?
JRST GETWD2 ;YES - SEE IF LETTER
JRST GETWD3 ;NO - NUMBER,STORE
; HERE IF NOT A NUMBER
GETWD2: CAILE T1,"Z"+40 ;ABOVE LOWER CASE RANGE ?
PJRST GETSK1 ;YES - SET BREAK
CAIL T1,"A"+40 ;LOWER CASE ?
TRC T1,40 ;YES - CONVERT TO UPPER CASE
CAIL T1,"A" ;LESS THAN A ?
CAILE T1,"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 T1,40 ;CONVER TO SIXBIT
TLNE T3,770000 ;OVERFLOWED T2 YET ?
IDPB T1,T3 ;NO STORE NEXT SIXBIT CHR.
XCT GETCHR ;GET NEXT CHARACTER
JRST GETWLP ;& 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 T
; NON-SKIP EXIT IF UNKNOWN SYMBOL
; SKIP EXIT IF OK
FINDST: EXCH T,SYM ;SAVE FOR EVALUATION BY 'EVAL'
MOVEM T,SYL ;SAVE SYM
TLO F,FGLSNM ;FIND GLOBAL SYMBOL
MOVSI T,GLOBAL ;ONLY GLOBALS
MOVEM T,SYMASK
PUSHJ P,FNDSYM ;FIND THE ASSOCIATED ADDRESS
POPJ P, ;NO SUCH SYMBOL
HRRM T,GOLOC ;SAVE ADDRESS FOR DISPATCH IN GOLOC
MOVE T,SYL ;GET THE OLD SYM
MOVEM T,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 T,RESTORE ;RESTORE USERS ACS
JRST @GOLOC ;OF YOU GO
; REMOVE BLANKS & TABS
GETSKB: XCT GETCHR ;GET NEXT CHARACTER
GETSK1: CAIE T1," " ;SPACE ?
CAIN T1,11 ;TAB ?
JRST GETSKB ;YES - GET NEXT CHR
GETSK2: CAIN T1,15 ;NO - FOUND NON-BLANK
JRST GETSKB ;IGNORE CR.
CAIE T1,12 ;TEST FOR LINE FEED
CAIN T1,14 ;FORM HAS THE SAME ACTION
JRST TERMLF ;YES - ACTION
CAIE T1,13 ;CONTRL K = EOL
CAIN T1,7 ;BELL - WILL DELIMIT
JRST TERMLF ; NO EXTRA LF
CAIN T1,33 ;TEST FOR ALTMODE
JRST TERNAM ;YES - ACTION
CAIE T1,175
CAIN T1,176
JRST TERNAM
CAIN T1,32 ;TEST FOR ^Z
JRST TERMCZ ;YES - ACTION
CAIE T1," " ;TEST - SPACE
CAIN T1,11 ;ACCEPT TAB
JRST TERMSP ;YES - ACTION
CAIN T1,"!" ;DELIMITER FOR COMMENT
JRST CLRCOM ;YES
MOVEM T1,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 T1,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 TF,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 TF,COMDEL ;DID WE FIND SECOND !
POPJ P, ;YES - WE GOT NEXT COMMAND CH
JUMPN T1,CLRCO1 ;IF VALID CHAR IGNORE (PART OF COMMENT)
SKIPGE TERMK ;EOL FOUND
JRST CLRCO1 ;NO CONTINUE
TRZ TF,COMDEL ;NOT IN COMMENT PROCESS ANYMORE
POPJ P, ;RETURN TO CALLER
ife tops20,<
loadch: inchwl t1
popj p,>
ifn tops20,<
loadch: push p,tf ;save tf
pbin% ;read byte from terminal
move t1,tf ;put it where it belongs
pop p,tf ;restore tf
popj p,> ;return, end of conditional
ife tops20,<
readcm: closeb
closeb
type( )
pjrst ttyin>
ifn tops20,<
RDPROG: MOVE T,[PERCSB,,TEMCSB] ;[133] BLT IN COMMAND STATE BLOCK
BLT T,TEMCSB+.CMGJB ;[133]
HRRZI T,RDPRG3 ;[133] HACK A COUPLE WORDS IN THE BLOCK
HRRZM T,TEMCSB ;[133]
MOVE T,[POINT 7,[ASCIZ /Program name: /]] ;[133]
MOVEM T,TEMCSB+2 ;[133]
RDPRG2: HRRZI TF,TEMCSB ;[133] INITIALIZE LINE, PROMPT
HRRZI T1,FUNINI ;[133]
COMND% ;[133]
RDPRG3: HRRZI TF,TEMCSB ;[133] READ IN PROGRAM NAME
HRRZI T1,FUNPRG ;[133]
COMND% ;[133]
ERJMP CMDER2 ;[133] ERROR, GO SAY WHY
TLNN TF,(CM%EOC) ;[133]
JRST RDPRG3 ;[133]
HRROI TF,PARBUF ;[133] DO RESCAN SO TTYIN CAN NOW
RSCAN% ;[133] READ BUFFER
HALTF% ;[133]
SETZ TF, ;[133]
RSCAN% ;[133]
HALTF% ;[133]
JRST TTYIN ;[133]
CMDER2: HRROI TF,[ASCIZ /?FDTJSE /] ;[133] ERROR READING PROGRAM NAME
PSOUT% ;[133]
MOVEI TF,.PRIOU ;[133]
HRLOI T1,.FHSLF ;[133]
SETZ 3, ;[133]
ERSTR% ;[133]
JFCL ;[133]
JFCL ;[133]
JRST RDPRG2 ;[133]
readcm: push p,tf
push p,r
kparse: move t,[percsb,,temcsb]
blt t,temcsb+.cmgjb
repars: hrrzi tf,temcsb
hrrzi r,funini
comnd%
lparse: hrrzi tf,temcsb
hrrzi r,funkey
comnd%
erjmp cmderr ;[114] error, go say why
tlne tf,(cm%nop)
jrst cmderr ;[114] error, go say why
tlne tf,(cm%eoc)
jrst cgo
hrrzi tf,lparse
hrrzm tf,temcsb
cloop: hrrzi tf,temcsb
hrrzi r,fungar
comnd%
erjmp cmderr ;[114] error, go say why
tlnn tf,(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,W1 ;[140]USE W1 AS SCRATCH AC
PUSH P,W2 ;[140]USE W2 AS SCRATCH AC
MOVE W1,[POINT 7,PARBUF] ;[140]INITIALIZE BYTE POINTER TO PARBUF
MOVEM W1,TXTIN
MOVE W1,[POINT 7,NEWBUF] ;[140]INITIALIZE BYTE POINTER TO NEWBUF
MOVEM W1,TXTOUT
LOOKSP: ILDB W1,TXTIN ;[140]GET A CHAR FROM COMMAND LINE
CAIN W1,12 ;[140]TEST FOR LINE FEED
JRST DORSCN ;[140]DO THE RSCAN WITH EXISTING BUFFER(PARBUF)
CAIN W1,14 ;[140]TEST FOR FORM FEED
JRST DORSCN ;[140]DO THE RSCAN WITH EXISTING BUFFER(PARBUF)
CAIN W1," " ;[140]TEST FOR A SPACE
JRST SPFND ;[140]SPACE FOUND
IDPB W1,TXTOUT ;[140]NOT A SPACE, WRITE CHAR TO NEW BUFFER
JRST LOOKSP ;[140]CONTINUE TRANSFER OF CHARS
SPFND: ILDB W1,TXTIN ;[140]GET A CHARACTER
CAIN W1," " ;[140]TEST FOR A SPACE
JRST SPFND ;[140]SPACE FOUND, IGNORE
CAIN W1,11 ;[140]TEST FOR A TAB
JRST SPFND ;[140]TAB FOUND, IGNORE
CAIN W1,15 ;[140]TEST FOR CARRIAGE RETURN
JRST CLRSC3 ;[140]FOUND, WRITE IT AND LF
CAIN W1,12 ;[140]TEST FOR LINE FEED
JRST CLRSCN ;[140]FOUND, SET UP CALL TO RSCAN WITH NEWBUF
CAIN W1,14 ;[140]TEST FOR FORM FEED
JRST CLRSCN ;[140]FOUND, SET UP CALL TO RSCAN WITH NEWBUF
CAIN W1,"!" ;[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 W2," " ;[140]BUT FIRST, WRITE A SPACE
IDPB W2,TXTOUT ;[140] TO SEPARATE COMMAND FROM ARG
TRANSF: IDPB W1,TXTOUT ;[140]NOW WRITE FIRST CHAR OF ARG OUT
ILDB W1,TXTIN ;[140]GET NEXT CHAR OF COMMAND LINE
CAIN W1,12 ;[140]TEST FOR LINE FEED
JRST LFORFF ;[140]FOUND, STORE LF OR FF IN NEW BUFFER
CAIE W1,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 W1,TXTOUT ;[140]STORE LF OR FF IN NEW BUFFER
JRST CLRSC2 ;[140]SET UP CALL TO RSCAN WITH NEW BUFFER
FLUSHC: ILDB W1,TXTIN ;[140]GET FIRST CHAR OF COMMENT
CAIN W1,12 ;[140]TEST FOR LINE FEED
JRST CLRSCN ;[140]FOUND,SET UP CALL TO RSCAN WITH NEWBUF
CAIN W1,14 ;[140]TEST FOR FORM FEED
JRST CLRSCN ;[140]FOUND,SET UP CALL TO RSCAN WITH NEWBUF
CAIN W1,"!" ;[140]TEST FOR END OF COMMENT
JRST SPFND ;[140]FOUND, GET NEXT CHARACTER
JRST FLUSHC ;[140]CONTINUE SKIPPING OVER COMMENT
CLRSC3: IDPB W1,TXTOUT ;[140]WRITE OUT CR
MOVEI W1,12 ;[140]GET SET TO WRITE OUT LF TO NEWBUF
CLRSCN: IDPB W1,TXTOUT ;[140]WRITE OUT LINE FEED TO NEWBUF(NEW BUFFER)
CLRSC2: MOVEI W1,0 ;[140]WRITE OUT NULL BYTE TO NEW BUFFER
IDPB W1,TXTOUT
MOVE W1,[XWD NEWBUF,PARBUF] ;[140]TRANSFER (NEWBUF) TO (PARBUF)
BLT W1,PARBUF+^D19 ;[140] FOR FORDDT'S PARSING MECHANISM
DORSCN: HRROI 1,PARBUF ;[140]SET UP PTR TO DO RSCAN
POP P,W2 ;[140]RESTORE W2
POP P,W1 ;[140]RESTORE W1
rscan%
haltf%
setz tf,
rscan%
haltf%
pop p,r
pop p,tf
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 T
; RETURN SYMBOL VALUE IN T
; IN ALL CASES T1=USERS LAST CHARACTER
;
; ADDITIONALY ENTER AT SIXIN TO ACCEPT LEFT JUSTIFIED SIXBIT
; IF USERS LEADING CHARACTER IS ALPHA
SIXIN: TRO TF,ALPHA ;THIS MODIFIES EITHER
EITHER: SETOM TERMK
CLEARM SYL
CLEARM DEN
TDZ F,[XWD FPF!FEF!MF!SIGN!OCTF,POWF] ;REMOVE THE UNWANTED FLAGS
EITHR2: XCT GETCHR ;READ USER INPUT
CAIE T1," " ;TILL NO BLANKS
CAIN T1,11 ;OR TABS
JRST EITHR2
PUSHJ P,GETSK2 ;TEST FOR DELIMITER
JUMPE T1,BADSYN
CAIL T1,"A"+40 ;ACCEPT LOWER CASE
CAILE T1,"Z"+40 ;CHARACTERS
JRST .+2 ;IS NOT
TRC T1,40 ;IS - CONVERT TO UPPER CASE
CAIL T1,"A"
CAILE T1,"Z"
;**** NUMERIC INPUT ****
JRST [TRZ TF,ALPHA ;NO LONGER NEEDED
XCT GETNUM ;CLEAR FLAGS
PUSHJ P,EITHR3 ;MUST BE A CONSTANT
JRST EITHR4] ;NON SKIP RETURN
TRZE TF,ALPHA ;ARE WE TRAPPING ALPHA
JRST SIXIN2 ;YES
;**** SYMBOLIC INPUT ****
;SIMULATE A CALL OF SYMIN
RECURS <DIMTOT,F,PUTTER,RP,SAVLOC,SYM,MATHSM,TEM,TEM1,DIMCNT,RAY.,FRMSAV>
TRZ F,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 SIXBIT TO RADIX 50
; CALL PUSHJ P,SIX250 WITH 6BT IN T2
; RETURNS HERE WITH RAD 50 IN T3
; N.B. USES: T1/T2/T3/T4/T5
SIX250: MOVE T1,[POINT 6,T2] ;SET UP BYTE POINTER FOR 6BT
SETZI T3, ;CLEAR FOR RAD 50
MOVEI T5,50 ;SET UP TO FORM RADIX 50
SIXMOR: ILDB T4,T1 ;GET NEXT 6BT BYTE
JUMPE T4,CPOPJ ;EXIT IF ZERO=LAST BYTE
CAIL T4,20 ;ACCEPT NUMERALS
CAILE T4,31 ;
JRST LETR ;NOT NUMERIC MAY BE ALPHA
SUBI T4,17 ;CONVERT TO RAD 50
JRST R50CHR ;STORE
LETR: CAIL T4,41 ;IS IT ALPHA
CAILE T4,72 ;
JRST BADSYN ;CANT CONVERT
SUBI T4,41-13 ;MAKE RAD 50
R50CHR: IMULI T3,(T5) ;MOVE UP LAST ENTRY
ADDI T3,(T4) ;UP DATE WITH NEW CHARACTER
TLNE T1,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 T2 TO RAD 50 IN T3
VALID: MOVE T1,[POINT 6,T2] ;GET FIRST CHARACTER
ILDB T3,T1 ; IN T3
CAIL T3,41 ;
CAILE T3,72 ;ALPHA ONLY
JRST ERR5 ; NOT F40
PJRST SIX250
; SUBROUTINE TO CHECK THAT ALL 6BIT CHARACTERS IN T2 ARE NUMERIC
; CALL PUSHJ P,ALLNUM
; NOT ALL NUMERIC
; ALL NUMERIC WITH P APPENDED IF A LABEL OR # IF SOURCE LINE
ALLNUM: MOVE T3,[POINT 6,T2] ;GET POINTER TO INPUT
ALLMOR: ILDB T1,T3 ;GET NEXT 6BIT CHAR
JUMPE T1,ALLEX ;ALL DONE
CAIL T1,20 ;TEST WITHIN RANGE
CAILE T1,31 ; OF NUMERALS 6BT
JRST ALLIN ;NO - SEE IF WE HAVE A SOURCE LINE
TLNE T3,770000 ;ALL 6 CHARS NUMERIC??????
JRST ALLMOR ; NO - SO DO MORE
JRST BADSYN ; YES - OO NASTY
ALLIN: TLZE F,LABEL ;ARE WE ALREADY PROCESSING LABEL INFO.
JRST BADSYN ;YES - ANOTHER # MUST BE REJECTED
MOVEI T1,"#" ;SEE IF THE USER IS TRYING TO GIVE LINE#
CAME T1,LSTCHR ;WAS A # HIS LAST CHARACTER
JRST CPOPJ ;NO USEFUL CHARACTERS TYPED - MAYBE GROUP#
JRST BADSYN ;YES - COMPLAIN ABOUT PRECEDING GARBAGE
ALLEX: TLZN F,LABEL ;ARE WE PROCESSING SOURCE LINES
JRST ALLFRM ;NO - SEE IF A FORMAT
MOVEI T1,'L' ;YES - GET THE SOURCE LINE TAG
DPB T1,T3 ;CONVERT TO THE FORM FORTRAN RECOGNISES
JRST CPOPJ1 ;EXIT AS ALL NUMERIC FROM USER
ALLFRM: MOVEI T1,'P' ;SET UP FOR A LABEL
DPB T1,T3 ;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 T=VALUE OF SYMBOL
; T1=LAST CHARACTER
; SUBFLG IS SET IF ARRAY NAME ONLY FOUND
SYMIN: TLZ F,LABEL ;CLEAR LABEL PROCESSING FLAG
SETZM MATHSM ;CLEAR SYMBOL SAVE
PUSHJ P,TTYIN ;GET USER SYMBOL
JUMPN T2,SYM12 ;NO CHARACTERS - MAYBE SOURCE LINE OR GROUP SPEC.
CAIE T1,"#" ;IS THE USER ATTEMPTING TO SPECIFY A SOURCE LINE
JRST SYM4 ;NO! - WELL MAYBE A GROUP REQUEST
TLO F,LABEL ;REMEMBER THIS IS A SOURCE LINE REQUEST
PUSHJ P,TTYIN ;GET USERS NEXT INFO.
JUMPE T2,BADSYN ;ZERO CHARACTERS HERE IS BAD
SYM12: PUSHJ P,ALLNUM ;SEE IF USER TYPED ALL NUMERIC
JRST SYM2 ;NO - MUST BE A VARIABLE
MOVE T1,LSTCHR ;REINSTATE USERS LAST CHAR
CAIE T1,"," ;SEE IF A KNOWN DELIMITER FOLLOWS
JUMPN T1,BADSYN ;ANY OTHER CHARACTER IS ILLEGAL
PUSHJ P,SIX250 ;CONVERT SYMBOL TO RADIX 50
TLOA F,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
MOVEM T3,SYM ;EVAL NEEDS IT HERE
MOVEM T3,MATHSM ;SAVE FOR LOOK
TRZE TF,DCEVAL ; ? CALL EVAL
POPJ P, ;NO DON'T
PUSHJ P,EVAL ;'EVAL'UATE THE SYMBOL NAME
POPJ P, ;SYMBOL NOT FOUND
MOVEM W1,CRYSYM ;[157]Save addr/RAD50 name
MOVEM T,SAVLOC ;SAVE THE VALUE OF THE SYMBOL
TLNE F,LABEL ;DID WE HAVE A LABEL?
JRST SYM3 ;YES - GO PROCESS
CLEARM SUBSCR ;ZERO THE OFFSET
PUSHJ P,RAYNAM ;DO WE KNOW ABOUT THIS ARRAY
CAIA ;NOT DEFINED
TRO TF,IMPRNG!ARRAY.;FLAG AS A POSSIBLE RANGE CONDITION
MOVE T1,LSTCHR ;GET BACK LAST CHAR SEEN
SYM7: JUMPE T1,SYM3 ;SEE IF WE HAD A LEGAL DELIMITER
CAIE T1,"[" ;[ MEANS WE HAVE AN ARRAY DEFINITION TO FOLLOW
JRST SYM13 ;OBVIOUSLY NOT AN ARRAY DEFINITION
TLO F,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 T1,"(" ;THE ONLY OTHER ALLOWED CHARACTER IS (
JRST SYM6 ;CHECK FOR OTHER DELIMITERS
TRZ TF,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 T,1 ; WE GET AN ARRAY DEFINITION
MOVEM T,RP
PUSHJ P,RAYNAM ;HAS THIS SYMBOL AN ARRAY REFERENCE?
TRZA F,SUBFLG ;CLEAR THE SUBSCRIPT FLAG
TRO F,SUBFLG ;YES - REMEMBER TO CHECK ITS SUBSCRIPTS
SYM10: PUSHJ P,EITHER ;GET EITHER SYMBOL OR # FROM USER
CAIA ;NUMERIC
MOVE T,(T) ;SYMBOL - GET VALUE
TRNE F,SUBFLG ;DO WE CHECK SUBSCRIPTS FOR THIS ARRAY
JRST SYM8 ; PROCESS SUBSCRIPTS
JUMPL T,.+2 ;AUTO CORRECTION ON -VE #
SUBI T,1 ;CORRECT FOR A=A(1)
; NO MORE SUBSCRIPTS - CHECK DELIMITERS
SYM9: MOVEM T,SUBSCR ;SAVE THE NEW OFFSET, WATCH ILL MEM REFS
CAIE T1,")" ;RIGHT PARENS MUST DELIMIT THE NO.
JRST BADSYN ; THIS WONT DO EITHER!
TRZE F,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
SYM6: JUMPE T1,SYM3 ;DELIMITER IS GOOD
CAIE T1,"," ;WE ALLOW COMMA OR MINUS AT THIS STAGE
CAIN T1,"-" ;
JRST SYM3 ;ACCEPT DELIMITER
CAIE T1,"." ;DOT IS ALLOWED FOR .LT. IN IF'S
CAIN T1,"=" ;= IS ALLOWED FOR ACCEPT (INLINE)
JRST SYM3
CAIE T1,"]" ;] IS A DELIMITER FOR [A(1)]
CAIN T1,")" ;) IS A DELIMITER FOR SUBSCRIPTS
JRST SYM3 ;
CAIE T1,"/" ; / IS A DELIMITER FOR DIMENSIONS
CAIN T1,":" ; EQUIV TO "/"
CAIA
JRST BADSYN ;ALL ELSE LOOSES
TRNE F,SUBFLG!SURGFL ;IF HANDLING SUBSCRIPTS
JRST SYM3 ;YES
;NO - THEN THE / SHOULD MEAN A PRINT MODIFIER
TRZE TF,ACCPT ;UNLESS AN ACCEPT IS IN PROGRESS
JRST SYM3 ;TEST FOR AN IMPLIED RANGE
MOVS TMOD,TMOD ;PREPARE TO RECIEVE FLAGS IN RH
PUSHJ P,OPTION ;GET THE PRINT MODIFIERS
JRST BADSYN ;NUMERICS ????
MOVS TMOD,TMOD ;RESET AS LOCALS,,DEFAULT
JRST SYM3 ;
; TIDY UP BEFORE EXIT
SYM3: MOVE T,SAVLOC ;GET THE SYMBOL VALUE
TRZE F,FORMAL ;WAS THE BASE A FORMAL ARRAY PARAMETER
;[BL] Character arrays will never be FORMALS /ahm/
SKIPE T,FRMSAV ;YES - START AT THE FORMAL ADDRESS
CAIA
JRST ERR38 ;UNLESS IT'S ZERO
MOVE T1,LSTCHR ;RESTORE USERS LAST CHARACTER
TLZE F,LABEL ;SKIP IF SYMBOL+SUBSCRIP TO PROCESS
JRST CPOPJ1 ;STATEMENT EXIT
ADD T,SUBSCR ;CORRECT SYMBOL VALUE TO WHAT USER ASKED FOR
TRZE F,DOUBLE ;[112] IS THIS A DOUBLE WORD ARRAY
ADD T,SUBSCR ;YES - SO GIVE HIM DOUBLE
TRNN F,CHARS ;[157]Character string?
JRST CPOPJ2 ;[157]NO
MOVE T,SAVLOC ;[157]T has been munged
MOVE T2,SUBSCR ;[157]Get offset
MOVEM T2,CLMOFF ;[157]Save for OFFSET
JRST CPOPJ2 ;AND LET HIM HAVE IT!
; HERE TO HANDLE ARRAY SUBSCRIPTS
SYM8: MOVEM T,ODF ;SAVE TEMPORARILY
PUSHJ P,GETDIM ;GET RANGE OF CURRENT DIMENSION
MOVE T,ODF ;PREPARE TO TEST UPPER SUBSCRIPT LIMIT
SUB T,TEM1 ;IF IN RANGE - SHOULD BE NEGATIVE
JUMPG T,ERR23 ;IF NOT COMPLAIN - SUBSCRIPT ERROR
MOVE T,ODF ;GET USERS SUBSCRIPT VALUE
SUB T,TEM ;REMOVE OFFSET
JUMPL T,ERR23 ; SHOULD BE POSITIVE AFTER REMOVING OFFSET
IMUL T,RP ;INCREASE BY CURRENT RANGE PRODUCT
ADDB T,DIMTOT ;STORE TOTAL ELEMENT COUNT
MOVE T1,LSTCHR ; AND LAST USER CHARACTER
CAIE T1,"," ;MORE SUBSCRIPTS?
JRST SYM9 ;NO - RETURN TO NORMAL PROCESSING
MOVE ODF,TEM1 ;PREPARE TO UPDATE
SUB ODF,TEM ; RANGE PRODUCT
AOJ ODF, ; WITH NEW RANGE
IMULM ODF,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 TMOD(RH)=PRINT OPTIONS T1=USERS LAST CHAR.
OPTION: TRO TMOD,ANYMOD ;FLAG FIRST TIME THROUGH THIS SCAN
OPTN2: PUSHJ P,SIXIN ;ACCEPT SIXBIT
POPJ P, ;NON SKIP RETURN WITH NUMERIC IN T
JUMPE T2,BADSYN ;NO CHARACTERS
TRZE TMOD,ANYMOD ;FIRST MODIFIER?
HLLZ TMOD,TMOD ;CLEAR FOR NEW MODIFIERS
LDB T2,[POINT 6,T2,5] ;GET THE FIRST CHARACTER OF THE SWITCH
CAIN T2,'A' ;ASCII?
TRO TMOD,A.!ANYMOD ;
CAIN T2,'O' ;OCTAL
TRO TMOD,O.!ANYMOD ;
CAIN T2,'R' ;RASCII
TRO TMOD,R.!ANYMOD ;
CAIN T2,'S' ;SOURCE LINE TRACE OPTION?
TRO TMOD,S.!ANYMOD ;
CAIN T2,'C' ;[157][164]Character string?
TRO TMOD,C.!ANYMOD ;[157][164]
TRZ TMOD,B. ;[120] IGNORE /BIG FOR THE REST
CAIN T2,'X' ;[157]COMPLEX?
TRO TMOD,X.!ANYMOD ;[157]
CAIN T2,'D' ;DOUBLE
TRO TMOD,D.!ANYMOD ;
CAIN T2,'F' ;FLOATING
TRO TMOD,F.!ANYMOD ;
CAIN T2,'I' ;INTEGER
TRO TMOD,I.!ANYMOD ;
CAIN T2,'L' ;[120] LOGICAL
TRO TMOD,L.!ANYMOD ;[120]
CAIN T2,'B' ;[120] 'BIG' ?
TRO TMOD,B.!ANYMOD ;[120] 'BIG' OPTION
CAIN T2,'E' ;TRACE ENTRIES OPTION
TRO TMOD,E.!ANYMOD ;
TRZN TMOD,ANYMOD ;ANY MODIFIERS SEE - NO MEANS:
JRST BADSYN ;NO KNOWN MODIFIER
JUMPE T1,OPTN3 ;END OF OPTIONS FLAGS IN T
CAIN T1,"," ;ALSO END OF OPTIONS DELIMITER
JRST OPTN3 ;SKIP RETURN
CAIE T1,"/" ;MORE MODIFIERS ?
JRST BADSYN ;NO - NO OTHER MODIFIERS ALLOWED
PJRST OPTN2 ;GET MORE
OPTN3: TRNN TMOD,C.!A.!X.!D.!F.!I.!O.!R.!L.
;[120] [157][164]ANY PRINT MODIFIERS SET UP?
TRO TMOD,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 W1
; 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 S T,W1
TRZ TF,GUDLBL ;CLEAR THE GOOD LABEL FLAG
MOVE T,(W1) ;GET THE SYMBOL
CAIG T,50 ;SINGLE CHARACTER CAN NOT BE A LABEL
POPJ P, ;RESTORE T,W1
TLZ T,PNAME ;SYMBOL NAME ONLY
IDIVI T,50 ;GET LAST CHARACTER
MOVEM W1,TRULST ;SAVE FOR LATER
TRU3: JUMPE T,TRU6 ;ALL CHARACTERS SEPERATED IF T=0
IDIVI T,50 ;GET NEXT CHAR.
CAIL W1,1 ;IS THIS CHARACTER
CAILE W1,12 ; NUMERIC?
POPJ P, ; NO - LABEL NOT VALID
JRST TRU3 ;YES - GET NEXT CHARACTER
TRU6: TRO TF,GUDLBL ;FLAG A GOOD LABEL SO FAR
MOVE W1,TRULST ;GET BACK LAST CHARACTER
CAIE W1,26 ;WAS THE LAST CHARACTER AN 'L'
CAIN W1,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 W1
; CALL PUSHJ P,TRUVAR
; RETURN1 NOT A GOOD VARIABLE
; RETURN2 STANDARD F10 VARIABLE
TRUVAR: PUSHJ P,SAV2AC ;SAVE ACS W1,T
MOVE T,(R) ;GET THE SYMBOL
TLZ T,PNAME ;SYMBOL NAME ONLY
IDIVI T,50 ;GET THE FIRST CHARACTER
MOVEM T+1,TRUFST ;SAVE IT
JRST TRUV2
TRUV1: JUMPE T,TRUV3 ;LOOKED AT ALL CHARACTERS OF SYMBOL?
IDIVI T,50 ;NO - GET NEXT CHARACTER
TRUV2: CAIGE W1,1 ;ENSURE WE HAVE ONLY NUMERIC OR
CAIG T,44 ; ALPH CHARS
JRST TRUV1 ;OK SO FAR
POPJ P, ;BAD CHARACTER FOR VARIABLE
TRUV3: CAIL W1,13 ;CHECK THAT THIS FIRST CHARACTER OF
AOS -3(P) ; THE SYMBOL IS ALPHA
POPJ P, ;OTHERWISE JUST NON SKIP RETURN
; ROUTINE TO DISPLAY ASCII TEXT AS '.....'
; ENTER WITH EACH CHARACTER IN T
ASCOUT: JUMPE T,ASCNUL ;HAVE WE A NULL?
CAIN T,177 ;DELETE IS SPECIAL
JRST ASCDEL ;TYPE <DEL>
CAIL T,173 ;MAYBE AN ESCAPE CHARACTER
JRST ASCAPE ;YES
CAIL T,40 ;LESS THAN 40 = CONTROL CHARACTER
IFN TOPS20,< ;[151]
JRST ASCASC ;[151] NEVER FLAG IF RUNNING UNDER TOPS20
>;END IFN TOPS20 ;[151]
IFE TOPS20,< ;[151]
JRST ASCUP ;PERHAPS LOWER CASE?
>;END IFE TOPS20 ;[151]
type(^)
ADDI T,100 ;MAKE ASCII
ASCASC: putchr (T) ;TYPE AS ASCII
POPJ P, ;DONE
IFE TOPS20,< ;[151]
ASCUP: SKIPE TTYLC ;[151] IF TTY LC IS ON, DON'T FLAG
CAIG T,140 ;LOWER CASE?
JRST ASCASC ;JUST GOOD OLD ASCII
type(')
JRST ASCASC ;TYPE AS ASCII
>;END IFE TOPS20 ;[151]
ASCNUL: type(<<NUL>>)
POPJ P,
ASCDEL: type(<<DEL>>)
POPJ P,
ASCAPE: openb
PUSH P,W1 ;SAVE AROUND OCTAL PRINT
PUSHJ P,TYP4 ;TYPE OCTAL
POP P,W1 ;RESTORE REMAINDER OF OUTPUT
closeb
POPJ P,
; ROUTINE TO ACCEPT THE MAIN PROGRAM NAME FROM USER
; SIX CHARACTERS ONLY
; CALL PUSHJ P,GETPRG
; RETURN1 NEVER
; RETURN2 RADIX 50 PROGRAM NAME IN T
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 T2 ;?IS THERE A SYMBOL
JRST BADPRG ;[133] NO - ERROR
PUSHJ P,VALID ;CHECK FOR BEGINNING LETTER AND CONVERT
;TO RADIX 50
MOVEM T3,SYM ;FOR FNDSYM
;[155] TLO F,FPRNM ;FIND PROGRAM NAME
TLO F,FGLSNM ;[155]FIND GLOBAL SYMBOL
PUSHJ P,FNDSYM
JRST [PUSHJ P,DISP9 ;NOT THERE
PUSHJ P,CLRLIN ;[133] GET RID OF ANY JUNK
JRST GETPRG] ;TRY AGAIN
HLRZ T1,(T) ;WHERE IS THE USER ATTEMPTING TO START
CAIE T1,(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
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 T1,T2 ;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 T,SYM ;SET UP FOR RADIX 50 PRINT
PUSHJ P,SPT1 ;RADIX 50 PRINT
TRNN F,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 T,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 W1,SYM
PUSHJ P,SPT
TYPE (< is not a format statement>)
POPJ P,
ERR17: TYPE (<?FDTNSP >)
MOVE T,SYM
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)
JRST DIM1 ;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 DIM1 ;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 T,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 T,SYM ;DISPLAY BASE SYMBOL
PUSHJ P,SPT1 ;DISPLAY SYMBOL
AOS T,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 T,SYM ;GET THE ARRAY NAME
PUSHJ P,SPT1 ;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 W1,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
; 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
E9: TYPE (?FDTIER Internal FORDDT error - 9)
JRST RET
;COMMAND ERRORS
ERROR: type(?FDTURC Unrecognized command )
MOVE T1,T2 ;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 T1,T2 ;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 /
/
SUBTTL VARIABLE STORAGE
NMBFSZ==^D12 ;[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
SAVHSM: BLOCK 1 ;C(.JBHSM), USED BY EVAL, LOOK
ESCAPE: -1 ;NON ZERO MEANS NO ^C IN EFFECT SO ESCAPE ALLOWED
REENTR: 0 ;NON-ZERO IF REENTER HAS BEEN DONE
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,< ;[151]
TTYLC: BLOCK 1 ;[151] RETURNED BY .TOLCT TRMOP. LOWERCASE SET/UNSET
>;END IFE TOPS20 ;[151]
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
MATHSM: BLOCK 1 ;USED BY "LOOK" TO RESOLVE MULTIPLE DEF
SYM: BLOCK 1
SYMASK: BLOCK 1 ;MASK FOR SYM TBL SYMBOL (FOR FNDSYM, WITH FGLSNM)
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 T3
PRGNAM: BLOCK 2 ;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
STPCNT: BLOCK 1 ;STEP COUNT - HOW MANY LINES TO TRACE
OPENED: SQUOZE 0,MAIN. ;HOLDS CURRENTLEY OPENED PROGRAM NAME
OPENLS: BLOCK 1 ;HOLDS SUB-SET OF JBSYM FOR OPENED PROGRAM
OLDOPN: BLOCK 1 ;PROG THAT WAS OPEN BEFORE GROUP REQUEST
GOLOC: BLOCK 1 ;HOLDS E.T.V. TO EXTERNAL ROUTINES
SUBSCR: BLOCK 1 ;HOLDS ARRAY SUBSCRIPT VALUE
COUNT: BLOCK 1
JOBOPC: BLOCK 1 ;HOLDS .JBOPC IF WE ARE IN A RE-ENTER
PNAMSV: BLOCK 1 ;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
BLOCK 3 ;[145] FOR BREAKPOINT ZERO
B1ADR: BLOCK 1
B1SKP: BLOCK 1
B1CNT: BLOCK 1
BLOCK NBP*3-3
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 17 ;[147]
AC17: BLOCK 1
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 ;TEMP STORAGE FOR VALUE IN LOKSYM
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 ;PUSH DOWN LIST
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,<
pagwrn: -1 ;flag for page warning message in dep4
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
IFN DEBUG <
PATCH: BLOCK 50 ;PATCHING SPACE
>
IF2,<
PURGE ERJMP,JRSTF,RESET,SAVE,XMOVEI
>
;IFE DEBUG <XPUNGE> ;DELETE SYMBOLS
DDTEND: END SFDDT