Trailing-Edge
-
PDP-10 Archives
-
BB-AI48A-BM
-
datatrieve/put.bli
There are no other files named put.bli in the archive.
%TITLE 'PUT PORT - A Callable Datatrieve Example'
MODULE PUT (MAIN = MAINPROG) =
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!
! P U T
!
!
! COPYRIGHT (c) 1984 BY
! DIGITAL EQUIPMENT CORPORATION, MAYNARD
! MASSACHUSETTS. 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 THAT IS
! NOT SUPPLIED BY DIGITAL.
!
!
! FUNCTIONAL DESCRIPTION
! This module demonstrates writing into ports.
!
! Linking instructions:
! @LOAD PUT,SYS:DTRLIB
!
! VERSION NUMBER
! 1
!
! HISTORY
!
!-----------------------------------------------------------------------
BEGIN
LIBRARY 'DABSYM'; ! Include Definitions Of The DAB
LIBRARY 'DYNLIB'; ! Dynamic library symbols
REQUIRE 'BLI:TUTIO'; ! Simple form I/O package
REQUIRE 'DAB.REQ'; ! The DAB itself
FORWARD ROUTINE
MESSAGE : NOVALUE,
COMMAND : NOVALUE FORTRAN_FUNC,
PUT_PORT : NOVALUE,
MAINPROG : NOVALUE;
LITERAL
REC_LENGTH = 35;
! Get storage for global buffers
OWN
TTY_LENGTH,
TTY_BUFFER : BLOCK [CH$ALLOCATION(REC_LENGTH)],
REC_BUFFER : VECTOR[CH$ALLOCATION(REC_LENGTH)];
ROUTINE PUT_PORT(ADDR,LEN) : NOVALUE =
!+++++++++++++++++++++++++++++++++++++++++++++++++++
!
! P U T _ P O R T
!
! FUNCTIONAL DESCRIPTION
! This routine passes a filled in port record buffer
! to Datatrieve.
!
! FORMAL PARAMETERS
! Address of the record buffer
! Length of the record buffer
!
! IMPLICIT PARAMETERS
! The Datatrieve Access Buffer (DAB)
!
! RETURNED VALUE
! none
!
!------------------------------------------------------
BEGIN
DAB[DAB$W_REC_LEN] = .LEN;
IF (.DAB[DAB$W_STATE] EQL DTR$K_STL_PPUT) THEN
BEGIN
DAB[DAB$A_REC_BUF] = .ADDR;
TTY_PUT_MSG(.DAB[DAB$A_REC_BUF],.DAB[DAB$W_REC_LEN]);
TTY_PUT_CRLF();
DTR$PUT_PORT(DAB)
END;
END;
ROUTINE MAINPROG : NOVALUE =
!+++++++++++++++++++++++++++++++++++++++++++++++++++
!
! M A I N P R O G
!
! FUNCTIONAL DESCRIPTION
! Demonstrate writing into ports.
!
! Requires a domain named DRINK, with 01 level record
! named JUICE, and fields named NAME,TASTE,COLOR, and
! PRICE.
!
! FORMAL PARAMETERS
! None.
!
! RETURNED VALUE
! none
!
!------------------------------------------------------
BEGIN
DY$MIN();
DTR$INIT(DAB);
COMMAND(UPLIT('READY DRINK WRITE'),17);
MESSAGE();
COMMAND(UPLIT('DECLARE PORT PT1 USING 01 LIQ.'),30);
MESSAGE();
COMMAND(UPLIT('02 NAME PIC X(10).'),18);
MESSAGE();
COMMAND(UPLIT('02 TASTE PIC X(10).'),19);
MESSAGE();
COMMAND(UPLIT('02 COLOR PIC X(10).'),19);
MESSAGE();
COMMAND(UPLIT('02 PRICE PIC ZZ9V99.;'),21);
MESSAGE();
COMMAND(UPLIT('FOR PT1 STORE DRINK USING JUICE = LIQ'),37);
MESSAGE();
DO BEGIN
TTY_PUT_CRLF();
TTY_PUT_QUO('Name: ');
CH$COPY(TTY_GET_LINE(TTY_BUFFER,12) - 2,CH$PTR(TTY_BUFFER),%C' ',
10,CH$PTR(REC_BUFFER[0]));
TTY_PUT_QUO('Taste: ');
CH$COPY(TTY_GET_LINE(TTY_BUFFER,12) - 2,CH$PTR(TTY_BUFFER),%C' ',
10,CH$PTR(REC_BUFFER[2]));
TTY_PUT_QUO('Color: ');
CH$COPY(TTY_GET_LINE(TTY_BUFFER,12) - 2,CH$PTR(TTY_BUFFER),%C' ',
10,CH$PTR(REC_BUFFER[4]));
TTY_PUT_QUO('Price: ');
CH$FILL(%C'0',5,CH$PTR(REC_BUFFER[6]));
TTY_LENGTH = TTY_GET_LINE(TTY_BUFFER,7) - 2;
CH$MOVE(.TTY_LENGTH,CH$PTR(TTY_BUFFER),
CH$PLUS(CH$PTR(REC_BUFFER[6]),(5 - .TTY_LENGTH)));
PUT_PORT(REC_BUFFER[0],REC_LENGTH);
MESSAGE();
TTY_PUT_QUO('Another? ');
END UNTIL (TTY_GET_CHAR() NEQ %C'Y');
TTY_PUT_CRLF();
DTR$PORT_EOF(DAB);
MESSAGE();
COMMAND(UPLIT('PRINT DRINK'),11);
MESSAGE();
DTR$FINISH(DAB);
END;
ROUTINE COMMAND (PATTERN,PATTERN_LENGTH) : FORTRAN_FUNC NOVALUE =
!+++++++++++++++++++++++++++++++++++++++++++++++++++
!
! C O M M A N D
!
! FUNCTIONAL DESCRIPTION
! If waiting at stall point then, the string is copied into
! value buffer and the command is sent to DATATRIEVE. This
! routine shows the usefulness of pattern strings. Pattern
! strings are imbedded commands in the text string which
! are substituted at run time by extra arguments. For example
! this routine accepts !A as a pattern string for which it
! substitutes a string. Two more arguments are needed, the
! address and length of the string.
!
! FORMAL PARAMETERS
! PATTERN - The pattern to be output on the screen
! PATTERN_LENGTH - Length in characters of the pattern
!
! IMPLICIT PARAMETERS
! The Datatrieve Access Buffer (DAB)
!
! RETURNED VALUE
! none
!------------------------------------------------------
BEGIN
BUILTIN
ACTUALCOUNT,
ACTUALPARAMETER;
LOCAL
CHAR, ! Character read
PAT_PTR, ! Pointer to pattern
RES_PTR, ! Pointer to resulting string
ARG_NUM; ! Number of arguments
PAT_PTR = CH$PTR(.PATTERN);
RES_PTR = CH$PTR(VALUE_BUFFER);
ARG_NUM = 2;
! First match the command string pattern and fill in any
! fields started with exclamation points.
! When the ! is encountered then arguments from the end of the routine
! are substituted in. The types of comment are:
! !A - Address and length of string
! !F - Floating point number
! !I - Integer number
INCR CHARNUM FROM 1 TO .PATTERN_LENGTH DO BEGIN
CHAR = CH$RCHAR_A(PAT_PTR);
IF (.CHAR NEQ %C'!')
THEN CH$WCHAR_A(.CHAR,RES_PTR)
ELSE BEGIN
CHAR = CH$RCHAR_A(PAT_PTR);
CHARNUM = .CHARNUM + 1;
SELECTONE .CHAR OF SET
[%C'A'] : BEGIN
ARG_NUM = .ARG_NUM + 2;
RES_PTR = CH$MOVE(ACTUALPARAMETER(.ARG_NUM),
CH$PTR(ACTUALPARAMETER(.ARG_NUM - 1)),
.RES_PTR);
END;
[%C'I'] : BEGIN
BUILTIN JSYS;
REGISTER AC1=1,AC2=2,AC3=3;
AC1 = .RES_PTR;
AC2 = ACTUALPARAMETER(.ARG_NUM + 1);
AC3 = 10;
JSYS(1,%O'224',AC1,AC2,AC3);
RES_PTR = .AC1;
ARG_NUM = .ARG_NUM + 1;
END;
[%C'F'] : BEGIN
BUILTIN JSYS;
REGISTER AC1=1,AC2=2,AC3=3;
AC1 = .RES_PTR;
AC2 = ACTUALPARAMETER(.ARG_NUM + 1);
AC3 = 0;
JSYS(1,%O'233',AC1,AC2,AC3);
RES_PTR = .AC1;
ARG_NUM = .ARG_NUM + 1;
END;
TES;
IF (.ARG_NUM GTR ACTUALCOUNT()) THEN BEGIN
TTY_PUT_MSG(UPLIT('Too many pattern spaces for arguments'),37);
END;
END;
END;
! Now set up the command field and call Datatrieve
DAB[DAB$W_VAL_LEN] = CH$DIFF(.RES_PTR,CH$PTR(VALUE_BUFFER));
IF .DAB[DAB$W_STATE] EQL DTR$K_STL_CMD THEN
BEGIN
BEGIN
TTY_PUT_MSG(VALUE_BUFFER,.DAB[DAB$W_VAL_LEN]);
TTY_PUT_CRLF();
END;
DTR$COMMAND(DAB);
END;
END;
ROUTINE MESSAGE : NOVALUE =
!+++++++++++++++++++++++++++++++++++++++++++++++++++
!
! M E S S A G E
!
! FUNCTIONAL DESCRIPTION
! Stops at message stall_point and displays on the screen
! any messages
!
! FORMAL PARAMETERS
! None.
!
! RETURNED VALUE
! none
!
!------------------------------------------------------
BEGIN
WHILE (.DAB[DAB$W_STATE] EQL DTR$K_STL_LINE) OR
(.DAB[DAB$W_STATE] EQL DTR$K_STL_MSG) DO
BEGIN
IF ((.DAB[DAB$L_CONDITION] NEQ DTR$_SUCCESS) AND
(.DAB[DAB$L_CONDITION] NEQ DTR$_ERROR)) OR
.DAB[DAB$W_STATE] EQL DTR$K_STL_LINE THEN
BEGIN
TTY_PUT_MSG(MESSAGE_BUFFER,.DAB[DAB$W_MSG_LEN]);
TTY_PUT_CRLF();
END;
DTR$CONTINUE(DAB);
END;
END;
END
ELUDOM