Trailing-Edge
-
PDP-10 Archives
-
BB-D480F-BB_1985_short
-
formsc.mac
There are 19 other files named formsc.mac in the archive. Click here to see a list.
SEARCH MTHPRM,FORPRM
TV FORMSC Miscellaneous routines ,10(4207)
SUBTTL Sue Godsell/SRM/EDS/EGM/CDM/AHM/RVM/PLB/MRB 29-Mar-85
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1977, 1985
;ALL RIGHTS RESERVED.
;
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
;ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
;INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
;COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
;OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
;TRANSFERRED.
;
;THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
;AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
;CORPORATION.
;
;DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
;SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
COMMENT \
***** Begin Revision History *****
***** Begin Version 6 *****
1100 SWG 15-Aug-75
CLEANUP FOR V6 - REMOVE ALL F40, KA THINGS. JSYSIZE
THOSE ROUTINES WHICH DO MONITOR CALLS: TIME,TIM2G0,DATE
SSWTCH
REMOVE .MXFOR AND FORX40;TAKE KA CONDITIONALS OUT OF UNIVERSAL;
REMOVE UNNECESSARY AC DEFS FROM FLOAT. AND IFIX.
Add OUTSTR macro for TOPS-20 IN FDDT.
1175 JLC 12-Dec-80
Fixed LSNGET routine, did not like nulls in line number
and did not clear digit AC, always returned error (-1).
1256 DAW 5-FEB-81
Use new calling sequence for FOROP.
1260 DAW 6-Feb-81
LSNGET smashed ACs 2 and 3.
1266 DAW 11-Feb-81
Changes to support extended addressing in DUMP & PDUMP, TIME,
and DATE routines.
1300 DAW 24-Feb-81
Get FIN. calls and IOLISTS correct again in DUMP and PDUMP.
1302 JLC 24-Feb-81
Changed LSNGET to have channel # as arg.
1335 EDS 12-Mar-81 Q10-05759
Use symbols when testing output of ODCNV% jsys in TIME.
Make TIME return the arguments correctly.
1342 EDS 13-Mar-81 Q10-05075
Make routines TRACEable change everything to HELLO macros.
Fix TWOSEG and RELOC problems. Clean up TITLEs.
1351 EDS 16-Mar-81 Q10-04786
Fix TWOSEG and RELOC problems.
1372 EGM 30-Mar-81 ________
Make OVERFL compatible with 5A, and eliminate TIME JSYS conflict.
1425 BL 14-Apr-81 Q10-05076
Make OVERFL functionality include 'logical function'.
Returns T0=0 if OVERFLOW=NO, T0=-1 if OVERLFOW=YES.
Original functionality unchanged.
1464 DAW 12-May-81
Error messages.
1500 DAW 27-May-81
Edit 1464 made it get "E" error.
1517 BL 18-Jun-81 Q10-05075
Use HELLO macro at CLRDIV (FORMSC).
1532 DAW 14-Jul-81
OPEN rewrite: Base level 1
1560 DAW 28-Jul-81
OPEN rewrite: Base level 2
1615 DAW 19-Aug-81
Get rid of 2-word BP option.
1656 DAW 2-Sep-81
Get rid of magic numbers.
1720 JLC 16-Sep-81
Added test in DIVERT to make sure unit is open for FORMATTED I/O.
1747 DAW 28-Sep-81
Got rid of FORPRM dependency in DIVERT.
1767 DAW 8-Oct-81
Explain "magic" numbers in OVERFL.
2020 DAW 21-Oct-81
Change DATE to return SPACE as last character instead of NULL,
so it will match a literal generated by the compiler.
***** Begin Version 6A *****
2077 RJD 31-Aug-82
In OVERFL, index OLDCT for a correct comparison between the tables
containing the current APR counts and the old counts.
2103 MRB 13-Sep-82 20-18016
Time function will return incorrect results for european time
zones. Use the TOPS-20 JSYS ODTIM to get correct time.
***** Begin Version 7 *****
3000 CDM 19-Oct-81
Added character routines ADJC1., ADJCG.
3001 AHM 2-Oct-81
Make ADJ1. and ADJG. work under extended addressing. Also,
redefine array dimension field from 777B8 to 177B8 so that array
bounds checking blocks in section 0 will hopefully look more
like the final version to be redefined for extended addressing.
Finally, create a PROTA. entry point which is the same as PROAR.
for now to match the symbol that FORTRA 7(1250) requests.
3025 AHM 18-Nov-81
Fix a bug in the trailing space edit to DATE (2020) that I introduced
when merging it into the V7 sources, and change two MOVEIs to XMOVEIs
for extended addressing support for good measure.
3052 AHM 1-Mar-82
Make PROAR. work for extended addressing by widening the flag
field in the dimension block to the upper 4 bits. Delete
PROTA. entry point since it is not needed for extended
addressing after all.
3066 RVM 27-Mar-82
Fix ADJ1., ADJG., ADJC1., and ADJCG. to not calculate the size
of assumed-size arrays.
3073 JLC 31-Mar-82
Remove RELEAS routine; it was for F40.
3122 JLC 28-May-82
Segment FORMSC. Changed LERRs to $FCALLs, and move error msgs
to a separate module FORMSL in FORMSC.
3124 AHM 6-Jun-82
Added a SEGMENT macro to FDDT so that everything goes into
.CODE. and .DATA. under FTXLIB. Also, preserve T1 around the
PSOUT for "%FORDDT not loaded" under Tops-20.
3125 JLC 3-Jun-82
Moved the error character to the beginning of the error macro
calls.
3131 JLC 11-Jun-82
Allow character string argument for ERRSNS error string return.
3132 CKS 11-Jun-82
Add PROSB. to do substring bounds checking.
3140 JLC 2-Jul-82
Fix ERRSET so that -1 for error number gets the entire table
instead of just the V6-defined traps.
3141 JLC 2-Jul-82
Install FFUNIT.
3142 AHM 3-Jul-82
Install PRGEND in FFUNIT.
3161 JLC 16-Aug-82
Fixed ERRSNS for extended addressing multi-sections.
3165 JLC 28-Aug-82
Separate bounds check errors from others.
3205 AHM 18-Nov-82
Insert error message texts for TMA, CGP, CRP, NSS, CFS, CGS.
Change VDM and ICF to "Should not happen" errors. Reword AQS.
3206 CDM 5-Nov-82/17-Jan-83
Allow character arguments for DATE and TIME.
3257 AHM 14-Jan-83
Fix DUMP and PDUMP - FUNCT macro made OTSZERWRD I/O list
elements non-zero, FIN word was in wrong half of an I/O list,
change positional OUT. argument lists to keyword form, correct
change in carriage control semantics between V6 and V7.
***** End V7 Development *****
3311 AHM 21-Apr-83
The dummy FDDT module that resolves XCT FDDT.## requests from
/DEBUG:TRACE when FORDDT isn't loaded was in the hiseg instead
of the lowseg. Unfortunately, FDDT. contains self-modifying
code, and write-locking the high segment made it die.
3322 TGS 6-Jun-83 SPR:20-19252
Calling ERRSET with a subroutine argument not declared EXTERNAL
in the calling program unit jumps into an empty variable when
the user subroutine is called. Test for this case and ABORT if so.
3362 TGS 28-Oct-83 SPR:20-19293
New TOPMEM and SRTINI calls to set ENDP/STARTP to force memory
allocation from a user-supplied page number downward and, for
SRTINI, preallocate pages 600:677 for SORT. Insert new error
messages for IPN (Illegal page number) and CPP (Can't preallocate
pages) errors.
3405 TGS 24-Jan-84 SPR:20-19857
TIME subroutine will round minutes early (09:13 59.6 to 09:14 59.9
if called in a loop, for example.) Do not use ODTIM% to return
hours and minutes, since this JSYS uses a totally different algorithm
for rounding on minute boundaries.
3407 TGS 31-Jan-84 SPR:20-19929
QUIETX should suppress library routine error summaries as well as
CPU summaries. (FORMSC comment change only).
***** Begin Version 10 *****
4007 RJD 24-Mar-83
Eliminate extra PUSH and POP in OVLP.
4012 PLB 1-Jun-83
Fix ERRSET to work with user code and OTS in different sections.
4023 JLC 23-Jun-83
Search MTHPRM also.
4030 PLB 6-Jul-83
Fix OVERFL to remove AOBJN & BLT.
4044 JLC 19-Sep-83
Changed F.MED so it uses $N for the subroutine name, and
thus can be called by any subroutine.
4060 JLC 1-Nov-83
Removed EXTEND error messages, mistakenly placed (by me)
in FORMSL.
4065 JLC 6-Dec-83
Add subroutine PA1050 to allow PA1050 in core for V10
programs running on TOPS-20.
4074 RVM 28-Jan-84
Add the Mil. Spec/VAX FORTRAN bit manipulation functions.
4100 MRB 9-Feb-84
Added code to do compatibility flagging in FORLIB. Outputs
a warning message for usage of non compatible language features
like CALLing an external function.
4101 CDM 16-Feb-84
Create and expand the character stack differently when running
in extended addressing. Give the stack its own section(s) so
that it has plenty of room. Also add user subroutine ALCCHR.
4110 CDM 8-Mar-84
Reworked DUMP and PDUMP to work under extended addressing.
Changed how the AC's are stored to be dumped out (used to be
stored on the stack, with AC's being PUSH-ed and POP-ed
everywhere, even though this is a subroutine and doesn't need to
preserve any AC's). Corrected I/O calls to the ots to work in
non-zero sections. For now, not giving both upper and lower
bounds for dumping will give a warning message. Lots of
comments added. Grouped together argument lists to make them
look coherent. Changed "-" to "///" in format statements to
make then standard conforming (/FLAG will flag this).
4121 AHM 30-Apr-84
Made QUIETX use HELLO macro, since it is now user callable,
and supported.
Module: FORMSC
4130 MRB 6-Jun-84
Add check for compatibility flagger to routine FFUNIT.
4155 JLC 2-Oct-84
Moved %SVCNV, a routine to manipulate symbol table pointers,
to here so it can be accessed by FORDDT with OTS:SHARE, the
LINKing of sharable FOROTS, and OTS:NONSHARE.
Separate system-dependent code in %SVCNV.
4162 RVM 2-Nov-84
Define VAX FORTRAN INTEGER*2 and INTEGER*4 INTRINSIC function names.
4163 RVM 2-Nov-84
Define the undotted names of the bit functions.
4165 MRB 15-Nov-84
Change the equates for the undotted names to the dotted names
to equate 30 bit addresses instead of just 18 bit addresses.
4170 JLC 19-Nov-84
Fix FORSYM: put in a SEGMENT CODE so the code isn't obliterated
on TOPS-10.
4171 JLC 29-Nov-84
Fix some documentation in ERRSET.
4172 MRB 4-Dec-84
Fix-up some flagger stuff for the routines DATE, TIME, ERRSET,
ERRSNS.
4174 JLC 9-Jan-85
Fix %SVCNV for symbol tables up to 511 pages as IOWDs.
4206 CDM 29-Mar-85 QAR 853072
Fix ISHFTC to work correctly when rotate index is negative.
4207 CDM 29-Mar-85 QAR 853038
Add SECNDS function for VMS compatability.
***** End V10 Development *****
***** End Revision History *****
\
PRGEND
TITLE ADJ1.
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1972, 1985
;ALL RIGHTS RESERVED.
SEARCH MTHPRM,FORPRM
;AC ASSIGNMENTS
ARG==L ;ARG POINTER
TEMOFF==T0 ;HOLDS OFFSET COMPUTATION
;T1==1 ;HOLDS LOOP DOUNTER (DIMENSIONALITY)
;T2==2 ;HOLDS MULTIPLIER COMPUTED
TABREG==T3 ;HOLDS DESTROYED ARG POINTER
;THE FOLLOWING ALGORITHM IS IMPLEMENTED TO
;COMPUTE ARRAY FACTORS, OFFSET AND SIZE FOR THE
;SPECIAL CASE WHEN ALL LOWER BOUNDS ARE A
;CONSTANT 1 AND ALL DIMENSIONS ARE ADJUSTABLE.
;MULT(I) ARE MULTIPLIERS
;U(I) ARE UPPER BOUNDS (EQUIVALENT TO RANGE)
;OFFSET=MULT(1)
;ARRAYSIZ=MULT(1)
;DO 10 I=2,NUMBER OF DIMENSIONS-1
;ARRAYSIZ=ARRAYSIZ*U(I-1)
;MULT(I)=MULT(I-1)*U(I-1)
;OFFSET=OFFSET+MULT(I)
;10 CONTINUE
;OFFSET=-OFFSET+BASE ADDRESS OF ARRAY
;THE PARAMETERS PASSED ARE (INORDER):
;POINTER TO NUMBER OF DIMENSIONS
;POINTER TO TEMP FOR ARRAYSIZ
;BASE ADDRESS OF ARRAY
;POINTER TO TEMP FOR OFFSET
;MULT(1)
;U(1)
;MULT(2)
;U(2)
; .
; .
; .
;MULT(N)
;U(N)
;**NOTE THAT THE DOUBLE PRECISION/SINGLE PRECISION
;IS HANDLED BY PASSING A 2/1 AS MULT(1).
SEGMENT CODE
HELLO (ADJ1.)
PUSH P,T2 ;SAVE REGISTERS USED
PUSH P,TABREG ;
MOVE T1,@0(ARG) ;FETCH DIMENSIONALITY
MOVE TABREG,ARG ;COPY ARG REGISTER
MOVE TEMOFF,@4(ARG) ;GET OFFSET WITH MULT(1)
MOVE T2,TEMOFF ;GET MULT(1) WITH MULT(1)
MOVEM T2,@1(ARG) ;INITIALIZE ARRAYSIZ
LOOP1: SOJLE T1,LUPDUN ;QUIT IF DONE
MOVE T2,@5(TABREG) ;FETCH U(I-1)
IMULM T2,@1(ARG) ;MULTIPLY INTO ARRAYSIZ
IMUL T2,@4(TABREG) ;MULT BY MULT(I-1)
MOVEM T2,@6(TABREG) ;FORMING MULT(I)
ADD TEMOFF,T2 ;[3001] Keep (30 bit) sum of offset factors
ADDI TABREG,2 ;ADVANCE POINTER
JRST LOOP1 ;GO AROUND AGAIN
LUPDUN: MOVN TEMOFF,TEMOFF ;NEGATE OFFSET
XMOVEI T2,@2(ARG) ;[3001] Get 30 bit array base address
ADD TEMOFF,T2 ;[3001] Add it in
MOVEM TEMOFF,@3(ARG) ;STORE VALUE OF OFFSET
MOVE T2,@5(TABREG) ;FETCH U(I) FOR LAST ARRAYSIZE MULTIPLY
CAME T2,[1B0-1] ;[3066] Don't multiply for assumed-size array
IMULM T2,@1(ARG) ;MULTIPLY TO MEM IT IN
POP P,TABREG ;RESTORE REGISTERS
POP P,T2
GOODBY
PRGEND
TITLE ADJG.
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1972, 1985
;ALL RIGHTS RESERVED.
SEARCH MTHPRM,FORPRM
;AC ASSIGNMENTS
ARG==L ;ARGUMENT LIST
TEMOFF==T0 ;USED TO COMPUTE OFFSET
;T1==1 ;USED TO HOLD LOOP COUNT (DIMENSIONALITY)
;T2==2 ;USED TO HOLD MULTIPLIERS
TABREG==T3 ;USED TO HOLD DESTROYED ARG PTR
;THE FOLLOWING ALGORITHM IS IMPLEMENTED TO COMPUTE
;ARRAY FACTORS AND OFFSET AND SIZE FOR THE
;GENERAL CASE.
;A PARTIALLY COMPUTED OFFSET MAY BE INPUT
;THE ALGORITHM MAY START IN AN ARBITRARY PLACE AND MULT(1)
;MAY BE 1 (STARTING FROM SCRATCH) OR ANOTHER VALUE.
;THE ABILITY TO START ANYWHERE IS NECESSARY SINCE
;FACTOR AND OFFSET INFO MAY ALREADY HAVE BEEN
;COMPUTED FOR CONSTANT ARRAY BOUNDS APPEARING IN THE
;LIST FIRST.
;MULT(I) ARE THE FACTORS
;U(I) ARE THE UPPER BOUNDS
;L(I) ARE THE LOWER BOUNDS
;OFFSET=MULT(1)*L(1)
;ARRAYSIZ=MULT(1)
;DO 10 I=2,NUMBER OF DIMENSIONS-1
;TEMP=U(I-1)-L(I-1)+1
;MULT(I)=MULT(I-1)*TEMP
;OFFSET=OFFSET+MULT(I)
;ARRAYSIZ=ARRAYSIZ*TEMP
;10 CONTINUE
;OFFSET=-OFFSET+BASE ADDRESS OF ARRAY
;TEMP=U(I)-L(I)+1
;ARRAYSIZ=ARRAYSIZ*TEMP
;THE PARAMETERS ARE (IN ORDER OF APPEARANCE)
;POINTER TO NUMBER OF DIMENSIONS
;POINTER TO ARRAY SIZE
;BASE ADDRESS OF ARRAY
;POINTER TO TEMP CONTAINING OFFSET
;MULT(1)
;U(1)
;L(1)
;MULT(2)
;U(2)
;L(2)
; .
; .
; .
;MULT(N)
SEGMENT CODE
HELLO (ADJG.)
PUSH P,T2 ;SAVE REGISTERS USED
PUSH P,TABREG ;
MOVE T1,@0(ARG) ;FETCH DIMENSIONALITY
MOVE TABREG,ARG ;COPY ARG REGISTER
SETZ TEMOFF, ;[324] CLEAR OFFSET
MOVE T2,@4(ARG) ;MULT(1) - (PASSED IN)
MOVEM T2,@1(ARG) ;INITIALIZE ARRAYSIZ
LOOP1: IMUL T2,@6(TABREG) ;MULT(1)*L(1)
ADD TEMOFF,T2 ;[3001] Add (30 bits) to initial offset
SOJLE T1,LUPDUN ;QUIT IF DONE
MOVE T2,@5(TABREG) ;U(I-1)
SUB T2,@6(TABREG) ;MINUS L(I-1)
ADDI T2,1 ;PLUS 1
IMULM T2,@1(ARG) ;MULTIPLY INTO ARRAYSIZ
IMUL T2,@4(TABREG) ;TIMES MULT(I-1)
MOVEM T2,@7(TABREG) ;EQUALS MULT(I)
ADDI TABREG,3 ;INCREMENT TO NEXT BUNCH
JRST LOOP1 ;GO AROUND AGAIN
LUPDUN: MOVN TEMOFF,TEMOFF ;NEGATE OFFSET
XMOVEI T2,@2(ARG) ;[3001] Get 30 bit array base address
ADD TEMOFF,T2 ;[3001] Add it in
MOVEM TEMOFF,@3(ARG) ;STORE OFFSET
MOVE T2,@5(TABREG) ;GET U(I) FOR LAST ARRAYSIZ MULT
CAMN T2,[1B0-1] ;[3066] Assumed-size array case?
JRST BYE ;[3066] Yes, don't calculate size
SUB T2,@6(TABREG) ;-L(I)
ADDI T2,1 ;ADD ONE OF COURSE
IMULM T2,@1(ARG) ;MULT AND STACH IN ARRAY SIZE
BYE: POP P,TABREG ;RESTORE REGISTERS USED
POP P,T2
GOODBY
PRGEND
TITLE ADJC1. Adjustable dimension with start of 1
SEARCH MTHPRM,FORPRM
;AC ASSIGNMENTS
ARG==L ;Arg pointer
TEMOFF==T0 ;Holds offset computation
;T1==1 ;Holds loop dounter (dimensionality)
;T2==2 ;Holds multiplier computed
TABREG==T3 ;Holds destroyed arg pointer
; The following algorithm is implemented to compute array factors,
; offset and size for the special case when all lower bounds are a
; constant 1 and all dimensions are adjustable. Modeled from ADJ1.
; MULT(I) are multipliers.
; U(I) are upper bounds (equivalent to range).
; MULT(1)=<size of array from descriptor>
; OFFSET=MULT(1)
; ARRAYSIZ=MULT(1)
; DO 10 I=2,NUMBER OF DIMENSIONS-1
; ARRAYSIZ=ARRAYSIZ*U(I-1)
; MULT(I)=MULT(I-1)*U(I-1)
; OFFSET=OFFSET+MULT(I)
;10 CONTINUE
; OFFSET=-OFFSET
; The parameters passed are (inorder):
; Pointer to number of dimensions
; Pointer to temp for ARRAYSIZ
; Descriptor of array
; Pointer to temp for OFFSET
; MULT(1)
; U(1)
; MULT(2)
; U(2)
; .
; .
; .
; MULT(N)
; U(N)
; **Note that MULT1(1) is assigned from the descriptor's size
; unlike for numeric arrays (ADJ1) which has a constant passed.
SEGMENT CODE
HELLO (ADJC1.)
PUSH P,T2 ;Save registers used
PUSH P,TABREG ;
DMOVE T1,@2(ARG) ;Get array descriptor, t2=size of array
MOVEM T2,@4(ARG) ;Assign MULT(1)
MOVEM T2,@1(ARG) ;Initialize ARRAYSIZ
MOVE TEMOFF,T2 ;Get offset with MULT(1)
MOVE T1,@0(ARG) ;Fetch dimensionality
MOVE TABREG,ARG ;Copy arg register
LOOP1: SOJLE T1,LUPDUN ;Quit if done
MOVE T2,@5(TABREG) ;Fetch U(I-1)
IMULM T2,@1(ARG) ;Multiply into ARRAYSIZ
IMUL T2,@4(TABREG) ;Mult by MULT(I-1)
MOVEM T2,@6(TABREG) ;Forming MULT(I)
ADD TEMOFF,T2 ;Keep sum of OFFSET factors
ADDI TABREG,2 ;Advance pointer
JRST LOOP1 ;Go around again
LUPDUN: MOVNM TEMOFF,@3(ARG) ;Negate OFFSET and store it
MOVE T2,@5(TABREG) ;Fetch U(I) for last arraysize multiply
CAME T2,[1B0-1] ;[3066] Don't multiply for assumed-size array
IMULM T2,@1(ARG) ;Multiply to mem it in
POP P,TABREG ;Restore registers
POP P,T2
GOODBY
PRGEND
TITLE ADJCG. General adjustable dimension array
SEARCH MTHPRM,FORPRM
;AC assignments
ARG==L ;Argument list
TEMOFF==T0 ;Used to compute offset
;T1==1 ;Used to hold loop count (dimensionality)
;T2==2 ;Used to hold multipliers
TABREG==T3 ;Used to hold destroyed arg ptr
; The following algorithm is implemented to compute array factors and
; offset and size for the general case. It is modeled after ADJG.
; A partially computed offset may be input.
; The algorithm may start in an arbitrary place and MULT(1)
; may be 1 (starting from scratch) or another value.
; The ability to start anywhere is necessary since factor and offset
; info may already have been computed for constant array bounds appearing
; in the list first.
; MULT(I) are the factors
; U(I) are the upper bounds
; L(I) ARE THE LOWER BOUNDS
; MULT(1)=<size from descriptor passed>
; OFFSET=MULT(1)*L(1)
; ARRAYSIZ=MULT(1)
; DO 10 I=2,NUMBER OF DIMENSIONS-1
; TEMP=U(I-1)-L(I-1)+1
; MULT(I)=MULT(I-1)*TEMP
; OFFSET=OFFSET+MULT(I)
; ARRAYSIZ=ARRAYSIZ*TEMP
;10 CONTINUE
; OFFSET=-OFFSET
; TEMP=U(I)-L(I)+1
; ARRAYSIZ=ARRAYSIZ*TEMP
; The paramters are (in order of appearance)
; Pointer to number of dimensions
; Pointer to array size
; Descriptor for array
; Pointer to temp containing offset
; MULT(1)
; U(1)
; L(1)
; MULT(2)
; U(2)
; L(2)
; .
; .
; .
; MULT(N)
SEGMENT CODE
HELLO (ADJCG.)
PUSH P,T2 ;SAVE REGISTERS USED
PUSH P,TABREG ;
DMOVE T1,@2(ARG) ;Descriptor, T2 is size of array
MOVEM T2,@4(ARG) ;Assign MULT(1)
MOVEM T2,@1(ARG) ;INITIALIZE ARRAYSIZ
MOVE T1,@0(ARG) ;FETCH DIMENSIONALITY
MOVE TABREG,ARG ;COPY ARG REGISTER
SETZ TEMOFF, ;CLEAR OFFSET
LOOP1: IMUL T2,@6(TABREG) ;MULT(1)*L(1)
ADD TEMOFF,T2 ;ADD TO INITIAL OFFSET
SOJLE T1,LUPDUN ;QUIT IF DONE
MOVE T2,@5(TABREG) ;U(I-1)
SUB T2,@6(TABREG) ;MINUS L(I-1)
ADDI T2,1 ;PLUS 1
IMULM T2,@1(ARG) ;MULTIPLY INTO ARRAYSIZ
IMUL T2,@4(TABREG) ;TIMES MULT(I-1)
MOVEM T2,@7(TABREG) ;EQUALS MULT(I)
ADDI TABREG,3 ;INCREMENT TO NEXT BUNCH
JRST LOOP1 ;GO AROUND AGAIN
LUPDUN: MOVNM TEMOFF,@3(ARG) ;NEGATE OFFSET and store it
MOVE T2,@5(TABREG) ;GET U(I) FOR LAST ARRAYSIZ MULT
CAMN T2,[1B0-1] ;[3066] Assumed-size array case?
JRST BYE ;[3066] Yes, don't calculate size
SUB T2,@6(TABREG) ;-L(I)
ADDI T2,1 ;ADD ONE OF COURSE
IMULM T2,@1(ARG) ;MULT AND STACH IN ARRAY SIZE
BYE: POP P,TABREG ;RESTORE REGISTERS USED
POP P,T2
GOODBY
PRGEND
TITLE ADJ. VARIABLE DIMENSION SUBSCRIPT CALCULATOR
SUBTTL D. TODD /DRT 15-FEB-1973 TOM OSTEN/TWE
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1972, 1985
;ALL RIGHTS RESERVED.
;FROM LIB40 VERSION V.032(323)
;ADJ. IS A PROGRAM CALLED AT RUN-TIME BY A FORTRAN PROGRAM
;TO CALCULATE THE MULTIPLIERS AND OFFSET FOR SUBSCRIPT CALCULATIONS
;FOR DIMENSIONS DECLARED AS SUBROUTINE ARGUMENTS. THE COMPILER
;GENERATES THE FOLLOWING SEQUENCE:
; JSA 16, ADJ.
; EXP N ;DIMENSIONALITY OF ARRAY
; ARG X, TEMP+N+1 ;ARG IS A NO-OP, X IS THE TYPE
;OF THE ARGUMENT,TEMP IS A PNTR
;TYPE,TEMP+N+1 POINTS TO END OF
;MULTIPLIER TABLE
; EXP U1 ;ADDRESS OF NUMBER WHICH IS THE
; ;UPPER BOUND FOR FIRST SUBSCRIPT
; EXP L1 ;ADDRESS OF NUMBER WHICH IS THE
; ;LOWER BOUND FOR FIRST SUBSCRIPT
; .
; .
; .
; EXP LN ;LAST LOWER BOUND ADDRESS
;THE TEMP BLOCK IS CONSTRUCTED AS FOLLOWS:
;TEMP: SIZE OF ARRAY (EQUAL TO MULTIPLIER N)
; OFFSET
; MULTIPLIER N-1
; .
; .
; .
; MULTIPLIER 1
; MULTIPLIER 0
;THE I-TH MULTIPLIER, P(I), IS DESCRIBED BY:
; P(0) = 1
; P(I) = P(I-1) * (U(I) - L(I) + 1)
;THE OFFSET IS DESCRIBED BY
; OFFSET = SUM FROM 1 TO N OF P(I-1)*L(I)
SEARCH MTHPRM,FORPRM
A=0
B=1
C=2
D=3
E=4
F=5
G=6
Q=16
P=17
SEGMENT CODE
HELLO (ADJ.) ;ENTRY TO ADJ. ROUTINE
MOVEM 2,SAV2 ;SAVE AC 2
LDB C,[POINT 3,1(Q),11] ;GET HI 3 BITS OF ARG TYPE
SUBI C,3 ;0 RESULT MEANS D.P. OR COMPLEX
MOVEM C,ACFLD ;SAVE THE RESULT
MOVNI C, @(Q) ;GET MINUS COUNT OF DIMENSIONS
MOVEI B, @1(Q) ;GET TOP ADDRESS OF TEMP BLOCK
ADDI B, -1(C) ;SET B TO BEGINNING OF TEMP BLOCK
HRL B, C ;AOBJN WORD IS (-CNT)ADDR
MOVEI A, 1 ;INITIALIZE P(0) = 1
SETZM OFFSET ;INITIALIZE OFFSET=0
ADJ.1: MOVEM A, (B) ;STORE P(N)
ADDI Q, 2 ;SET FOR NEXT PAIR OF DIMENSIONS
MOVE C, A ;COPY P(N)
IMUL C, @1(Q) ;P(N-1)*L(N)
ADDM C,OFFSET ;ADD INTO OFFSET
MOVE C, @(Q) ;GET U(N)
SUB C, @1(Q) ;U(N) - L(N)
IMULI A, 1(C) ;P(N-1)*(U(N) -L(N) +1)
AOBJN B, ADJ.1 ;N=N+1, GO AROUND LOOP
MOVE C,OFFSET ;GET OFFSET BACK
SKIPN ACFLD ;WAS TYPE D.P. OR COMPLEX?
ASH C,1 ;YES, MULTIPLY OFFSET BY 2 FOR
;COMPLEX OR DOUBLE PRECISION ARG.
MOVEM C, (B) ;OFFSET TO NEXT TO LAST ENTRY
MOVEM A, 1(B) ;SIZE TO LAST ENTRY
MOVE 2,SAV2 ;RESTORE AC 2
GOODBY (2) ;RETURN
SEGMENT DATA
OFFSET: BLOCK 1
ACFLD: BLOCK 1 ;HOLD 0 IF DOUBLE PRECISION OR COMPLEX
SAV2: BLOCK 1 ;TEMP STORAGE FOR AC 2
PRGEND
TITLE PROAR. ARRAY BOUNDS CHECKING ROUTINE
SUBTTL SARA MURPHY/AHM 1-Mar-81
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1974, 1985
;ALL RIGHTS RESERVED.
SEARCH MTHPRM,FORPRM ;DEFINE GLOBAL SYMBOLS
FSRCH ;[3052] Search MACTEN or MACSYM
; Routine to perform FORTRAN array bounds checking at run time.
; Called with an argument block of the form:
; -------------------------------------------------
; !1!0! ! PTR TO SEQ NUMB OF ST !
; -------------------------------------------------
; !1!0! ! PTR TO DIMENSION INF !
; -------------------------------------------------
; !1!0! ! PTR TO 1ST SUBSCRIPT !
; -------------------------------------------------
; !1!0! ! PTR TO 2ND SUBSCRIPT !
; Etc.
;
; Where dimension information is represented by a block of the form:
; -------------------------------------------------
; ! ARRAY NAME (IN SIXBIT) !
; -------------------------------------------------
; !1!0! DIM CT ! !I! ! BASE ADDRESS !
; -------------------------------------------------
; V6 !A!F!0!0! ! PTR TO OFFSET !
; V7 !1!0!A!F! ! PTR TO OFFSET !
; -------------------------------------------------
; !1!0! ! PTR TO 1ST LOWER BND !
; -------------------------------------------------
; !1!0! ! PTR TO 1ST UPPER BND !
; -------------------------------------------------
; !1!0! ! PTR TO 1ST FACTOR !
; -------------------------------------------------
; !1!0! ! PTR TO 2ND UPPER BND !
;
; ETC
; WHERE A IS A FLAG FOR "ADJUSTABLY DIMENSIONED ARRAY"
; F IS A FLAG FOR "FORMAL ARRAY"
;
; Note that the argument list is created in the compiler routine
; PROARRXPN in the file ARRXPN.BLI and the dimension block is created
; and written in CGDIMBLK in DEBUG.BLI.
;
;COMPUTES THE ADDRESS OF THE SPECIFIED ARRAY ELEMENT AND
; RETURNS THAT ADDRESS IN AC 0. IF ANY OF THE BOUNDS ARE
; EXCEEDED, AN ERROR MESSAGE IS GIVEN BEFORE PROCEEDING
;THE ADDRESS OF THE ARRAY ELEMENT IS COMPUTED BY THE
; FORMULA:
; BASE ADDR + OFFSET + (1ST SS)*(1ST FACTOR) +
; (2ND SS)*(2ND FACTOR) + .....
;IF AN ARRAY IS NOT A FORMAL, THE BASE ADDR+OFFSET WILL BE ADDED
; IN TO THE RESULT OF THIS ROUTINE BY THE FORTRAN PROGRAM CALLING
; THIS ROUTINE - THEREFORE THESE 2 TERMS ARE NOT INCLUDED IN THE RESULT
; UNLESS THE ARRAY IS FORMAL.
;IF AN ARRAY IS ADJUSTABLY DIMENSIONED, THE "OFFSET" CALCULATED UPON
; ENTRY TO THE SUBROUTINE IN WHICH THE ARRAY IS DECLARED ALREADY
; INCLUDES THE BASE ADDRESS - THEREFORE FOR ADJUSTABLY DIMENSIONED
; ARRAYS NEED NOT HAVE THE BASE ADDRESS ADDED IN SEPARATELY.
; Note that there are two formats for the adjustably dimensioned array
; and formal array flags. The old format used for V6 and before used
; the two high order bits of the flag word. The pattern "10" was
; illegal for V6 because it means "adjustably dimensioned but not
; formal" - a non-sequitur for Fortran. Which is just as well,
; because the two high order bits of the flag word had to be forced to
; "10" for V7 in order to make the flag word an IFIW for extended
; addressing. The definitions of the bits were just shifted over by 2
; places for extended addressing.
DP=P4 ;PTR INTO THE BLOCK OF DIMENSION INFORMATION. POINTS
; TO THE SUB-BLOCK OF INFORMATION FOR A GIVEN DIMENSION
SSP=P1 ;[3052] Pointer to the arg block entry for a subscript
SS=P2 ;Value of the subscript being processed
COUNT=P3 ;[3052] The number of subscripts left to go
SUM=0 ;[3052] Computed sum of subscripts with factors
;[3052] (Used to compute the element address)
;DEFINE FIELDS IN THE ARG-BLOCK FOR THIS ROUTINE
ISNWD=0 ;WD 0 CONTAINS THE SEQ NUMBER OF THE STMNT
; CONTAINING THIS ARRAY REF
DBLKP=1 ;WD 1 CONTAINS PTR TO THE DIMENSION BLOCK
; FOR THIS ARRAY
ARNAMP=1 ;SINCE 1ST WD OF DIMENSION BLOCK IS THE ARRAY
; NAME, WD 1 OF ARG BLOCK PTS TO THE ARRAY NAME
SS1WD=2 ;WD 2 CONTAINS PTR TO THE 1ST SS
;DEFINE FIELDS IN THE DIMENSION BLOCK
DNAMWD=0 ;ARRAY NAME IS IN WD 0 OF THE DIMENS BLOCK
DBASWD=1 ;BASE ADDR IS IN WD 1 OF THE BLOCK
DOFFWD=2 ;OFFSET IS IN WD 2 OF THE BLOCK
D1WD=3 ;SUB-BLOCK FOR THE 1ST DIMENSION STARTS
; IN WD 3
DCTSIZ=7 ;[3001] Number of bits in the dimension count
;[3001] field in the dimension descriptor block
DCTPOS=8 ;LAST BIT IN THE DIMENSION CT FIELD IS BIT 8
DCTWD=1 ;DIMENSION CT FIELD IS IN WD 1 OF THE BLOCK
TYPWRD==1 ;[3052] Dim block word that contains the array type
TYPMSK==<Z 17,0> ;[3052] Type field is the AC field
DFLGWD=2 ;DIMENSION BLOCK FLAGS ARE IN WD 2 OF DIM BLO
DFLSIZ=4 ;[3052] Dimension block flags are 4 bits
DFLPOS=3 ;[3052] Bits 0-3
;DEFINE FIELDS IN THE SUB-BLOCKS FOR EACH DIMENSION
DLBWD=0 ;PTR TO LOWER BOUND IS IN WD 0 OF A SUB-BLOCK
; FOR A GIVEN DIMENSION
DUBWD=1 ;PTR TO UPPER BOUND IS IN WD 1 OF A SUB-BLOCK
DFACWD=2 ;PTR TO FACTOR IS IN WD 2 OF A SUB-BLOCK
DSBSIZ=3 ;NUMBER OF WDS IN THE SUB-BLOCK FOR EACH DIMEN
SEGMENT CODE
EXTERN ABORT. ;[3205] FOROTS fatal error entry point
HELLO (PROAR.)
PUSH P,DP ;SAVE ACs
PUSH P,SSP
PUSH P,SS
PUSH P,COUNT ;[3052] Save the count AC
XMOVEI DP,@DBLKP(L) ;[3052] Pointer to dimension block
XMOVEI SSP,SS1WD(L) ;[3052] Set up pointer to the SS list
LDB COUNT,[POINT DCTSIZ,DCTWD(DP),DCTPOS] ;Load dimension count
; Get flags to see how to compute the base address of the array.
LDB T1,[POINT DFLSIZ,DFLGWD(DP),DFLPOS] ; Adj-dim and formal flags
LDB SUM,[POINTR (TYPWRD(DP),TYPMSK)] ;[3052] Get the array type
CAIN SUM,TP%CHR ;[3052] Is it a character variable ?
MOVEI T1,^B1011 ;[3052] Yes, they act like an adjustable formal
;[3052] (The main program "adds in" the array
;[3052] base with an ADJBP, but we are
;[3052] responsible for starting off with the
;[3052] offset pointed to by DOFFWD(DP))
XCT PXCTAB(T1) ;Execute table entry (indexed by T1)
XMOVEI DP,D1WD(DP) ;[3052] Pointer to info on 1st dimension
LP: MOVE SS,@0(SSP) ;1ST SUBSCRIPT
CAML SS,@DLBWD(DP) ;IF LESS THAN LOWER BOUND
CAMLE SS,@DUBWD(DP) ; OR GTR THAN UPPER BOUND
PUSHJ P,PERR ; GIVE A MESSAGE
IMUL SS,@DFACWD(DP) ;MULTIPLY BY FACTOR
ADD SUM,SS ;ADD INTO THE ADDRESS BEING COMPUTED
ADDI DP,DSBSIZ ;GO ON TO NEXT DIMENSION
ADDI SSP,1 ;[3052] Go on to next SS
SOJG COUNT,LP ;[3052] Loop back for more
POP P,COUNT ;[3052] Restore ACs
POP P,SS
POP P,SSP
POP P,DP
POPJ P, ;RETURN
;EXECUTE TABLE
; There are presently 4 bits - this implies a 16 word table.
PXCTAB: MOVEI SUM,0 ;[3052] |0000| V6 Non-formal
$FCALL SNH,ABORT. ;[3052] |0001| Flags for V7 set by V6
$FCALL SNH,ABORT. ;[3052] |0010| Flags for V7 set by V6
$FCALL SNH,ABORT. ;[3052] |0011| Flags for V7 set by V6
XMOVEI SUM,@DBASWD(DP) ;[3052] |0100| V6 Non-adj formal
$FCALL SNH,ABORT. ;[3052] |0101| Flags for V7 set by V6
$FCALL SNH,ABORT. ;[3052] |0110| Flags for V7 set by V6
$FCALL SNH,ABORT. ;[3052] |0111| Flags for V7 set by V6
MOVEI SUM,0 ;[3052] |1000| V7 Non-formal
XMOVEI SUM,@DBASWD(DP) ;[3052] |1001| V7 Non-adj formal
$FCALL SNH,ABORT. ;[3052] |1010| V7 Adj but not formal
;[3052] should never occur
MOVE SUM,@DOFFWD(DP) ;[3052] |1011| V7 Computed offset for
;[3052] an adjustable array
MOVE SUM,@DOFFWD(DP) ;[3052] |1100| V6 Computed offset for
;[3052] an adjustable array
$FCALL SNH,ABORT. ;[3052] |1101| Flags for V7 set by V6
$FCALL SNH,ABORT. ;[3052] |1110| Flags for V7 set by V6
$FCALL SNH,ABORT. ;[3052] |1111| Flags for V7 set by V6
;END OF EXECUTE TABLE
;ROUTINE CALLED WHEN A BOUNDS VIOLATION HAS BEEN DETECTED
PERR: XMOVEI T1,1-SS1WD(SSP) ;[3052] Set T1 to the dimension
SUB T1,L ;[3052] being processed
PUSH P,T2 ;SAVE T2,T3
PUSH P,T3
MOVE T2,@ARNAMP(L) ;GET THE ARRAY NAME
MOVE T3,@ISNWD(L) ;GET THE ISN
;(SRE,21,101,%,<Subscript range error - subscript $D of array $S = $D
; on line $D>,<T1,T2,P2,T3>)
$FCALL SRE ;ISSUE MESSAGE, CONTINUE
POP P,T3 ;RESTORE T2,T3
POP P,T2
POPJ P,
;@ISNWD(L)[T3]/ ISN of statement containing this array ref
;T1/ Dimension number being processed
;@ARNAMP(L)[T2]/ Array name in SIXBIT
;SS[P2]/ Value of illegal subscript
PRGEND
TITLE FORDMP - DUMP and PDUMP Dump memory routines
SUBTTL /DMN/SWG/DAW/AHM
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1972, 1985
;ALL RIGHTS RESERVED.
;FROM 1 MAY 1966 ED YOURDON, 2/12/68 NSR
;++
; FUNCTIONAL DESCRIPTION:
;
; Both DUMP and PDUMP output core to a line printer between the
; optional locations passed by the user. DUMP calls "EXIT." when
; done, while PDUMP returns to the users program. The code is
; shared, ENTFLG is used to determine whether DUMP or PDUMP was
; entered.
;
; First to be dumped are following PC flags and then the contents
; of the accumulators.
;
; AR OV FLAG
; AR CRY0 FLAG
; AR CRY1 FLAG
; PC CHANGE FLAG - FLOATING OVERFLOW
; BIS FLAG
;
; Following this are any memory locations the user has specified.
;
; If a group of memory locations have the same contents, DUMP and
; PDUMP will finish printing the current line, then indicate the
; repeated locations by:
;
; Locations xx through yy contain zz
;
; CALLING SEQUENCE:
;
; CALL DUMP(A(1),B(1),F(1), ... ,A(n),B(n),F(n))
; CALL PDUMP(A(1),B(1),F(1), ... ,A(n),B(n),F(n))
;
; INPUT PARAMETERS:
;
; Arguments are in triplets, each triplet taken separately.
;
; A(n) First element to be dumped.
;
; B(n) Last element to be dumped.
;
; If the last two arguments, B(n) and F(n), are missing an
; octal dump is made from A(n) to the end of user area.
;
; F(n) Mode to dump the elements in.
;
; 0 octal (O12 format)
; 1 floating point (G12.5 format)
; 2 integer (I12 format)
; 3 ascii (A12 format)
; 4 double precision (G25.16)
;
; An illegal or missing mode assignment causes the dump to
; be made in octal.
;
; where A, B, and F are optional sets of triplet arguments.
;
; If no arguments are given, the entire user area is dumped in
; octal. Under extended addressing, both A(n) and B(n) must be
; given.
;
; IMPLICIT INPUTS:
;
; None
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; Used as Fortran subroutine, does NOT save AC values.
;
;--
;Accumulator assignments and parameter assignments
B==3 ;SCRATCH
C==4 ;...
S==5 ;ADDRESS OF LOCATION CURRENTLY DUMPED
F==6 ;ADDRESS OF HIGH LOCATION TO BE DUMPED
I==7 ;ARGUMENT INDICATOR
LL==10 ;LOOP COUNTER
FRMT==11 ;HOLDS FORMAT FOR REPEATED LINES
ARC==12 ;-Number of args left
PP==15 ;BLT AC, ALSO HOLDS A FORMAT ADDRESS
P==17 ;PUSHDOWN POINTER
N==12 ;SIZE OF AC BLOCK TO BE SAVED ON PD LIST
DEVICE==-3 ;DEVICE ASSIGNMENT FOR PRINT
NLIST==5 ;NO. OF DIFFERENT FORMAT DUMPS AVAILABLE
SEARCH MTHPRM,FORPRM
FSRCH
SEGMENT CODE
HELLO (DUMP) ;Beginning of DUMP routine
SETOM ENTFLG ;FLAG DUMP ENTRY = -1
JRST DUMPA ;HOP DOWN TO COMMON CODE
HELLO (PDUMP) ;Beginning of PDUMP routine
SETZM ENTFLG ;FLAG PDUMP ENTRY = 0
;Common code to DUMP and PDUMP. Dump the PC flags and save away the
;AC's.
DUMPA: DMOVEM T0,ACSAVE ;[4110] Save AC0, AC1
MOVEM T2,ACSAVE+2 ;[4110] Save AC2
;
; [4100] Check for compatibility flagging.
;
SKIPE [FLGON.##] ;[4100]Is any compatbility flagging on?
$FCALL CFX ;[4100]Yes; display the compatibility message
IF20,<
XMOVEI T1,. ;What section are we running in?
TLNN T1,-1 ;[4110] Is section non-zero?
JRST DPNZER ;[4110] No, in section 0
;Running in non-zero section. Get and Save PC flags
;differently.
XSFM FLGLOC ;Save PC flags the extended way.
;Save AC3 through AC17
MOVEI T0,20-3 ;[4110] Number of AC's to move.
XMOVEI T1,T3 ;[4110] AC3 is start of what to move
XMOVEI T2,ACSAVE+3 ;[4110] Where to put the saved AC's
EXTEND T0,[XBLT] ;[4110] Save AC 3 thru AC 17
JRST DPPRFL ;[4110] Ready to dump flags
>; End IF20
;Get PC flags and save AC's away.
DPNZER: POP P,FLGLOC ;[4110] Get PC flags out. The PUSHJ to
; call us loaded them in the left half
; of the return address pushed on the
; stack.
PUSH P,FLGLOC ;Restore to top of stack
;Save AC3 through AC17
HRLI T1,T3 ;[4110] [Source=AC3,,0]
HRRI T1,ACSAVE+3 ;[4110] [source,,Destination]
BLT T1,ACSAVE+20-1 ;[4110] Save AC's
;[4110] Destination + n -1
;Print headers for PC flags
DPPRFL: XMOVEI L,ARG3 ;[4110]
PUSHJ P,OUT.## ;[3257] Set up for output
;Put out the actual PC flags, "ON"/"OFF"
MOVE C,BYTEP ;GET BYTE POINTER FOR FLAGS
MOVEI F,5 ;LOOP FOR FIVE FLAGS
FLAGS: ILDB B,C ;GET FLAG BIT STORED BY JSR
MOVE S,OFFON(B) ;GET EITHER "OFF" OR "ON"
XMOVEI L,ARG4 ;[4110]
PUSHJ P,IOLST.## ;[3257] Do the output
SOJG F,FLAGS ;LOOP BACK FOR MORE FLAGS
FUNCT FIN.## ;Finish outputting
;Output the values in the AC's.
;Setup the format for printing "ACnn" headers and the AC values
XMOVEI L,ARG5 ;[4110] Output S
PUSHJ P,OUT.## ;[3257] Set up for more output
CLEARB S,I ;AC0-AC7, SET INDICATOR TO ZERO
;Output "AC 00 ... AC 07"
D1: XMOVEI L,ARG4 ;[4110] Output S
PUSHJ P,IOLST.##
CAIGE S,7 ;For registers 0 thru 7
AOJA S,D1 ;Loop back until done
;Output the contents of AC0 through AC7
XMOVEI L,ARG6 ;[4110] ACSAVE through ACSAVE+7
PUSHJ P,IOLST.##
;Output "AC 10 ... AC 17"
MOVEI S,10 ;Start with AC 10
D3: XMOVEI L,ARG4 ;[4110] Output S
PUSHJ P,IOLST.##
CAIGE S,17 ;Done AC17 yet?
AOJA S,D3 ;No, Loop again
;Output contents of AC10 through AC17
XMOVEI L,ARG7 ;[4110] ACSAVE+10 through ACSAVE+17
PUSHJ P,IOLST.##
;Argument processor. See how many arguments we have.
MOVE L,ACSAVE+L ;[4110] Restore argument pointer
HLRE ARC,-1(L) ;Get -arg count
JUMPE ARC,ENDCHK ;No arguments: Dump all of core
;Come here to process a set of 3 args. We have at least one. If less
;than three, then we must set up defaults.
;
; L points to arg list
; ARC is -number of args left
SGET: SETZ I, ;Set to 1 if whole group of 3 args present
XMOVEI L,ARG8 ;[4110]
PUSHJ P,OUT.## ;[3257] Go set up for output and do it
FUNCT FIN.## ;[3257] All done!
AOJG ARC,SDOUT ;If no more args, quit
MOVE L,ACSAVE+L ;[4110] Restore argument pointer
XMOVEI S,@0(L) ;Yes, pick up the address of beginning
AOJG ARC,ENDCK2 ;End of arg list
XMOVEI F,@1(L) ;No, F:= end address
AOJG ARC,ENDCK3 ;Jump if end of arg list
MOVE C,@2(L) ;No, C:= format type code
AOJ I, ;INDICATE THAT ALL 3 ARGUMENTS HAVE BEEN SEEN
CAIL C,NLIST ;IS THIS A LEGAL ARGUMENT?
JRST ENDCK3 ;No, DUMP IN OCTAL MODE
;Now we dump some memory out. Check the arguments
;Come here with:
; C = type of dump (0= Octal, 1= floating, etc.)
; S = Lowest location to be dumped
; F = Highest location to be dumped
; I = 0 if we defaulted any args because they were missing,
; = 1 if all three args were present.
SCHEK: CAML S,F ;ARE ARGUMENTS IN ORDER?
EXCH S,F ;NO, SWITCH THEM
MOVE PP,C ;COPY ARG TO PP FOR USE IN ARG BLOCKS
MOVE B,TABLE(C) ;Get ots code for the mode specified
DPB B,[POINT 4,IOLSTC,12] ;Put mode in the format for IO call
DPB B,[POINT 4,IOLSTS,12] ;""
;Main dump processor
DPROC: MOVE B,S ;[4110] GET CURRENT ADDRESS IN B
MOVE LL,S ;POINTER IN REPETITION CHECK
;Look for repeating words in the dump. If we can find multiple line(s)
;(8 or more words) that repeat, then output them in groups rather than
;every word separately.
; C is the location to compare against.
; LL is incremented every time through the loop to be the
; next memory location to look at.
MOVE C,@S ;Word to check against for repetition
LOOK: CAMN C,@LL ;Do words match?
CAMGE F,LL ;Yes, Finished this section of code?
JRST DIFF ;Go compute repeated lines
XMOVEI T1,@S ;Where to begin dumping
ADDI T1,7 ;Above + 7 = "end of a line"
CAML LL,T1 ;Finished checking a line?
ADDI S,10 ;Yes, increment S to next line
; Unless incremented, we don't have any matches
CAMG S,F ;Beyond the end of what to dump?
AOJA LL,LOOK ;No, increment pointer, check more
;End of checking for repetition. Either have reached the end of
;memory to dump or have found a non-identical line.
DIFF: CAMN B,S ;WERE ANY LINES REPEATED?
JRST OLOOP0 ;NO, DUMP THIS LINE INDIVIDUALLY
;Found identical line(s). "Locations n thru m contain "
MOVE T1,S ;[4110] Last loc
SUBI T1,1 ;[4110] Off by one
XMOVEI L,ARG9 ;[4110]
PUSHJ P,OUT.## ;[3257] Set up for output
XMOVEI L,ARG10 ;[4110] Output B, T1
PUSHJ P,IOLST.## ;END OF REPETITION MESSAGE
;Output the common word that is repeated.
XMOVEI L,ARG1 ;GET FORMAT FOR MESSAGE
PUSHJ P,OUT.##
XMOVEI L,IOLSTC ;OUTPUT REPEATED WORD -> C
PUSHJ P,IOLST.##
;Loop for outputting words. Start outputting a regular line
;here. 8 words per line.
OLOOP0: MOVE C,LIST2(PP) ;PICK UP FORMAT TYPE
OLOOP1: CAMLE S,F ;ALL DONE DUMPING?
JRST NEXT1 ;YES, CHECK for more ARGUMENTS
XMOVEI L,ARG2 ;NO, OUTPUT FOR 8 WORDS/LINE
PUSHJ P,OUT.##
XMOVEI L,ARG4 ;[4110] Output S
PUSHJ P,IOLST.##
;Each time through loop output one location.
MOVEI B,^D8 ;LOOP COUNTER - Output 8 memory locations
OLOOP2: XMOVEI L,IOLSTS ;ADDRESS FOR THIS LINE
PUSHJ P,IOLST.## ;MEMORY WORD
CAML S,F ;ALL DONE DUMPING
JRST NEXT ;YES, CHECK for more ARGUMENTS
CAIE PP,DFMNM ;Double precision?
AOJA S,OLOOP3 ;NO, MOVE POINTER TO NEXT WORD
ADDI S,2 ;YES, ADVANCE POINTER ONE WORD
SOJ B, ;OUTPUTS ONLY 4 WORDS
OLOOP3: SOJG B,OLOOP2 ;DONE WITH THIS LINE?
PUSHJ P,FIN.## ;YES, FINISH OFF FORMAT STATEMENT
JRST DPROC ;[4110] SCAN NEXT LINE
;One or more arguments missing. Set defaults, then dump the memory.
;No arguments given.
ENDCHK: HRRZI S,20 ;DUMP FROM 20 (after registers)
;Ending and mode not given
ENDCK2: HRRZ F,.JBFF ;TO END OF USER AREA
SUBI F,1 ;DO NOT DUMP FIRST FREE
IF20,<
;If running in non-zero section, user must give beginning and
;ending arguments to dump memory. Extended adressing means too
;much memory to dump everything on an innocent line printer.
XMOVEI T1,T0 ;[4110] Section that AC 0 is in
JUMPE T1,ENDCK3 ;[4110] If section zero, then ok
$FCALL DMA ;[4110] Warning - Give me some arguments!!
JRST SDOUT ;[4110] Exit, don't do anything.
> ;End IF20
;Mode not given
ENDCK3: SETZ C, ;Set OCTAL mode
JRST SCHEK ;FIX EXIT, CHECK CORE LIMITS
;Dump is finished. Process next triplet of arguments (if there is any).
NEXT: PUSHJ P,FIN.## ;FINISH FORMAT
NEXT1: JUMPE I,SDOUT ;MORE ARGUMENTS TO COME?
MOVEI T0,3 ;[4110]
ADDM T0,ACSAVE+L ;[4110] Yes, saw 3 args last time, Bump arg ptr.
JRST SGET ;GO GET SOME MORE ARGUMENTS
;Here when done dumping all arguments. Get ready to return to caller or
;jump to EXIT. .
SDOUT: SKIPE ENTFLG ;[4110] IS IT THE PDUMP ENTRY?
JRST SDOUT1 ;NO - DUMP
GOODBY ;PDUMP - RETURN TO USER
SDOUT1: FUNCT (EXIT.) ;DUMP - Exit and stop the program
;Format statements for output
EXP MESS1L ;[3257] FMTSIZ=
MESS1: ASCII "(1H148X9HCORE DUMP/1H 7HOv flag17X9HCry0"
ASCII " flag15X9HCry1 flag15x12HFlt ov flag 13X"
ASCII "8HFPD flag/1H 5(A9,15X))"
MESS1L==.-MESS1 ;[3257] Compute size of FORMAT statement
EXP MESS2L ;[3257] FMTSIZ=
MESS2: ASCII "(2(/// 8(9X 3HAC O2) /7X8O14/))" ;[4110] "AC nn"
MESS2L==.-MESS2 ;[3257] Compute size of FORMAT statement
EXP MESS3L ;[3257] FMTSIZ=
MESS3: ASCII "(///)" ;[4110] Skip three lines
MESS3L==.-MESS3 ;[3257] Compute size of FORMAT statement
EXP MESS4L ;[3257] FMTSIZ=
MESS4: ASCII "(///' Locations 'O10,9H through O10,9H contain /1H )" ;[4110]
MESS4L==.-MESS4 ;[3257] Compute size of FORMAT statement
;Argument blocks for OUT./IOLST. calls
XWD -2,0
ARG1: BYTE (2)^B10 (7)1 (4)TP%INT (5)0 (18)[DEVICE] ;[4110] UNIT=
BYTE (2)^B10 (7)2 (4)TP%LBL (5)35 (18)LIST1 ;[4110] @LIST1(PP)
XWD -2,0
ARG2: BYTE (2)^B10 (7)1 (4)TP%INT (5)0 (18)[DEVICE] ;[4110] UNIT=
BYTE (2)^B10 (7)2 (4)TP%LBL (5)35 (18)LIST2 ;[4110] @LIST2(PP)
XWD -2,0 ;[3257] Arg count
ARG3: BYTE (2)^B10 (7)1 (4)TP%INT (5)0 (18)[DEVICE] ;[4110] UNIT=
BYTE (2)^B10 (7)2 (4)TP%LBL (5)0 (18)MESS1 ;[4110] FMT=
XWD -2,0 ;[3257] Arg count
ARG4: BYTE (2)^B10 (7)1 (4)TP%INT (5)0 (18)S ;[4110] S
0 ;[4110] End of list
XWD -2,0 ;[3257] Arg count
ARG5: BYTE (2)^B10 (7)1 (4)TP%INT (5)0 (18)[DEVICE] ;[4110] UNIT=
BYTE (2)^B10 (7)2 (4)TP%LBL (5)0 (18)MESS2 ;[4110] FMT=
XWD -4,0 ;[4110] 4 args
ARG6: BYTE (2)^B10 (7)2 (4)TP%INT (5)0 (18)[10] ;[4110] 10 words
BYTE (2)^B10 (7)0 (4)TP%INT (5)0 (18)[1] ;[4110] Incr by 1
BYTE (2)^B10 (7)1 (4)TP%INT (5)0 (18)ACSAVE ;[4110] Start here
0 ;[4110] EOL
XWD -4,0 ;[4110] 4 args
ARG7: BYTE (2)^B10 (7)2 (4)TP%INT (5)0 (18)[10] ;[4110] 10 words
BYTE (2)^B10 (7)0 (4)TP%INT (5)0 (18)[1] ;[4110] Incr by 1
BYTE (2)^B10 (7)1 (4)TP%INT (5)0 (18)ACSAVE+10 ;[4110] Start here
BYTE (2)^B10 (7)4 (27)0 ;[4110] Fin
XWD -2,0 ;[3257] Arg count
ARG8: BYTE (2)^B10 (7)1 (4)TP%INT (5)0 (18)[DEVICE] ;[4110] UNIT=
BYTE (2)^B10 (7)2 (4)TP%LBL (5)0 (18)MESS3 ;[4110] FMT=
XWD -2,0 ;[3257] Arg count
ARG9: BYTE (2)^B10 (7)1 (4)TP%INT (5)0 (18)[DEVICE] ;[4110] UNIT=
BYTE (2)^B10 (7)2 (4)TP%LBL (5)0 (18)MESS4 ;[4110] FMT=
XWD -3,0 ;3 args
ARG10: BYTE (2)^B10 (7)1 (4)TP%INT (5)0 (18)B ;[4110] Addresses
BYTE (2)^B10 (7)1 (4)TP%INT (5)0 (18)T1 ;[4110] First location rep'ed
BYTE (2)^B10 (7)4 (27)0 ;[4110] Last
;More format statements and some constants, too
EXP 4 ;[3257] Size of FORMAT
OFRMT: ASCII "(1H0,O10,8O14)"
EXP 4 ;[3257]
EFRMT: ASCII "(1H0,O10,8G14.5)"
EXP 4 ;[3257]
IFRMT: ASCII "(1H0,O10,8I14)"
EXP 4 ;[3257]
AFRMT: ASCII "(1H0,O10,8A14)"
EXP 4 ;[3257]
DFRMT: ASCII "(1H0,O10,4G25.16)"
EXP 4 ;[3257]
OFRMT2: ASCII "(1H0,40X,O14)"
EXP 4 ;[3257]
EFRMT2: ASCII "(1H0,40X,G14.5)"
EXP 4 ;[3257]
IFRMT2: ASCII "(1H0,40X,I14)"
EXP 4 ;[3257]
AFRMT2: ASCII "(1H0,40X,A14)"
EXP 4 ;[3257]
DFRMT2: ASCII "(1H0,40X,G25.16)"
LIST1: IFIW OFRMT2
IFIW EFRMT2
IFIW IFRMT2
IFIW AFRMT2
IFIW DFRMT2
LIST2: IFIW OFRMT
IFIW EFRMT
IFIW IFRMT
IFIW AFRMT
IFIW DFRMT
DFMNM==.-LIST2-1 ;D format index
OFFON: ASCII "OFF " ;Flag is off
ASCII "ON " ;Flag is on
TABLE: EXP TP%SPO,TP%SPR,TP%INT,TP%LIT,TP%DPR
BYTEP: POINT 1,FLGLOC ;Byte pointer for PC flags
SEGMENT DATA
;** IOLSTC and IOLSTS have their dump "mode" (specified by user) written
;** into them, so they must be writable.
XWD -2,0
IOLSTC: BYTE (2)^B10 (7)1 (4)TP%INT (5)0 (18)C ;[4110] C
BYTE (2)^B10 (7)4 (29)0 ;[4110] Fin
XWD -2,0
IOLSTS: BYTE (2)^B10 (7)1 (4)TP%INT (1)1 (4)0 (18)S ;[4110] Indirect bit on
0 ;End of list
FLGLOC: BLOCK 1 ;TO STORE PC WORD flags
ENTFLG: BLOCK 1 ;Flag for which entry WAS taken
; 0 = DUMP
; 1 = PDUMP
ACSAVE: BLOCK 20 ;[4110] Save the AC's
PRGEND
TITLE ILL ZERO INPUT WORD ON ILLEG. CHARACTERS
SUBTTL D. TODD /DRT/DMN/TWE/SWG 20-Aug-79
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1972, 1985
;ALL RIGHTS RESERVED.
;FROM LIB40 VERSION V.032(323)
;WHEN THE FLAG ILLEG. IS SET (BY CALLING ILL),
;FLOATING POINT INPUT WORDS WILL BE CLEARED IF
;ANY ILLEGAL CHARACTERS ARE SCANNED FOR THAT WORD.
;THE ILLEG. FLAG IS CLEARED BY FOROTS. AT THE END
;OF EACH FORMAT STATEMENT.
;THE CALLING SEQUENCE IS PUSHJ P,ILL
;THE ROUTINE 'LEGAL' ALLOWS ONE TO CLEAR THE
;ILLEG. FLAG SO THAT ILLEGAL CHARACTERS WILL
;RESULT IN THE NORMAL ILLEGAL CHARACTER RETURN.
;THE CALLING SEQUENCE IS PUSHJ P,LEGAL
SEARCH MTHPRM,FORPRM
EXTERNAL FOROP.
SEGMENT CODE
HELLO (ILL)
;
; [4100] Check for compatibility flagging.
;
SKIPE [FLGON.##] ;[4100]Is any compatbility flagging on?
$FCALL CFX ;[4100]Yes; display the compatibility message
MOVEI T0,FO$ILL ;Function code in T0
XMOVEI T1,ILLEG ;FOROP. returns addr. here
PUSHJ P,FOROP. ;FOROP RETURNS ADDRESS
SETOM @ILLEG ;SET ILL CH FLAG
GOODBY
HELLO (LEGAL)
;
; [4100] Check for compatibility flagging.
;
SKIPE [FLGON.##] ;[4100]Is any compatbility flagging on?
$FCALL CFX ;[4100]Yes; display the compatibility message
MOVEI T0,FO$ILL ;T0:= function code
XMOVEI T1,ILLEG ;T1:= Address to return adr in
PUSHJ P,FOROP. ;GET ADDRESS OF ILLEGAL FLAG
SETZM @ILLEG ;CLEAR ILL CH FLAG
GOODBY
SEGMENT DATA
ILLEG: BLOCK 1
PRGEND
TITLE SAVFMT
;CODE TO ENCODE THE FORMAT IN AN ARRAY
;CALLS FOROP TO CALL %FMTSV IN FOROTS
SEARCH MTHPRM,FORPRM
EXTERN FOROP.
SEGMENT CODE
HELLO (SAVFMT)
;
; [4100] Check for compatibility flagging.
;
SKIPE [FLGON.##] ;[4100]Is any compatbility flagging on?
$FCALL CFX ;[4100]Yes; display the compatibility message
MOVEI T0,FO$FSV ;Function code
;No arg used
PUSHJ P,FOROP.
GOODBY
PRGEND
TITLE CLRFMT
;CODE TO THROW AWAY THE ENCODING OF A FORMAT IN AN ARRAY
;CALLS FOROP TO CALL %FMTCL IN FOROTS
SEARCH MTHPRM,FORPRM
EXTERN FOROP.
SEGMENT CODE
HELLO (CLRFMT)
;
; [4100] Check for compatibility flagging.
;
SKIPE [FLGON.##] ;[4100]Is any compatbility flagging on?
$FCALL CFX ;[4100]Yes; display the compatibility message
MOVEI T0,FO$FCL ;SETUP FOR FOROP
;No arg used
PUSHJ P,FOROP.
GOODBY
PRGEND
TITLE LSNGET
;FUNCTION WHICH RETURNS THE INTEGER VALUE OF THE LINE SEQUENCE NUMBER
;OF THE CURRENT LINE FOR MODE=LINED
SEARCH MTHPRM,FORPRM
EXTERN FOROP.
SEGMENT CODE
HELLO (LSNGET)
;
; [4100] Check for compatibility flagging.
;
SKIPE [FLGON.##] ;[4100]Is any compatbility flagging on?
$FCALL CFX ;[4100]Yes; display the compatibility message
MOVEI T0,FO$GLN ;Return current line number
MOVE T1,@(L) ;GET CHANNEL #
PUSHJ P,FOROP. ;Returns line number in T0
DMOVEM T2,SAVE2 ;SAVE 2 AC'S
MOVEI T3,5 ;5 CHARS IN LSN
SETZB T1,T2 ;CLEAR THE NUMBER
LSNLP: ROTC T0,7 ;GET A CHAR
JUMPE T1,LSNENL ;SKIP NULLS
CAIN T1," " ;CONVERT SPACE TO "0"
MOVEI T1,"0"
CAIG T1,"9" ;MAKE SURE IT'S LEGAL
CAIGE T1,"0"
JRST LSNILL ;NOT LEGAL
IMULI T2,^D10 ;MUL PREVIOUS BY 10
ADDI T2,-"0"(T1) ;ACCUMULATE NUMBER
SETZ T1, ;AND CLEAR FOR NEW DIGIT
LSNENL: SOJG T3,LSNLP
MOVE T0,T2 ;RETURN THE INTEGER
DMOVE T2,SAVE2 ;Restore acs
GOODBY
LSNILL: MOVNI T0,1 ;-1=ILLEGAL CHAR IN LSN
DMOVE T2,SAVE2 ;Restore acs
GOODBY
SEGMENT DATA
SAVE2: BLOCK 2 ;FOR THE AC'S
PRGEND
TITLE DATE TODAY'S DATE
SUBTTL D. TODD /DRT/KK/DMN/SWG/AHM/CDM 5-Nov-82
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1972, 1985
;ALL RIGHTS RESERVED.
;FROM LIB40 VERSION V.32(433)
;This subroutine puts today's date into a numeric dimensioned two-word
;array or a character variable.
;The date will be in the form:
; "17-Aug-66 "
;The routine is called in the following manner:
; MOVEI L,ARGBLK
; PUSHJ P,DATE
SEARCH MTHPRM,FORPRM
FSRCH
SEGMENT CODE
HELLO (DATE) ;ENTRY TO DATE ROUTINE.
;
; [4100] Check for compatibility flagging.
;
SKIPE [FLGON.##] ;[4172]Is compatbility flagging on?
$FCALL CFX ;[4172]Yes; display the compatibility message
PUSH P,T2 ;[3206] Save ac's
PUSH P,T3 ;[3206]
; Put time into SVDT
IF10,<
XMOVEI T1,@0(L) ;[3025] Get address of 2 word array
CALLI T1,14 ;Get the date from the monitor.
IDIVI T1,^D31 ;Div. by 31 to obtain the day-1.
ADDI T2,1 ;To obtain the day.
IDIVI T2,^D10 ;Convert into two dec. digits.
SKIPN T2 ;Is the day .LT. 10?
MOVNI T2,20 ;Yes, output blank.
MOVEI T0,"0"(T2) ;Get first digit
LSH T0,7 ;Make space
ADDI T0,"0"(T3) ;Add in 2nd digit
IDIVI T1,^D12 ;To obtain the month
EXCH T1,T2 ;Save year in T2
MOVE T1,TABLE(T1) ;Get month in T1
LSHC T0,3*7 ;Left justify 0 & 1
LSH T0,1 ;0 = ASCII /DD-MO/
;1 = ASCII /N-/
MOVEI T2,^D64(T2) ;Get the year
IDIVI T2,^D10 ;Convert into two dec. digits
ADDI T2,"0" ;Make ASCII
ADDI T3,"0"
LSH T2,2*7+1 ;Shift to CHAR 3
LSH T3,7+1 ;Shift to CHAR 4
ADD T3,T2 ;Add in to T3
ADD T1,T3 ;[3206] So low word is in T1
ADDI T1," "_1 ;[3206] Make space for last character instead
;[2020] of NULL; this allows compare of
;[2020] literal to work, since FORTRAN pads
;[2020] the word with spaces.
DMOVEM T0,SVDT ;[3206] Store away date to return
> ;END IF10
IF20,< ;BEGIN -20 ONLY CODE
HRROI T1,SVDT ;Point to address for result
SETO T2, ;Ask for today's date
MOVX T3,OT%NTM ;Do not want time
ODTIM% ;Do the JSYS
MOVEI T1," "_1 ;[3206] Change NULL to SPACE
;[2020] This allows compare of literal to
;[2020] work, since FORTRAN pads the word
;[2020] with spaces.
IORM T1,SVDT+1 ;[3206] Store away date to return
> ;END IF20
; Return date to caller
LDB T0,[POINTR (0(L),ARGTYP)] ;[3206] Type of argument
CAIE T0,TP%CHR ;[3206] Is it character?
JRST NOTCHR ;[3206] No
; Argument is character. Rather than worrying how to handle the
; length of the character descriptor, and how to pad with
; blanks, let the move sludge handle this.
MOVEI T0,^D10 ;[3206] Move 2 words of source
MOVE T1,[POINT 7,SVDT] ;[3206] Make a byte pointer for source
DMOVE T3,@0(L) ;[3206] Arg's BP and length
EXCH T3,T4 ;[3206] Reverse order
EXTEND T0,[MOVSLJ
" "] ;[3206] Put the date in the argument
JFCL ;[3206] NOP
JRST EXDATE ;[3206] Return
NOTCHR: ; Argument is numeric
DMOVE T0,SVDT ;[3206] Get date
DMOVEM T0,@0(L) ;[3206] Return date calculated above
EXDATE: POP P,T3 ;[3206] Return ac's
POP P,T2 ;[3206]
POPJ P, ;[3206] Return to caller
IF10,<
TABLE: ASCII /-Jan-/
ASCII /-Feb-/
ASCII /-Mar-/
ASCII /-Apr-/
ASCII /-May-/
ASCII /-Jun-/
ASCII /-Jul-/
ASCII /-Aug-/
ASCII /-Sep-/
ASCII /-Oct-/
ASCII /-Nov-/
ASCII /-Dec-/
>
SEGMENT DATA
SVDT: BLOCK 2 ;Place to store results from monitor call
PRGEND
TITLE TIM2GO RETURN TIME LIMIT IN SECONDS
SUBTTL H. P. WEISS/SWG 20-AUG-79
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1974, 1985
;ALL RIGHTS RESERVED.
SEARCH MTHPRM,FORPRM
FSRCH
SEGMENT CODE
IF10,< ;BEGIN TOPS-10 CODE
HELLO (TIM2GO) ;DEFINE ENTRY POINT
;
; [4100] Check for compatibility flagging.
;
SKIPE [FLGON.##] ;[4100]Is any compatbility flagging on?
$FCALL CFX ;[4100]Yes; display the compatibility message
PUSH P,T1 ;GRAB A REGISTER
MOVE T1,[44,,11] ;DETERMINE JIFFIES PER SECOND
GETTAB T1, ;VIA GETTAB
JRST NEVER ;UNIMPLEMENTED
FSC T1,233 ;CONVERT TO FLOATING POINT
MOVE T0,[-1,,40] ;DETERMINE TIME LIMIT
GETTAB T0, ;VIA GETTAB
JRST NEVER ;UNIMPLEMENTED
TLZ T0,777700 ;CLEAR EXTRA BITS
JUMPE T0,NEVER ;RETURN INFINITY IF 0
FSC T0,233 ;CONVERT TO FLOATING POINT
FDVR T0,T1 ;COMPUTE SECONDS TILL EXPIRATION
DONE: POP P,T1 ;RESTORE REGISTER USED
GOODBY (0) ;RETURN
NEVER: HRLOI T0,377777 ;SET LIMIT TO INFINITY
JRST DONE
> ;END IF10
IF20,< ;TOPS-20 CODE
ENTRY TIM2GO
TIM2GO:
;
; [4100] Check for compatibility flagging.
;
SKIPE [FLGON.##] ;[4100]Is any compatbility flagging on?
$FCALL CFX ;[4100]Yes; display the compatibility message
PUSH P,T1 ;SAVE ACS
PUSH P,T2
PUSH P,T3
SETO T1, ;SET T1 TO -1 TO GET THIS JOB'S TIME
MOVE T2,[-3,,TBLK] ;SET UP POINTER TO BLOCK FOR RETURN VALS
MOVX T3,.JIRT ;START AT RUNTIME FIELD IN STRUCTURE
GETJI% ;DO THE JSYS
JRST NEVER
SKIPN T1,TBLK+2 ;PICK UP TIME LIMIT
JRST NEVER ;LIMIT IS 0 THEREFORE INFINITY
MOVE T2,TBLK ;PICK UP RUNTIME
SUB T1,T2 ;GET DIFFERENCE BETWEEN RUNTIME AND TIME LIMIT
FLTR T0,T1 ;AND FLOAT IT
FDVRI T0,(1000.0) ;CONVERT MILLISECONDS TO SECONDS
DONE: POP P,T3 ;RESTORE ACS
POP P,T2
POP P,T1
POPJ P,
NEVER: HRLOI T0,377777
JRST DONE
SEGMENT DATA
TBLK: BLOCK 3
> ;END IF20
PRGEND ;END OF TIM2GO
TITLE TIME TIME OF DAY
SUBTTL /KK/SWG/EDS/EGM/CDM
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1972, 1985
;ALL RIGHTS RESERVED.
;FROM LIB40 %2.(120)
;This subroutine returns the time of day in two single word arguments or
;a character variable.
;
;The first argument gets the hour and minute, and the optional second
;argument gets the second and tenth of a second.
;The first argument is given in military time:
; 02:15 (for a.m. time)
; 14:15 (for p.m. time)
;
;The optional second argument is of the form:
; 37.4
;The routine is called in the following manner:
; XMOVEI L,ARGBLK
; PUSHJ P,TIME
;ON THE -10, TIME OBTAINS THE TIME FROM THE MONITOR IN THE FORM:
; TIME=THE NUMBER OF MILLISECONDS SINCE MIDNIGHT.
;ON THE -20, TIME OBTAINS THE INTERNAL TIME FROM THE MONITOR AND
; CONVERTS IT INTO MILLISECONDS SINCE MIDNIGHT, DOES THE SAME
; CONVERSION FROM THERE AS ON THE -10, BUT ALSO HAS TO CORRECT FOR
; GREENWICH MEAN TIME WHICH IS THE TIME THE -20 INTERNAL TIME IS
; STORED IN.
SEARCH MTHPRM,FORPRM
SEGMENT CODE
SALL ;FOR HELLO MACRO - SEE BELOW
HELLO (TIME)
FSRCH ;MUST FOLLOW HELLO MACRO TO AVOID OLD TIME JSYS
;
; [4100] Check for compatibility flagging.
;
SKIPE [FLGON.##] ;[4172]Is compatbility flagging on?
$FCALL CFX ;[4172]Yes; display the compatibility message
PUSH P,T2 ;[3206] Save ac's
PUSH P,T3 ;[3206]
PUSH P,T4 ;[3405]
;Process the first argument. Put it into TTIME.
IF10,< ;TOPS10-only code
MSTIME T1, ;Get time in millisecs from the monitor.
> ;[3405] End IF10
IF20,< ;[3405] TOP20-only code
GTAD% ;[3405] Get internal GMT
HRLZ T1,T1 ;[3405] Put in left half
LSH T1,-1 ;[3405] Divide by 2
MUL T1,[^D86400000] ;[3405] Compute ms since midnight in T1
> ;[3405] End IF20
IDIVI T1,^D60000 ;[2103]Total mins. in 1, leftover msecs. in 2.
MOVEM T2,TEMP1 ;Save the leftover ms
IDIVI T1,^D60 ;Hours in 1, minutes in 2.
MOVEM T2,TEMP2 ;[3405] Save minutes
;[3405] For TOPS20, which is based on Greenwich Mean Time, determine and
;[3405] adjust for local time zone correction factor and adjust if necessary for
;[3405] Daylight Savings.
;The general algorithm is similar to that in SECNDS. If this must be
;changed, them SECNDS probably ought to be changed also.
IF20,< ;[3405] TOPS20-only code
SETO T2, ;[3405] -1 for current time
SETZ T4, ;[3405] 0 for local time
ODCNV% ;[3405] Return T4/flags+zone,,secs since 00:00
HLR T3,T4 ;[3405] Pick up left half
HRROI T2,<^-<(IC%TMZ)>> ;[3405] Mask -1,,777700 to isolate zone
TDZ T3,T2 ;[3405] Get zone bits (12-17) only
TRNE T3,40 ;[3405] Time zone negative(-12 to +12)?
TDO T3,T2 ;[3405] Yes, propogate its sign bit
TXNE T4,IC%ADS ;[3405] Was Daylight Savings in effect?
SUBI T3,1 ;[3405] Yes, subtract one hour
SUB T1,T3 ;[3405] Adjust hours by time zone factor
SKIPGE T1 ;[3405] Did hours go negative?
ADDI T1,^D24 ;[3405] Yes, get it mod 24 hours
> ;[3405] End IF20
MOVE T0,[POINT 7,TTIME] ;[3206] Build a BP for answer
MOVEM T0,HLDBP ;Save it away
JSP T3,SUB1 ;[3405] Go to subr. to set up hr.in T1 in ASCII
MOVEI T1,":" ;Set up ":".
IDPB T1,HLDBP ;Deposit ":" in the word.
MOVE T1,TEMP2 ;Pick up the minutes.
JSP T3,SUB1 ;Go to subr. to set up min. in ASCII.
;[3405]
; Return time in 1st argument
LDB T0,[POINTR (0(L),ARGTYP)] ;[3206] Get type of 1st argument
CAIE T0,TP%CHR ;[3206] Is it character?
JRST NTCHR1 ;[3206] no
; Character argument. Use move string, so we don't have to
; worry about the length the user specified and how to pad with
; spaces.
MOVEI T0,5 ;[3206] Length of 1 numeric word
MOVE T1,[POINT 7,TTIME] ;[3206] Address of source (time to return)
DMOVE T3,@0(L) ;[3206] Arg BP and length
EXCH T3,T4 ;[3206] Exchange positions
EXTEND T0,[MOVSLJ
" "] ;[3206] Put the time in the argument
JFCL ;[3206] NOP
JRST NEXT1 ;[3206]
NTCHR1: ; Numeric argument
MOVE T0,TTIME ;[3206] Return time in
MOVEM T0,@0(L) ;[3206] the first argument
NEXT1: HLRZ T3,-1(L) ;[3206] Number of arguments
CAIE T3,-2 ;[3206] Are there two?
JRST EXTIME ;[3206] Exit from here
;[3405]
; Process 2nd argument to return seconds
TIME02:
MOVE T0,[POINT 7,TTIME] ;[3206] Build BP for second argument
MOVEM T0,HLDBP ;Save it away
MOVEI T1," " ;PUT IN A BLANK AS THE FIRST
IDPB T1,HLDBP ;CHARACTER IN THE 2ND WORD.
MOVE T1,TEMP1 ;PICK UP THE MSECONDS.
IDIVI T1,^D1000 ;SECONDS IN 1, LEFTOVER MSECS. IN 2.
MOVEM T2,TEMP1 ;SAVE THE MSECS.
JSP T3,SUB1 ;GO TO SUBR. TO SET UP THE SECS. IN ASCII.
MOVEI T1,"." ;SET UP "."
IDPB T1,HLDBP ;IN THE WORD.
MOVE T2,TEMP1 ;PICK UP THE MSECS.
IDIVI T2,^D100 ;GET THE TENTH OF A SECOND.
MOVEI T2,"0"(2) ;MAKE IT ASCII
IDPB T2,HLDBP ;PUT IT IN THE SECOND WORD.
LDB T0,[POINTR (1(L),ARGTYP)] ;[3206] Type of 2nd argument
CAIE T0,TP%CHR ;[3206] Is it character?
JRST NTCHR2 ;[3206] No
; 2nd argument is character.
MOVEI T0,5 ;[3206] Length of source in characters
MOVE T1,[POINT 7,TTIME] ;[3206] Make a BP for
DMOVE T3,@1(L) ;[3206] 2nd arg's BP and length
EXCH T3,T4 ;[3206] Exchange them
EXTEND T0,[MOVSLJ
" "] ;[3206] Put the time in the argument
JFCL ;[3206] NOP
JRST EXTIME ;[3206] Exit from here
NTCHR2: ; 2nd argument is numeric.
MOVE T0,TTIME ;[3206] Return the seconds as the 2nd arg
MOVEM T0,@1(L) ;[3206]
EXTIME: POP P,T4 ;[3405]
POP P,T3 ;[3206] Restore ac's
POP P,T2 ;[3206]
POPJ P, ;[3206] Return
SUB1: IDIVI T1,^D10 ;SUBROUTINE ENTRY POINT.
MOVEI T1,"0"(T1) ;MAKE IT ASCII
IDPB T1,HLDBP ;DEPOSIT IT IN THE WORD.
MOVEI T2,"0"(T2) ;MAKE IT ASCII
IDPB T2,HLDBP ;DEPOSIT IT IN THE WORD.
JRST (T3) ;RETURN TO MAIN SEQUENCE.
SEGMENT DATA
TTIME: BLOCK 1 ;[3206] Temporary storage for Time
TEMP1: BLOCK 1 ;[3206]
TEMP2: BLOCK 1 ;[3206]
HLDBP: BLOCK 1 ;Saved byte ptr
PRGEND
TITLE SLITE SENSE LITE SETTING AND TESTING FUNCTION
SUBTTL D. TODD /DRT/TWE/SWG 20-AUG-1979
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1972, 1985
;ALL RIGHTS RESERVED.
;FROM LIB40 VERSION V.032(323)
;SENSE LIGHT SETTING AND TESTING PROGRAM
;THIS PROGRAM CAN BE ENTERED AT TWO PLACES. THE SENSE LIGHT
;TESTING PROGRAM IS CALLED IN THE FOLLOWING MANNER:
; MOVEI L,ARGBLK
; PUSHJ P,SLITET
;IT TAKES TWO ARGUMENTS I AND J.
;I IS THE ADDRESS OF AN INTEGER ARGUMENT, AND J IS THE ADDRESS
;OF THE ANSWER. IF SENSE LIGHT I IS ON, THE ANSWER IS ONE, AND
;IF IT IS OFF, THE ANSWER IS 2.
;THE SENSE LIGHT SETTING PROGRAM IS CALLED IN THE FOLLOWING
;MANNER:
; MOVEI L,ARGBLK
; PUSHJ P,SLITE
;SLITE TAKES ONE ARGUMENT I.
;I IS THE ADDRESS OF AN INTEGER ARGUMENT WHOSE VALUE IS
;BETWEEN 0 AND 36. IF I=0, ALL SENSE LIGHTS ARE TURNED OFF.
;OTHERWISE, SENSE LIGHT I IS TURNED ON.
SEARCH MTHPRM,FORPRM
SEGMENT CODE
HELLO (SLITE) ;ENTRY TO SLITE PROGRAM
;
; [4100] Check for compatibility flagging.
;
SKIPE [FLGON.##] ;[4100]Is any compatbility flagging on?
$FCALL CFX ;[4100]Yes; display the compatibility message
MOVN T1, @(L) ;GET ARGUMENT
JUMPE T1, SLITE2 ;IS IT ZERO?
MOVSI T0, 400000 ;NO, PUT A ONE IN BIT 0
ROT T0, 1(T1) ;ROTATE IT INTO POSITION
MOVE T1, LITES ;GET THE SENSE LIGHTS
TDO T1, T0 ;TURN ON PROPER LIGHT
SLITE2: MOVEM T1, LITES ;SAVE NEW SENSE LIGHTS
GOODBY (1) ;RETURN
HELLO (SLITET) ;ENTRY TO SENSE TESTING PROGRAM
MOVN T1, @(L) ;PICK UP ARGUMENT
MOVSI T0, 400000 ;PUT A ONE IN BIT 0
ROT T0, 1(T1) ;ROTATE IT INTO POSITION
MOVEI T1, 1 ;SET ANSWER TO ONE FOR NOW
MOVEM T1, @1(L) ;...
MOVE T1, LITES ;PICK UP SENSE LIGHTS
TDZN T1,T0 ;IS THE PROPER LIGHT ON?
AOS @1(L) ;NO, CHANGE ANSWER TO 2
MOVEM T1,LITES ;RESTORE WITH TESTED LIGHT OFF
GOODBY (2) ;RETURN
SEGMENT DATA
LITES: 0
PRGEND
TITLE SSWTCH DATA SWITCH TESTING FUNCTION
SUBTTL D. TODD /DRT/TWE/SWG/EDS 16-Mar-81
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1972, 1985
;ALL RIGHTS RESERVED.
;FROM LIB40 VERSION V.032(323)
; DATA SWITCH TESTING PROGRAM
;THIS PROGRAM IS CALLED IN THE FOLLOWING MANNER:
; MOVEI L, ARGBLK
; PUSHJ P,SSWTCH
;I IS THE ADDRESS OF AN INTEGER ARGUMENT AND J IS THE ADDRESS
; OF THE ANSWER . IF DATA SWITCH I IS UP,THE ANSWER IS 2 , AND
; IF IT IS DOWN, THE ANSWER IS 1.
;ON TOPS-20, THE SWITCHES ARE NOT AVAILABLE, THEREFORE SSWTCH WILL
; ALWAYS RETURN AN ANSWER OF 1. WE ARE KEEPING THE ROUTINE AROUND
;FOR COMPATIBILITY
SEARCH MTHPRM,FORPRM
FSRCH
SEGMENT CODE
HELLO (SSWTCH) ;ENTRY TO SSWTCH PROGRAM
;
; [4100] Check for compatibility flagging.
;
SKIPE [FLGON.##] ;[4100]Is any compatbility flagging on?
$FCALL CFX ;[4100]Yes; display the compatibility message
IF10,< ;ONLY MAKES SENSE ON A -10
MOVN T1, @(L) ;PICK UP ARGUMENT
MOVSI T0, 400000 ;PUT A ONE IN BIT 0
ROT T0,(T1) ; ROTATE BIT INTO POSITION
MOVEI T1,2 ; SET ANSWER TO 2 FOR NOW
MOVEM T1, @1(L) ;...
SWITCH T1, ;GET DATA SWITCHES FROM MONITOR
MOVEI T1,2 ; SET ANSWER TO 2 FOR NOW
SOS @1(L) ; NO, CHANGE ANSWER TO ONE
> ;END IF10
IF20,<
MOVEI T1,1 ;ALWAYS SAY NO
MOVEM T1,@1(L) ;STORE IN USER'S VARIABLE
> ;END IF20
GOODBY (2) ;RETURN
PRGEND
TITLE ERRSET SET APR TRAP PARAMETERS
SUBTTL CHRIS SMITH/CKS/PLB
;Call:
; CALL ERRSET (N)
;or CALL ERRSET (N, I)
;or CALL ERRSET (N, I, SUBR)
;
;where N = max number of error messages to type
;
; I = which error this call applies to. One of:
; -1 any of the following
; 0 integer overflow
; 1 integer divide check
; 2 input integer overflow
; 3 input floating overflow
; 4 floating overflow
; 5 floating divide check
; 6 floating underflow
; 7 input floating underflow
; 8 library routine error
; 9 output field width too small
; 21 FORLIB warnings
; 22 non-standard usage warnings
;
; If I is not specified, -1 is assumed
;
; SUBR = routine to call on the trap
;
; The effect is as if
; CALL SUBR (I, IPC, N2, ITYPE, UNFIXED, FIXED)
; were placed in the program just after the instruction causing
; the trap.
; I = error number of trap, same as above
; IPC = PC of trap instruction
; (or if error number= 9, IPC = PC of FOROTS call)
; N2 = 2nd error number (reserved for DEC)
; ITYPE = data type of value
; UNFIXED = value returned by the processor
; FIXED = value after fixup by MTHTRP
; If SUBR is not specified, no routine is called on the APR trap.
SEARCH MTHPRM,FORPRM
EXTERN MTHOP.
EXTERN ABORT. ;[3322]
SEGMENT CODE
HELLO (ERRSET)
;
; [4172] Check for compatibility flagging.
;
SKIPE [FLGON.##] ;[4172]Is any compatbility flagging on?
$FCALL CFX ;[4172]Yes; display the compatibility message
MOVEI T0,ML$APR ;T0:= function code
XMOVEI T1,APRCT ;Read apr table addresses to here
PUSHJ P,MTHOP. ;READ THEM
MOVEM T0,ERRSZ ;SAVE SIZE OF TABLE
XMOVEI T1,. ;[4012] GET LOCAL SECTION
TLNE T1,-1 ;[4012] IS SECTION NUMBER ZERO?
SKIPA T1,[<T2>B5] ;[4012] NO, USE "EFIW T2,"
MOVSI T1,(IFIW (T2)) ;[4012] ELSE, MAKE IFIW INDEXED BY T2
IORM T1,APRCT ;[4012] POINTING TO ERROR COUNT TABLE
IORM T1,APRLM ;[4012] AND ERROR MESSAGE LIMIT TABLE
IORM T1,APRSB ;[4012] AND SUBROUTINE ADDRESS TABLE
HLLZ T4,-1(L) ;[4012] GET ARG COUNT
SETO T2, ;DEFAULT IS ALL APR ERRORS
SETZ T3, ;DEFAULT SUBROUTINE IS NONE
MOVE T1,@(L) ;GET ERR MESSAGE LIMIT
AOBJP T4,ERSET1 ;[4012] IF OUT OF ARGS, GO STORE THEM
MOVE T2,@1(L) ;[4012] GET ERROR NUMBER
AOBJP T4,ERSET1 ;[4012] IF OUT OF ARGS, GO STORE THEM
XMOVEI T3,@2(L) ;[4012] GET ROUTINE TO CALL
SKIPN (T3) ;[3322] VALID ROUTINE CALL?
$FCALL MXD,ABORT. ;[3322] MISSING EXTERNAL DECLARATION. ABORT
ERSET1: CAML T2,ERRSZ ;REASONABLE ERROR NUMBER?
$FCALL NOR,EPOPJ ;NUMBER OUT OF RANGE
MOVEI T0,1 ;[4012] DEFAULT IS DO JUST ONE ITEM
JUMPGE T2,ERSETL ;IF INDIVIDUAL ERROR, GO SET IT
MOVE T0,ERRSZ ;[4012] IF ALL ERRORS, LOOP MAXIMUM TIMES
SETZ T2, ;[4012] STARTING AT ITEM ZERO
ERSETL: MOVE T4,T1 ;GET ERR MESSAGE LIMIT
ADD T4,@APRCT ;ADD TO NUMBER THAT ALREADY HAPPENED
MOVEM T4,@APRLM ;STORE ERR MESSAGE LIMIT
MOVEM T3,@APRSB ;STORE SUBROUTINE ADDRESS OR 0
AOJ T2, ;[4012] BUMP INDEX AC
SOJG T0,ERSETL ;[4012] SET ALL ERRORS IF THAT'S WHAT HE WANTS
EPOPJ: POPJ P, ;DONE
SEGMENT DATA
APRCT: BLOCK 1 ;ADDRESS OF APR ERROR COUNTS
APRLM: BLOCK 1 ;ADDRESS OF APR ERROR LIMITS
APRSB: BLOCK 1 ;ADDRESS OF APR ERROR SUBROUTINES
ERRSZ: BLOCK 1 ;SIZE OF TABLES
PRGEND
TITLE MTHOP.
SEARCH MTHPRM,FORPRM
ENTRY MTHOP.
EXTERN FOROP.
MTHOP.==<FOROP.+0>
PRGEND
TITLE ERRSNS READ LAST IO ERROR
SUBTTL CHRIS SMITH/CKS
;Call:
; CALL ERRSNS (I,J)
;or CALL ERRSNS (I,J,MSG)
;
;I and J are returned with the First number and the Second number
;for the last error
;
;MSG, if present, is a 16-word array returned holding the text
;of the message for the last error
SEARCH MTHPRM,FORPRM
FSRCH
EXTERN FOROP.
SEGMENT CODE
HELLO (ERRSNS)
;
; [4100] Check for compatibility flagging.
;
SKIPE [FLGON.##] ;[4172]Is compatbility flagging on?
$FCALL CFX ;[4172]Yes; display the compatibility message
MOVEI T0,FO$ERR ;Read error numbers
XMOVEI T1,ERRNUM ;To block beginning here
PUSHJ P,FOROP. ;READ THEM
HLRE T1,-1(L) ;GET ARG COUNT
MOVN T1,T1 ;MAKE POSITIVE
MOVE T2,ERRNUM ;STORE ERR NUMBERS
CAIL T1,1
HLRZM T2,@0(L)
CAIL T1,2
JRST [HRRZ T2,T2 ;Get RH only
CAIN T2,-1 ;-1?
SETO T2, ;Yes, make full word
MOVEM T2,@1(L) ;Store 2nd ERR number
JRST .+1]
CAIGE T1,3 ;STRING SPECIFIED?
POPJ P, ;NO, DONE
MOVE T1,ERRMSA ;GET MSG POINTER
LDB T2,[POINTR (2(L),ARGTYP)] ;GET ARG TYPE
CAIE T2,TP%CHR ;CHARACTER?
JRST ERRNC ;NO
DMOVE T2,@2(L) ;YES. GET PNTR/COUNT
JRST ERRLP ;AND JOIN COMMON CODE
ERRNC: XMOVEI T2,@2(L) ;GET STRING ADDRESS
$BLDBP T2 ;BUILD A BYTE POINTER TO IT
MOVEI T3,^D80 ;COUNT 80 CHARS
ERRLP: ILDB T4,T1 ;GET CHAR
JUMPE T4,ERREND ;NULL IS END
IDPB T4,T2 ;STORE CHAR
SOJG T3,ERRLP
ERREND: JUMPLE T3,ERRRET ;IF 80 CHARS, DONE
MOVEI T1," " ;PAD WITH TRAILING SPACES
IDPB T1,T2
SOJG T3,.-1
ERRRET: POPJ P, ;DONE
SEGMENT DATA
ERRNUM: BLOCK 1 ;ERR NUMBERS
ERRMSA: BLOCK 1 ;ERR MSG ADDRESS
PRGEND
TITLE DIVERT DIVERT ERROR MESSAGE OUTPUT
SUBTTL CHRIS SMITH/CKS
;Call:
;
; CALL DIVERT (U)
;where U is the unit number of an open unit, sends error messages
;to U instead of to the TTY. If U is -1, the diversion is ended.
;
; CALL CHKDIV (U)
;sets U to the unit number where errors are diverted, or -1 if none
SEARCH MTHPRM,FORPRM
EXTERN FOROP.
SEGMENT CODE
HELLO (CLRDIV)
;
; [4100] Check for compatibility flagging.
;
SKIPE [FLGON.##] ;[4100]Is any compatbility flagging on?
$FCALL CFX ;[4100]Yes; display the compatibility message
SETO T1, ;Same as saying "UNIT=-1"
JRST DIV01 ; (Should always return status 0)
HELLO (DIVERT)
;
; [4100] Check for compatibility flagging.
;
SKIPE [FLGON.##] ;[4100]Is any compatbility flagging on?
$FCALL CFX ;[4100]Yes; display the compatibility message
MOVE T1,@(L) ;Get unit number
DIV01: MOVEI T0,FO$DIV ;Do diversion
PUSHJ P,FOROP.
;Status is returned in T1.
;T1: = 0 means ok.
; = 1 means ?Illegal unit number.
; = 2 means ?unit not open
; = 3 means ?Not open for FORMATTED IO
; = 4 means ?Can't write to unit.
XMOVEI T0,DIVRT(T1) ;GET ADDR TO GO
MOVE T1,@(L) ;GET UNIT NUMBER
PJRST @T0 ;GO THERE
;Indexed by status value
DIVRT: JRST DIVRET ;(0) OK, return
$FCALL IDU,DIVRET ;(1) Illegal unit
$FCALL UNO,DIVRET ;(2) Unit not open
$FCALL NOF,DIVRET ;(3) Not open for FORMATTED IO
$FCALL CWU,DIVRET ;(4) Can't write to unit
DIVRET: POPJ P, ;DONE
HELLO (CHKDIV)
;
; [4100] Check for compatibility flagging.
;
SKIPE [FLGON.##] ;[4100]Is any compatbility flagging on?
$FCALL CFX ;[4100]Yes; display the compatibility message
MOVEI T0,FO$GDV ;Get divert unit
PUSHJ P,FOROP.
MOVEM T1,@(L) ;Return unit number
POPJ P, ;Done
PRGEND
TITLE OVERFL RETURN OVERFLOW INFO
SUBTTL CHRIS SMITH/CKS/EGM
;Call:
;
; CALL OVERFL (IANS)
;
;If any overflow, underflow, or divide check has occurred since the last
;call to OVERFL, IANS is set to 1 and T0 is set to -1; if not, IANS is
;set to 2 and T0 is set to 0.
;
; Note to maintainers: The "magic" number 8 that appears in this routine
;is because APR counts 0 thru 7 are various arithmetic traps.
;The entry number is determined by 3 PC flag bits in combination.
SEARCH MTHPRM,FORPRM
EXTERN FOROP.
SEGMENT CODE
HELLO (OVERFL)
;
; [4100] Check for compatibility flagging.
;
SKIPE [FLGON.##] ;[4100]Is any compatbility flagging on?
$FCALL CFX ;[4100]Yes; display the compatibility message
PUSH P,T2 ;SAVE
PUSH P,T3 ; REGS
MOVEI T0,FO$APR ;Read APR table addresses
XMOVEI T1,APRCT ;Into here
PUSHJ P,FOROP. ;READ THEM
XMOVEI T1,. ;[4030] GET LOCAL SECTION
TLNE T1,-1 ;[4030] IS SECTION NUMBER ZERO?
SKIPA T1,[<T1>B5] ;[4030] NO, USE "EFIW T1,"
MOVSI T1,(IFIW (T1)) ;MAKE INDIRECT WORD INDEXED BY T1
IORM T1,APRCT ;[4030] POINTING TO COUNT TABLE
MOVEI T1,8-1 ;[4030] MAKE TABLE SOJG COUNTR
MOVEI T2,2 ;INIT ANSWER TO 2 (NO OVERFLOWS)
OVLP: MOVE T3,@APRCT ;GET CURRENT COUNT
CAMLE T3,OLDCT(T1) ;[2077][4007] GREATER THAN OLD COUNT?
MOVEI T2,1 ;YES, SET ANSWER TO 1 (OVERFLOW OCCURRED)
MOVEM T3,OLDCT(T1) ;[4030] STORE NEW COUNT
SOJG T1,OVLP ;[4030] LOOK THROUGH WHOLE TABLE
MOVEM T2,@0(L) ;STORE ANSWER FOR CALLER
SETZM T0 ;ASSUME NO OVERFLOW, T0=FALSE
CAIN T2,1 ;WAS THERE?
SETOM T0 ; YES, SET T0=TRUE
POP P,T3 ;RESTORE
POP P,T2 ; REGS
POPJ P, ;DONE
SEGMENT DATA
OLDCT: BLOCK 8 ;PREVIOUS APR COUNTS
APRCT: BLOCK 1 ;ADDRESS OF CURRENT APR COUNTS
APRLM: BLOCK 1 ;ADDRESS OF LIMITS
APRSB: BLOCK 1 ;ADDRESS OF SUBROUTINES
PRGEND
TITLE TRACE DUMMY ROUTINE DEFINES TRACE ENTRY IN FOROTS (FORERR)
SUBTTL D. TODD /DRT 05-APR-1973
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1973, 1985
;ALL RIGHTS RESERVED.
SEARCH MTHPRM,FORPRM
NOSYM
ENTRY TRACE ;HELLO MACRO CAN NOT BE USED
;SIXBIT NAME DEFINED IN TRACE (FORERR)
HELLO (TRACE)
;
; [4100] Check for compatibility flagging.
;
SKIPE [FLGON.##] ;Is any compatbility flagging on ?
$FCALL CFX ;Yes; display the compatibility message
PJRST TRACE.## ;Call the correct (dotted) name
PRGEND
TITLE INIOVL SUBROUTINE TO SET PRINCIPAL OVERLAY FILE
SUBTTL D. M. NIXON 10-MAY-74
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1974, 1985
;ALL RIGHTS RESERVED.
VERWHO==0 ;EDITOR
VERVER==1 ;MAJOR VERSION NUMBER
VERUPD==0 ;MINOR VERSION NUMBER
VEREDT==1 ;EDIT NUMBER
ENTRY INIOVL
INIOVL=INIOV.## ;REAL SUBROUTINE IS IN OVRLAY
PRGEND
TITLE GETOVL SUBROUTINE TO GET LINKS INTO CORE
SUBTTL D. M. NIXON 10-MAY-74
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1974, 1985
;ALL RIGHTS RESERVED.
VERWHO==0 ;EDITOR
VERVER==1 ;MAJOR VERSION NUMBER
VERUPD==0 ;MINOR VERSION NUMBER
VEREDT==1 ;EDIT NUMBER
ENTRY GETOVL
GETOVL=GETOV.## ;REAL SUBROUTINE IS IN OVRLAY
PRGEND
TITLE REMOVL SUBROUTINE TO REMOVE LINKS FROM CORE
SUBTTL D. M. NIXON 10-MAY-74
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1974, 1985
;ALL RIGHTS RESERVED.
VERWHO==0 ;EDITOR
VERVER==1 ;MAJOR VERSION NUMBER
VERUPD==0 ;MINOR VERSION NUMBER
VEREDT==1 ;EDIT NUMBER
ENTRY REMOVL
REMOVL=REMOV.## ;REAL SUBROUTINE IS IN OVRLAY
PRGEND
TITLE RUNOVL SUBROUTINE TO JUMP TO START ADDRESS OF LINK
SUBTTL D. M. NIXON 10-MAY-74
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1974, 1985
;ALL RIGHTS RESERVED.
VERWHO==0 ;EDITOR
VERVER==1 ;MAJOR VERSION NUMBER
VERUPD==0 ;MINOR VERSION NUMBER
VEREDT==1 ;EDIT NUMBER
ENTRY RUNOVL
RUNOVL=RUNOV.## ;REAL SUBROUTINE IS IN OVRLAY
PRGEND
TITLE LOGOVL SUBROUTINE TO SET LOG OVERLAY FILE
SUBTTL D. M. NIXON 10-MAY-74
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1974, 1985
;ALL RIGHTS RESERVED.
VERWHO==0 ;EDITOR
VERVER==1 ;MAJOR VERSION NUMBER
VERUPD==0 ;MINOR VERSION NUMBER
VEREDT==1 ;EDIT NUMBER
ENTRY LOGOVL
LOGOVL=LOGOV.## ;REAL SUBROUTINE IS IN OVRLAY
PRGEND
TITLE TMPOVL SUBROUTINE TO SET WRITABLE OVERLAY FILE
SUBTTL D. M. NIXON 10-MAY-74
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1974, 1985
;ALL RIGHTS RESERVED.
VERWHO==0 ;EDITOR
VERVER==1 ;MAJOR VERSION NUMBER
VERUPD==0 ;MINOR VERSION NUMBER
VEREDT==1 ;EDIT NUMBER
ENTRY TMPOVL
TMPOVL=TMPOV.## ;REAL SUBROUTINE IS IN OVRLAY
PRGEND
TITLE SAVOVL SUBROUTINE TO MARK LINK AS WRITABLE
SUBTTL D. M. NIXON 10-MAY-74
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1974, 1985
;ALL RIGHTS RESERVED.
VERWHO==0 ;EDITOR
VERVER==1 ;MAJOR VERSION NUMBER
VERUPD==0 ;MINOR VERSION NUMBER
VEREDT==1 ;EDIT NUMBER
ENTRY SAVOVL
SAVOVL=SAVOV.## ;REAL SUBROUTINE IS IN OVRLAY
PRGEND
TITLE CLROVL SUBROUTINE TO MARK LINK AS NOT WRITABLE
SUBTTL D. M. NIXON 10-MAY-74
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1974, 1985
;ALL RIGHTS RESERVED.
VERWHO==0 ;EDITOR
VERVER==1 ;MAJOR VERSION NUMBER
VERUPD==0 ;MINOR VERSION NUMBER
VEREDT==1 ;EDIT NUMBER
ENTRY CLROVL
CLROVL=CLROV.## ;REAL SUBROUTINE IS IN OVRLAY
PRGEND
TITLE FDDT - DUMMY FORDDT
SUBTTL D. M. NIXON/DMN/CKS/AHM 21-Apr-83
SEARCH MTHPRM,FORPRM
FSRCH
SEGMENT DATA ;[3311] Put this in the lowseg because
;[3124] FDDT. is impure
IF20,<
DEFINE OUTSTR (X) <
PUSH P,T1 ;[3124] Save T1
HRROI T1,X
PSOUT%
POP P,T1 ;[3124] Restore T1
>
>
HELLO (FDDT.)
PUSHJ P,.+1 ;FIRST TIME IN
OUTSTR [ASCIZ /%FORDDT not loaded
/]
PUSH P,[CAI] ;REPLACE WITH NO-OP
POP P,FDDT. ;SO WE ONLY SEE MESSAGE ONCE
POPJ P, ;RETURN
PRGEND
TITLE EXIT
SEARCH MTHPRM,FORPRM
ENTRY EXIT
EXTERN EXIT.
HELLO (EXIT)
;
; [4100] Check for compatibility flagging
;
SKIPE [FLG77.##] ;Is ANSI compatbility flagging on ?
$FCALL CFR ;Yes; display the compatibility message
PJRST EXIT.## ;Call the correct (dotted) name
PRGEND
TITLE EXIT1
;ENTRY POINT TO JUST CLOSE FILES
ENTRY EXIT1
EXTERN EXIT1.
EXIT1==<EXIT1.+0>
PRGEND
TITLE QUIETX
SEARCH MTHPRM,FORPRM
;[3407] DOES A QUIET EXIT FROM FOROTS (NO CPU TIME MESSAGE, NO ERROR
;[3407] SUMMARIES, IF ANY)
EXTERN FOROP.
SEGMENT CODE
HELLO (QUIETX) ;[4121] User callable subroutine
MOVEI T0,FO$QIT ;QUIET EXIT FUNCTION
PJRST FOROP.
PRGEND
TITLE PROSB. Substring bounds checking routine
SUBTTL CHRIS SMITH/CKS 8-Jun-82
;[3132] New
;Routine to perform substring bounds checking.
;The compiler transforms the substring reference
;
; VAR(LB:UB)
;
;into
;
; VAR(LB: PROSB.(VAR,LB-1,UB,ISN,'VAR') )
;
;where PROSB. checks the validity of LB and UB, then returns UB. If the bounds
;are invalid, a warning message is typed. (LB-1 is used instead of LB because
;LB-1 is conveniently available in the compiler's internal representation of
;substrings.)
;The conditions for valid substring bounds are
;
; LB .LE. UB
; LB .GE. 1
; UB .LE. LEN(VAR)
;
;If a bound is found to be out of range, a warning message is typed. No
;attempt at correction is made - the program will get the same results as if
;/DEBUG:BOUNDS were not specified, except for the message.
SEARCH MTHPRM,FORPRM
SEGMENT CODE
SALL
;Argument block offsets
VAR==0 ;Variable we're taking substring of
LB==1 ;Lower bound - 1
UB==2 ;Upper bound
ISN==3 ;Statement number of substring reference
VARNAME==4 ;Sixbit variable name for error message
HELLO (PROSB.)
PUSH P,T2 ;SAVE ACS
PUSH P,T3
XMOVEI T1,@VAR(L) ;GET POINTER TO DESCRIPTOR
MOVE T1,1(T1) ;GET CHARACTER VARIABLE LENGTH
MOVE T2,@LB(L) ;GET LOWER BOUND - 1
MOVE T3,@UB(L) ;GET UPPER BOUND
JUMPL T2,SERR ;CHECK LB .GE. 1 (LB-1 .GE. 0)
CAML T2,T3 ;MUST HAVE LB .LE. UB (LB-1 .LT. UB)
JRST SERR ;NO, ERROR
CAMLE T3,T1 ;CHECK UB .LE. LENGTH
JRST SERR ;NO, ERROR
;Return UB.
RET: MOVE T0,@UB(L) ;RETURN UB FOR SUBSTRING CALCULATION
POP P,T3 ;RESTORE ACS
POP P,T2
POPJ P, ;RETURN
;Here on error, type message and return normally.
SERR: PUSH P,T4 ;SAVE SOME MORE REGISTERS FOR ERR MESSAGE
PUSH P,T5
MOVE T4,@ISN(L) ;GET ISN
MOVE T5,@VARNAME(L) ;GET VARIABLE NAME
ADDI T2,1 ;CONVERT LB-1 TO LB
$FCALL SSE ;"%Substring range error VAR(LB:UB)
; on line ISN at LABEL+OFFSET"
POP P,T5 ;RESTORE REGISTERS
POP P,T4
JRST RET ;GO RETURN UB
PRGEND
TITLE PA1050
SEARCH MTHPRM,FORPRM
EXTERN FOROP.
SEGMENT CODE
HELLO (PA1050)
MOVEI T0,FO$PAT ;ALLOW AND GET PA1050
PJRST FOROP.
PRGEND
TITLE FFUNIT
SEARCH MTHPRM,FORPRM
EXTERN FOROP.
SEGMENT CODE
HELLO (FFUNIT)
;
; [4130] Check for compatibility flagging.
;
SKIPE [FLGON.##] ;[4130]Is any compatbility flagging on?
$FCALL CFX ;[4130]Yes; display the compatibility message
MOVEI T0,FO$GFU ;GET # OF FIRST FREE UNIT
PUSHJ P,FOROP.
MOVEM T0,@(L) ;SAVE IN USER'S VARIABLE
POPJ P,
PRGEND ;[3142] End of the routine
TITLE TOPMEM ALLOCATE MEMORY FROM TOP DOWN
SUBTTL TGS 20-Oct-83
SEARCH MTHPRM,FORPRM ;[3362]
EXTERN FOROP.,ABORT. ;[3362]
SEGMENT CODE ;[3362]
;[3362] SET ENDP AND STARTP TO DESIRED PAGE NUMBER TO FORCE MEMORY
;[3362] ALLOCATION FROM THE TOP DOWN. NO PREALLOCATION FOR SORT'S PAGES
;[3362] IS DONE.
;[3362] USER CALL:
;[3362] CALL TOPMEM (<top page number>)
HELLO (TOPMEM) ;[3362]
MOVE T1,@0(L) ;[3362] GET PAGE NUMBER ARGUMENT
CAIG T1,777 ;[3362] WITHIN RANGE?
CAIG T1,0 ;[3362] 1-777?
$FCALL IPN,ABORT. ;[3362] NO, DIE.
MOVEI T0,FO$NOS ;[3362] FOROP FUNCTION TO SET ENDP/STARTP
PUSHJ P,FOROP. ;[3362] DO IT.
GOODBY ;[3362] RETURN
PRGEND ;[3362]
TITLE SRTINI ALLOCATE MEMORY TOPDOWN AND PREALLOCATE SORT
SUBTTLE TGS 20-Oct-83
SEARCH MTHPRM,FORPRM ;[3362]
EXTERN FOROP.,ABORT.,%PASRT ;[3362]
SEGMENT CODE ;[3362]
;[3362] SET ENDP AND STARTP TO DESIRED PAGE NUMBER TO FORCE MEMORY
;[3362] ALLOCATION FROM THE TOP DOWN. ALSO PREALLOCATE PAGES FOR SORT.
;[3362] FOROP. CALL FO$SRT SETS A FLAG SO FORSRT WON'T ALSO TRY TO PREALLOCATE.
;[3362] CALLING THIS ROUTINE SHOULD BE UNNECESSARY ON EXTENDED MACHINES SINCE
;[3362] SORT WILL BE IN ITS OWN SECTION.
;[3362] USER CALL:
;[3362] CALL SRTINI (<top page number>)
HELLO (SRTINI) ;[3362]
MOVE T1,@0(L) ;[3362] GET PAGE NUMBER ARGUMENT
CAIG T1,777 ;[3362] WITHIN RANGE?
CAIG T1,0 ;[3362] 1-777?
$FCALL IPN,ABORT. ;[3362] NO, DIE.
MOVEI T0,FO$SRT ;[3362] FOROP. FUNCTION CODE TO SET ENDP/STARTP
PUSHJ P,FOROP. ;[3362] AND PREALLOCATE SORT PAGES.
SETOM %PASRT ;[3362] ASSUME SUCCESS.
CAME T0,[-1] ;[3362] DID WE PREALLOCATE?
POPJ P, ;[3362] YES, RETURN.
SETZM %PASRT ;[3362] NO. CLEAR FLAG,
$FCALL CPP ;[3362] WARN AND RETURN.
POPJ P, ;[3362] RETURN
PRGEND ;[3362]
TITLE FORMSL - Fortran Library error message macros
SUBTTL Jon Campbell/JLC 28-May-82
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1982, 1985
;ALL RIGHTS RESERVED.
;++
; FUNCTIONAL DESCRIPTION:
;
; Defines the text of error messages in the fortran library (FORLIB).
; Uses the Macro $FERR to generate error messages in propper format.
;
; Arguments to $FERR:
; $FERR( 1st - Warning/error character (? or %),
; 2nd - Unique three character pnuemonic for error
; message. A F.<3 character> symbol is created,
; 3rd - Error class number. (21 for Forlib error messages.)
; 4th - Unique error number for message. (Not currently used.)
; 5th - Message to appear
;
; For more information the error message macros see FORPRM & MTHPRM.
;
; CALLING SEQUENCE:
;
; Called from FORLIB code with a $FCALL macro (which generates):
;
; JRST F.nnn ;Where nnn is the 3 letter error code.
;
; For more information on the $FERR macro see FORPRM.
;
; INPUT PARAMETERS:
;
; None
;
; IMPLICIT INPUTS:
;
; None
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; None
;
; SIDE EFFECTS:
;
; None
;
;--
SEARCH MTHPRM, FORPRM
SEGMENT CODE
RADIX 10
SALL
$FERR (%,CFF,33,322,$I Intrinsic routine $N invoked incompatibly,<[VAXIDX]>);[4100]
IF20,< $FERR (%,CFR,33,323,$I FORTRAN-20 supplied routine $N invoked,<[ANSIDX]>)
$FERR (%,CFX,33,323,$I FORTRAN-20 supplied routine $N invoked,<[ANSIDX+VAXIDX]>) >;END IF20
IF10,< $FERR (%,CFR,33,323,$I FORTRAN-10 supplied routine $N invoked,<[ANSIDX]>)
$FERR (%,CFX,33,323,$I FORTRAN-10 supplied routine $N invoked,<[ANSIDX+VAXIDX]>) >;END IF10
$FERR (%,CFO,33,326,$I Overlap of character assignments,<[VAXIDX]>)
$FERR (?,IOE,98,0,$J) ;General-purpose I/O error
$FERR (%,NOR,-1,0,ERRSET: error number out of range - ignored)
;[3205] 21,102 was VDM
;[3205] 21,103 was ICF
$FERR (?,IDU,21,104,DIVERT: illegal to divert to unit $D,<T1>)
$FERR (?,UNO,21,105,DIVERT: unit $D is not open,<T1>)
$FERR (?,NOF,21,106,DIVERT: unit $D is not open for FORMATTED I/O,<T1>)
$FERR (?,CWU,21,107,DIVERT: Can't write to unit $D,<T1>)
$FERR (?,CLE,21,108,<Concatenation result larger than expected>)
$FERR (?,ICE,21,109,<Illegal length character expression>)
$FERR (?,NCS,21,110,No character stack allocated - compiler error)
;[4101] 21,111 was NCA
$FERR (?,AQS,21,112,<First argument to SORT must be a quoted string>) ;[3205]
$FERR (%,SSE,23,113,<Substring range error $S($D:$D)
on line $D>,<T5,T2,T3,T4>)
$FERR (%,SRE,23,114,<Subscript range error - subscript $D of array $S = $D
on line $D>,<T1,T2,P2,T3>)
$FERR (?,TMA,21,115,<Too many arguments in call to SORT>) ;[3205]
$FERR (?,CGP,21,116,<Can't get pages 600:677 for SORT>) ;[3205]
$FERR (?,MXD,-1,0,<Missing EXTERNAL declaration in CALL to $N>);[3322]
$FERR (%,WNA,21,0,<Wrong number of arguments in call to $N>) ;[4207]
$FERR (%,NFL,21,0,<Argument to SECNDS not floating point>) ;[4207]
IF10,<
$FERR (?,CRP,21,117,<Can't return pages 600:677 after call to SORT>)
> ; End of IF10
IF20,<
$FERR (?,NSS,21,118,<No free section available for SORT>) ;[3205]
$FERR (?,CFS,21,119,<Can't find SYS:SORT.EXE - $J>) ;[3205]
$FERR (?,CGS,21,120,<Can't get SYS:SORT.EXE - $J>) ;[3205]
> ; End of IF20
$FERR (%,CPP,21,121,<Can't preallocate pages 600:677 for SORT>) ;[3362]
$FERR (?,IPN,21,122,Illegal page number $O,<T1>) ;[3362]
$FERR (?,SNH,-1,0,<Internal FOROTS error>) ;[3205]
IF20,< ;[3205]
$FERR (?,IJE,-1,0,<Internal FOROTS JSYS error - $J>) ;[3205]
$FERR (%,DMA,21,126,<$N: Must give lower and upper bounds to dump in non-zero section>) ;[4110]
> ; End of IF20 ;[3205]
$FERR (?,CCS,21,123,<Not enough memory for creating character stack>) ;[4101]
$FERR (?,ECS,21,124,<Not enough memory for expanding character stack>) ;[4101]
$FERR (?,ALZ,21,125,<$N: Argument less than or equal to zero>) ;[4101]
PRGEND
TITLE IIABS -- VAX FORTRAN INTEGER*2 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY IIABS
EXTERN IABS.
IIABS=<IABS.+0>
PRGEND
TITLE JIABS -- VAX FORTRAN INTEGER*4 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY JIABS
EXTERN IABS.
JIABS=<IABS.+0>
PRGEND
TITLE IINT -- VAX FORTRAN INTEGER*2 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY IINT
EXTERN INT.
IINT=<INT.+0>
PRGEND
TITLE JINT -- VAX FORTRAN INTEGER*4 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY JINT
EXTERN INT.
JINT=<INT.+0>
PRGEND
TITLE IIDINT -- VAX FORTRAN INTEGER*2 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY IIDINT
EXTERN IDINT.
IIDINT=<IDINT.+0>
PRGEND
TITLE JIDINT -- VAX FORTRAN INTEGER*4 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY JIDINT
EXTERN IDINT.
JIDINT=<IDINT.+0>
PRGEND
TITLE ININT -- VAX FORTRAN INTEGER*2 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY ININT
EXTERN NINT.
ININT=<NINT.+0>
PRGEND
TITLE JNINT -- VAX FORTRAN INTEGER*4 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY JNINT
EXTERN NINT.
JNINT=<NINT.+0>
PRGEND
TITLE IIDNNT -- VAX FORTRAN INTEGER*2 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY IIDNNT
EXTERN IDNIN.
IIDNNT=<IDNIN.+0>
PRGEND
TITLE JIDNNT -- VAX FORTRAN INTEGER*4 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY JIDNNT
EXTERN IDNIN.
JIDNNT=<IDNIN.+0>
PRGEND
TITLE FLOATI -- VAX FORTRAN INTEGER*2 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY FLOATI
EXTERN FLOAT.
FLOATI=<FLOAT.+0>
PRGEND
TITLE FLOATJ -- VAX FORTRAN INTEGER*4 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY FLOATJ
EXTERN FLOAT.
FLOATJ=<FLOAT.+0>
PRGEND
TITLE IIFIX -- VAX FORTRAN INTEGER*2 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY IIFIX
EXTERN IFIX.
IIFIX=<IFIX.+0>
PRGEND
TITLE JIFIX -- VAX FORTRAN INTEGER*4 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY JIFIX
EXTERN IFIX.
JIFIX=<IFIX.+0>
PRGEND
TITLE DFLOTI -- VAX FORTRAN INTEGER*2 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY DFLOTI
EXTERN DFLOT.
DFLOTI=<DFLOT.+0>
PRGEND
TITLE DFLOTJ -- VAX FORTRAN INTEGER*4 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY DFLOTJ
EXTERN DFLOT.
DFLOTJ=<DFLOT.+0>
PRGEND
TITLE IMAX0 -- VAX FORTRAN INTEGER*2 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY IMAX0
EXTERN MAX0.
IMAX0=<MAX0.+0>
PRGEND
TITLE JMAX0 -- VAX FORTRAN INTEGER*4 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY JMAX0
EXTERN MAX0.
JMAX0=<MAX0.+0>
PRGEND
TITLE IMAX1 -- VAX FORTRAN INTEGER*2 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY IMAX1
EXTERN MAX1.
IMAX1=<MAX1.+0>
PRGEND
TITLE JMAX1 -- VAX FORTRAN INTEGER*4 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY JMAX1
EXTERN MAX1.
JMAX1=<MAX1.+0>
PRGEND
TITLE AIMAX0 -- VAX FORTRAN INTEGER*2 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY AIMAX0
EXTERN AMAX0.
AIMAX0=<AMAX0.+0>
PRGEND
TITLE AJMAX0 -- VAX FORTRAN INTEGER*4 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY AJMAX0
EXTERN AMAX0.
AJMAX0=<AMAX0.+0>
PRGEND
TITLE IMIN0 -- VAX FORTRAN INTEGER*2 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY IMIN0
EXTERN MIN0.
IMIN0=<MIN0.+0>
PRGEND
TITLE JMIN0 -- VAX FORTRAN INTEGER*4 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY JMIN0
EXTERN MIN0.
JMIN0=<MIN0.+0>
PRGEND
TITLE IMIN1 -- VAX FORTRAN INTEGER*2 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY IMIN1
EXTERN MIN1.
IMIN1=<MIN1.+0>
PRGEND
TITLE JMIN1 -- VAX FORTRAN INTEGER*4 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY JMIN1
EXTERN MIN1.
JMIN1=<MIN1.+0>
PRGEND
TITLE AIMIN0 -- VAX FORTRAN INTEGER*2 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY AIMIN0
EXTERN AMIN0.
AIMIN0=<AMIN0.+0>
PRGEND
TITLE AJMIN0 -- VAX FORTRAN INTEGER*4 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY AJMIN0
EXTERN AMIN0.
AJMIN0=<AMIN0.+0>
PRGEND
TITLE IIDIM -- VAX FORTRAN INTEGER*2 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY IIDIM
EXTERN IDIM.
IIDIM=<IDIM.+0>
PRGEND
TITLE JIDIM -- VAX FORTRAN INTEGER*4 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY JIDIM
EXTERN IDIM.
JIDIM=<IDIM.+0>
PRGEND
TITLE IMOD -- VAX FORTRAN INTEGER*2 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY IMOD
EXTERN MOD.
IMOD=<MOD.+0>
PRGEND
TITLE JMOD -- VAX FORTRAN INTEGER*4 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY JMOD
EXTERN MOD.
JMOD=<MOD.+0>
PRGEND
TITLE IISIGN -- VAX FORTRAN INTEGER*2 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY IISIGN
EXTERN ISIGN.
IISIGN=<ISIGN.+0>
PRGEND
TITLE JISIGN -- VAX FORTRAN INTEGER*4 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY JISIGN
EXTERN ISIGN.
JISIGN=<ISIGN.+0>
PRGEND
TITLE BITEST -- VAX FORTRAN INTEGER*2 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY BITEST
EXTERN BTEST.
BITEST=<BTEST.+0>
PRGEND
TITLE BJTEST -- VAX FORTRAN INTEGER*4 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY BJTEST
EXTERN BTEST.
BJTEST=<BTEST.+0>
PRGEND
TITLE IIAND -- VAX FORTRAN INTEGER*2 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY IIAND
EXTERN IAND.
IIAND=<IAND.+0>
PRGEND
TITLE JIAND -- VAX FORTRAN INTEGER*4 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY JIAND
EXTERN IAND.
JIAND=<IAND.+0>
PRGEND
TITLE IIBCLR -- VAX FORTRAN INTEGER*2 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY IIBCLR
EXTERN IBCLR.
IIBCLR=<IBCLR.+0>
PRGEND
TITLE JIBCLR -- VAX FORTRAN INTEGER*4 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY JIBCLR
EXTERN IBCLR.
JIBCLR=<IBCLR.+0>
PRGEND
TITLE IIBITS -- VAX FORTRAN INTEGER*2 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY IIBITS
EXTERN IBITS.
IIBITS=<IBITS.+0>
PRGEND
TITLE JIBITS -- VAX FORTRAN INTEGER*4 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY JIBITS
EXTERN IBITS.
JIBITS=<IBITS.+0>
PRGEND
TITLE IIBSET -- VAX FORTRAN INTEGER*2 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY IIBSET
EXTERN IBSET.
IIBSET=<IBSET.+0>
PRGEND
TITLE JIBSET -- VAX FORTRAN INTEGER*4 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY JIBSET
EXTERN IBSET.
JIBSET=<IBSET.+0>
PRGEND
TITLE IIEOR -- VAX FORTRAN INTEGER*2 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY IIEOR
EXTERN IEOR.
IIEOR=<IEOR.+0>
PRGEND
TITLE JIEOR -- VAX FORTRAN INTEGER*4 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY JIEOR
EXTERN IEOR.
JIEOR=<IEOR.+0>
PRGEND
TITLE IIOR -- VAX FORTRAN INTEGER*2 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY IIOR
EXTERN IOR.
IIOR=<IOR.+0>
PRGEND
TITLE JIOR -- VAX FORTRAN INTEGER*4 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY JIOR
EXTERN IOR.
JIOR=<IOR.+0>
PRGEND
TITLE IISHFT -- VAX FORTRAN INTEGER*2 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY IISHFT
EXTERN ISHFT.
IISHFT=<ISHFT.+0>
PRGEND
TITLE JISHFT -- VAX FORTRAN INTEGER*4 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY JISHFT
EXTERN ISHFT.
JISHFT=<ISHFT.+0>
PRGEND
TITLE INOT -- VAX FORTRAN INTEGER*2 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*2 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY INOT
EXTERN NOT.
INOT=<NOT.+0>
PRGEND
TITLE JNOT -- VAX FORTRAN INTEGER*4 FUNCTION NAME
SUBTTL R. Meyers/RVM 12-Sep-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4162.
;
; Provide the VAX-11 FORTRAN INTEGER*4 function name as a synonym of
; the FORTRAN-10/20 INTEGER function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY JNOT
EXTERN NOT.
JNOT=<NOT.+0>
PRGEND
TITLE BTEST -- Undotted Function name
SUBTTL R. Meyers/RVM 2-Nov-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4163.
;
; Provide the undottend name of the bit function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY BTEST
EXTERN BTEST.
BTEST=<BTEST.+0>
PRGEND
TITLE IAND -- Undotted Function name
SUBTTL R. Meyers/RVM 2-Nov-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4163.
;
; Provide the undottend name of the bit function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY IAND
EXTERN IAND.
IAND=<IAND.+0>
PRGEND
TITLE IBCLR -- Undotted Function name
SUBTTL R. Meyers/RVM 2-Nov-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4163.
;
; Provide the undottend name of the bit function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY IBCLR
EXTERN IBCLR.
IBCLR=<IBCLR.+0>
PRGEND
TITLE IBITS -- Undotted Function name
SUBTTL R. Meyers/RVM 2-Nov-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4163.
;
; Provide the undottend name of the bit function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY IBITS
EXTERN IBITS.
IBITS=<IBITS.+0>
PRGEND
TITLE IBSET -- Undotted Function name
SUBTTL R. Meyers/RVM 2-Nov-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4163.
;
; Provide the undottend name of the bit function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY IBSET
EXTERN IBSET.
IBSET=<IBSET.+0>
PRGEND
TITLE IEOR -- Undotted Function name
SUBTTL R. Meyers/RVM 2-Nov-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4163.
;
; Provide the undottend name of the bit function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY IEOR
EXTERN IEOR.
IEOR=<IEOR.+0>
PRGEND
TITLE IOR -- Undotted Function name
SUBTTL R. Meyers/RVM 2-Nov-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4163.
;
; Provide the undottend name of the bit function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY IOR
EXTERN IOR.
IOR=<IOR.+0>
PRGEND
TITLE ISHFT -- Undotted Function name
SUBTTL R. Meyers/RVM 2-Nov-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4163.
;
; Provide the undottend name of the bit function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY ISHFT
EXTERN ISHFT.
ISHFT=<ISHFT.+0>
PRGEND
TITLE ISHFTC -- Undotted Function name
SUBTTL R. Meyers/RVM 2-Nov-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4163.
;
; Provide the undottend name of the bit function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY ISHFTC
EXTERN ISHFC.
ISHFTC=<ISHFC.+0>
PRGEND
TITLE NOT -- Undotted Function name
SUBTTL R. Meyers/RVM 2-Nov-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4163.
;
; Provide the undottend name of the bit function.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY NOT
EXTERN NOT.
NOT=<NOT.+0>
PRGEND
TITLE MVBITS -- Undotted Subroutine name
SUBTTL R. Meyers/RVM 2-Nov-84
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;+
; Created in edit 4163.
;
; Provide the undottend name of the bit subroutine.
;
;-
SEARCH MTHPRM
NOSYM
ENTRY MVBITS
EXTERN MVBIT.
MVBITS=<MVBIT.+0>
PRGEND
TITLE BTEST. - Test a Bit for Being On
SUBTTL Randall Meyers/RVM 3-Oct-83
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;++ [4074] Create this routine
; FUNCTIONAL DESCRIPTION:
;
; This function is a logical function. The ith bit of argument
; 'n' is tested. If it is 1, the value of this function is
; .TRUE.; if it is 0, the value of the function is .FALSE.
;
; CALLING SEQUENCE:
;
; FLAG = BTEST(N, I)
;
; INPUT PARAMETERS:
;
; N An INTEGER containing the bit to be tested.
; I An INTEGER that is the bit position of the bit to be
; tested (0 is the rightmost bit).
;
; IMPLICIT INPUTS:
;
; None
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; .TRUE. If the bit tested was one.
; .FALSE. If the bit tested was zero.
;
; SIDE EFFECTS:
;
; None
;
;--
SEARCH MTHPRM,FORPRM
FSRCH
SEGMENT CODE
HELLO (BTEST.) ;Entry to BTEST function
MOVE T1,@1(L) ;Get second argument
MOVEI T0,1 ;Get a one
LSH T0,(T1) ;Make up mask
TDNN T0,@0(L) ;Is the bit turned on?
TDZA T0,T0 ;No--return .FALSE.
SETO T0, ;Yes--return .TRUE.
POPJ P, ;Return
PRGEND
TITLE IAND. - Bitwise AND
SUBTTL Randall Meyers/RVM 3-Oct-83
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;++ [4074] Create this routine
; FUNCTIONAL DESCRIPTION:
;
; This INTEGER function performs the bitwise AND of its two
; INTEGER arguments.
;
; CALLING SEQUENCE:
;
; IANS = IAND(M, N)
;
; INPUT PARAMETERS:
;
; M An INTEGER to be AND'ed
; N An INTEGER to be AND'ed
;
; IMPLICIT INPUTS:
;
; None
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; The bitwise and of the two arguments as an INTEGER.
;
; SIDE EFFECTS:
;
; None
;
;--
SEARCH MTHPRM,FORPRM
FSRCH
SEGMENT CODE
HELLO (IAND.) ;Entry to IAND function
MOVE T0,@0(L) ;Get first argument
AND T0,@1(L) ;AND with second argument
POPJ P, ;Return
PRGEND
TITLE IBCLR. - Clear a bit
SUBTTL Randall Meyers/RVM 3-Oct-83
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;++ [4074] Create this routine
; FUNCTIONAL DESCRIPTION:
;
; This INTEGER function returns a copy of argument N with the
; ith bit set to zero.
;
; CALLING SEQUENCE:
;
; IANS = IBCLR(N, I)
;
; INPUT PARAMETERS:
;
; N An INTEGER containing the bit to be cleared.
; I An INTEGER that is the bit position of the bit to be
; cleared (0 is the rightmost bit).
;
; IMPLICIT INPUTS:
;
; None
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; A copy of argument N with bit I set to zero.
;
; SIDE EFFECTS:
;
; None
;
;--
SEARCH MTHPRM,FORPRM
FSRCH
SEGMENT CODE
HELLO (IBCLR.) ;Entry to IBCLR function
MOVE T1,@1(L) ;Get second argument
MOVEI T0,1 ;Get a one
LSH T0,(T1) ;Make up mask
ANDCA T0,@0(L) ;Get first argument with bit turned off
POPJ P, ;Return
PRGEND
TITLE IBITS. - Extract a bit field
SUBTTL Randall Meyers/RVM 3-Oct-83
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;++ [4074] Create this routine
; FUNCTIONAL DESCRIPTION:
;
; This INTEGER function extracts a subfield of 'LEN' bits from
; 'M' starting with bit position 'I' and extending left for
; 'LEN'. The result field is right justified and the remaining
; bits are set to zero. The value of I must be greater than or
; equal to zero, and less than 35. The value of I+LEN must be
; less than or equal to 36.
;
; CALLING SEQUENCE:
;
; IANS = IBITS(M, I, LEN)
;
; INPUT PARAMETERS:
;
; M An INTEGER, the source of the bitfield.
; I An INTEGER, the starting position of the bitfield (the
; leftmost bit).
; LEN An INTEGER, the length of the bitfield.
;
; IMPLICIT INPUTS:
;
; None
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; The bitfield, right justified, as an INTEGER.
;
; SIDE EFFECTS:
;
; None
;
;--
SEARCH MTHPRM,FORPRM
FSRCH
SEGMENT CODE
HELLO (IBITS.) ;Entry to IBITS function
MOVE T0,@1(L) ;Get argument 2 (The start of bit field)
DPB T0,[POINT 6,PTR,5] ;Store in pointer
MOVE T0,@2(L) ;Get argument 3 (The size of the bit field)
DPB T0,[POINT 6,PTR,11] ;Store in pointer
LDB T0,PTR ;Get bit field
POPJ P, ;Return
LIT
SEGMENT DATA
PTR: POINT .-.,@0(L),.-. ;Pointer to first argument
PRGEND
TITLE IBSET. - Set a bit
SUBTTL Randall Meyers/RVM 3-Oct-83
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;++ [4074] Create this routine
; FUNCTIONAL DESCRIPTION:
;
; This INTEGER function returns a copy of its first argument
; with a bit to one.
;
; CALLING SEQUENCE:
;
; IANS = IBSET(N, I)
;
; INPUT PARAMETERS:
;
; N An INTEGER containing the source bitstring.
; I An INTEGER that is the bit position of the bit to be
; set (0 is the rightmost bit).
;
; IMPLICIT INPUTS:
;
; None
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; A copy of the first argument with the I'th bit set to one.
;
; SIDE EFFECTS:
;
; None
;
;--
SEARCH MTHPRM,FORPRM
FSRCH
SEGMENT CODE
HELLO (IBSET.) ;Entry to IBSET function
MOVE T1,@1(L) ;Get second argument
MOVEI T0,1 ;Get a one
LSH T0,(T1) ;Make up mask
IOR T0,@0(L) ;Get first argument with specified bit on
POPJ P, ;Return
PRGEND
TITLE IEOR. - Bitwise Exclusive OR
SUBTTL Randall Meyers/RVM 3-Oct-83
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;++ [4074] Create this routine
; FUNCTIONAL DESCRIPTION:
;
; This INTEGER function performs the bitwise exclusive OR of its
; two INTEGER arguments.
;
; CALLING SEQUENCE:
;
; IANS = IEOR(M, N)
;
; INPUT PARAMETERS:
;
; M An INTEGER to be exclusive OR'ed
; N An INTEGER to be exclusive OR'ed
;
; IMPLICIT INPUTS:
;
; None
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; The bitwise exclusive OR of the two arguments as an INTEGER.
;
; SIDE EFFECTS:
;
; None
;
;--
SEARCH MTHPRM,FORPRM
FSRCH
SEGMENT CODE
HELLO (IEOR.) ;Entry to IEOR function
MOVE T0,@0(L) ;Get first argument
XOR T0,@1(L) ;Exclusive OR with second argument
POPJ P, ;Return
PRGEND
TITLE IOR. - Bitwise Inclusive OR
SUBTTL Randall Meyers/RVM 3-Oct-83
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;++ [4074] Create this routine
; FUNCTIONAL DESCRIPTION:
;
; This INTEGER function performs the bitwise inclusive OR of its
; two INTEGER arguments.
;
; CALLING SEQUENCE:
;
; IANS = IOR(M, N)
;
; INPUT PARAMETERS:
;
; M An INTEGER to be inclusive OR'ed
; N An INTEGER to be inclusive OR'ed
;
; IMPLICIT INPUTS:
;
; None
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; The bitwise inclusive OR of the two arguments as an INTEGER.
;
; SIDE EFFECTS:
;
; None
;
;--
SEARCH MTHPRM,FORPRM
FSRCH
SEGMENT CODE
HELLO (IOR.) ;Entry to IOR function
MOVE T0,@0(L) ;Get first argument
IOR T0,@1(L) ;Inclusive OR with second argument
POPJ P, ;Return
PRGEND
TITLE ISHFT. - Logical Shift
SUBTTL Randall Meyers/RVM 3-Oct-83
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;++ [4074] Create this routine
; FUNCTIONAL DESCRIPTION:
;
; This INTEGER function performs a LOGICAL shift of 'K' places.
;
; CALLING SEQUENCE:
;
; IANS = ISHFT(M, K)
;
; INPUT PARAMETERS:
;
; M The INTEGER to be shifted.
; K The INTEGER number of places to shift.
;
; IMPLICIT INPUTS:
;
; None
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; 'M' logically shifted by 'K' bits.
;
; SIDE EFFECTS:
;
; None
;
;--
SEARCH MTHPRM,FORPRM
FSRCH
SEGMENT CODE
HELLO (ISHFT.) ;Entry to ISHFT function
MOVE T0,@0(L) ;Get first argument
MOVE T1,@1(L) ;Get second argument
LSH T0,(T1) ;Shift
POPJ P, ;Return
PRGEND
TITLE ISHFC. - Logical Shift
SUBTTL Randall Meyers/RVM 3-Oct-83
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;++ [4074] Create this routine
; FUNCTIONAL DESCRIPTION:
;
; This INTEGER function circularly shifts the rightmost 'IC'
; bits of its argument 'K' places; i.e., the bits shifted out
; of one end are shifted into the opposite end. No bits are
; lost. The unshifted bits of the result are the same as the
; unshifted bits of the argument 'M'. The absolute value of the
; argument 'K' must be less than or equal to 'IC'. The argument
; 'IC' must be greater than zero and less than or equal to 36.
; (This function is known by the FORTRAN INTRISIC name 'ISHFTC'.)
;
; CALLING SEQUENCE:
;
; IANS = ISHFTC(M, K, IC)
;
; INPUT PARAMETERS:
;
; M The INTEGER to rotate.
; K The INTEGER number of places to rotate.
; IC The INTEGER size of the bitfield to rotate.
;
; IMPLICIT INPUTS:
;
; None
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; The rightmost 'IC' bits of 'M' logically rotated by 'K' bits.
;
; SIDE EFFECTS:
;
; None
;
;--
SEARCH MTHPRM,FORPRM
FSRCH
SEGMENT CODE
; T0 == argument
; T1 == shift factor
; T2 == byte to rotate
; T3 == byte to rotate
HELLO (ISHFC.) ;Entry to ISHFTC function
DMOVEM T2,SAVE23 ;Save T2 and T3
PUSH P,T4 ;[4206] Save T4
MOVE T0,@0(L) ;Get argument 1 (the bitstring)
MOVE T1,@1(L) ;Get argument 2 (the shift factor)
MOVE T2,@2(L) ;Get argument 3 (the byte size)
DPB T2,[POINT 6,PTR,11] ;Store byte size in pointer
LDB T3,PTR ;Get byte to be rotated
MOVE T2,T3 ;Get copy of byte
LSH T3,(T1) ;Shift to get high order part of rotated byte
MOVE T4,@2(L) ;[4206] Byte size
SKIPGE T1 ;[4206] If shift factor was negative,
MOVN T4,T4 ;[4206] Then negate byte size, make it positive
SUB T1,T4 ;[4206] Get shift factor used to form low order part
LSH T2,(T1) ;Shift to get low order part of rotated byte
OR T3,T2 ;Form rotated result
DPB T3,PTR ;Deposit in copy of original bitstring
POP P,T4 ;[4206] Restore T4
DMOVE T2,SAVE23 ;Restore T2 and T3
POPJ P, ;Return
LIT
SEGMENT DATA
PTR: POINT .-.,T0,35 ;Pointer to copy of first argument
SAVE23: BLOCK 2 ;Local storage for T2 and T3
PRGEND
TITLE MVBIT. - Extract a bit field
SUBTTL Randall Meyers/RVM 3-Oct-83
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;++ [4074] Create this routine
; FUNCTIONAL DESCRIPTION:
;
; This subroutine moves 'LEN' bits from positions 'I' through
; I+LEN-1 of argument 'M' to positions J through J+LEN-1 of
; argument 'N'. The portion of argument 'N' not affected by
; the movement of bits remians unchanged. All arguments are
; INTEGER expressions except 'N' must be a variable or array
; element. Arguments 'M' and 'N' are permitted to be the same
; numeric storage unit. The values of I+LEN and of J+LEN must
; be less than or equal to 36.
;
; CALLING SEQUENCE:
;
; CALL MVBITS(M, I, LEN, N, J)
;
; INPUT PARAMETERS:
;
; M The source of the bitstring to be transferred.
; I The bit position of the source bitstring in M.
; LEN The number of bits.
; N The destination (this word will have the bitsting
; inserted.
; J The bit position of the source bitstring in N.
;
;
; IMPLICIT INPUTS:
;
; None
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; None
;
; SIDE EFFECTS:
;
; None
;
;--
SEARCH MTHPRM,FORPRM
FSRCH
SEGMENT CODE
HELLO (MVBIT.) ;[4163] Entry to MVBITS function
MOVE T0,@1(L) ;Get argument 2 (Start of source field)
DPB T0,[POINT 6,SPTR,5] ;Store in pointer to source
MOVE T0,@4(L) ;Get argument 5 (Start of destination field)
DPB T0,[POINT 6,DPTR,5] ;Store in pointer to destination
MOVE T0,@2(L) ;Get argument 3 (The size of the bit fields)
DPB T0,[POINT 6,SPTR,11] ;Store in pointer to source
DPB T0,[POINT 6,DPTR,11] ;Store in pointer to destination
LDB T0,SPTR ;Get bit field from source
DPB T0,DPTR ;Store bit field in destination
POPJ P, ;Return
LIT
SEGMENT DATA
SPTR: POINT .-.,@0(L),.-. ;Pointer to first argument (source)
DPTR: POINT .-.,@3(L),.-. ;Pointer to fourth argument (destination)
PRGEND
TITLE NOT. - Bitwise NOT
SUBTTL Randall Meyers/RVM 3-Oct-83
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 1985
;ALL RIGHTS RESERVED.
;++ [4074] Create this routine
; FUNCTIONAL DESCRIPTION:
;
; This INTEGER function performs the bitwise logical complement
; of its INTEGER argument.
;
; CALLING SEQUENCE:
;
; IANS = NOT(M)
;
; INPUT PARAMETERS:
;
; M An INTEGER to be complemented.
;
; IMPLICIT INPUTS:
;
; None
;
; OUTPUT PARAMETERS:
;
; None
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; The bitwise logical complement of the argument.
;
; SIDE EFFECTS:
;
; None
;
;--
SEARCH MTHPRM,FORPRM
FSRCH
SEGMENT CODE
HELLO (NOT.) ;Entry to NOT function
SETCM T0,@0(L) ;Complement argument
POPJ P, ;Return
PRGEND
SEARCH MTHPRM,FORPRM
TV FORSYM SYMBOL TABLE MANIPULATION ROUTINES
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1974, 1985
;ALL RIGHTS RESERVED.
;[4152] NEW
;++
; FUNCTIONAL DESCRIPTION:
;
; Converts an IOWD or pointer to a symbol table (usually found
; in .JBSYM of FOROTS' section) into an address and count in
; T1 and T2.
;
; CALLING SEQUENCE:
;
; PUSHJ P,%SVCNV
;
; INPUT PARAMETERS:
;
; Symbol table IOWD or address of symbol vector in T1
;
; IMPLICIT INPUTS:
;
; None
;
; OUTPUT PARAMETERS:
;
; Address of symbol table in T1
; Length of symbol table in T2
;
; IMPLICIT OUTPUTS:
;
; None
;
; SIDE EFFECTS:
;
; None
;
;--
SEGMENT CODE
ENTRY %SVCNV
IF20,<
%SVCNV: TLNE T1,777000 ;[4174] IF ANY OF THESE BITS ARE SET
JRST STIOWD ;[4174] ASSUME IT'S AN IOWD
MOVE T3,.STLEN(T1) ;GET SYMBOL VECTOR LENGTH FOR SEARCHING IT
SUBI T3,1 ;MINUS THE COUNT WORD
ADDI T1,1 ;POINT TO 1ST ENTRY
SVCLP: LDB T2,[POINTR (.STDAT(T1),ST%TYP)] ;GET SYMBOL TYPE
CAIN T2,.R50D ;THE DEFINED SYMBOL TABLE?
JRST SVCDON ;YES. GO PICK UP ADDRESS AND LENGTH
ADDI T1,3 ;NO. GO TRY AGAIN
SUBI T3,3 ;DECREMENT COUNT
JUMPG T3,SVCLP ;LOOP IF MORE
SETZB T1,T2 ;RETURN NO SYMBOL TABLE IF NO MATCH
POPJ P,
SVCDON: LDB T2,[POINTR (.STDAT(T1),ST%LEN)] ;GET SYMBOL TABLE SIZE
MOVE T1,.STPTR(T1) ;AND ADDRESS
POPJ P,
> ;END IF20
IF10,<
%SVCNV:
> ;END IF10
STIOWD: HLRO T2,T1 ;[4174] GET NEGATIVE SIZE IN T2
MOVM T2,T2 ;GET POSITIVE
XMOVEI T1,(T1) ;GET ADDRESS OF SYMBOL TABLE
POPJ P,
PRGEND
SEARCH MTHPRM,FORPRM
TV SECNDS Returns seconds since midnight
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1985
;ALL RIGHTS RESERVED.
;[4207] NEW
;++
; FUNCTIONAL DESCRIPTION:
;
; User-callable routine which returns the number of seconds since
; midnight in single precision floating point, minus the argument
; passed to it.
;
; CALLING SEQUENCE:
;
; X = SECNDS( Y )
;
; Where X and Y are single precision floating point.
;
; INPUT PARAMETERS:
;
; Y (Shown above) A floating point number to be subtracted
; from the number of seconds from midnight.
;
; IMPLICIT INPUTS:
;
; None
;
; OUTPUT PARAMETERS:
;
; Function return value is in T0.
;
; IMPLICIT OUTPUTS:
;
; None
;
; FUNCTION VALUE:
;
; The number of seconds since midnight in floating point format.
;
; SIDE EFFECTS:
;
; None
;
;--
SEGMENT CODE
ENTRY SECNDS
HELLO (SECNDS)
;Check for correct number of arguments. Only 1 allowed.
HLRZ T0,-1(L) ;Get count of arguments
CAIE T0,-1 ;If -1 (one argument),
$FCALL WNA ;Wrong number of arguments
;Check argument to insure that it's floating point or octal.
LDB T0,[POINTR (0(L),ARGTYP)] ;Get argument type
CAIN T0,TP%SPR ;.NE. floating point?
JRST OK ;Yes, go around
CAIE T0,TP%SPO ;Argument single precision octal?
$FCALL NFL ;Argument isn't floating or octal
OK: SKIPE [FLG77.##] ;Is /FLAG:ANSI on?
$FCALL CFX ;Yes; give warning message, this isn't ANSI
;Calculate milliseconds since midnight
IF10,<
MSTIME T0, ;Milliseconds since midnight
> ;END IF10
IF20,<
PUSH P,T2 ; Save registers
PUSH P,T3
PUSH P,T4
GTAD% ;Get internal time
;Convert <days,,fraction-of-days> to milliseconds since midnight
HRLZ T0,T1 ;Get fractional days, put in left half
LSH T0,-1 ;Move away from sign bit
MUL T0,[<^D24>*<^D60>*<^D60>*<^D1000>]
;Compute msec since midnight
;Adjust for local time zone (from GMT) and daylight savings time
;The general algorithm is similar to that in TIME. If this must be
;changed, them TIME probably ought to be changed also.
SETO T2, ;Want current time
SETZ T4, ;Use local time
ODCNV% ;JSYS, get local zone and daylight indicator
HLR T3,T4 ;Bits indicating time zone, daylight savings...
HRROI T2,<^-<(IC%TMZ)>> ;Mask -1,,777700 to isolate time zone
TDZ T3,T2 ;Get time zone bits (12-17) only
TRNE T3,40 ;Time zone negative (-12 to +12)?
TDO T3,T2 ;Yes, propogate its sign bit
TXNE T4,IC%ADS ;Is Daylight Savings in effect?
SUBI T3,1 ;Yes, subtract one hour
IMUL T3,[<^D60>*<^D60>*<^D1000>]
;Convert hours to milliseconds
SUB T0,T3 ;Add in local time/daylight savings factors
SKIPGE T0 ;Seconds go negative?
ADD T0,[<^D24>*<^D60>*<^D60>*<^D1000>]
; yes, add in a day's milliseconds to get
; mod 24 hrs.
POP P,T4 ;Restore registers
POP P,T3
POP P,T2
> ;END IF20
FLTR T0,T0 ;Convert integer milliseconds to floating point
FDVR T0,[1000.0] ;Convert milliseconds to seconds
FSBR T0,@0(16) ;Subtract off user's argument
POPJ P, ;Return to caller
END