*
* $Id$
*
* $Log$
* Revision 1.1  1996/03/08 15:44:21  mclareni
* Initial revision
*
*
#if defined(CERNLIB_IBMMVS)
*         $GETINH (PL/I)
*          GETINH (FORTRAN,PASCAL)
*
*        PROMPT A MESSAGE ON A TSO TERMINAL AND READ TYPED ANSWER
*        ON THE SAME LINE
*
*         AUTHOR:
*              G. WEIL      CENTRE DE CALCUL DE STRASBOURG (CNRS)
*
*        17/02/91: /MK/,GSI
*                  MODIFIED TO RUN IN AMODE=31,RMODE=ANY.
*        18/02/91: /MK/,GSI
*                  DO NOT ECHO USER RESPONSE (E.G. FOR PASSWORDS)
*        19/02/91: /MK/,GSI
*                  SEPARATE ENTRIES FOR FORTRAN/PASCAL AND PL/I
*
*        PL/I USAGE:
*        ==============
*
*        DCL OUT,IN CHAR(*) VAR;  ! PROMPT & READ STRING
*    OR  DCL OUT,IN CHAR(*);      ! PROMPT & READ STRING
*        BIN FIXED(31) IST;       ! RETURN CODE
*
*        CALL $GETINH( OUT, IN, IST );
*
*        FORTRAN USAGE:
*        ==============
*
*        CHARACTER*(*) OUT, IN    ! PROMPT & READ STRING
*        INTEGER     LGOUT, LGIN  ! THEIR MAX. LENGTH
*        INTEGER     IST          ! RETURN CODE
*                   CALL GETINH ( OUT, LGOUT, IN, LGIN, IST )
*
*        PASCAL  USAGE:
*        ==============
*
*       program test;
*       type
*          stringxx =                     packed array [1..xx] of char;
*          Procedure GETINH( var  cbufin: stringxx;
*                            var  lbufin: integer;
*                            var cbufout: stringxx;
*                            var lbufout: integer;
*                            var irc: integer );
*          external;
*       var
*          cprompt : packed array [1..80] of char;
*          cc      : packed array [1..80] of char;
*          lin, lout, nn : integer;
*
*       begin;
*          cprompt:='enter password 1';
*          lin := 16; lout := 80; nn := 0;
*          GETINH( cprompt, lin, cc, lout, nn );
*       end.
*
*         IST       STATUS                                  (OUTPUT)
*               >0  NB OF CHARACTERS READ
*              -01  BAD LGOUT
*              -02  BAD LGIN
*              -08  'ATTN' INTERRUPT RECEIVED
*              -12  BUFFER TOO SMALL
*              -20  TERMINAL DISCONNECTED
*
*
*
$GETINH   AMODE     31
$GETINH   RMODE     ANY
*
          MACRO
          REGS
          PUSH      PRINT
          PRINT     ON,NOGEN
R0        EQU       0
R1        EQU       1
R2        EQU       2
R3        EQU       3
R4        EQU       4
R5        EQU       5
R6        EQU       6
R7        EQU       7
R8        EQU       8
R9        EQU       9
R10       EQU       10
R11       EQU       11
R12       EQU       12
R13       EQU       13
R14       EQU       14
R15       EQU       15
F0        EQU       0
F2        EQU       2
F4        EQU       4
F6        EQU       6
          POP       PRINT
          MEND
*
$GETINH  CSECT                    PL/I ENTRY
         ENTRY GETINH
          REGS
         USING $GETINH,R15        addressability
          SAVE      (14,12)       SAVE REGISTERS
          LM        R2,R4,0(R1)   LOAD PL/I PARAMETER ADDRESSES
         LR    R6,R4              SAME REG.S AS FORTRAN
         LR    R4,R3
         SR    R7,R7              RESET PTR. TO VAR. STRING PREFIX
*
*                      PL/I STRING HANDLING, PROMPT
*
         LA    R3,4(0,R2)         PTR. TO MAX LENGTH
         L     R2,0(0,R2)         PTR. TO STRING ITSELF
         TM    2(R3),X'80'        FIXED/VARYING ?
         BZ    OUT_FIXED
            LA R3,0(0,R2)         PTR. TO PREFIX
            LA R2,2(0,R2)         PTR. TO STRING
OUT_FIXED EQU  *
         LH    R3,0(0,R3)         LOAD STRING LENGTH
*
*                      PL/I STRING HANDLING, input buffer
*
         LA    R5,4(0,R4)         PTR. TO MAX LENGTH
         L     R4,0(0,R4)         PTR. TO STRING
         TM    2(R5),X'80'        FIXED/VARYING ?
         BZ     IN_FIXED
            LA R7,0(0,R4)         PTR. TO PREFIX
            SR R0,R0
            STH R0,0(0,R7)        RETURN NULL STRING (DEFAULT)
            LA R4,2(0,R4)         PTR. TO STRING
IN_FIXED EQU  *
         LH    R5,0(0,R5)         LOAD MAX. STRING LENGTH
         LA    BASE,$GETINH_START ADDRESSABILITY
         DROP  R15                GIVE UP
         USING $GETINH_START,BASE SAME BASE AS FORTRAN ENTRY
         B     $GETINH_START
*
* ***
*
GETINH    EQU       *             FORTRAN & PASCAL ENTRY
*
         DROP  BASE
         USING  GETINH,R15        ADDRESSABILITY
          SAVE      (14,12)
          LM        R2,R6,0(R1)   PICKUP PARAMETER ADDRESSES
          L         R3,0(0,R3)    LENGTH PROMPT STRING
          L         R5,0(0,R5)    LENGTH BUFFER STRING
         SR    R7,R7
         LA    BASE,$GETINH_START
         DROP  R15
         USING $GETINH_START,BASE
$GETINH_START  EQU  *             COMMON START & BASE REFERENCE
*
* *** CHECK REASONABLE LENGTH OF GIVEN I/O BUFFERS
*
         SR    R15,R15
         BCTR  R15,0              -1
          LTR       R3,R3
          BNH       GO_HOME
         BCTR  R15,0              -2
          LTR       R5,R5
          BNH       GO_HOME
*
* *** DYNAMIC SAVE AREA FOR TPUT/GET
*
          GETMAIN   RC,LV=72
          ST        R13,4(R1)
          ST        R1,8(R13)
          LR        R13,R1
*
* *** ALLOCATE LOCAL BUFFER SPACE < 16MB FOR TPUT/GET
*
         LR    R11,R5
         GETMAIN    R,LV=(R11)              INPUT BUF
         LR    R10,R1
         LA    R9,1(0,R3)         LENGTH+1
         GETMAIN    R,LV=(R9)             OUTPUT BUF
         LR    R8,R1              ADDRESS OF BUFFER
         LR    R0,R8              ADDRESS OF BUFFER
         LR    R1,R3              LENGTH
         MVCL  R0,R2              COPY OUTPUT BUFFER
         LR    R2,R0
         MVI   0(R2),BYP_INP      INSERT BYPASS/INHIBIT CHARACTER
*
* *** TPUT PROMPT STRING AND TGET ANSWER
*
         ICM   R8,B'1000',=AL1(PUTFLG) INSERT FLAG
          TPUT      (R8),(R9),ASIS
          LTR       R15,R15
          BNZ       ERREUR
         ICM   R10,B'1000',=AL1(GETFLG)
          TGET      (R10),(R11),R
          LTR       R15,R15
          BNZ       ERREUR
          LNR       R15,R1
*
* *** COPY BACK THE DATA READ
*
         LR    R0,R10             BUFFER ADDRESS
         ICM   R1,B'1000',=CL1' '    PAD WITH BLANKS
         MVCL  R4,R0              COPY BACK RECEIVED DATA
*
* *** ERROR HANDLING AND CLEANUP
*
ERREUR   LCR       R15,R15
         ST        R15,0(R6)
         LTR   R7,R7
         BE    SKIP_VAR1          RETURN PL/I CHAR(*) VARYING ??
           LTR R15,R15
           BNH SKIP_VAR1
           STH R15,0(0,R7)
SKIP_VAR1 EQU *
         L         R3,4(R13)
         FREEMAIN  RC,LV=72,A=(R13)
         FREEMAIN  R,LV=(R11),A=(R10)
         FREEMAIN  R,LV=(R9),A=(R8)
         LR        R13,R3
         RETURN    (14,12),T,RC=0
*
GO_HOME  EQU   *
         ST    R15,0(R6)
         LTR   R7,R7
         BE    SKIP_VAR2          RETURN PL/I CHAR(*) VARYING ??
           LTR R15,R15
           BNH SKIP_VAR2
           STH R15,0(0,R7)
SKIP_VAR2 EQU *
          RETURN    (14,12),T,RC=0
*
* *** CONSTANT DEFINITIONS
*
PUTFLG    EQU       B'00000001'
GETFLG    EQU       B'10000000'
BYP_INP   EQU       X'24'         BYPASS/INHIBIT CHARACTER
*
BASE     EQU   R12
*
          END
#endif
