Google
 

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