Trailing-Edge
-
PDP-10 Archives
-
BB-AI48A-BM
-
datatrieve/simple.bli
There are no other files named simple.bli in the archive.
%TITLE 'SIMPLE - A BLISS-36 Callable-Datatrieve sample program'
MODULE SIMPLE (MAIN = MAINPROG) =
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!
! S I M P L E
!
!
! 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 the use of callable Datatrieve-20
! from BLISS-36.
!
! To LINK this program:
! @LOAD SIMPLE,SYS:DTRLIB
!
! VERSION NUMBER
! 1
!
! HISTORY
!
!-----------------------------------------------------------------------
BEGIN
LIBRARY 'BLI:MONSYM'; ! TOPS-20 symbols
LIBRARY 'DABSYM'; ! Datatrieve-20 symbols
LIBRARY 'DYNLIB'; ! Dynamic library symbols
REQUIRE 'DAB.REQ'; ! Datatrieve-20 data structures
FORWARD ROUTINE
MAINPROG : NOVALUE,
MESSAGE : NOVALUE,
COMMAND : FORTRAN_FUNC NOVALUE;
LITERAL
TRUE = 1,
FALSE = 0;
! Macros for TTY IO
MACRO TTY_PUT_CRLF =
BEGIN
BUILTIN JSYS;
REGISTER AC1=1;
AC1 = %O'15';
JSYS(-1,PBOUT_,AC1);
AC1 = %O'12';
JSYS(-1,PBOUT_,AC1);
END % ;
MACRO TTY_PUT_MSG (BUFFER,LENGTH) =
BEGIN
BUILTIN JSYS;
REGISTER AC1=1,AC2=2,AC3=3;
AC1 = $PRIOU;
AC2 = CH$PTR(BUFFER);
AC3 = - LENGTH;
JSYS(-1,SOUT_,AC1,AC2,AC3);
END % ;
ROUTINE MAINPROG : NOVALUE =
!+++++++++++++++++++++++++++++++++++++++++++++++++++
!
! M A I N P R O G
!
! FUNCTIONAL DESCRIPTION
! This routine invokes callable Datatrieve to execute
! two simple Datatrieve statements, then exits.
!
! FORMAL PARAMETERS
! None.
!
! RETURNED VALUE
! It doesn't return.
!
!------------------------------------------------------
BEGIN
! Dynamic libraries master initialization
DY$MIN();
! Initialize callable Datatrieve
DTR$INIT(DAB);
! Pass statements to Datatrieve ...
COMMAND(UPLIT('!S !S !S !S !S'),14,
UPLIT('THIS'),4,UPLIT('COMMAND'),7,UPLIT('IS'),2,
UPLIT('IN'),2,UPLIT('ERROR'),5);
! And get any responses (may be more than one line of text) ...
MESSAGE();
TTY_PUT_CRLF;
COMMAND(UPLIT('!S !I !S !I'),11,
UPLIT('PRINT'),5,2,UPLIT('+'),1,2);
MESSAGE();
TTY_PUT_CRLF;
COMMAND(UPLIT('PRINT "THIS IS AN !S OF !S SUBSTITUTION"'),40,
UPLIT('EXAMPLE'),7,
UPLIT('STRING'),6);
MESSAGE();
TTY_PUT_CRLF;
COMMAND(UPLIT('PRINT !I + !I'),13,2,2);
MESSAGE();
TTY_PUT_CRLF;
COMMAND(UPLIT('PRINT !F / !F'),13,%E'1',%E'7');
MESSAGE();
TTY_PUT_CRLF;
! Finish using callable Datatrieve
DTR$FINISH(DAB);
END;
ROUTINE MESSAGE : NOVALUE =
!+++++++++++++++++++++++++++++++++++++++++++++++++++
!
! M E S S A G E
!
! FUNCTIONAL DESCRIPTION
! Accept messages from callable Datatrieve (all kinds)
! until Datatrieve wants something else (like a command).
!
! FORMAL PARAMETERS
! None.
!
! RETURNED VALUE
! None.
!
!------------------------------------------------------
BEGIN
WHILE ((.DAB[DAB$W_STATE] EQL DTR$K_STL_MSG) OR
(.DAB[DAB$W_STATE] EQL DTR$K_STL_LINE)) 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(.DAB[DAB$A_MSG_BUF],.DAB[DAB$W_MSG_LEN]);
TTY_PUT_CRLF;
END;
DTR$CONTINUE(DAB);
END;
END;
ROUTINE COMMAND (PATTERN,PATTERN_LENGTH) : FORTRAN_FUNC NOVALUE =
!+++++++++++++++++++++++++++++++++++++++++++++++++++
!
! C O M M A N D
!
! FUNCTIONAL DESCRIPTION
! Formats a command line for Datatrieve and sends it.
! The pattern string contains substitution parameters which
! are filled in from later arguments. The substitution
! parameters are:
! !S - Address and length of string
! !F - Floating point number
! !I - Integer number
!
! FORMAL PARAMETERS
! Pattern string
! Length of pattern string
! .
! .
! .
!
! RETURNED VALUE
! None.
!
!------------------------------------------------------
BEGIN
BUILTIN
ACTUALCOUNT,
ACTUALPARAMETER;
LOCAL
CHAR,
PAT_PTR,
RES_PTR,
ARG_NUM;
! Set up source and destination pointers
PAT_PTR = CH$PTR(.PATTERN);
RES_PTR = CH$PTR(.DAB[DAB$A_VAL_BUF]);
ARG_NUM = 2;
! First match the command string pattern and fill in any fields starting
! with exclamation points. When the ! is encountered, the extra
! arguments are substituted in.
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'S'] : 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,NOUT_,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,FLOUT_,AC1,AC2,AC3);
RES_PTR = .AC1;
ARG_NUM = .ARG_NUM + 1;
END;
TES;
END;
END;
! Now show the user the command and pass it to Datatrieve
DAB[DAB$W_VAL_LEN] = CH$DIFF(.RES_PTR,CH$PTR(.DAB[DAB$A_VAL_BUF]));
TTY_PUT_MSG(.DAB[DAB$A_VAL_BUF],.DAB[DAB$W_VAL_LEN]);
TTY_PUT_CRLF;
IF (.DAB[DAB$W_STATE] EQL DTR$K_STL_CMD) THEN DTR$COMMAND(DAB);
END;
END
ELUDOM