C*---------------------------------------------------------------------* C| Q I O I N P : READ KEYBOARD INPUT USING QIO CHARACTER HANDLING | C*---------------------------------------------------------------------* LOGICAL FUNCTION QIOINP(BUF,BUFLEN) C----------------------------------------------- C C THIS PROGRAM TRANSLITERATES AN HP26XX KEYBOARD TO DISPLAY C CONTROL CHARACTERS ON THE TERMINAL SCREEN. C C CHARACTER-ORIENTED I/O IS HANDLED BY SYSTEM SERVICE ROUTINES C PROVIDED WITH THE VAX/VMS V2.4 OPERATING SYSTEM. C C NO SPECIAL VAX/VMS PRIVILEGES ARE NEEDED TO RUN THIS ROUTINE. C C*---------------------------------------------------------------------* C----------------------------------------------- COMMON DATA STRUCTURES C- - - - - - - - - - - - - - - - - - - - - - - - ASCII MNEMONIC SET INCLUDE 'CmdInterpDir:ASCII.PAR' C- - - - - - - - - - - - - - - - - - - - - - - - TRANSLATION TABLE COMMON /KEYTAB/ TRTABL(128) BYTE TRTABL DATA TRTABL/ - 00,01,02,03,04,05,06,07,08,09,10,11,12,13,14,15, - 16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31, - 32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47, - 48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63, - '@', 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', - 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', - 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', '[', '\', - ']', '^', '_', '`', 'a', 'b', 'c', 'd', 'e', 'f', - 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o', 'p', - 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', 'y', 'z', - '{', '|', '}', '~', 127/ C----------------------------------------------- SUBPROGRAM PARAMETERS BYTE BUF(1) INTEGER BUFLEN C----------------------------------------------- LOCAL DATA STRUCTURES INTEGER WRDLEN, J, K, KLIMIT, MAXLIM DATA MAXLIM/72/ LOGICAL FIRST1 DATA FIRST1/.TRUE./ C----------------------------------------------- QIO INPUT/OUTPUT DATA C- - - - - - - - - - - - - - - - - - - - - - - - STATUS BLOCK & CHANNEL INTEGER*2 IOSB(4), CHAN, LDN C- - - - - - - - - - - - - - - - - - - - - - - - I/O FUNCTION CODES INTEGER*4 RNECHO C- - - - - - - - - - - - - - - - - - - - - - - - SYSTEM FUNCTION CODES EXTERNAL IO$_TTYREADALL, IO$M_NOFILTR EXTERNAL IO$M_NOECHO C- - - - - - - - - - - - - - - - - - - - - - - - I/O STATUS INDICATOR INTEGER*4 STAT EXTERNAL SS$_NORMAL C----------------------------------------------- CHARACTER*6 DEVNAM C----------------------------------------------- BYTE ABYTE BYTE ALBKSP(75), RUBOUT(3), DFUNON(2), DFUNOF(6) DATA ALBKSP /75*BACKSPACE/ DATA RUBOUT/BACKSPACE, ESC, BIGK/ DATA DFUNON/ESC,BIGY/, DFUNOF/ESC,BIGZ, BS,BS,ESC,BIGK/ BYTE CLREND(2) DATA CLREND/ESC,BIGK/ C----------------------------------------------- CHARACTER SET MODES BYTE ROMSET(7), ALTSET(3) INTEGER ROMLEN, ALTLEN DATA ROMSET /ESC,BIGZ, BS,BS,ESC,BIGK, CTRL_O/, ROMLEN/7/ DATA ALTSET /CTRL_N, ESC,BIGY/, ALTLEN/3/ C----------------------------------------------- CHARACTER SET INDICATORS BYTE CTRKEY(9) DATA CTRKEY/ESC,BIGY, 0, ESC,BIGZ, BS,BS,ESC,BIGK/ BYTE ROMSYM, ALTSYM DATA ROMSYM/EOT/, ALTSYM/RS/ C----------------------------------------------- CARR. RET. & LINE FEED BYTE CRLF(2) DATA CRLF /CR, LF/ C----------------------------------------------- INTEGER ROMAN, ALTERN DATA ROMAN/1/, ALTERN/2/ C CHRSET=1 - ENGLISH CHARACTERS CHRSET=2 - ALTERNATE CHARACTERS BYTE ENGMOD, ALTMOD, NULMOD, NEWSET DATA ENGMOD/CTRL_O/, ALTMOD/CTRL_N/, NULMOD/0/ C----------------------------------------------- FUNCTIONS CALLED INTEGER*4 SYS$QIOW, SYS$TRNLOG, SYS$ASSIGN C*---------------------------------------------------------------------* QIOINP = .FALSE. C----------------------------------------------- INIT I/O STATUS IF (FIRST1) FIRST1 = .FALSE. C- - - - - - - - - - - - - - - - - - - - - - - - DEFINE TTY READ W/O ECHO RNECHO = %LOC(IO$_TTYREADALL) .OR. %LOC(IO$M_NOECHO) - .OR. %LOC(IO$M_NOFILTR) C- - - - - - - - - - - - - - - - - - - - - - - - GET TERMINAL DEVICE STAT = SYS$TRNLOG('TT',LDN,DEVNAM,,,%VAL(3)) IF (STAT .NE. %LOC(SS$_NORMAL)) GO TO 575 STAT = SYS$ASSIGN(DEVNAM,CHAN,,) IF (STAT .NE. %LOC(SS$_NORMAL)) GO TO 600 FIN C----------------------------------------------- SET INPUT BUFFER STATUS 55 K = 0 KLIMIT = MAXLIM LAST1 = 0 CHRSET = ROMAN C----------------------------------------------- READ ONE CHARACTER 75 STAT = SYS$QIOW (%VAL(21), %VAL(CHAN), %VAL(RNECHO), - IOSB,,, %REF(ABYTE), %VAL(1),,0,,) IF (STAT .NE. %LOC(SS$_NORMAL)) GOTO 625 C----------------------------------------------- TEST FOR RUBOUT-TYPE KEY IF (ABYTE.EQ.DEL .OR. ABYTE.EQ.BACKSPACE) IF (CHRSET .EQ. ALTERN) ENTER-ROMAN-CHARACTER-SET IF (K .GT. 0) CALL QIOOUT(RUBOUT,3) BACK-UP-AND-DETERMINE-CHARACTER-SET SELECT (NEWSET) (ENGMOD) CHRSET = ROMAN (ALTMOD) CHRSET = ALTERN FIN WHEN (CHRSET .EQ. ALTERN) ENTER-ALTERNATE-CHARACTER-SET ELSE CALL QIOOUT(ENGMOD,1) GO TO 75 FIN C----------------------------------------------- TEST FOR CARRIAGE RETURN IF (ABYTE .EQ. CR) IF (CHRSET .EQ. ALTERN) ENTER-ROMAN-CHARACTER-SET CALL QIOOUT(CRLF,2) CHRSET = ROMAN DO (J=K+1,BUFLEN) BUF(J) = BLANK RETURN FIN C----------------------------------------------- TEST FOR LINE ERASE IF (ABYTE .EQ. CTRL_U) IF (CHRSET .EQ. ALTERN) ENTER-ROMAN-CHARACTER-SET CALL QIOOUT('^U',2) CALL QIOOUT(CRLF,2) GO TO 55 FIN C----------------------------------------------- SELECT (ABYTE) C----------------------------------------------- TEST FOR CHAR TOGGLE (CTRL_A) WHEN (CHRSET .EQ. ALTERN) CHRSET = ROMAN ENTER-ROMAN-CHARACTER-SET FIN ELSE CHRSET = ALTERN ENTER-ALTERNATE-CHARACTER-SET FIN FIN C----------------------------------------------- TEST FOR ENGLISH MODE (CTRL_E) IF (CHRSET .EQ. ALTERN) ENTER-ROMAN-CHARACTER-SET CTRKEY(3) = ROMSYM CALL QIOOUT(CTRKEY,9) CHRSET = ROMAN K = K + 1 BUF(K) = ENGMOD FIN C----------------------------------------------- TEST FOR ALTERNATE MODE (CTRL_T) INDICATE-ALTERNATE-CHARACTER-SET ENTER-ALTERNATE-CHARACTER-SET CHRSET = ALTERN K = K + 1 BUF(K) = ALTMOD FIN C----------------------------------------------- (OTHERWISE) K = K + 1 BUF(K) = ABYTE IF (ABYTE .EQ. ' ') LAST1 = K C----------------------------------------------- IF (CHRSET .EQ. ALTERN) C--------------------------------------- TRANSLITERATE TO REPLACEMENT SET BUF(K) = TRTABL(ABYTE+1) FIN C----------------------------------------------- TEST FOR LINE FILLED IF (K .GE. KLIMIT) WRDLEN=1 C----------------------------------------------- TEST FOR NON-BLANK CHAR IF (BUF(K) .NE. ' ') C----------------------------------------------- NO BLANK FOUND IF (LAST1 .GT. 0) C-----------------------------------------------WRITE BACKSPACES OVER WORD WRDLEN = K - LAST1 IF (CHRSET .EQ. ALTERN) ENTER-ROMAN-CHARACTER-SET CALL QIOOUT(ALBKSP,WRDLEN) C----------------------------------------------- ERASE END OF LINE CALL QIOOUT(CLREND,2) IF (CHRSET .EQ. ALTERN) ENTER-ALTERNATE-CHARACTER-SET FIN FIN C----------------------------------------------- OUTPUT CR & LF IF (CHRSET .EQ. ALTERN) ENTER-ROMAN-CHARACTER-SET CALL QIOOUT(CRLF,2) IF (CHRSET .EQ. ALTERN) ENTER-ALTERNATE-CHARACTER-SET C----------------------------------------------- ADJUST LIMIT KLIMIT = KLIMIT + MAXLIM LAST1 = 0 C----------------------------------------------- PRINT PARTIAL WORD CALL QIOOUT(BUF(K-WRDLEN+1),WRDLEN) GO TO 75 FIN WHEN (CHRSET.EQ.ALTERN .AND. BUF(K).EQ.' ') ENTER-ROMAN-CHARACTER-SET CALL QIOOUT(' ',1) ENTER-ALTERNATE-CHARACTER-SET FIN ELSE C----------------------------------------------- ASSIGN CHARACTER ABYTE = BUF(K) C----------------------------------------------- CHECK IF PRINTABLE WHEN (CHRSET.EQ.ROMAN .AND. ABYTE.LT.' ') CTRKEY(3) = ABYTE CALL QIOOUT(CTRKEY,9) FIN ELSE CALL QIOOUT(ABYTE,1) C----------------------------------------------- FIN FIN FIN GO TO 75 C----------------------------------------------- 575 TYPE *,' * SYS$TRNLOG ERROR:' GO TO 665 600 TYPE 610,DEVNAM 610 FORMAT(' ERROR ASSIGNING DEVICE ',A6) GO TO 665 625 TYPE *,' QIOW READ ERROR' GO TO 665 665 CALL SYS$EXIT(%VAL(STAT)) RETURN C=============================================== TO ENTER-ROMAN-CHARACTER-SET CALL QIOOUT(ROMSET,ROMLEN) C=============================================== TO ENTER-ALTERNATE-CHARACTER-SET CALL QIOOUT(ALTSET,ALTLEN) FIN C=============================================== TO BACK-UP-AND-DETERMINE-CHARACTER-SET C RETURNS: NEWSET = (ENGMOD,ALTMOD,NULMOD) NEWSET = NULMOD C----------------------------------------------- IF BUFFER NOT EMPTY IF (K .GT. 0) C----------------------------------------------- IF CHANGING MODES IF (BUF(K).EQ.ENGMOD .OR. BUF(K).EQ.ALTMOD) C----------------------------------------------- FIND PREVIOUS MODE IF (K .GT. 1) DO (J=K-1,1,-1) IF (NEWSET.EQ.NULMOD.AND.(BUF(J).EQ.ENGMOD.OR.BUF(J).EQ.ALTMOD)) NEWSET = BUF(J) FIN FIN FIN C----------------------------------------------- IF (NEWSET .EQ. NULMOD) NEWSET = ENGMOD FIN K = K - 1 FIN FIN C=============================================== TO INDICATE-ALTERNATE-CHARACTER-SET IF (CHRSET .NE. ROMAN) ENTER-ROMAN-CHARACTER-SET CTRKEY(3) = ALTSYM CALL QIOOUT(CTRKEY,9) FIN C=============================================== END C*---------------------------------------------------------------------* C| Q I O O U T : PRINT OUTPUT ON TERMINAL USING QIO CHARACTER HANDLING| C*---------------------------------------------------------------------* SUBROUTINE QIOOUT(OUTBUF,BUFLEN) C----------------------------------------------- SUBPROGRAM PARAMETERS INTEGER OUTBUF(1), BUFLEN C----------------------------------------------- LOCAL DATA STRUCTURES LOGICAL FIRST1 DATA FIRST1/.TRUE./ C----------------------------------------------- INTEGER*2 IOSB(4), CHANNL, LDN CHARACTER*6 DEVNAM EXTERNAL IO$_WRITEVBLK, IO$M_NOFORMAT INTEGER*4 WRTALL C- - - - - - - - - - - - - - - - - - - - - - - - I/O STATUS INDICATOR INTEGER*4 STAT EXTERNAL SS$_NORMAL C----------------------------------------------- FUNCTIONS CALLED INTEGER SYS$TRNLOG, SYS$ASSIGN, SYS$QIOW C=============================================== INIT OUTPUT IF (FIRST1) FIRST1 = .FALSE. C- - - - - - - - - - - - - - - - - - - - - - - - GET TERMINAL DEVICE STAT = SYS$TRNLOG('TT',LDN,DEVNAM,,,%VAL(3)) STAT = SYS$ASSIGN(DEVNAM,CHANNL,,) C- - - - - - - - - - - - - - - - - - - - - - - - DEFINE WRITE FUNCTION WRTALL = %LOC(IO$_WRITEVBLK) .OR. %LOC(IO$M_NOFORMAT) FIN C----------------------------------------------- ATTEMPT WRITE STAT = SYS$QIOW( %VAL(21),%VAL(CHANNL),%VAL(WRTALL), - IOSB,,,%REF(OUTBUF),%VAL(BUFLEN),,%VAL(0),,) C----------------------------------------------- IF ERROR, GIVE MSG IF (STAT .NE. %LOC(SS$_NORMAL)) TYPE *,' *IN QIOOUT - CANNOT PERFORM QIO WRITE, STAT,BUFLEN=', - STAT,BUFLEN FIN C=============================================== RETURN RETURN END