Trailing-Edge
-
PDP-10 Archives
-
FORTRAN-10_V7wLink_Feb83
-
forop.mac
There are 11 other files named forop.mac in the archive. Click here to see a list.
SEARCH FORPRM
TV FOROP MISC FUNCTIONS FOR LIBRARY ROUTINES,7(3252)
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1981, 1983
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
;ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
;INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
;COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
;OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
;TRANSFERRED.
;THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
;AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
;CORPORATION.
;DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
;SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
COMMENT \
***** Begin Revision History *****
1100 CKS
NEW
1256 DAW
New calling sequence for FOROP. Also do not smash AC2.
1302 JLC
Change FO$GLN (LSNGET) to use channel number as argument.
1464 DAW
Error messages.
1523 JLC 03-Jul-81
Added calls for getting memory interface parameters,
-10 channel parameters, and setting quiet exit.
1532 DAW 14-Jul-81
OPEN rewrite: Base level 1
1561 DAW 28-Jul-81
LSNGET always returned -1
1747 DAW 28-Sep-81
Change FO$DIV to actually do the diversion, return status
codes for errors. Added FO$GDV to return the diverted unit number.
1775 JLC 9-Oct-81
Fix LSNGET (i.e. FOGLN) to return -1 for non-open units.
2005 JLC 15-Oct-81
Added new entry (close all files) for use by REENTER code.
2033 DAW 19-Nov-81
Reset "F" at start of "Close all files" routine.
***** Begin Version 7 *****
3035 JLC Add FOROPs FOGCH and FOGFB.
3056 JLC 23-Mar-82
Removed obnoxious POP P,T1 for new lowseg/hiseg dispatch.
3122 JLC 28-May-82
Changed some global refs.
3136 JLC 26-Jun-82
Added a new function to return the number of the
first free FORTRAN logical unit.
3161 JLC 19-Aug-82
Modified return of ERRSNS message so it can be set to
"No error" if no error has been detected.
3165 JLC 28-Aug-82
Add FORDDT error break entry.
3250 JLC 7-Jan-83
Remove obsolete FOROP before release of product.
3252 JLC 12-Jan-82
Add FENTRY.
***** End Revision History *****
\
SEGMENT CODE
FSRCH
ENTRY FOROP%
EXTERN %ERRLM,%ERRSB,%ERRCT,%ERRSZ,%POPJ,%FMTSV,%FMTCL,%ERNM1,%ERNM2
EXTERN %LPAGE,%JBFPT,%DESHG,%EXPNT,%PTAB,%QUIET,G.ERBF,%ERRBK
IF10,< EXTERN %CHMSK>
;CALL: T0 = 0,,function-code
; T1 = Arg
;Since this routine is called by functions, it preserves
;all ACs except T0 and T1.
FENTRY (FOROP)
ADDI T0,DISPTB ;Get address to jump to
CAIG T0,DISPTB+DSPMAX ;Range check
JRST FORO11 ;Dispatch
; ERR (FFX,,,?,FOROP function code exceeds range,,%POPJ)
FOFFX: $ECALL FFX,%POPJ ;"?FOROP function code exceeds range"
FORO11: TXO T0,@IFIW ;Indirect, local section address
JRST @T0 ;Dispatch
DISPTB: IFIW FOAPR ;(0) READ APR TABLE ADDRESSES
IFIW FOILL ;(1) READ ILL FLAG ADDRESS
IFIW FOERR ;(2) READ ERRSNS INFO
IFIW FODIV ;(3) SET DIVERT TO ERROR UNIT
IFIW FOHSP ;(4) READ HIGH SEG SYMBOL POINTER
IFIW FOFSV ;(5) SAVE FORMAT
IFIW FOFCL ;(6) DELETE FORMAT
IFIW FOGLN ;(7) GET THE LINE NUMBER OF LAST LINE
IFIW FOMEM ;(10) RETURN VARIOUS MEMORY PARAMETERS
IFIW FOCHN ;(11) RETURN ADDR OF CHANNEL WORD
IFIW FOQIT ;(12) QUIET EXIT FROM FORTRAN
IFIW FOGDV ;(13) GET DIVERTED UNIT NUMBER
IFIW FOFFX ;(14) OBSOLETE FUNCTION
IFIW FOGCH ;(15) GET CHANNEL # (-10) OR JFN (-20)
IFIW FOGFB ;(16) GET FILOP BLK ADDR (-10) OR 0 (-20)
IFIW FOGFU ;(17) GET 1ST FREE FORTRAN UNIT NUMBER
IFIW FOSBA ;(20) SET FORDDT BREAK ADDRESS
DSPMAX==.-DISPTB-1
;READ APR TABLE ADDRESSES
FOAPR: XMOVEI T0,%ERRCT
MOVEM T0,(T1)
XMOVEI T0,%ERRLM
MOVEM T0,1(T1)
XMOVEI T0,%ERRSB
MOVEM T0,2(T1)
MOVEI T0,%ERRSZ ;RETURN SIZE IN T0
POPJ P, ;DONE
;SET ADDRESS OF FORDDT (OR OTHER DEBUGGER) BREAK
FOSBA: MOVEM T1,%ERRBK ;STORE BREAK ADDRESS IN POINTER
POPJ P,
;PICK UP ADDRESS OF ILLEG FLAG
FOILL: XMOVEI T0,ILLEG.## ;GET ADDRESS OF FLAG WORD
MOVEM T0,(T1) ;STORE ADDRESS IN CALLER'S DATA AREA
POPJ P,
;READ ERRSNS INFO
FOERR: HRLZ T0,%ERNM1 ;GET ERR1,,ERR2
HRR T0,%ERNM2
MOVEM T0,0(T1) ;STORE
XMOVEI T0,G.ERBF ;GET ADDRESS OF ERR MSG BUFFER
SKIPN G.ERBF ;ANY MSG THERE?
XMOVEI T0,[ASCIZ /No error/] ;NO. USE NO ERROR MESSAGE
$BLDBP T0 ;CREATE A BYTE POINTER
MOVEM T0,1(T1) ;STORE
POPJ P, ;DONE
;SET ERR-MESSAGE DIVERT UNIT
;Call:
;T1/ Unit number
;Returns:
;T1/ Status:
; 0= ok
; 1= ?Illegal unit number
; 2= ?Unit not open
; 3= ?Unit not open for FORMATTED IO
; 4= ?Can't write to unit
FODIV: JUMPL T1,FODIV1 ;Negative unit number
CAILE T1,MAXUNIT
JRST DIVIUN ;?illegal unit number
PUSH P,T2 ;save a couple acs
PUSH P,T3
MOVE T1,%DDBTAB##(T1) ;Get UDB
JUMPE T1,DIVUNO ;?Unit not open
MOVE T2,DDBAD(T1) ;T2= DDB addr.
LOAD T3,FORM(T2) ;See if open for FORMATTED IO
CAIE T3,FM.FORM ;If not FORMATTED,
JRST DIVNOF ; return error
LOAD T3,ACC(T2) ;Get ACCESS
CAIE T3,AC.SIN ;SEQIN
CAIN T3,AC.RIN ;RANDIN
JRST DIVCWU ;Yes, can't write to unit
MOVEM T1,U.ERR## ;Store divert unit
JRST DIVOK ;All ok
FODIV1: AOJN T1,DIVIUN ;If not -1, illegal unit number
;Unit -1: Clear diversion
SETZM U.ERR##
SETZ T1, ;Return status 0
POPJ P,
DIVIUN: MOVEI T1,1 ;(1) Illegal unit number
POPJ P, ;Return
DIVUNO: MOVEI T1,2 ;(2) Unit not open
JRST FODIVR
DIVNOF: MOVEI T1,3 ;(3) Unit not open for FORMATTED IO
JRST FODIVR
DIVCWU: MOVEI T1,4 ;(4) Can't write to unit
JRST FODIVR
DIVOK: SETZ T1, ;(0) OK STATUS
FODIVR: POP P,T3 ;Restore acs
POP P,T2
POPJ P, ;Return
;FO$GDV - Get DIVERT unit number
;
;Returns:
; T1/ unit number, -1 if no diversion
FOGDV: SKIPN T1,U.ERR## ;Any diverted unit?
SOJA T1,FOGDV1 ;No, return -1
LOAD T1,UNUM(T1) ;Yes, return unit #
FOGDV1: POPJ P,
;ENCODE A FORMAT IN AN ARRAY
FOFSV: PJRST %FMTSV ;GO TO IT
;THROW IT AWAY
FOFCL: PJRST %FMTCL ;GO DO IT
;GET THE LINE NUMBER OF THE PRESENT LINE
FOGLN: MOVE T1,%DDBTAB##(T1) ;GET THE DDB ADDR
JUMPE T1,RETM1 ;NO U, RETURN -1
MOVE T1,DDBAD(T1)
JUMPE T1,RETM1 ;NO D, RETURN -1
MOVE T0,LSNUM(T1) ;GET THE SEQUENCE NUMBER
POPJ P,
RETM1: MOVNI T0,1 ;RETURN -1
POPJ P,
FOMEM: XMOVEI T0,%EXPNT ;ADDR OF "CORE UUO" SIMULATOR
MOVEM T0,(T1)
XMOVEI T0,%JBFPT ;ADDR OF .JBFF PNTR
MOVEM T0,1(T1)
XMOVEI T0,%LPAGE ;ADDR OF BOTTOM PAGE MARKER
MOVEM T0,2(T1)
XMOVEI T0,%DESHG ;ADDR OF DESIRED HIGH ADDR
MOVEM T0,3(T1)
XMOVEI T0,%PTAB ;ADDR OF MEMORY BITMAP
MOVEM T0,4(T1)
POPJ P,
FOCHN:
IF10,< XMOVEI T0,%CHMSK ;RETURN ADDR OF CHANNEL WORD>
IF20,< SETZ T0, ;NO CHANNELS ON -20>
POPJ P,
FOQIT: SETOM %QUIET ;SET THE QUIET EXIT FLAG
POPJ P,
FOGCH:
CAIG T1,MAXUNIT ;SEE IF IN RANGE
CAMGE T1,[MINUNIT]
JRST RETM1 ;NO GOOD
MOVE T1,%DDBTAB(T1) ;GET UDB
MOVE T1,DDBAD(T1) ;GET DDB ADDR
IF10,<
SKIPN T1,CHAN(T1) ;FILE OPEN YET?
JRST RETM1 ;NO. NO CHANNEL #
LDB T0,[POINTR T1,FO.CHN] ;GET CHANNEL #
POPJ P,
>;END IF10
IF20,<
LOAD T0,IJFN(T1) ;GET JFN
JUMPE T0,RETM1 ;ZERO MEANS NO JFN
POPJ P,
>;END IF20
FOGFB:
IF10,<
CAIG T1,MAXUNIT ;SEE IF IN RANGE
CAMGE T1,[MINUNIT]
JRST RETM1 ;NO GOOD
MOVE T1,%DDBTAB(T1) ;GET UDB
MOVE T1,DDBAD(T1) ;GET DDB ADDR
XMOVEI T0,FBLK(D) ;GET FILOP BLOCK ADDR
POPJ P,
>;END IF10
IF20,<
JRST RETM1
>;END IF20
;GET A FREE UNIT - FIND THE FIRST EMPTY DDB TABLE ENTRY
FOGFU: MOVSI T1,-MAXUNIT ;GET NEG # POSITIVE UNITS
FUNLP: SKIPN %DDBTA(T1) ;FREE ONE?
JRST GOTFUN ;YES. RETURN IT
AOBJN T1,FUNLP ;LOOK AT ALL OF THEM IF NECESSARY
JRST RETM1 ;RETURN -1 IF NONE
GOTFUN: MOVEI T0,(T1) ;RETURN UNIT #
POPJ P,
;READ HIGH SEG SYMBOL POINTER
FOHSP:
IF10,<
PUSH P,T2 ;Save T2
MOVE T2,[-2,,.GTUPM] ;GET BASE ADDRESS OF HIGH SEGMENT
GETTAB T2,
SETZ T2, ;FAILED, ASSUME NO HIGH SEG
JUMPE T2,NOHSP ;RETURN 0 IF NO HIGH SEG
HLRZ T2,T2 ;MOVE TO RIGHT HALF
TRZ T2,777 ;TRUNCATE TO PAGE BOUNDARY, JUST IN CASE
MOVE T2,.JBHSM(T2) ;GET POINTER
NOHSP: MOVEM T2,(T1) ;RETURN IT
POP P,T2 ;Restore T2
POPJ P,
> ;IF10
IF20,<
PUSH P,T2 ;Save ac T2
MOVE T2,.JBHRL ;FIND HIGH SEG
JUMPE T2,NOHSP ;ZERO .JBHRL MEANS NONE
PUSH P,T3 ;Save T3
HLRZ T3,T2
SUBI T2,(T3)
POP P,T3 ;Restore T3
TRZ T2,777 ;TRUNCATE TO PAGE BOUNDARY, JUST IN CASE
MOVE T2,.JBHSM(T2) ;GET POINTER
NOHSP: MOVEM T2,(T1) ;RETURN IT
POP P,T2 ;Restore ac T2
POPJ P,
> ;IF20
PURGE $SEG$
END