C+ C EXIT_DTC C C This subroutine establishes the exit handler for the DTC C package. Since, all kinds of screen formatting is being C done (if the terminal is a VT100) with scroll regions, large C letters, etc., the only safe way to get out of the program C via a control-Y and leave the terminal in a defined state, C is to allways exit via an exit handler which will reset C the scroll region (full screen) and erase the screen. c C Note that this routine also sets the terminal up for NO_WRAP C and resets it to whatever its initial characteristics were C when the exit handler is called at exit. The reason for C setting the terminal for no wrap is that we do not want C erroniously long input lines to wrap around to the next line C and screw up the display. C C CALL EXIT_DTC(Iterminal,TTchan) C Where C Itermianl I*4 Terminal type found from $GETDVI C TTchan I*2 Channel # for SYS$INPUT obtained C from SYS$ASSIGN C C Written by: James G. Downward C KMS Fusion, Inc. C PO Box 1567 C Ann Arbor, Mich 48106 C C IDENT /2/ C- SUBROUTINE EXIT_DTC(Iterminal,TTchan) IMPLICIT INTEGER*4 (A - Z) ! INTEGER*2 TTchan,TTchan2 ! INTEGER*4 EXIT_STATUS, EXIT_BLOCK(5) ! INTEGER*4 Iterminal ! What kind of term INTEGER*4 Pid EXTERNAL EXIT_DTC2 ! Call on exit COMMON /Term_channel/ TTchan2 ! Pass it our I/O chnl COMMON /PID/ PID PID=0 ! No subprocesses at 1st C Declare exit handler ! EXIT_BLOCK(2) = %LOC(EXIT_DTC2) ! EXIT_BLOCK(3) = 2 ! EXIT_BLOCK(4) = %LOC(EXIT_STATUS) ! EXIT_BLOCK(5) = %LOC(ITERMINAL) ! TTchan2=TTchan ! Transfer to EXIT_DTC2 STATUS = SYS$DCLEXH (EXIT_BLOCK) ! Requires Implicit Is_Set=.TRUE. ! Light a candle IF (.NOT. STATUS) CALL LIB$STOP (%VAL(STATUS)) ! INTEGER*4 (A-Z) CALL Enable_AST(TTchan) ! Enable ^Y ast RETURN ! Back to mainline END ! SUBROUTINE EXIT_DTC2(EXIT_STATUS, Iterminal) C C .. This routine is called when the program tries to exit. It does C a number of things. It tries to erase the screen. How it does this C depends on the type of terminal we have. Only VT100's and Tek 4014 C really erase, the rest just space up. It also resets scrolling C regions on VT100 type terminals, resets any changed terminal C characteristics, and cancels any outstanding I/O. If a sbprocess C window exists (PID <> 0), it deletes the subprocess. C IMPLICIT INTEGER*4 (A - Z) ! CHARACTER*1 Cescape,Cform_Feed,Cline_Feed ! CHARACTER*1 Ckeypad /'>'/ ! Reset keypad mode CHARACTER*2 Clights /'[q'/ ! Reset lights off CHARACTER*4 Corigin /'[?6l'/ ! Reset Origin mode CHARACTER*4 Cjump /'[?4l'/ ! Reset Jump mode CHARACTER*7 Cscroll /'[1;24;r'/ ! Scoll window CHARACTER*4 Clarge /'[?3l'/ ! Make large characters CHARACTER*12 Cpage ! LOGICAL Is_Set ! If Subprocess in use INTEGER*2 TTchan ! INTEGER*4 Term_Char ! INTEGER*4 DELAY_INTERVAL(2) ! For SETIMR INTEGER*4 PID ! EXTERNAL IO$_SETMODE ! COMMON /CTL_MASK/ Old_Mask ! Reestablisy ^Y state COMMON /Terminal_characteristics/ Term_char(3) ! COMMON /Term_channel/ TTchan ! COMMON /PID/ PID ! DATA Cescape /27/ ! DATA Cform_feed /12/ ! DATA Cline_feed /10/ ! PARAMETER (DT$_TTYUNKN= 0) ! Unknown PARAMETER (DT$_VT05= 1) ! **Unknown** PARAMETER (DT$_VK100= 2) ! Vk100 video board PARAMETER (DT$_VT173= 3) ! **Unknown** PARAMETER (DT$_FT1= 16) ! Tek 4014 term PARAMETER (DT$_FT2= 17) ! NBI Term PARAMETER (DT$_FT3= 18) ! **Unknown** PARAMETER (DT$_FT4= 19) ! **Unknown** PARAMETER (DT$_FT5= 20) ! **Unknown** PARAMETER (DT$_FT6= 21) ! **Unknown** PARAMETER (DT$_FT7= 22) ! **Unknown** PARAMETER (DT$_FT8= 23) ! **Unknown** C ... C ... hard copy terminals C ... PARAMETER (DT$_LAX= 32) ! Send 7 LF FF to all PARAMETER (DT$_LA36= 32) ! hard copy terminals PARAMETER (DT$_LA120= 33) ! unless have form ctl PARAMETER (DT$_LA34= 34) ! PARAMETER (DT$_LA38= 35) ! PARAMETER (DT$_LA12= 36) ! PARAMETER (DT$_LA24= 37) ! PARAMETER (DT$_LA100= 37) ! PARAMETER (DT$_LQP02= 38) ! C ... C ... Video terminals C ... PARAMETER (DT$_VT5X= 64) ! **Unknown** PARAMETER (DT$_VT52= 64) ! Treat as VT52 PARAMETER (DT$_VT55= 65) ! Treat as VT52 PARAMETER (DT$_VT100= 96) ! VT100 C ... C ... Delete dead subprocess if any C ... IF(PID.NE.0) Istatus=SYS$DELPRC(PID,) C ... C ... Restore terminal characteristics (if modified) C ... Set_Mode = %LOC(IO$_SETMODE) ! STATUS = SYS$QIOW (,%VAL(TTCHAN), %VAL(Set_mode)! Reset any changed - ,,,,Term_Char, %VAL(8),,,,) ! term charact. IF (.NOT. STATUS) CALL LIB$STOP (%VAL(STATUS)) ! C ... C ... Allow the ^Y to go to DCL now C ... STATUS = LIB$ENABLE_CTRL(Old_Mask) ! for catching ^Y AST C ... C ... Erase the terminal screen C ... IF(Iterminal.GE.DT$_VT100) THEN ! If a VT100 Cpage=Cescape//'[1;H'//Cescape//'[2J' ! Length=9 ! ELSE IF(Iterminal.EQ.DT$_FT1) THEN ! If a 4014 Cpage=Cescape//Cform_Feed ! Length=2 ! ELSE IF(Iterminal.EQ.DT$_FT2 .OR. ! If a NBI beastie - Iterminal.EQ.DT$_LA120 .OR. ! or a LA120 - Iterminal.EQ.DT$_VK100) THEN ! or VK100 vid board Cpage=Cform_Feed ! then use a FF Length=1 ! ELSE ! Else use 7 linefeeds DO I=1,7 ! to simulate a page Cpage(I:I)=Cline_Feed ! END DO ! Length=7 ! END IF ! C C ... We may already have had output printing to the terminal. Now one C ... can not do output in an AST routine to a channel which has output C ... blocked on it (by the AST routine). So for the purpose of erasing C ... the screen, etc. we will open a new unit (channel) and do our C ... terminal control I/O to it. C ... OPEN(UNIT=5,NAME='SYS$OUTPUT',STATUS='UNKNOWN') ! WRITE(5,5) Cpage(1:Length) ! Output control char 5 FORMAT('+',A,$) ! IF(Iterminal.GE.96) THEN ! WRITE(5,20)Cescape//Ckeypad//Cescape//Clights// - Cescape//Corigin// - Cescape//Cscroll//Cescape//Cjump// - Cescape//Clarge 20 FORMAT('+',A,$) ! END IF ! IF(Iterminal.EQ.DT$_FT1) THEN ! Set delay 10 sec STATUS = SYS$BINTIM ('0 00:00:02',DELAY_INTERVAL)! Cnvt ASCII to binary STATUS = SYS$SETIMR (%VAL(1), DELAY_INTERVAL,,)! Now wait STATUS = SYS$WAITFR (%VAL(1)) ! END IF ! RETURN END SUBROUTINE ENABLE_AST (TTCHAN) C This subroutine enables a ^Y attention AST C for the terminal. This means that ^Y will go to this task rather C than DCL. We must be sure to reenable ^Y prior to exit or we C will not be able to use it later. IMPLICIT INTEGER*4 (A - Z) INTEGER*2 TTCHAN ! INTEGER*4 Imask ! INTEGER*4 Old_Mask ! INTEGER*4 Term_char, New_char(3) ! EXTERNAL CTRL_Y_AST ! Catches ^Y's EXTERNAL IO$_SETMODE, IO$M_CTRLYAST ! for QIO's EXTERNAL IO$_SENSEMODE,TT$V_WRAP ! PARAMETER (LIB$M_CLI_CTRLY = '02000000'X) ! Disable ^Y bit COMMON /CTL_MASK/ Old_Mask ! COMMON /Terminal_characteristics/ Term_char(3)! Imask = LIB$M_CLI_CTRLY ! STATUS = LIB$DISABLE_CTRL(Imask,Old_Mask) ! Disable ^Y for CLI SET_AST = %LOC(IO$_SETMODE) .OR. %LOC(IO$M_CTRLYAST) C ... C ... Find out what the terminal characteristics are and then set C ... the terminal for NO_WRAP C ... Sense_mode = %LOC(IO$_SENSEMODE) ! Set_Mode = %LOC(IO$_SETMODE) ! C C .. Get the current terminal characteristics C STATUS = SYS$QIOW (,%VAL(TTCHAN), %VAL(Sense_mode) - ,,,,Term_Char, %VAL(8),,,,) ! IF (.NOT. STATUS) CALL LIB$STOP (%VAL(STATUS)) ! Die if fails New_Char(1)=Term_Char(1) ! Transfer charact New_char(2)=IBCLR(Term_Char(2),%LOC(TT$V_WRAP)) ! Clear wrap bit STATUS = SYS$QIOW (,%VAL(TTCHAN), %VAL(Set_mode) - ,,,,New_Char, %VAL(8),,,,) ! Set for nowrap IF (.NOT. STATUS) CALL LIB$STOP (%VAL(STATUS)) C ... C ... Enable AST recognition C ... STATUS = SYS$QIOW (,%VAL(TTCHAN), %VAL(SET_AST) ! - ,,,,CTRL_Y_AST, TTCHAN,,,,) ! IF (.NOT. STATUS) CALL LIB$STOP (%VAL(STATUS)) ! RETURN ! Done END SUBROUTINE CTRL_Y_AST (TTCHAN) INTEGER*2 TTchan CALL EXIT ! exit to exit handler RETURN END