Trailing-Edge
-
PDP-10 Archives
-
RMS_V2_840216
-
uetp/lib/rmtbls.b36
There are 4 other files named rmtbls.b36 in the archive. Click here to see a list.
!<BLF/REQUIRE 'BLI:BLF.REQ'>
MODULE rmtbls (MAIN = driver
) =
BEGIN
LIBRARY 'sys:rmsint';
LINKAGE
!
! Linkage for alternate output routines
!
$m2_compatible = PUSHJ : !
LINKAGE_REGS (15, 13, 1) !
NOPRESERVE (2, 3, 4) !
PRESERVE (0, 5, 6, 7, 8, 9, 10, 11, 12, 14); !
EXTERNAL ROUTINE
tx$out : NOVALUE, ! The usual routine
tx$rpt : NOVALUE, ! The alternate output routine
tx$set : NOVALUE; ! The alt-output setup routine
GLOBAL
nocrfl, ! -1 if not appending CRLF
nooutf, ! -1 if string is continued
strbp, ! BP to arg ASCIZ string
nargs, ! Number of args
tempbp, ! Temporary BP
tempcc, ! and temporary count
retad, ! Return address to routine
ttybp, ! TTY byte ptr
ttycc, ! TTY char count
altbfp, ! Alternate buffer pointer
altcc, ! Alternate char count
dstbp, ! Bp to dest. buffer
dstcc, ! # chars left in dest. buffer
outbuf : VECTOR [100], ! Output string buffer
tempbf : VECTOR [20], ! Temp buffer for dates, MOVST
altout, ! -1 if TX$RPT called
altbcc, ! Address of user's BP, CC
bufdmp, ! User dump buffer routine
bufint, ! User init buffer routine
svt34 : VECTOR [2], ! Some saved ACs
svt56 : VECTOR [2]; ! ...
MACRO
$m2$$stringarg (value) =
%IF %ISSTRING (value)
%THEN
UPLIT (%ASCIZ value)
%ELSE value
%FI
%;
KEYWORDMACRO
$identify_program (
program,
blabel) =
BEGIN
tx$rpt ($m2$$stringarg (program), ! Program name
$m2$$stringarg (blabel), ! Current label
identify_report); ! Format string
tx$out (UPLIT (%ASCIZ '[Beginning BLISS test]'));
END %;
KEYWORDMACRO
$log_entry (
message) =
tx$rpt ($m2$$stringarg (message), ! Message to send
log_report) %; ! Format string
MACRO
$exit_command =
tx$rpt (UPLIT (%ASCIZ 'EXIT')) %; ! Format string
KEYWORDMACRO
$error_entry (
expected = rms$_suc, ! Expected result
arg_block, ! Argument block
description) =
! Operation description
BEGIN
LOCAL
argblk : REF BLOCK [],
errsts,
errstv;
error_count = .error_count + 1;
argblk = (arg_block);
errsts = .argblk [1, 18, 18, 0];
errstv = .argblk [1, 0, 18, 0];
tx$rpt (.error_count, !
$m2$$stringarg (description), !
error_report);
tx$out (.error_count, (expected), .errsts, .errstv, !
$m2$$stringarg (description), error_type);
END %;
MACRO
st$ptr (data) =
CH$PTR(UPLIT(%ASCIZ %STRING(data, %REMAINING))) %,
ch$sequence (length) =
VECTOR[CH$ALLOCATION(length)] %;
MACRO
start_report =
st_rpt %,
finish_report =
finrpt %,
initialize_report_buffer =
inirpt %,
put_report_buffer =
putrpt %;
FORWARD ROUTINE
!+
! Routines from the UETP harness
!-
driver : NOVALUE,
start_report : NOVALUE,
finish_report : NOVALUE,
initialize_report_buffer : NOVALUE $m2_compatible,
put_report_buffer : NOVALUE $m2_compatible;
FORWARD ROUTINE
!+
! T E S T R O U T I N E S
!-
tstseq : NOVALUE,
tstidx : NOVALUE,
tstrel : NOVALUE;
LITERAL
rptbuf_len = 132;
OWN
error_count,
rptbuf : ch$sequence [rptbuf_len],
rptfab : $fab (fac = put, fop = sup, fna = 'RMTBLS.LOG', !
org = seq, rfm = stm),
rptrab : $rab (fab = rptfab, ubf = rptbuf),
rptptr,
rptcnt;
BIND
identify_report = st$ptr ('TEST ^A^LBLABEL ^A'),
log_report = st$ptr ('TYPE LOG^LSEND ^A'),
error_report = st$ptr ('TYPE ERROR^LSEND # ^1: ^A'),
error_type = st$ptr ( !
'[Error # ^1: expected STS: ^2; returned STS: ^2 STV:^2]^L',
'[Description: ^A]^L'), !
test_blabel = st$ptr ('BLSRUN::'),
test_name = st$ptr ('NEWRMS');
ROUTINE driver : NOVALUE =
BEGIN
start_report (); ! Set up for reporting
!
! Do some processing
!
tstseq ();
tstidx ();
tstrel ();
!
! Terminate and close report file
!
finish_report ();
END; ! End DRIVER
ROUTINE start_report : NOVALUE =
BEGIN
error_count = 0; ! Initially no errors
!
! Open the report file
!
$create (fab = rptfab); ! Hope for no errors
$connect (rab = rptrab); ! ...
tx$set (UPLIT (CH$PTR (rptbuf), rptbuf_len), ! Buffer descriptor
put_report_buffer, ! Buffer output routine
initialize_report_buffer); ! Buffer initialization routine
END; ! End START_REPORT
ROUTINE finish_report : NOVALUE =
BEGIN
!
! Close the report file
!
$exit_command; ! Send EXIT to command file
$close (fab = rptfab);
END; ! End FINISH_REPORT
ROUTINE initialize_report_buffer : NOVALUE $m2_compatible =
BEGIN
rptptr = CH$PTR (rptbuf);
rptcnt = rptbuf_len;
CH$FILL (0, rptbuf_len, .rptptr);
END; ! End INITIALIZE_REPORT_BUFFER
ROUTINE put_report_buffer : NOVALUE $m2_compatible =
BEGIN
LOCAL
rptlen;
rptlen = CH$DIFF (CH$FIND_CH (rptbuf_len, CH$PTR (rptbuf), 0), !
CH$PTR (rptbuf));
rptrab [rab$h_rsz] = .rptlen;
$put (rab = rptrab);
END; ! End PUT_REPORT_BUFFER
ROUTINE tstseq : NOVALUE =
BEGIN
LOCAL
seqbuf : ch$sequence (80),
seqfab : $fab_decl,
seqrab : $rab_decl;
$log_entry (message = 'Beginning sequential file testing');
$fab_init (fab = seqfab, fna = 'SEQSEQ.RMS', fop = sup, !
org = seq, rfm = var, fac = <get, put, del, upd>);
$rab_init (rab = seqrab, fab = seqfab, ubf = seqbuf, !
usz = %ALLOCATION (seqbuf));
IF NOT $create (fab = seqfab) ! Make a sequential file
THEN
BEGIN
$error_entry (arg_block = seqfab, !
description = 'Routine TSTSEQ: $CREATE failed');
RETURN;
END;
IF NOT $connect (rab = seqrab) ! Connect a record stream
THEN
BEGIN
$error_entry (arg_block = seqrab, !
description = 'Routine TSTSEQ: $CONNECT failed');
RETURN;
END;
!+
! Write 26 records of length 1 to 26
!-
INCR counter FROM 1 TO 26 DO
BEGIN
CH$FILL ((%C'@' + .counter), .counter, CH$PTR (seqbuf));
seqrab [rab$h_rsz] = .counter;
IF NOT $put (rab = seqrab) ! Write the record
THEN
BEGIN
$error_entry (arg_block = seqrab, !
description = 'Routine TSTSEQ: $PUT failed');
RETURN;
END;
END;
IF NOT $close (fab = seqfab) ! Close the file
THEN
BEGIN
$error_entry (arg_block = seqfab, !
description = 'Routine TSTSEQ: $CLOSE failed');
RETURN;
END;
$log_entry (message = 'Sequential tests successful');
END; ! End TSTSEQ
ROUTINE tstidx : NOVALUE =
BEGIN
LITERAL
file_bytes_per_word = 4,
gfloating_field = 0,
integer_field = 2,
floating_field = 3;
BIND
trecord=PLIT(
PLIT(%G'1.7762G20',143,%E'9123.4','fooBAR'),
PLIT(%G'1.77621G20',142,%E'-123.4','toad'),
PLIT(%G'-1.776001G20',2144,%E'123.4E-10','twoddle'),
PLIT(%G'981.776G120',194,%E'3.4','fie'),
PLIT(%G'6G0',1,%E'16.16','You are number 6'),
PLIT(%G'7G2',14,%E'4','frog'),
PLIT(%G'1.776001G20',145,%E'123.4015','a little more'),
PLIT(%G'331.2G199',999,%E'-1999.8','BIG'),
PLIT(%G'-21.776G20',184,%E'123.401','phoo'),
PLIT(%G'.776G20',154,%E'147.12','nepra'),
PLIT(%G'1.77G20',111,%E'104.1','rock'),
PLIT(%G'1.776G-20',141,%E'101.4','foo1'),
PLIT(%G'-1.776G20',44,%E'153.9','foo2'),
PLIT(%G'1.772G20',1440,%E'333.4','foo3'),
PLIT(%G'1.777G77',777,%E'77777.7','This is it!!!'),
PLIT(%G'1.776G20',144,%E'123.4','foo')
): VECTOR;
OWN GFL77: VECTOR[2] INITIAL(%G'1.772G20');
OWN
idxbuf : ch$sequence (80),
idxfab : $fab_decl,
idxrab : $rab_decl,
keybuf : VECTOR [20],
gflkeyxab : $xabkey ( dtp = gfl, pos = <gfloating_field>,
%( nxt = packeyxab, )% kref = 2 ),
fl1keyxab : $xabkey ( dtp = fl1, pos = <floating_field>,
nxt = gflkeyxab, kref = 1 ),
in4keyxab : $xabkey ( dtp = in4, pos = <integer_field>,
nxt = fl1keyxab );
$log_entry (message = 'Beginning indexed file testing');
$fab_init (fab = idxfab, fna = 'IDXIDX.RMS', fop = sup, xab = in4keyxab,
org = idx, rfm = var, fac = <get, put, del, upd>, bsz = 9 );
$rab_init (rab = idxrab, fab = idxfab, ubf = idxbuf,
rac = key, kbf = keybuf,
usz = %ALLOCATION (idxbuf));
IF NOT $create (fab = idxfab) ! Make an indexed file
THEN
BEGIN
$error_entry (arg_block = idxfab, !
description = 'Routine TSTIDX: $CREATE failed');
RETURN;
END;
IF NOT $connect (rab = idxrab) ! Connect a record stream
THEN
BEGIN
$error_entry (arg_block = idxrab, !
description = 'Routine TSTIDX: $CONNECT failed');
RETURN;
END;
!+
! Write our test records out
!-
INCR counter FROM 0 TO .trecord[-1]-1 DO
BEGIN
BIND thisrecord = .trecord [.counter]: VECTOR;
idxrab [rab$a_rbf] = thisrecord;
idxrab [rab$h_rsz] = .thisrecord[-1]*file_bytes_per_word;
IF NOT $put (rab = idxrab) ! Write the record
THEN
BEGIN
$error_entry (arg_block = idxrab, !
description = 'Routine TSTIDX: $PUT failed');
RETURN;
END;
END;
!
! Find a record using integer key
!
keybuf=777; ! Pick a record to fetch
IF NOT $get (rab = idxrab)
THEN
BEGIN
$error_entry (arg_block = idxrab, !
description = 'Routine TSTIDX: $GET failed');
RETURN;
END;
IF .idxbuf [integer_field] NEQ 777
THEN
BEGIN
$error_entry (arg_block = idxrab, !
description = 'Routine TSTIDX: $GET got wrong record');
RETURN;
END;
IF NOT $get (rab = idxrab)
THEN
BEGIN
$error_entry (arg_block = idxrab, !
description = 'Routine TSTIDX: $GET failed');
RETURN;
END;
IF .idxbuf [integer_field] NEQ 777
THEN
BEGIN
$error_entry (arg_block = idxrab, !
description = 'Routine TSTIDX: $GET got wrong record');
RETURN;
END;
!
! Fetch a record using a G-floating key
!
keybuf[0]=.gfl77[0]; ! Set up the key to search for
keybuf[1]=.gfl77[1];
idxrab [rab$b_krf] = 2; ! Select which index to use
IF NOT $get (rab = idxrab)
THEN
BEGIN
$error_entry (arg_block = idxrab, !
description = 'Routine TSTIDX: $GET (by G-floating) failed');
RETURN;
END;
IF .idxbuf [integer_field] NEQ 1440
THEN
BEGIN
$error_entry (arg_block = idxrab, !
description = 'Routine TSTIDX: $GET (by G-floating) got wrong record');
RETURN;
END;
IF NOT $close (fab = idxfab) ! Close the file
THEN
BEGIN
$error_entry (arg_block = idxfab, !
description = 'Routine TSTIDX: $CLOSE failed');
RETURN;
END;
$log_entry (message = 'Indexed tests successful');
END; ! End TSTIDX
ROUTINE tstrel : NOVALUE =
BEGIN
LITERAL
file_bytes_per_word = 4,
gfloating_field = 0,
integer_field = 2,
floating_field = 3;
BIND
trecord=PLIT(
PLIT(%G'1.7762G20',143,%E'9123.4','fooBAR'),
PLIT(%G'1.77621G20',142,%E'-123.4','toad'),
PLIT(%G'-1.776001G20',2144,%E'123.4E-10','twoddle'),
PLIT(%G'981.776G120',194,%E'3.4','fie'),
PLIT(%G'6G0',1,%E'16.16','You are number 6'),
PLIT(%G'7G2',14,%E'4','frog'),
PLIT(%G'1.776001G20',145,%E'123.4015','a little more'),
PLIT(%G'331.2G199',999,%E'-1999.8','BIG'),
PLIT(%G'-21.776G20',184,%E'123.401','phoo'),
PLIT(%G'.776G20',154,%E'147.12','nepra'),
PLIT(%G'1.77G20',111,%E'104.1','rock'),
PLIT(%G'1.776G-20',141,%E'101.4','foo1'),
PLIT(%G'-1.776G20',44,%E'153.9','foo2'),
PLIT(%G'1.772G20',1440,%E'333.4','foo3'),
PLIT(%G'1.777G77',777,%E'77777.7','This is it!!!'),
PLIT(%G'1.776G20',144,%E'123.4','foo')
): VECTOR;
OWN
relbuf : ch$sequence (80),
relfab : $fab_decl,
relrab : $rab_decl,
keybuf: VECTOR [20];
$log_entry (message = 'Beginning relative file testing');
$fab_init (fab = relfab, fna = 'RELREL.RMS', fop = sup, mrs = 50,
org = rel, rfm = var, fac = <get, put, del, upd>, bsz = 9 );
$rab_init (rab = relrab, fab = relfab, ubf = relbuf,
rac = key, kbf = keybuf,
usz = %ALLOCATION (relbuf));
IF NOT $create (fab = relfab) ! Make an indexed file
THEN
BEGIN
$error_entry (arg_block = relfab, !
description = 'Routine TSTREL: $CREATE failed');
RETURN;
END;
IF NOT $connect (rab = relrab) ! Connect a record stream
THEN
BEGIN
$error_entry (arg_block = relrab, !
description = 'Routine TSTREL: $CONNECT failed');
RETURN;
END;
!+
! Write our test records out
!-
INCR counter FROM 0 TO .trecord[-1]-1 DO
BEGIN
BIND thisrecord = .trecord [.counter]: VECTOR;
keybuf = .counter+1; ! Relative record number
relrab [rab$a_rbf] = thisrecord;
relrab [rab$h_rsz] = .thisrecord[-1]*file_bytes_per_word;
IF NOT $put (rab = relrab) ! Write the record
THEN
BEGIN
$error_entry (arg_block = relrab, !
description = 'Routine TSTREL: $PUT failed');
RETURN;
END;
END;
!
! Find a record
!
keybuf=3; ! Pick a record to fetch
IF NOT $get (rab = relrab)
THEN
BEGIN
$error_entry (arg_block = relrab, !
description = 'Routine TSTREL: $GET failed');
RETURN;
END;
IF .relbuf [integer_field] NEQ 2144
THEN
BEGIN
$error_entry (arg_block = relrab, !
description = 'Routine TSTREL: $GET got wrong record');
RETURN;
END;
IF NOT $close (fab = relfab) ! Close the file
THEN
BEGIN
$error_entry (arg_block = relfab, !
description = 'Routine TSTREL: $CLOSE failed');
RETURN;
END;
$log_entry (message = 'Relative tests successful');
END; ! End TSTREL
END
ELUDOM
! End MODULE RMTBLS