HP 3000 Manuals HP 3000 Manuals
USER-DEFINED PROCEDURES (continued)
PASCAL - MPROC Procedure (Continued)
(*------------------------------------------*)
(* MPROC DECLARATION *)
(*------------------------------------------*)
(* 3 *)
PROCEDURE MPROC (VAR CALLAGAIN, PAGE_EJECT: SMALLINT;
VAR BASE_IDS: BASEARRAY;
VAR DBBUF: DBBUF_REC;
VAR DSET_LIST, DATA_BASE_LIST: LISTARRAY;
VAR LINEBUF: LINEARRAY;
VAR REGARR: REGARRAY;
VAR USERSTOR: STORARRAY;
VAR USERPARAM: SMALLINT;
VAR DATA_BASE_NAME: DBARRAY;
VAR DATA_SET_NAME: DSARRAY;
VAR CALL_NUM, LINES_LEFT, PAGENO: SMALLINT;
VAR NUM_DSETS, NUM_DBASES: SMALLINT);
TYPE DAY_REC = RECORD CASE INTEGER OF
0 : (D_DAY : INTEGER);
1 : (DAY : ARRAY [1..2] OF SMALLINT);
END;
YEAR_REC = RECORD CASE INTEGER OF
0 : (D_YEAR : INTEGER);
1 : (YEAR : ARRAY [1..2] OF SMALLINT);
END;
JDATE_REC = RECORD CASE INTEGER OF
0 : (DAY_YR : PACKED RECORD
YEAR : 0..127;
DAY : 0..511;
END);
1 : (DATE : SMALLINT);
END;
VAR FMTDATE : PACKED ARRAY [1..17] OF CHAR;
DAY : DAY_REC;
YEAR : YEAR_REC;
HOLD : INTEGER;
JDATE : JDATE_REC;
M, N : SMALLINT;
HOLD_BUF: RECORD CASE INTEGER OF
0 : (SINGLE_INT : ARRAY [1..2] OF SMALLINT);
1 : (DOUBLE_INT : INTEGER);
END;
PASCAL - MPROC Procedure (Continued)
PROCEDURE FMTCALENDAR; INTRINSIC;
(*--------------------------------------------------------*)
(* THERE ARE TWO DATES IN THE DATA BASE TO BE FORMATTED. *)
(* ONE IS IN THE ORDER-D DATA SET, THE OTHER IS IN THE *)
(* SHIP-D DATA SET. BECAUSE THE SETS HAVE BEEN JOINED, *)
(* IT IS POSSIBLE TO GET BOTH DATES AND FORMAT THEM. *)
(* NOTE: IT IS THE APPLICATIONS RESPONSIBILITY TO KNOW *)
(* WHERE IN THE DATA BUFFER THE VALUE IS LOCATED. *)
(*--------------------------------------------------------*)
(*--------------------------------------------------------*)
(* THE DATE IS IN A TWO WORD INTEGER AND NEEDS TO BE RE- *)
(* FORMATTED BEFORE PASSING TO FMTCALENDAR. *)
(*--------------------------------------------------------*)
(*--------------------------------------------------------*)
(* IF CALL_NUM IS ONE THEN WE CAN ASSUME THE ENTRY IS *)
(* FROM THE ORDER-D DATA SET, SINCE IT IS THE FIRST DATA *)
(* SET MENTIONED IN THE JOIN COMMAND. IF CALL_NUM IS NOT *)
(* ONE THEN WE CAN ASSUME THAT THE PROCEDURE HAS BEEN *)
(* CALLED AGAIN, AND WE NOW HAVE THE ENTRY FROM THE *)
(* SHIP-D DATA SET. *)
(*--------------------------------------------------------*)
BEGIN
IF CALL_NUM =1 THEN (* FIRST DATE *)
BEGIN
HOLD_BUF.SINGLE_INT[1] := DBBUF.DBBUF_INT[4];
HOLD_BUF.SINGLE_INT[2] := DBBUF.DBBUF_INT[5];
END
ELSE (* SECOND DATE *)
BEGIN
HOLD_BUF.SINGLE_INT[1] := DBBUF.DBBUF_INT[6];
HOLD_BUF.SINGLE_INT[2] := DBBUF.DBBUF_INT[7];
END;
YEAR.D_YEAR := HOLD_BUF.DOUBLE_INT DIV 1000; (* ISOLATE YEAR *)
HOLD := YEAR.D_YEAR * 1000;
DAY.D_DAY := HOLD_BUF.DOUBLE_INT - HOLD;
JDATE.DAY_YR.DAY := DAY.DAY[2]; (* DAY IN BITS 0-6 *)
JDATE.DAY_YR.YEAR := YEAR.YEAR[2]; (* YEAR IN BITS 7-15 *)
FMTCALENDAR (JDATE.DATE, FMTDATE);
PASCAL - MPROC Procedure (Continued)
(*--------------------------------------------------------*)
(* PUT THE FORMATTED DATE INTO THE OUTPUT BUFFER USED BY *)
(* QUERY FOR THE REPORT OUTPUT LINE. AGAIN, CALL_NUM IS *)
(* USED TO DETERMINE WHERE IN THE OUTPUT BUFFER TO PLACE *)
(* THE VALUE. ALSO, IF CALL_NUM IS ONE THEN WE NEED TO *)
(* SET THE DATA BASE NAME, THE DATA SET NAME, AND THE *)
(* CALLAGAIN PARAMETERS IN ORDER TO GET THE ENTRY FROM *)
(* THE SHIP-D DATA SET TO FORMAT THE SHIPPING DATE. *)
(*--------------------------------------------------------*)
IF CALL_NUM = 1 THEN (* ORDER-D DATA SET *)
BEGIN
M := 1;
FOR N := 19 TO 35 DO
BEGIN
LINEBUF.BLINEBUF[N] := FMTDATE [M];
M := M + 1;
END;
DATA_BASE_NAME.BDB_NAME := 'ACCTS ';
DATA_SET_NAME.BDS_NAME := 'SHIP-D ';
CALLAGAIN := -1; (* 4 *)
END
ELSE (* SHIP-D DATA SET *)
BEGIN
M := 1;
FOR N := 39 TO 55 DO
BEGIN
LINEBUF.BLINEBUF[N] := FMTDATE [M];
M := M + 1;
END;
CALLAGAIN := 0;
END;
END;
BEGIN
END.
PASCAL Notes
(* 1 *)
Variant records can be used when it is necessary to access arrays that
contain different data types. Variant records are allocated the maximum
amount of storage needed for the record. Because of this it is possible
to 'overlay' the fields so data can be accessed as different types. For
example, DBBUF can now be accessed as character data if DBBUF_CHAR is
referenced, or as a single word integer data if DBBUF_INT is referenced.
(* 2 *)
For proper storage (one character per byte), character data should be in
a PACKED ARRAY OF CHAR (PACs). However, PACs have byte addresses and the
data passed between QUERY and the user-defined procedure must have word
addresses. When a PAC is declared as a field in a RECORD, it has a word
address.
(* 3 *)
QUERY passes all parameters as word addresses. The parameters must be
declared as VAR so that indirect addressing is performed, otherwise, the
addresses will be taken as values.
(* 4 *)
When PASCAL assigns TRUE to a BOOLEAN, a one is placed in the left byte
of the BOOLEAN value. When SPL tests TRUE or FALSE, it tests for odd or
even respectively. The PASCAL TRUE will be considered FALSE. So
CALLAGAIN is declared to be a SMALLINT and is assigned the SPL convention
of minus one for TRUE and zero for FALSE.
Additional Comments
If you wish to use PASCAL I/O to help debug your procedure you must do it
the following way:
REWRITE (output, '$STDLIST');
WRITELN (output, 'message');
FORTRAN - MPROC Procedure
$CONTROL FREE
#-------------------------------------------------------#
# YOU WILL NOT WANT TO INITIALIZE THE USL FILE IF YOU #
# ARE COMPILING DIFFERENT SUBPROGRAMS INTO IT. #
#-------------------------------------------------------#
$CONTROL MAP, USLINIT, LOCATION
$CONTROL SEGMENT=MULTISEG
#------------------------------------------------------#
# #
# MPROC #
# #
# EXAMPLE OF A FORTRAN USER-DEFINED PROCEDURE, USED #
# WITH A REPORT STATEMENT. #
# #
#------------------------------------------------------#
# THIS PROCEDURE TAKES A JULIAN DATE AND CONVERTS IT #
# TO "DAY, MONTH, YEAR" FORMAT BY CALLING THE MPE #
# INTRINSIC FMTCALENDAR. #
#------------------------------------------------------#
#
#------------------------------------------#
# MPROC DECLARATION #
#------------------------------------------#
#
SUBROUTINE MPROC (CALLAGAIN, PAGEEJECT, BASEIDS, DBBUF, &
DSETLIST, DBLIST, LINEBUF, REGARR, &
USERSTOR, USERPARAM, DBNAME, &
DSNAME, CALLNUM, LINESLEFT, PAGENO, &
NUMDSETS, NUMDBASES)
#
LOGICAL CALLAGAIN, PAGEEJECT
INTEGER BASEIDS(130), DBBUF(2051), DSETLIST(53), DBLIST(53)
INTEGER LINEBUF(69), REGARR(150), USERSTOR(64)
INTEGER USERPARAM
INTEGER DBNAME(13), DSNAME(8)
INTEGER CALLNUM, LINESLEFT, PAGENO, NUMDSETS, NUMDBASES
#
#
INTEGER FMTDATE (9)
CHARACTER BFMTDATE (18)
EQUIVALENCE (FMTDATE,BFMTDATE)
#
INTEGER*4 DHOLD, DDAY, DYEAR, HOLDYR
INTEGER DAY(2), YEAR(2), HOLD(2)
EQUIVALENCE (DDAY,DAY), (DYEAR,YEAR), (DHOLD,HOLD)
#
FORTRAN - MPROC Procedure (Continued)
INTEGER INTDBNAME(13), INTDSNAME(8)
CHARACTER*26 CHDBNAME
CHARACTER*16 CHDSNAME
EQUIVALENCE (INTDBNAME,CHDBNAME), (INTDSNAME,CHDSNAME)
#
LOGICAL JDATE
#
#
SYSTEM INTRINSIC FMTCALENDAR
#
#--------------------------------------------------------#
# THERE ARE TWO DATES IN THE DATA BASE TO BE FORMATTED. #
# ONE IS IN THE ORDER-D DATA SET, THE OTHER IS IN THE #
# SHIP-D DATA SET. BECAUSE THE SETS HAVE BEEN JOINED, #
# IT IS POSSIBLE TO GET BOTH DATES AND FORMAT THEM. #
# NOTE: IT IS THE APPLICATIONS RESPONSIBILITY TO KNOW #
# WHERE IN THE DATA BUFFER THE VALUE IS LOCATED. #
#--------------------------------------------------------#
#--------------------------------------------------------#
# THE DATE IS IN A TWO WORD INTEGER AND NEEDS TO BE RE- #
# FORMATTED BEFORE PASSING TO FMTCALENDAR. #
#--------------------------------------------------------#
#--------------------------------------------------------#
# IF CALLNUM IS ONE THEN WE CAN ASSUME THE ENTRY IS #
# FROM THE ORDER-D DATA SET, SINCE IT IS THE FIRST DATA #
# SET MENTIONED IN THE JOIN COMMAND. IF CALLNUM IS NOT #
# ONE THEN WE CAN ASSUME THAT THE PROCEDURE HAS BEEN #
# CALLED AGAIN, AND WE NOW HAVE THE ENTRY FROM THE #
# SHIP-D DATA SET. #
#--------------------------------------------------------#
#
IF (CALLNUM .GT. 1) GOTO 100
HOLD(1) = DBBUF(4)
HOLD(2) = DBBUF(5)
GOTO 200
#
100 HOLD(1) = DBBUF(6)
HOLD(2) = DBBUF(7)
#
200 DYEAR = DHOLD / 1000
HOLDYR = DYEAR * 1000
DDAY = DHOLD - HOLDYR
JDATE[0:7] = BOOL (YEAR(2))
JDATE[7:9] = BOOL (DAY(2))
#
FORTRAN - MPROC Procedure (Continued)
DO 225 N = 1, 18
225 BFMTDATE(N) = " "
#
CALL FMTCALENDAR (JDATE, BFMTDATE)
#
#--------------------------------------------------------#
# PUT THE FORMATTED DATE INTO THE OUTPUT BUFFER USED BY #
# QUERY FOR THE REPORT OUTPUT LINE. AGAIN, CALL'NUM IS #
# USED TO DETERMINE WHERE IN THE OUTPUT BUFFER TO PLACE #
# THE VALUE. ALSO, IF CALL'NUM IS ONE THEN WE NEED TO #
# SET THE DATA BASE NAME, THE DATA SET NAME, AND THE #
# CALLAGAIN PARAMETERS IN ORDER TO GET THE ENTRY FROM #
# THE SHIP-D DATA SET TO FORMAT THE SHIPPING DATE. #
#--------------------------------------------------------#
#
IF (CALLNUM .GT. 1) GOTO 300
M = 1
DO 250 N = 10, 18
LINEBUF(N) = FMTDATE(M)
250 M = M + 1
CHDBNAME = "ACCTS "
CHDSNAME = "SHIP-D "
M = 1
DO 275 N = 1, 13
DBNAME(N) = INTDBNAME(M)
275 M = M + 1
M = 1
DO 285 N = 1, 8
DSNAME(N) = INTDSNAME(M)
285 M = M + 1
CALLAGAIN = .TRUE.
GOTO 400
#
300 M = 1
DO 350 N = 21, 29
LINEBUF(N) = FMTDATE(M)
350 M = M + 1
CALLAGAIN = .FALSE.
#
400 RETURN
END
QPROC Procedure
The following examples show the QPROC user-defined procedure in two
languages: SPL and COBOL. This procedure displays the parameter values
when it is called from QUERY. You can interactively change the parameters
which can be modified by user-defined procedures. The changes can affect
the data returned. The procedure can be terminated before all the report
entries have been processed by entering CONTROL Y at an input prompt.
The procedure will terminate after that sequence of parameter prompts is
finished and the report command will terminate.
SPL - QPROC Procedure
$PAGE "QPROC: Program Description."
$CONTROL MAP, USLINIT, SUBPROGRAM
$CONTROL SEGMENT=QPROC
<<*****************************************************************>>
<< >>
<< Q P R O C >>
<< >>
<< SPL Example of QUERY user callable procedure >>
<< >>
<<*****************************************************************>>
begin
INTRINSIC PRINT,
ASCII,
DASCII,
DEBUG,
READ,
BINARY;
PROCEDURE QPROC(CALLAGAIN,PAGE'EJECT,BASE'IDS,DBBUF, DSET'LIST,
DATA'BASE'LIST, LINEBUF, REGARR, USERSTOR, USERPARAM,
DATA'BASE'NAME, DATA'SET'NAME, CALL'NUM, LINES'LEFT,
PAGENO, NUM'DSETS, NUM'DBASES );
LOGICAL CALLAGAIN, PAGE'EJECT;
INTEGER ARRAY BASE'IDS, DBBUF, DSET'LIST, DATA'BASE'LIST,
LINEBUF, REGARR, USERSTOR, USERPARAM,
DATA'BASE'NAME, DATA'SET'NAME;
INTEGER CALL'NUM, LINES'LEFT, PAGENO, NUM'DSETS,
NUM'DBASES;
$PAGE "QPROC: Procedure Global Variables."
begin
SPL - QPROC Procedure (Continued)
<<---------------------------------------------------------------->>
<< LOCAL DECLARATIONS >>
<<---------------------------------------------------------------->>
<<------------------------------------------------>>
<<-------- REDEFINE SOME PASSED PARAMETERS ------->>
<<------------------------------------------------>>
BYTE ARRAY BASE'IDS'B(*)=BASE'IDS;
BYTE ARRAY DBBUF'B(*)=DBBUF;
<<------------------------------------------------>>
<<--------------- NEW LOCAL STORAGE -------------->>
<<------------------------------------------------>>
INTEGER NUM'CHAR;
INTEGER I, J, K, L; << COUNTERS For DO-WHILE / DO-until >>
INTEGER REG'INDEX;
INTEGER END'PTR;
INTEGER START'PTR;
INTEGER DEC'PTR; << DECIMAL POINT >>
ARRAY BUF(0:50 );
BYTE ARRAY BUF'B(*) = BUF;
INTEGER BUF'INDX;
ARRAY BUF1(0:50 );
BYTE ARRAY BUF1'B(*) = BUF1;
LONG ARRAY TEMP'L(0:1 );
INTEGER ARRAY TEMP'I(*) = TEMP'L;
$PAGE "QPROC: Outer block."
<<****************************************************************>>
<< START OF QPROC >>
<<****************************************************************>>
PRINT( BUF, 0, %60 );
PRINT( BUF, 0, %60 );
move BUF'B(0): = " ******** PROCEDURE QPROC *******";
PRINT( BUF, -49, %40 );
SPL - QPROC Procedure (Continued)
<<----------------------------------------------------------------->>
<< CALL AGAIN >>
<<----------------------------------------------------------------->>
move BUF : = "-- CALL AGAIN -- (CHANGE to True or False)";
PRINT( BUF, 0, %40 );
PRINT( BUF, -42, %40 );
if CALLAGAIN = TRUE then move BUF := "--TRUE-- ";
if CALLAGAIN = FALSE then move BUF := "--FALSE--";
PRINT( BUF, -9, %40 );
I := READ( BUF, -5 );
if I<>0 and (BUF'B = "T" or BUF'B = "t") then CALLAGAIN := TRUE;
if I<>0 and (BUF'B = "F" or BUF'B = "f") then CALLAGAIN := FALSE;
<<---------------------------------------------------------------->>
<< PAGE EJECT >>
<<---------------------------------------------------------------->>
move BUF := "-- PAGE EJECT -- (CHANGE to True or False)";
PRINT( BUF, 0, %40 );
PRINT( BUF, -42, %40 );
if PAGE'EJECT = TRUE then move BUF := "--TRUE-- ";
if PAGE'EJECT = FALSE then move BUF := "--FALSE--";
PRINT( BUF, -9, %40 );
I := READ( BUF, -5 );
if I<>0 and (BUF'B = "T" or BUF'B = "t") then PAGE'EJECT:= TRUE;
if I<>0 and (BUF'B = "F" or BUF'B = "f") then PAGE'EJECT:= FALSE;
<<---------------------------------------------------------------->>
<< BASE ID'S >>
<<---------------------------------------------------------------->>
move BUF := "-- BASE ID'S --";
PRINT( BUF, 0, %40 );
PRINT( BUF, -15, %40 );
move BUF'B(0) := (79(" ") );
if BASE'IDS(1) <> %020040 then begin
NUM'CHAR := ASCII( BASE'IDS(0), 10, BUF'B );
move BUF'B(NUM'CHAR) := BASE'IDS'B(2), (24 );
if BASE'IDS(14) <> %020040 then begin
NUM'CHAR := ASCII( BASE'IDS(13), 10, BUF'B(35) );
move BUF'B(NUM'CHAR+35) := BASE'IDS'B(28), (24 );
end;
end;
PRINT( BUF, -79, %40 );
$PAGE
<<---------------------------------------------------------------->>
<< DATA BASE RECORD BUFFER >>
<<---------------------------------------------------------------->>
move BUF := "-- DB BUFFER -- ";
PRINT( BUF, 0, %40 );
SPL - QPROC Procedure (Continued)
PRINT( BUF, -15, %40 );
move BUF'B(0) := (79(" ") );
For I := 0 until 10 do
ASCII( DBBUF(I), 8, BUF'B(I*7) );
PRINT (BUF, -79, %40 );
move BUF'B(0) := (79(" ") );
For I := 0 step 7 until 70 do begin
BUF'B(I+1) := DBBUF'B(I/7*2 );
if BUF'B(I+1)<%40 or BUF'B(I+1)>%176 then BUF'B(I+1):=%40;
BUF'B(I+4) := DBBUF'B(I/7*2+1 );
if BUF'B(I+4)<%40 or BUF'B(I+1)>%176 then BUF'B(I+4):=%40; end;
PRINT (BUF, -79, %40 );
<<---------------------------------------------------------------->>
<< LIST OF DATA SETS >>
<<---------------------------------------------------------------->>
move BUF := "-- DATA SET LIST --";
PRINT( BUF, 0, %40 );
PRINT( BUF, -19, %40 );
move BUF'B(0) := (79(" ") ); J := 0;
For I := 0 step 8 until 72 do begin
NUM'CHAR := ASCII( DSET'LIST(J), 10, BUF'B(I) ); J := J+1; end;
PRINT (BUF, -79, %40 );
<<---------------------------------------------------------------->>
<< LIST OF DATA BASES >>
<<---------------------------------------------------------------->>
move BUF := "-- DATA BASE LIST --";
PRINT( BUF, 0, %40 );
PRINT( BUF, -20, %40 );
move BUF'B(0) := (79(" ") ); J := 0;
For I := 0 step 8 until 72 do begin
NUM'CHAR := ASCII( DATA'BASE'LIST(J), 10, BUF'B(I) );J:=J+1;end;
PRINT (BUF, -79, %40 );
<<---------------------------------------------------------------->>
<< PRINT LINE BUFFER >>
<<---------------------------------------------------------------->>
move BUF'B:="--LINE BUFFER -- ";
PRINT( BUF, 0, %40 );
PRINT( BUF, -16, %40 );
PRINT( LINEBUF, -79, %40 );
I := READ( LINEBUF, -79 );
PRINT'REGARR:
$PAGE
<<---------------------------------------------------------------->>
<< ARRAY OF REGISTERS >>
<< (assume real numbers in registers) >>
<<---------------------------------------------------------------->>
move BUF := "-- REGISTER ARRAY -- ";
SPL - QPROC Procedure (Continued)
PRINT( BUF, 0, %40 );
PRINT( BUF, -20, %40 );
move BUF'B(0) := (79(" "));
J := 0;
For I := 0 step 13 until 78 do begin
move TEMP'I := REGARR(J), (4 );
NUM'CHAR:=DASCII( FIXR(REAL(TEMP'L)), 10, BUF'B(I) );
J := J + 5;+
end;
PRINT( BUF, -79, %40 );
I := READ( BUF, -79 );
END'PTR := 0;
START'PTR := 0;
DEC'PTR := 0;
BUF'INDX := 0;
REG'INDEX := 0;
if J = 0 then go to SKIP'REGISTER'LOAD; << SEE BELOW >>
<<---------------------------->>
<<------- REGISTER LOAD ------>>
<<---------------------------->>
For J := 0 until I do
begin
if BUF'B(J) = "," then END'PTR := J;
if BUF'B(J) = "," or J = I then
begin
if DEC'PTR = START'PTR then DEC'PTR := END'PTR; <<NO DECIMAL>>
K := BINARY( BUF1'B, BUF'INDX );
if <> then K := 0;
TEMP'L := LONG(REAL(K) );
For L:= 1 until (BUF'INDX-(DEC'PTR-START'PTR)) do
begin
TEMP'L := TEMP'L * .1L0;
end;
move REGARR(REG'INDEX) := TEMP'I, (4);
REG'INDEX := REG'INDEX + 5;
BUF'INDX := 0;
DEC'PTR := J;
end;
if BUF'B(J) = "," then START'PTR := J+1;
if BUF'B(J) = "," then DEC'PTR := J+1;
if BUF'B(J) = "." then DEC'PTR := J;
if BUF'B(J) <> "," and BUF'B(J) <> "." then
begin
move BUF1'B(BUF'INDX) := BUF'B(J), (1);
BUF'INDX := BUF'INDX + 1;
end;
end;
SPL - QPROC Procedure (Continued)
SKIP'REGISTER'LOAD: << SKIP REGISTER LOAD >>
$PAGE
<<---------------------------------------------------------------->>
<< USER STORE ARRAY >>
<<---------------------------------------------------------------->>
move BUF := "-- USER STORE -- ";
PRINT( BUF, 0, %40 );
PRINT( BUF, -16, %40 );
PRINT( USERSTOR, -79, %40 );
I := READ( USERSTOR, -79 );
<<---------------------------------------------------------------->>
<< USER PARAMETER >>
<<---------------------------------------------------------------->>
move BUF := "-- USER PARAMETER -- (INTEGER) ";
PRINT( BUF, -30, %40 );
NUM'CHAR := ASCII( USERPARAM, 10, BUF'B );
PRINT( BUF, 0, %40 );
PRINT( BUF, -NUM'CHAR, %40 );
GET'USERPARAM:
I := READ( BUF, -7 );
if I <> 0 then
begin
USERPARAM := BINARY( BUF'B, I );
if <> then begin
move BUF := "## DBINARY COULD NOT CONVERT ## ";
PRINT( BUF, -31, %40 );
go to GET'USERPARAM;
end;
end;
<<---------------------------------------------------------------->>
<< DATA BASE NAME >>
<<---------------------------------------------------------------->>
move BUF := "-- DATA BASE NAME -- ";
PRINT( BUF, 0, %40 );
PRINT( BUF, -20, %40 );
PRINT( DATA'BASE'NAME, -26, %40 );
I := READ( DATA'BASE'NAME, -26 );
<<---------------------------------------------------------------->>
<< DATA SET NAME >>
<<---------------------------------------------------------------->>
move BUF := "-- DATA SET NAME -- ";
PRINT( BUF, 0, %40 );
PRINT( BUF, -20, %40 );
SPL - QPROC Procedure (Continued)
PRINT( DATA'SET'NAME, -16, %40 );
I := READ( DATA'SET'NAME, -16 );
$PAGE
<<---------------------------------------------------------------->>
<< CALL NUMBER >>
<<---------------------------------------------------------------->>
move BUF := "-- CALL NUMBER -- ";
PRINT( BUF, 0, %40 );
PRINT( BUF, -17, %40 );
NUM'CHAR:=ASCII( CALL'NUM, 10, BUF'B );
PRINT( BUF, -NUM'CHAR, %40 );
<<---------------------------------------------------------------->>
<< LINES LEFT >>
<<---------------------------------------------------------------->>
move BUF := "-- LINES LEFT -- ";
PRINT( BUF, 0, %40 );
PRINT( BUF, -16, %40 );
NUM'CHAR:=ASCII( LINES'LEFT, 10, BUF'B );
PRINT( BUF, -NUM'CHAR, %40 );
<<---------------------------------------------------------------->>
<< PAGE NUMBER >>
<<---------------------------------------------------------------->>
move BUF := "-- PAGE NUMBER -- ";
PRINT( BUF, 0, %40 );
PRINT( BUF, -17, %40 );
NUM'CHAR:=ASCII( PAGENO, 10, BUF'B );
PRINT( BUF, -NUM'CHAR, %40 );
<<---------------------------------------------------------------->>
<< NUMBER OF DATA SETS >>
<<---------------------------------------------------------------->>
move BUF := "-- NUMBER OF DATA SETS -- ";
PRINT( BUF, 0, %40 );
PRINT( BUF, -25, %40 );
NUM'CHAR:=ASCII( NUM'DSETS, 10, BUF'B );
PRINT( BUF, -NUM'CHAR, %40 );
<<---------------------------------------------------------------->>
<< NUMBER OF DATA BASES >>
<<---------------------------------------------------------------->>
move BUF := "-- NUMBER OF DATA BASES -- ";
PRINT( BUF, 0, %40 );
PRINT( BUF, -26, %60 ); << DOUBLE SPACE AFTER LAST LINE >>
NUM'CHAR:=ASCII( NUM'DBASES, 10, BUF'B );
PRINT( BUF, -NUM'CHAR, %40 );
end;
end.
COBOL - QPROC Procedure
$CONTROL USLINIT,SUBPROGRAM,DYNAMIC
IDENTIFICATION DIVISION.
PROGRAM-ID. QPROC.
AUTHOR. HP.
***************************************************************
* *
* Q P R O C *
* *
* COBOL Example of QUERY user callable procedure *
* *
*-------------------------------------------------------------*
* QPROC requires the use of COBOLII's "Accept free" verb *
* and should be compiled using a COBOLII compiler. Numeric *
* fields are displayed in zoned format for simplicity of *
* the example. *
***************************************************************
ENVIRONMENT DIVISION.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 BUF.
05 BUFX OCCURS 136 TIMES PIC X.
01 REG-NBR PIC S9(4) COMP.
LINKAGE SECTION.
01 CALLAGAIN PIC S9(4) COMP.
01 PAGE-EJECT PIC S9(4) COMP.
01 BASE-IDS.
05 BASE-ID1 PIC S9(4) COMP.
05 BASE-NAME1 PIC X(24).
05 BASE-ID2 PIC S9(4) COMP.
05 BASE-NAME2 PIC X(24).
05 BASE-ID-OTHERS PIC X(208).
01 DBBUF.
05 DBBUF-70 PIC X(70).
05 DBBUFI REDEFINES DBBUF-70 OCCURS 35 TIMES
PIC S9(4) COMP.
05 DBBUF-OTHER PIC X(4026).
01 DSET-LIST.
05 DSET OCCURS 100 TIMES PIC S9(4) COMP.
01 DATA-BASE-LIST.
05 DBASE OCCURS 100 TIMES PIC S9(4) COMP.
01 LINEBUF.
05 LINEBUF-70 PIC X(70).
05 LINEBUF-OTHER PIC X(66).
COBOL - QPROC Procedure (Continued)
01 REGARR.
05 REG OCCURS 30 TIMES PIC S9(18) COMP-3.
01 USERSTOR.
05 USERSTOR-70 PIC X(70).
05 USERSTOR-OTHER PIC X(58).
01 USERPARAM PIC S9(4) COMP.
01 DATA-BASE-NAME PIC X(26).
01 DATA-SET-NAME PIC X(16).
01 CALL-NUM PIC S9(4) COMP.
01 LINES-LEFT PIC S9(4) COMP.
01 PAGENO PIC S9(4) COMP.
01 NUM-DSETS PIC S9(4) COMP.
01 NUM-DBASES PIC S9(4) COMP.
$PAGE "QPROC: Procedure Division."
***********************************************************
* PROCEDURE DIVISION *
***********************************************************
PROCEDURE DIVISION USING CALLAGAIN, PAGE-EJECT, BASE-IDS,
DBBUF, DSET-LIST, DATA-BASE-LIST, LINEBUF, REGARR,
USERSTOR, USERPARAM, DATA-BASE-NAME, DATA-SET-NAME,
CALL-NUM, LINES-LEFT, PAGENO, NUM-DSETS, NUM-DBASES.
BEGIN-QPROC.
DISPLAY SPACE.
DISPLAY SPACE.
DISPLAY " ******* PROCEDURE QPROC ******* "
*---------------------------------------------------------*
* CALL AGAIN *
*---------------------------------------------------------*
DISPLAY SPACE.
DISPLAY "-- CALL AGAIN -- (CHANGE to True or False) ".
MOVE SPACE TO BUF.
ACCEPT BUF.
IF BUFX(1) = "T" OR BUFX(1) = "t" THEN MOVE -1 TO CALLAGAIN.
IF BUFX(1) = "F" OR BUFX(1) = "f" THEN MOVE 0 TO CALLAGAIN.
*--------------------------------------------------------*
* PAGE EJECT *
*--------------------------------------------------------*
DISPLAY SPACE.
DISPLAY "-- PAGE EJECT -- (CHANGE to True or False) ".
MOVE SPACE TO BUF.
ACCEPT BUF.
IF BUFX(1) = "T" OR BUFX(1) = "t" THEN MOVE -1 TO PAGE-EJECT.
IF BUFX(1) = "F" OR BUFX(1) = "f" THEN MOVE 0 TO PAGE-EJECT.
COBOL - QPROC Procedure (Continued)
*--------------------------------------------------------*
* BASE ID'S *
*--------------------------------------------------------*
DISPLAY "-- BASE ID'S --".
IF BASE-ID2 = 8224 THEN
DISPLAY BASE-ID1, " ", BASE-NAME1
ELSE
DISPLAY BASE-ID1, " ", BASE-NAME1, " ", BASE-ID2,
" ", BASE-NAME2.
*--------------------------------------------------------*
* DATA BASE RECORD BUFFER *
*--------------------------------------------------------*
DISPLAY SPACE.
DISPLAY "-- DB BUFFER -- (Decimal and Character)".
DISPLAY DBBUFI(1), " ", DBBUFI(2), " ", DBBUFI(3), " ",
DBBUFI(4), " ", DBBUFI(5), " ", DBBUFI(6), " ",
DBBUFI(7), " ", DBBUFI(8), " ", DBBUFI(9), " ",
DBBUFI(10).
DISPLAY DBBUF-70.
*--------------------------------------------------------*
* LIST OF DATA SETS *
*--------------------------------------------------------*
DISPLAY SPACE.
DISPLAY "-- DATA SET LIST--".
DISPLAY DSET(1), " ", DSET(2), " ", DSET(3), " ",
DSET(4), " ", DSET(5), " ", DSET(6), " ",
DSET(7), " ", DSET(8), " ", DSET(9), " ".
*--------------------------------------------------------*
* LIST OF DATA BASES *
*--------------------------------------------------------*
DISPLAY SPACE.
DISPLAY "-- DATA BASE LIST--".
DISPLAY DBASE(1), " ", DBASE(2), " ", DBASE(3), " ",
DBASE(4), " ", DBASE(5), " ", DBASE(6), " ",
DBASE(7), " ", DBASE(8), " ", DBASE(9), " ".
*--------------------------------------------------------*
* PRINT LINE BUFFER *
*--------------------------------------------------------*
DISPLAY SPACE.
DISPLAY "-- LINE BUFFER --".
DISPLAY LINEBUF-70.
ACCEPT LINEBUF.
COBOL - QPROC Procedure (Continued)
*--------------------------------------------------------*
* PRINT REGISTER ARRAY *
* (Packed decimal is assumed) *
*--------------------------------------------------------*
DISPLAY SPACE.
DISPLAY-REGISTERS.
DISPLAY " ".
DISPLAY "-- REGISTER ARRAY -- (0-8 Displayed)".
DISPLAY REG(1), " ", REG(2), " ", REG(3), " ".
DISPLAY REG(4), " ", REG(5), " ", REG(6), " ".
DISPLAY REG(7), " ", REG(8), " ", REG(9), " ".
ACCEPT-REGISTERS.
DISPLAY "CHANGE A REGISTER (Yes/No)?".
MOVE SPACE TO BUF.
ACCEPT BUF.
IF BUFX(1) = "Y" OR BUFX(1) = "y" THEN
DISPLAY "ENTER REGISTER NUMBER (0-29)?"
ACCEPT REG-NBR FREE
IF REG-NBR > -1 AND REG-NBR < 31 THEN
DISPLAY "ENTER VALUE FOR REGISTER"
ADD 1 TO REG-NBR
ACCEPT REG(REG-NBR) FREE.
IF BUFX(1) = "Y" OR BUFX(1) = "y" THEN
GO TO DISPLAY-REGISTERS.
*--------------------------------------------------------*
* USER STORE ARRAY *
*--------------------------------------------------------*
DISPLAY SPACE.
DISPLAY "-- USER STORE --".
DISPLAY USERSTOR-70.
ACCEPT USERSTOR.
*--------------------------------------------------------*
* USER PARAMETER *
*--------------------------------------------------------*
DISPLAY SPACE.
DISPLAY "-- USER PARAMETER --".
DISPLAY USERPARAM.
ACCEPT USERPARAM FREE.
*--------------------------------------------------------*
* DATA BASE NAME *
*--------------------------------------------------------*
DISPLAY SPACE.
DISPLAY "-- DATA BASE NAME --".
COBOL - QPROC Procedure (Continued)
DISPLAY DATA-BASE-NAME.
MOVE " " TO DATA-BASE-NAME.
ACCEPT DATA-BASE-NAME.
*--------------------------------------------------------*
* DATA SET NAME *
*--------------------------------------------------------*
DISPLAY SPACE.
DISPLAY "-- DATA SET NAME --".
DISPLAY DATA-SET-NAME.
ACCEPT DATA-SET-NAME.
*--------------------------------------------------------*
* CALL NUMBER *
*--------------------------------------------------------*
DISPLAY SPACE.
DISPLAY "-- CALL NUMBER --".
DISPLAY CALL-NUM.
*--------------------------------------------------------*
* LINES LEFT *
*--------------------------------------------------------*
DISPLAY SPACE.
DISPLAY "-- LINES LEFT --".
DISPLAY LINES-LEFT.
*--------------------------------------------------------*
* PAGE NUMBER *
*--------------------------------------------------------*
DISPLAY SPACE.
DISPLAY "-- PAGE NUMBER --".
DISPLAY PAGENO.
*--------------------------------------------------------*
* NUMBER OF DATA SETS *
*--------------------------------------------------------*
DISPLAY SPACE.
DISPLAY "-- NUM-DSETS --".
DISPLAY NUM-DSETS.
*--------------------------------------------------------*
* NUMBER OF DATA BASES *
*--------------------------------------------------------*
DISPLAY SPACE.
DISPLAY "-- NUMBER OF DATA BASES --".
DISPLAY NUM-DBASES.
GOBACK.