Google
 

Trailing-Edge - PDP-10 Archives - bb-h138f-bm - 7-sources/fffisa.b36
There are 3 other files named fffisa.b36 in the archive. Click here to see a list.
!<BLF/REQUIRE 'RMSBLF.REQ'>
!<BLF/SYNONYM $FIELD = FIELD>
!<BLF/SYNONYM $LITERAL = LITERAL>
!<BLF/SYNONYM $DISTINCT = 1>
MODULE fffisa =
BEGIN
!
!	COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1985, 1986.
!	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.
!
!
! 10/3/85 asp - add Doug Rayner's Tops 10/20 conditionals

REQUIRE 'fffreq';

REQUIRE 'rmsosd';				! For JSYSes

%IF %SWITCHES(TOPS10)
%THEN
LIBRARY 'BLI:UUOSYM';
%FI

LIBRARY 'bli:xport';				! For block formats

COMPILETIME
    Load_with_RMS = ((%Variant AND 1) NEQ 0),
    Section_Zero = ((%Variant AND 2) NEQ 0);

FORWARD ROUTINE
    openisam,					! $OPEN an ISAM file
    do_stat_blk,				! Read in the stat block
    get_ida_name : NOVALUE,			! Get .IDA name from stat block
    do_fab,					! Allocate/initialize FAB
    do_fst,					! Allocate/initialize FST
    do_rab,					! Allocate/initialize RAB
    do_rst,					! Allocate/initialize RST
    do_path,					! Allocate path vector
    unwind_open,				! Clean up bombed open
    openerror,					! Map an OPEN error
    cncisam,					! $CONNECT to ISAM file
    getisam,					! $GET an ISAM record
    findisam,					! $FIND an ISAM record
    dscisam,					! $DISCONNECT from ISAM file
    clsisam,					! $CLOSE an ISAM file
    get_block,					! Get a specific block
    put_block,					! Free up a block
    newidx,					! Initialize index path
    newdat,					! Initialize data position
    nxtidx,					! Find next index path
    nxtdat;					! Find next data position

EXTERNAL ROUTINE
    uaddr;					! Set up a user address

%IF NOT Section_Zero
%THEN
EXTERNAL ROUTINE
    ea_ch$move;					! CH$MOVE for ext. addressing
%FI

    $literal
    !
    !	Bits in flag word to keep track of OPEN status
    !
    stat_page_allocated = $distinct,
    fab_allocated = $distinct,
    fst_allocated = $distinct,
    rab_allocated = $distinct,
    rst_allocated = $distinct,
    buffers_allocated = $distinct,
    path_allocated = $distinct;

LITERAL
    isam$k_index_code = %O'401',		! Code in IDX header
    isam$k_eof = %O'377777377777',
    page_size = %O'1000',
    block_size = page_size / 4,
    isam$k_max_levels = 10;			! Max index levels for ISAM

!<BLF/PAGE>
!
!   ISAM data record header
!

    $field
    ida$r_fields = 				! Data record fields
	SET
	ida$h_size = [$bytes (2)],		! Size of record (SIX or EBC)
	$overlay (ida$h_size)			!
	ida$v_ascii_bit = [$bit],		! Bit always on for ASCII
	ida$h_asc_siz = [$bits (17)],		! Size of ASCII record
	$continue				!
	ida$h_version = [$bytes (2)],		! Version number
	ida$t_data = [$sub_block (0)]		! Beginning of data
	TES;

LITERAL
    ida$k_bln = 1;

%IF Section_Zero
%THEN

!+
! Since one word global byte pointers will not work in section zero
! (at least not on a 2020), change the calls to ea_ch$ptr and ea_ch$move
! to the normal BLISS defined ones
!-

UNDECLARE
    %Quote ea_ch$ptr;

MACRO
    ea_ch$ptr = ch$ptr %,
    ea_ch$move = ch$move %;

%FI

MACRO
    $isam_data_record =
 BLOCK [ida$k_bln] FIELD (ida$r_fields) %;

!<BLF/PAGE>
!
!   ISAM index block header
!

    $field
    ibk$r_fields = 				! Index block fields
	SET
	ibk$h_size = [$bytes (2)],		! Size in SIXBIT bytes
	ibk$h_level = [$bytes (2)],		! Index level of block
	ibk$g_version = [$bytes (4)]		! Version of this block
	TES;

LITERAL
    ibk$k_bln = 2;

MACRO
    $isam_index_block =
 BLOCK [ibk$k_bln] FIELD (ibk$r_fields) %;

!<BLF/PAGE>
!
!   ISAM index record
!

    $field
    iidx$r_fields = 				! Index entry fields
	SET
	iidx$g_down = [$bytes (4)],		! Pointer to next level
	iidx$g_version = [$bytes (4)],		! Version of block down
	iidx$t_key = [$sub_block (0)]		! Beginning of key
	TES;

LITERAL
    iidx$k_bln = 2;

MACRO
    $isam_index_record =
 BLOCK [iidx$k_bln] FIELD (iidx$r_fields) %;

!<BLF/PAGE>
!
!   ISAM statistics block format
!

    $field
    stat$r_fields =
	SET
	stat$g_header = [$bytes (4)],		! Header word
	stat$g_dev = [$bytes (4)],		! Device name
	stat$g_nam = [$bytes (4)],		! File name
	stat$g_ext = [$bytes (4)],		! Extension
	stat$g_cre = [$bytes (4)],		! Creation date
	stat$g_acc = [$bytes (4)],		! Access date
	stat$g_lvls = [$bytes (4)],		! Number of index levels
	stat$g_d_blk_fac = [$bytes (4)],	! Blocking factor of data file
	stat$g_d_empty = [$bytes (4)],		! Empty records per data block
	stat$g_i_blk_fac = [$sub_block (isam$k_max_levels)],	! Entries per index block
	stat$g_i_empty = [$sub_block (isam$k_max_levels)],	! Empty entries per index blk
	stat$g_d_blocks = [$bytes (4)],		! Data blocks in file
	stat$g_d_emp_blk = [$bytes (4)],	! Empty data blocks
	stat$g_i_sectors = [$bytes (4)],	! Sectors in index file
	stat$g_i_emp_sec = [$bytes (4)],	! Empty sectors in index file
	stat$g_first_emp = [$bytes (4)],	! First empty index sector
	stat$g_recsiz = [$bytes (4)],		! Largest data rec (words)
	stat$g_reckey = [$bytes (4)],		! Pointer to record key
	stat$g_numops = [$bytes (4)],		! Number of I/O operations
	stat$g_numuuo = [$bytes (4)],		! IN/OUT UUOs executed
	stat$g_satadr = [$bytes (4)],		! Address of first SAT block
	stat$g_numsat = [$bytes (4)],		! Number of SAT blocks
	stat$g_idxsec = [$bytes (4)],		! Sectors in index block
	stat$g_satbit = [$bytes (4)],		! Bits in all SAT blocks
	stat$g_keydes = [$bytes (4)],		! Key descriptor
	stat$g_idxsiz = [$bytes (4)],		! Size of index entry
	stat$g_idxadr = [$bytes (4)],		! Number of root block
	stat$g_pctdat = [$bytes (4)],		! % data file to leave free
	stat$g_pctidx = [$bytes (4)],		! % index file to leave free
	stat$g_recbyt = [$bytes (4)],		! Largest data rec size (bytes)
	stat$g_maxsat = [$bytes (4)],		! Max # of records in file
	stat$g_isaver = [$bytes (4)],		! ISAM version #
	stat$g_pagbuf = [$bytes (4)],		! I/O switch
	stat$g_name20 = [$STRING (200)]		! T-20 file name, 50 words
	TES;

LITERAL
    stat$k_bln = $field_set_size;

MACRO
    $isam_stat_block =
 BLOCK [stat$k_bln] FIELD (stat$r_fields) %;

!<BLF/PAGE>
!
!   ISAM key descriptor
!

    $field
    keydsc$r_fields =
	SET
	keydsc$v_siz = [$bits (12)],		! Size of key
	keydsc$v_filler = [$bits (3)],		! Nothing
	keydsc$v_sign = [$bit],			! Field is signed
	keydsc$v_mode = [$bits (2)],		! Mode of key
	keydsc$h_type = [$bytes (2)]		! Type of key
	TES;

!<BLF/PAGE>
!+
!	BLOCK DESCRIPTOR
!
!	BLD... symbols
!
!	This is a modified RMS bucket descriptor.  Two
!	more words are added to the bucket descriptor,
!	and contain the block number (within the file)
!	and the address of the block (within this bucket).
!-

FIELD
    bld$r_fields =
	SET
	bld$a_address = [0, 0, 18, 0],		! Bucket in-core
	bld$a_buffer_desc = [0, 18, 18, 0],	! Buffer descriptor
	bld$h_number = [1, 0, 18, 0],		! Bucket number
	bld$v_flags = [1, 18, 6, 0],		! Flags
	bld$v_locked = [1, 18, 1, 0],		! Bucket is locked
	bld$v_size = [1, 24, 8, 0],		! Bucket size (in blocks?)
	!   Bits 32-35 of word 1 are free
	bld$a_block = [2, 0, 36, 0],		! Address of block
	bld$h_block = [3, 0, 18, 0]		! Block number in file
	TES;

LITERAL
    bld$k_bln = 4;				! Length

MACRO
    $isam_block_descriptor =
		! Define a block descriptor
BLOCK [bld$k_bln] FIELD (bld$r_fields) %;

!<BLF/PAGE>
!
!   Path block structure
!

FIELD
    path$r_fields =
	SET
	path$h_block = [0, 0, 18, 0],		! Block number
	path$h_offset = [0, 18, 18, 1],		! Offset in words w/i block
	path$g_word = [0, 0, 36, 0]		! Whole word
	TES;

LITERAL
    path$k_bln = 1;

MACRO
    $path_word =
 BLOCK [path$k_bln] FIELD (path$r_fields) %,
    $path_block (len) =
 BLOCKVECTOR [len, path$k_bln] FIELD (path$r_fields) %;

!<BLF/PAGE>
EXTERNAL
    fab : REF $fab_decl,
    rab : REF $rab_decl,
    fst : REF $rms_fst,
    rst : REF $rms_rst,
    kdb : REF $rms_kdb,
    cbd : REF $rms_bucket_descriptor,
    adb : REF $rms_adb [8],
    fpt : REF $rms_fpt,
    uab : BLOCK [],				! $UTLINT argument block
    stksec,					! Section of stack locals
    fffsec,					! Our section
    rmssec,					! RMS's section
    blksec;					! User's xAB section


OWN
    open_status : BITVECTOR [%BPVAL] VOLATILE,	! Flags for $OPEN status
    jserr : VOLATILE,				! Error from JSYS
    idxfab : REF $fab_decl,
    idxrab : REF $rab_decl,
    idxfst : REF $rms_fst,
    idxrst : REF $rms_rst,
    idxcbd : REF $rms_bucket_descriptor,
    stat_page,
    stat_blk : REF $isam_stat_block,
    idafab : REF $fab_decl,
    idarab : REF $rab_decl,
    idafst : REF $rms_fst,
    idarst : REF $rms_rst,
    idacbd : REF $rms_bucket_descriptor,
    idafna : VECTOR [CH$ALLOCATION (18)],
    path : REF $path_block (isam$k_max_levels + 1);
GLOBAL ROUTINE openisam =
    BEGIN

    LOCAL
	keyptr : $byte_pointer;

    open_status = 0;				! Clear status
    !
    !	Store away the addresses of the blocks for the IDX file
    !
    idxfab = .fab;				! Store .IDX blocks
    idxrab = .rab;				! ...
    idxfst = .fst;				! ...
    idxrst = .rst;				! ...
    idxcbd = .cbd;				! ...
    !
    !	Start by getting a page for the ISAM statistics block,
    !	so we can have information ready when we need it here.
    !

    IF NOT do_stat_blk () THEN RETURN false;

    !
    !	Before we go further, let's tell the .IDX FST that
    !	we will want as many buffers as there are levels in
    !	the .IDX file.
    !
    idxfst [fst$v_number_buffers] = 		!
    idxfst [fst$v_minimum_buffers] = .stat_blk [stat$g_lvls];
    !
    !	Translate the SIXBIT name of the .IDA file.
    !
    get_ida_name ();
    !
    !	Allocate and initialize a FAB for the .IDA file.
    !

    IF NOT do_fab () THEN RETURN false;

    !
    !	Allocate and initialize the FST (and point the FAB at it)
    !

    IF NOT do_fst () THEN RETURN false;

    !
    !	Allocate and initialize the RAB
    !

    IF NOT do_rab () THEN RETURN false;

    !
    !	We will need to know the size of our buffers, so now
    !	figure out the size in physical blocks of index blocks
    !	and data blocks.  We have to use a BIND here to access
    !	STAT$G_I_BLK_FAC, which is a zero-size field defined
    !	by a sub-block.  This also determines the buffer size for
    !	the .IDX file (as the corresponding value does for .IDA).
    !
    BEGIN

    BIND
	index_blocking_factor = stat_blk [stat$g_i_blk_fac];

    idxfab [fab$v_bls] = ((((.idxfst [fst$h_mrs]*	!
    .index_blocking_factor) + ibk$k_bln) + 127)^-7);
    idxfst [fst$v_buffer_size] = (.idxfab [fab$v_bls] + 3)/4;
    END;
    !
    !	Size of data block
    !
    idafab [fab$v_bls] = ((((.idafst [fst$h_mrs] + 	!
    ida$k_bln)*.stat_blk [stat$g_d_blk_fac]) + 127)^-7);
    idafst [fst$v_buffer_size] = (.idafab [fab$v_bls] + 3)/4;
    !
    !	Allocate and initialize the RST
    !

    IF NOT do_rst () THEN RETURN false;

    !
    !	Put the address of the .IDA FAB/RAB/FST/RST/PATH structure
    !	where we can get it -- the user's FAB (the JNL field).
    !	(We must remember, though, that the .IDA FAB, etc.,
    !	are all located in RMS's section, rather than in the
    !	user's section.)
    !
    idxfab [fab$a_jnl] = .idarab;		! Store it away
    !
    !	Finally, we want to allocate a PATH block to be associated
    !	with this file.  It is a VECTOR or BLOCKVECTOR of length
    !	number-of-index-levels + 1-for-data-level + 1-for-EOF.
    !

    IF NOT do_path () THEN RETURN false;

    !
    !	Get some information from the stat block.
    !
    idxfst [fst$h_mrs] = .stat_blk [stat$g_idxsiz];	! Size of index entry
    idafst [fst$h_mrs] = .stat_blk [stat$g_recsiz];	! Size of data record
    idxfst [fst$h_bsz] = 36;			!
    keyptr = .stat_blk [stat$g_reckey];		! Fetch IDA byte size
    idxfab [fab$v_bsz] = 			! Let user know the byte size
    idafab [fab$v_bsz] = idafst [fst$h_bsz] = .keyptr [ptr$v_byte_size];
    idxfab [fab$h_mrs] = .stat_blk [stat$g_recbyt];	! Data record length
    idxfab [fab$v_rfm] = fab$k_var;		! Perhaps variable
    !
    !	Hide the address of the statistics block.
    !
    idarab [rab$a_kbf] = .stat_blk;
    RETURN true;
    END;					! End OPENISAM
ROUTINE do_stat_blk =
    BEGIN

    LOCAL
	stat_header;				! First word of header

    stat_page = get_page (page_count = 1);	! Get a page

    IF .stat_page EQL 0				! Allocation failure?
    THEN
	BEGIN
	unwind_open ();
	idxfab [fab$h_sts] = rms$_dme;
	RETURN false;
	END
    ELSE
	open_status [stat_page_allocated] = 1;

    stat_blk = .rmssec OR (.stat_page*page_size);	! Get address

%IF %SWITCHES(TOPS20)
%THEN

    stat_page = .stat_blk/page_size;		! Make global page number

    IF NOT pmap (xwd (.fst [fst$h_jfn], 0), 	! Map in first page ...
	    xwd ($fhslf, .stat_page), 		!   putting it here
	    pm_rd OR pm_epn)			! Read access, extended section
    THEN
	BEGIN
	idxfab [fab$h_sts] = rms$_cof;
	geter ($fhslf; jserr);
	idxfab [fab$h_stv] = .jserr<rh>;
	RETURN false;
	END;

%ELSE	! TOPS-10

    BEGIN

    !+
    ! Read in the first page of the file into stat_blk
    !-

	LOCAL
	    block_number,
	    io_command_list : VECTOR[2],
	    filop_arg_blk : VECTOR[3];

	REGISTER
	    t1;

	io_command_list[0] = ( - block_size) ^ 18 + .stat_blk - 1;
	io_command_list[1] = 0;

	block_number = 1;

	filop_arg_blk[0] = .idxfst[fst$h_jfn] ^ 18 + $FOINP;
	filop_arg_blk[1] = io_command_list[0];
	filop_arg_blk[2] = block_number;

	t1 = 3 ^ 18 + filop_arg_blk[0];

	IF NOT FILOP$_UUO(t1)
	THEN
	    BEGIN
	    idxfab[fab$h_sts] = rms$_cof;
	    idxfab[fab$h_stv] = .t1;
	    RETURN false;
	    END;

    END;

%FI

    !+
    !	Check to make sure that we are dealing with a
    !	real ISAM .IDX file by checking the header.
    !-

    stat_header = .stat_blk [stat$g_header];	! Header word

    IF .stat_header<lh> NEQ isam$k_index_code	! Not the right file?
    THEN
	BEGIN
	idxfab [fab$h_sts] = rms$_udf;
	idxfab [fab$h_stv] = rms$_plg;
	RETURN false;
	END;

    RETURN true;
    END;					! End DO_STAT_BLK
ROUTINE get_ida_name : NOVALUE =
    BEGIN

    LOCAL
	char,
	fnptr,					! Pointer to FNA buffer
	sixptr;					! Pointer to SIXBIT filename

    fnptr = ea_ch$ptr (.fffsec OR idafna);
    sixptr = ea_ch$ptr (stat_blk [stat$g_dev], 0, 6);	! Point at device

    INCR cnum FROM 1 TO 6 DO
	BEGIN
	char = CH$RCHAR_A (sixptr);		! Get a character

	IF .char EQL 0 THEN EXITLOOP;		! Exit on first space

	char = .char + %O'40';			! Make it ASCII
	CH$WCHAR_A (.char, fnptr);		! Write it out
	END;

    !
    !	Put in a ":" and get the file name the same way
    !
    CH$WCHAR_A (%C':', fnptr);
    sixptr = ea_ch$ptr (stat_blk [stat$g_nam], 0, 6);	! Point at filename

    INCR cnum FROM 1 TO 6 DO
	BEGIN
	char = CH$RCHAR_A (sixptr);		! Get a character

	IF .char EQL 0 THEN EXITLOOP;		! Exit on first space

	char = .char + %O'40';			! Make it ASCII
	CH$WCHAR_A (.char, fnptr);		! Write it out
	END;

    !
    !	Put in the requisite "." and get the extension
    !
    CH$WCHAR_A (%C'.', fnptr);
    sixptr = ea_ch$ptr (stat_blk [stat$g_ext], 0, 6);	! Point at extension

    INCR cnum FROM 1 TO 3 DO
	BEGIN
	char = CH$RCHAR_A (sixptr);		! Get a character

	IF .char EQL 0 THEN EXITLOOP;		! Exit on first space

	char = .char + %O'40';			! Make it ASCII
	CH$WCHAR_A (.char, fnptr);		! Write it out
	END;

    !
    !	Follow it all with a NUL
    !
    CH$WCHAR_A ($chnul, fnptr);
    END;					! End GET_IDA_NAME
ROUTINE do_fab =
    BEGIN
    idafab = get_memory (length = fab$k_bln);

    IF .idafab EQL 0				! Allocation failure?
    THEN
	BEGIN
	unwind_open ();
	idxfab [fab$h_sts] = rms$_dme;
	RETURN false;
	END
    ELSE
	open_status [fab_allocated] = 1;

    idafab = .rmssec OR .idafab;
    $fab_init (fab = .idafab, 			! Initialize the FAB
	fac = get, 				! ...
	fna = ea_ch$ptr (.fffsec OR idafna));	! ...
    !
    !	Get the JFN for the .IDA file.
    !

%IF %SWITCHES(TOPS20)
%THEN
    IF NOT gtjfn (gj_old OR gj_sht, .idafab [fab$a_fna]; idafab [fab$h_jfn])
    THEN
	BEGIN
	jserr = .idafab [fab$h_jfn];		! Isolate JSYS error
	idafab [fab$h_jfn] = 0;			! Clear field
	idxfab [fab$h_sts] = openerror (.jserr);
	idxfab [fab$h_stv] = .jserr;
	RETURN false;
	END;

    !
    !	Open the file now.
    !

    IF NOT openf (.idafab [fab$h_jfn], of_rd OR of_rdu; jserr)	! Open it
    THEN
	BEGIN
	idxfab [fab$h_sts] = openerror (.jserr);
	idxfab [fab$h_stv] = .jserr;
	RETURN false;
	END;

%ELSE	! TOPS-10

    BEGIN
    !+
    ! Open the IDA file.  Get the device, file name, and extension
    ! from the stat block.  Get the path from the monitor, i.e. the
    ! path for the IDX file.
    !-

	LOCAL
	    file_spec_blk : VECTOR[$FOFSF + 1 + 5],
	    filop_arg_blk : VECTOR[$FOLEB + 1],
	    lookup_blk : VECTOR[$RBEXT + 1];

	REGISTER
	    t1;

	filop_arg_blk[0] = .idxfst[fst$h_jfn] ^ 18 + $FOFIL;
	filop_arg_blk[1] = ($FOFSF + 1 + 5) ^ 18 + file_spec_blk[0];

	t1 = 2 ^ 18 + filop_arg_blk[0];

	IF NOT FILOP$_UUO(t1)
	THEN
	    BEGIN
	    idxfab[fab$h_sts] = openerror(.t1);
	    idxfab[fab$h_stv] = .t1;
	    RETURN false;
	    END;

	!+
	! Fill in the LOOKUP block from the stat block.  Fill in
	! the FILOP. block.  Open the file for read.  Save the channel
	! number assigned in the IDX FAB.
	!-

	lookup_blk[$RBCNT] = $RBEXT;
	lookup_blk[$RBNAM] = .stat_blk[stat$g_nam];
	lookup_blk[$RBEXT] = .stat_blk[stat$g_ext];
	lookup_blk[$RBPPN] = file_spec_blk[$FOFPP - $PTPPN];

	filop_arg_blk[$FOFNC] = FO$PRV + FO$ASC + $FORED;
	filop_arg_blk[$FOIOS] = $IODMP;
	filop_arg_blk[$FODEV] = .stat_blk[stat$g_dev];
	filop_arg_blk[$FOBRH] = filop_arg_blk[$FONBF] = 0;
	filop_arg_blk[$FOLEB] = lookup_blk[0];

	t1 = ($FOLEB + 1) ^ 18 + filop_arg_blk[0];

	IF NOT FILOP$_UUO(t1)
	THEN
	    BEGIN
	    idxfab[fab$h_sts] = openerror(.t1);
	    idxfab[fab$h_stv] = .t1;
	    RETURN false;
	    END;

	idafab[fab$h_jfn] = .POINTR(filop_arg_blk[$FOFNC], FO$CHN);

    END;

%FI
    RETURN true;
    END;					! End DO_FAB
ROUTINE do_fst =
    BEGIN
    idafst = get_memory (length = fst$k_bln);

    IF .idafst EQL 0				! Error?
    THEN
	BEGIN
	unwind_open ();
	idxfab [fab$h_sts] = rms$_dme;
	RETURN false;
	END
    ELSE
	open_status [fst_allocated] = 1;

    idafst = .rmssec OR .idafst;		! Make global
    idafst [fst$h_bln] = fst$k_bln;		! Header
    idafst [fst$h_bid] = fst$k_bid;		! ...
    idafst [fst$h_jfn] = .idafab [fab$h_jfn];	! Move the JFN
    idafst [fst$v_number_buffers] = 		! Set these for good measure
    idafst [fst$v_minimum_buffers] = rms$k_number_buffers;
    idafab [fab$a_ifi] = .idafst;		! Point FAB at FST
    RETURN true;
    END;					! End DO_FST
ROUTINE do_rab =
    BEGIN
    idarab = get_memory (length = rab$k_bln);

    IF .idarab EQL 0				! Error?
    THEN
	BEGIN
	unwind_open ();
	idxfab [fab$h_sts] = rms$_dme;
	RETURN false;
	END
    ELSE
	open_status [rab_allocated] = 1;

    idarab = .rmssec OR .idarab;
    $rab_init (rab = .idarab, 			! Initialize the RAB
	fab = .idafab, rac = seq);		! ...
    RETURN true;
    END;					! End DO_RAB
ROUTINE do_rst =
    BEGIN

    LOCAL
	cur_bfd : REF $rms_buffer_descriptor,	! Buffer descriptor pointer
	actual_rst_size,			! Allocated size of RST
	buffer_page,				! Beginning of contig. buf's
	total_pages,				! Total size of buffers
	number_of_buffers;			! Buffer count

    !
    !	We stored the buffer count away in the FST
    !
    number_of_buffers = .idafst [fst$v_number_buffers];
    actual_rst_size = rst$k_bln + (.number_of_buffers*2);
    idarst = get_memory (length = .actual_rst_size);

    IF .idarst EQL 0				! Allocation failure
    THEN
	BEGIN
	unwind_open ();
	idxfab [fab$h_sts] = rms$_dme;
	RETURN false;
	END
    ELSE
	open_status [rst_allocated] = 1;

    idarst = .idarst OR .rmssec;		! Make global
    idarst [rst$h_bln] = .actual_rst_size;	! Header
    idarst [rst$h_bid] = rst$k_bid;		! ...
    idarst [rst$v_bfd_count] = .number_of_buffers;
!
!	Allocate the buffers
!
    total_pages = .number_of_buffers*.idafst [fst$v_buffer_size];
    buffer_page = get_page (page_count = .total_pages);

    IF .buffer_page EQL 0			! Failure?
    THEN
	BEGIN
	unwind_open ();
	idxfab [fab$h_sts] = rms$_dme;
	RETURN false;
	END
    ELSE
	open_status [buffers_allocated] = 1;

!
!	Initialize the buffer descriptors
!
    cur_bfd = idarst [rst$g_buffer_desc];

    INCR buf_ctr FROM 1 TO .number_of_buffers DO
	BEGIN
	cur_bfd [buf$b_buffer_page] = .buffer_page;
	cur_bfd = cur_bfd + buf$k_bln;
	buffer_page = .buffer_page + .idafst [fst$v_buffer_size];
	END;

!
!	Link RST to the rest of the world
!
    idarst [rst$a_fst] = .idafst;
    idarst [rst$a_flink] = .idafst;		! Link to the FST
    idarst [rst$a_blink] = .idafst;		! ...
    idarab [rab$a_isi] = .idarst;		! Point RAB at RST
    idafst [fst$a_flink] = .idarst;		! Link to the FST
    idafst [fst$a_blink] = .idarst;		! ...
    RETURN true;
    END;					! End DO_RST
ROUTINE do_path =
    BEGIN
    path = get_memory (length = (.stat_blk [stat$g_lvls] + 2));

    IF .path EQL 0				! Memory exhausted?
    THEN
	BEGIN
	unwind_open ();
	idxfab [fab$h_sts] = rms$_dme;
	RETURN false;
	END
    ELSE
	open_status [path_allocated] = 1;

    path = .rmssec OR .path;
    idafab [fab$a_jnl] = .path;			! Store path address
    RETURN true;
    END;					! End DO_PATH
ROUTINE unwind_open =
    BEGIN

    IF .open_status EQL 0 THEN RETURN true;	! Nothing to do

    !
    !	Zero the left half of the block pointers
    !	so that PMEM doesn't do obscure things.
    !
    path<lh> = idafab<lh> = idarab<lh> = idarst<lh> = idafst<lh> = 0;

    !+
    !	Deallocate the path vector if need be
    !-

    IF .open_status [path_allocated]		!
    THEN
	put_memory (length = (.stat_blk [stat$g_lvls] + 2), 	! Free path
	    address = .fffsec OR path);

    !+
    !	Deallocate the buffers in the RST for the .IDA file.
    !-

    IF .open_status [buffers_allocated]		!
    THEN
	BEGIN

	LOCAL
	    total_pages,
	    first_bfd : REF $rms_buffer_descriptor,
	    first_page;

	!
	!	De-allocate the buffers
	!
	total_pages = .idarst [rst$v_bfd_count]*.idafst [fst$v_buffer_size];
	first_bfd = idarst [rst$g_buffer_desc];
	first_page = .first_bfd [buf$b_buffer_page];
	put_page (page_number = .first_page, page_count = .total_pages);
	END;

    !+
    !	Deallocate the RST.
    !-

    IF .open_status [rst_allocated]		!
    THEN
	put_memory (length = rst$k_bln, address = .fffsec OR idarst);

    !+
    !	Deallocate the RAB.
    !-

    IF .open_status [rab_allocated]		!
    THEN
	put_memory (length = rab$k_bln, address = .fffsec OR idarab);

    !+
    !	Deallocate the FST.
    !-

    IF .open_status [fst_allocated]		!
    THEN
	put_memory (length = fst$k_bln, address = .fffsec OR idafst);

    !+
    !	Deallocate the FAB.
    !-

    IF .open_status [fab_allocated]		!
    THEN
	put_memory (length = fab$k_bln, address = .fffsec OR idafab);

    !
    !	Get rid of the page for the statistics block
    !

    IF .open_status [stat_page_allocated]	!
    THEN
	put_page (page_number = .stat_page AND %O'777');

    RETURN true;
    END;					! End UNWIND_OPEN
ROUTINE openerror (monitor_error) =
    BEGIN

%IF %SWITCHES(TOPS20)
%THEN

    SELECTONE .monitor_error OF
	SET

	[gjfx4, gjfx5, gjfx6, gjfx8, gjfx9, 	! RMS$_FSI : invalid file spec
	    gjfx10, gjfx11, gjfx12, gjfx13] : 	! ...
	    RETURN rms$_fsi;

	[gjfx16, gjfx17, gjfx18, gjfx19, 	! RMS$_FNF : file not found
	    gjfx20, gjfx24] : 			! ...
	    RETURN rms$_fnf;

	[gjfx3, gjfx22] : 			! RMS$_CGJ : cannot get JFN
	    RETURN rms$_cgj;

	[OTHERWISE] : 				! RMS$_COF : cannot open file
	    RETURN rms$_cof;
	TES;

%ELSE	! TOPS-10

    SELECTONE .monitor_error OF
	SET
	[ERFNF_, ERIPP_, ERSNF_, ERSLE_]:
			RETURN(rms$_fnf);		! File not found
	[ERPRT_, ERDNE_]: RETURN(rms$_prv);	! Protection error
	[OTHERWISE]:  RETURN(rms$_cof);
	TES

%FI
    END;					! End OPENERROR
GLOBAL ROUTINE cncisam =
    BEGIN

    LOCAL
	root;

    !
    !	Store away the addresses of the blocks for the IDX file
    !
    idxfab = .fab;				! Store .IDX blocks
    idxrab = .rab;				! ...
    idxfst = .fst;				! ...
    idxrst = .rst;				! ...
    idxcbd = .cbd;				! ...
    !
    !	Fetch out the structures for the IDA file
    !
    idarab = .rmssec OR .idxfab [fab$a_jnl];
    idafab = .rmssec OR .idarab [rab$a_fab];
    idafst = .rmssec OR .idafab [fab$a_ifi];
    idarst = .rmssec OR .idarab [rab$a_isi];
    path = .rmssec OR .idafab [fab$a_jnl];
    stat_blk = .rmssec OR .idarab [rab$a_kbf];
    !
    !	Let us now trace our way through the abyss
    !	of the IDX file (without benefit of Virgil
    !	or Beatrice) and leave a path behind us.
    !
    root = .stat_blk [stat$g_idxadr];		! Fetch the root

    IF NOT newidx (.stat_blk [stat$g_lvls], .root)	! Build the path
    THEN
	BEGIN					! No records here at all
	idxrst [rst$g_next_record_pointer] = isam$k_eof;
	END
    ELSE
	BEGIN
	!
	!	Set the NRP to point at the first data record.
	!
	idxrst [rst$g_next_record_pointer] = .path [0, path$g_word];
	END;

    RETURN 1;
    END;					! End CNCISAM
GLOBAL ROUTINE getisam =
    BEGIN

    STACKLOCAL
	dummy_blk_desc : $isam_block_descriptor;

    LOCAL
	current_rfa : $path_word,		! RFA of input record
	bytes_to_move,				! Length to move
	byte_size,				! We refer to this a lot
	record_size,				! Length of record
	blk_desc : REF $isam_block_descriptor,
	data_block,
	data_record : REF $isam_data_record,
	file_pointer,				! Pointer to file buffer
	user_buffer,				! Address of user's buffer
	user_pointer,				! Pointer to user's buffer
	user_size;				! Size of user's buffer

    !

    !	Set up the descriptor pointers.  This unusual arrangement is
    !	necessary because the descriptor is on the stack and
    !	is therefore in another section.  This works around the
    !	attempts of BLISS to be devious and efficient.
    !
    blk_desc = .stksec OR dummy_blk_desc;	! Set pointer
    !
    !	Store away the addresses of the blocks for the IDX file
    !
    idxfab = .fab;				! Store .IDX blocks
    idxrab = .rab;				! ...
    idxfst = .fst;				! ...
    idxrst = .rst;				! ...
    idxcbd = .cbd;				! ...
    !
    !	Fetch out the structures for the IDA file
    !
    idarab = .rmssec OR .idxfab [fab$a_jnl];
    idafab = .rmssec OR .idarab [rab$a_fab];
    idafst = .rmssec OR .idafab [fab$a_ifi];
    idarst = .rmssec OR .idarab [rab$a_isi];
    path = .rmssec OR .idafab [fab$a_jnl];
    stat_blk = .rmssec OR .idarab [rab$a_kbf];
    !
    !	Set up to get the record with the current RFA:
    !	    1)	Calculate the size of the user buffer;
    !	    2)	Get the buffer's address; and
    !	    3)  Make a global pointer thereto.
    !
    byte_size = .idxfab [fab$v_bsz];
    user_size = .idxrab [rab$h_usz]*(%BPVAL/.byte_size);
    user_buffer = uaddr (.idxrab [rab$a_ubf]);
    user_pointer = ea_ch$ptr (.user_buffer, 0, .byte_size);

    !+
    !	Using the current RFA, read in the current
    !	block and build a pointer to the current record.
    !-

    current_rfa = .idxrst [rst$g_data_rfa];
    get_block (.current_rfa [path$h_block], 	! Get this block
	.idafab [fab$v_bls], 			! It's this big (in blocks)
	.blk_desc, 				! And we want it put here
	0);					! This is the data level
    data_block = .blk_desc [bld$a_block];	! Point to the block
    data_record = .data_block + .current_rfa [path$h_offset];

    !+
    !	Fetch the record size
    !-

    IF .byte_size EQL 7				! ASCII file?
    THEN
	record_size = .data_record [ida$h_asc_siz]	! Yes - shifted size
    ELSE
	record_size = .data_record [ida$h_size];	! No - normal size

    !
    !	Build a pointer to the record in the file buffer
    !
    file_pointer = ea_ch$ptr (data_record [ida$t_data], 0, .byte_size);
    !
    !	Move the data
    !
    bytes_to_move = MIN (.user_size, .record_size);
    ea_ch$move (.bytes_to_move, .file_pointer, .user_pointer);
    !
    !	Toss the block
    !
    put_block (.stksec OR .blk_desc, 0);	! Throw it away

    !+
    !	Finish appropriately
    !-

    %IF Load_with_RMS
    %THEN

    !+
    ! Since we share these locations with RMS, and since they may have
    ! been changed to point to the IDA file, restore the correct values.
    !-

    fab = .idxfab;				! Restore .IDX blocks
    rab = .idxrab;
    fst = .idxfst;
    rst = .idxrst;
    cbd = .idxcbd;

    %FI

    IF .record_size GTR .user_size		! RTB error?
    THEN
	BEGIN					! Yes - report RTB
	idxrab [rab$h_sts] = rms$_rtb;
	idxrab [rab$h_stv] = .record_size;
	idxrab [rab$h_rsz] = .bytes_to_move;
	idxrab [rab$a_rbf] = .idxrab [rab$a_ubf];
	RETURN false;
	END
    ELSE
	BEGIN					! No - all normal
	idxrab [rab$h_sts] = rms$_normal;
	idxrab [rab$h_stv] = 0;
	idxrab [rab$h_rsz] = .record_size;
	idxrab [rab$a_rbf] = .idxrab [rab$a_ubf];
	RETURN true;
	END;

    END;					! End GETISAM
GLOBAL ROUTINE findisam =
    BEGIN

    LOCAL
	root;

    !
    !	Store away the addresses of the blocks for the IDX file
    !
    idxfab = .fab;				! Store .IDX blocks
    idxrab = .rab;				! ...
    idxfst = .fst;				! ...
    idxrst = .rst;				! ...
    idxcbd = .cbd;				! ...
    !
    !	Fetch out the structures for the IDA file
    !
    idarab = .rmssec OR .idxfab [fab$a_jnl];
    idafab = .rmssec OR .idarab [rab$a_fab];
    idafst = .rmssec OR .idafab [fab$a_ifi];
    idarst = .rmssec OR .idarab [rab$a_isi];
    path = .rmssec OR .idafab [fab$a_jnl];
    stat_blk = .rmssec OR .idarab [rab$a_kbf];
    !
    !	Set up the RFA for the current record.  If the RFA is
    !	EOF, then we have reached EOF.
    !
    idxrst [rst$g_data_rfa] = .idxrst [rst$g_next_record_pointer];

    IF .idxrst [rst$g_data_rfa] EQL isam$k_eof	! Are we now at EOF?
    THEN
	BEGIN					! Return EOF
	idxrab [rab$h_sts] = rms$_eof;
	idxrab [rab$h_rsz] = 0;
	idxrab [rab$g_rfa] = 0;
	RETURN false;
	END;

    !+
    !	Follow the index down to the current record and then
    !	find the next record from that one.  If we fail, our
    !	next record will actually be EOF.  Otherwise, NRP
    !	will point at the data record shown by the PATH.
    !-

    root = .stat_blk [stat$g_idxadr];		! Get root pointer

    IF nxtidx (.stat_blk [stat$g_lvls], .root)	! Get next path
    THEN
	idxrst [rst$g_next_record_pointer] = .path [0, path$g_word]
    ELSE
	idxrst [rst$g_next_record_pointer] = isam$k_eof;


    %IF Load_with_RMS
    %THEN

    !+
    ! Since we share these locations with RMS, and since they may have
    ! been changed to point to the IDA file, restore the correct values.
    !-

    fab = .idxfab;				! Restore .IDX blocks
    rab = .idxrab;
    fst = .idxfst;
    rst = .idxrst;
    cbd = .idxcbd;

    %FI

    !
    !   All OK, return same
    !
    idxrab [rab$g_rfa] = .rst [rst$g_data_rfa];
    idxrab [rab$h_sts] = rms$_normal;
    idxrab [rab$h_stv] = 0;			! Nothing special
    idxrst [rst$v_last_operation] = op$k_find;
    RETURN true
    END;					! End FINDISAM
GLOBAL ROUTINE dscisam =
    BEGIN
    !
    !	Store away the addresses of the blocks for the IDX file
    !
    idxfab = .fab;				! Store .IDX blocks
    idxrab = .rab;				! ...
    idxfst = .fst;				! ...
    idxrst = .rst;				! ...
    idxcbd = .cbd;				! ...
    !
    !	Fetch out the structures for the IDA file
    !
    idarab = .rmssec OR .idxfab [fab$a_jnl];
    idafab = .rmssec OR .idarab [rab$a_fab];
    idafst = .rmssec OR .idafab [fab$a_ifi];
    idarst = .rmssec OR .idarab [rab$a_isi];
    path = .rmssec OR .idafab [fab$a_jnl];
    stat_blk = .rmssec OR .idarab [rab$a_kbf];
    RETURN 1;
    END;					! End DSCISAM
GLOBAL ROUTINE clsisam =
    BEGIN
    LOCAL
	idajfn;					! JFN for .IDA file
    !
    !	Store away the addresses of the blocks for the IDX file
    !
    idxfab = .fab;				! Store .IDX blocks
    idxrab = .rab;				! ...
    idxfst = .fst;				! ...
    idxrst = .rst;				! ...
    idxcbd = .cbd;				! ...
    !
    !	Fetch out the structures for the IDA file
    !
    idarab = .rmssec OR .idxfab [fab$a_jnl];
    idafab = .rmssec OR .idarab [rab$a_fab];
    idafst = .rmssec OR .idafab [fab$a_ifi];
    idarst = .rmssec OR .idarab [rab$a_isi];
    path = .rmssec OR .idafab [fab$a_jnl];
    stat_blk = .rmssec OR .idarab [rab$a_kbf];
    stat_page = .stat_blk/%O'1000';
    !
    !	Save the JFN of the .IDA file.
    !
    idajfn = .idafab [fab$h_jfn];
    !
    !	Zero the left half of the block pointers
    !	so that PMEM doesn't do obscure things.
    !
    path<lh> = idafab<lh> = idarab<lh> = idarst<lh> = idafst<lh> = 0;
    !
    !	Return memory used by the path vector.
    !
    put_memory (length = (.stat_blk [stat$g_lvls] + 2), 	! Free path
	address = .fffsec OR path);

    !+
    !	Get rid of the buffers we've allocated
    !-

    BEGIN

    LOCAL
	total_pages,
	first_bfd : REF $rms_buffer_descriptor,
	first_page;

    !
    !	De-allocate the buffers
    !
    total_pages = .idarst [rst$v_bfd_count]*.idafst [fst$v_buffer_size];
    first_bfd = idarst [rst$g_buffer_desc];
    first_page = .first_bfd [buf$b_buffer_page];
    put_page (page_number = .first_page, page_count = .total_pages);
    END;
    !
    !	Deallocate the other blocks
    !
    put_memory (length = rst$k_bln, address = .fffsec OR idarst);
    put_memory (length = rab$k_bln, address = .fffsec OR idarab);
    put_memory (length = fst$k_bln, address = .fffsec OR idafst);
    put_memory (length = fab$k_bln, address = .fffsec OR idafab);
    !
    !	Get rid of the page for the statistics block
    !
    put_page (page_number = .stat_page AND %O'777');
    !
    !	Close the .IDA file
    !

%IF %SWITCHES(TOPS20)
%THEN

    RETURN closf (.idajfn);

%ELSE	! TOPS-10

    BEGIN

	LOCAL
	    filop_arg_blk;

	REGISTER
	    t1;

	filop_arg_blk = .idajfn ^ 18 + $FOREL;

	t1 = 1 ^ 18 + filop_arg_blk;

	FILOP$_UUO(t1);

    END;

%FI

    END;					! End CLSISAM
ROUTINE get_block (block_no, count, desc : REF $isam_block_descriptor, level) =
    BEGIN

    LOCAL
	page_count,
	block_within_page,
	page_to_get;

    MACRO 					! DEBUG
	st$ptr (data) =
				! DEBUG
     CH$PTR(UPLIT(%ASCIZ %STRING(data, %REMAINING))) %;	! DEBUG

    IF .block_no LEQ 0				! Bad block
    THEN
	RETURN 0;

    IF .count LEQ 0				! Bad count
    THEN
	RETURN 0;

    desc [bld$h_block] = .block_no;		! Number of block
    block_within_page = (.block_no - 1) MOD 4;
    page_count = (.block_within_page + .count + 3)/4;
    page_to_get = (.block_no - 1)/4;		! Page to get

    !+
    !	What RAB do we use?  What level are we on?
    !-

    IF .level EQL 0				! Data level or index level
    THEN
	set_environment (rab = .idarab)		! Data file is used
    ELSE
	set_environment (rab = .idxrab);	! Index file is used

    get_bucket (bucket_size = .page_count, 	! Size to get
	bucket = .page_to_get, 			! ... which page
	desc = .desc);				! ... descriptor for return
    desc [bld$a_block] = (.rmssec OR 		! Section
    .desc [bld$a_address]) + 			! Base of bucket
    (.block_within_page*%O'200');		! Offset to block
    RETURN 1;
    END;					! End GET_BLOCK
ROUTINE put_block (desc : REF $isam_block_descriptor, level) =
    BEGIN

    !+
    !	What RAB do we use?  What level are we on?
    !-

    IF .level EQL 0				! Data level or index level
    THEN
	set_environment (rab = .idarab)		! Data file is used
    ELSE
	set_environment (rab = .idxrab);	! Index file is used

    RETURN put_bucket (desc = .desc, 		! Return this bucket
	    update = 0);			! ... with no updating
    END;					! End PUT_BLOCK
ROUTINE newidx (level, next_block) =
    BEGIN

    STACKLOCAL
	dummy_blk_desc : $isam_block_descriptor;

    LOCAL
	search_status,				! Status of loop search
	max_offset,				! Maximum offset for this block
	blk_desc : REF $isam_block_descriptor,
	index_block : REF $isam_index_block,
	index_record : REF $isam_index_record;

    !
    !	Set up the descriptor pointers.  This unusual arrangement is
    !	necessary because the descriptor is on the stack and
    !	is therefore in another section.  This works around the
    !	attempts of BLISS to be devious and efficient.
    !
    blk_desc = .stksec OR dummy_blk_desc;	! Set pointer
    !
    !	Clear the PATH entry.
    !
    path [.level, path$g_word] = 0;
    !
    !	Get the required block
    !
    get_block (.next_block, 			! Block to get
	.idxfab [fab$v_bls], 			! It's this big (in blocks)
	.blk_desc, 				! And we want it put here
	.level);				! What level of logical file?
    !
    !	Set up pointers to the block
    !
    index_block = .blk_desc [bld$a_block];	! Point at block
    !
    !	The maximum entry offset in this block is
    !	the size of the block less the size of an entry.
    !	Notice that since the size of a block is given
    !	ala SIXBIT, the size of the header is not included in
    !	the block.  Ergo, add 1 to the computed size.
    !
    max_offset = (.index_block [ibk$h_size]/6) + 1 - .stat_blk [stat$g_idxsiz];

    !+
    !	We may be successful finding a valid path on the through
    !	the first entry, but there is always a chance that the first
    !	15,999 records of a 16000 record file have been deleted,
    !	so we will loop through the entries in this block until
    !	one of the following occurs:
    !	    1)	a call to NEWIDX/NEWDAT (as appropriate) returns TRUE;
    !	    2)	we find an entry pointing to block 0 (non-existent entry);
    !	    3)	we exceed what should be the offset of the last entry.
    !
    !	In case 1, we have succeeded: store the path data and return TRUE.
    !	In cases 2 and 3, the path does not go through this block, so we
    !	should give back the block and return FALSE to our caller.
    !-

    search_status = false;

    INCR offset FROM ibk$k_bln TO .max_offset BY .stat_blk [stat$g_idxsiz] DO
	BEGIN

	LOCAL
	    down_status;			! Status of search downward

	index_record = .index_block + .offset;

	!+
	!   If there is no block specified, we
	!   have an empty index entry.
	!-

	IF .index_record [iidx$g_down] EQL 0 THEN EXITLOOP;	! We're done

	!+
	!   Get the result of looking down a bit further.
	!-

	IF .level GTR 1				! Index level or data level
	THEN
	    down_status = newidx (.level - 1, .index_record [iidx$g_down])
	ELSE
	    down_status = newdat (.index_record [iidx$g_down]);

	IF .down_status				! Success?
	THEN
	    BEGIN				! Save the path
	    path [.level, path$h_offset] = .offset;
	    path [.level, path$h_block] = .next_block;
	    search_status = true;
	    EXITLOOP;
	    END;

	END;

    !
    !	Put away the block we got.
    !
    put_block (.stksec OR .blk_desc, .level);	! Toss the block
    !
    !	Return the state of the world.
    !
    RETURN .search_status;
    END;					! End NEWIDX
ROUTINE newdat (next_block) =
    BEGIN

    STACKLOCAL
	dummy_blk_desc : $isam_block_descriptor;

    LOCAL
	search_status,				! Status of loop search
	blk_desc : REF $isam_block_descriptor,
	data_block,
	data_record : REF $isam_data_record;

    !

    !	Set up the descriptor pointers.  This unusual arrangement is
    !	necessary because the descriptor is on the stack and
    !	is therefore in another section.  This works around the
    !	attempts of BLISS to be devious and efficient.
    !
    blk_desc = .stksec OR dummy_blk_desc;	! Set pointer
    !
    !	Clear the PATH entry.
    !
    path [0, path$g_word] = 0;
    !
    !	Get the required block
    !
    get_block (.next_block, 			! Block to get
	.idafab [fab$v_bls], 			! It's this big (in blocks)
	.blk_desc, 				! And we want it put here
	0);					! Level 0 for data
    !
    !	Set up pointers to the block
    !
    data_block = .blk_desc [bld$a_block];	! Point at block
    data_record = .data_block;
    !
    !	See if we have a record here or not (zero in the first
    !	word says no record exists).
    !

    IF .data_record [ida$h_size] EQL 0		! Length determines existence
    THEN
	search_status = false			! No record here
    ELSE
	BEGIN
	path [0, path$h_block] = .next_block;	! Set this block
	path [0, path$h_offset] = 0;		! With offset of zero
	search_status = true;			! Yes, we have one.
	END;

    !
    !	Put away the block we got.
    !
    put_block (.stksec OR .blk_desc, 0);	! Toss the block
    !
    !	Return the state of the world.
    !
    RETURN .search_status;
    END;					! End NEWDAT
ROUTINE nxtidx (level, this_block) =
    BEGIN

    STACKLOCAL
	dummy_blk_desc : $isam_block_descriptor;

    LOCAL
	search_status,				! Status of loop search
	max_offset,				! Maximum offset for this block
	blk_desc : REF $isam_block_descriptor,
	index_block : REF $isam_index_block,
	index_record : REF $isam_index_record;

    !
    !	Set up the descriptor pointers.  This unusual arrangement is
    !	necessary because the descriptor is on the stack and
    !	is therefore in another section.  This works around the
    !	attempts of BLISS to be devious and efficient.
    !
    blk_desc = .stksec OR dummy_blk_desc;	! Set pointer
    !
    !	Get the required block
    !
    get_block (.this_block, 			! Block to get
	.idxfab [fab$v_bls], 			! It's this big (in blocks)
	.blk_desc, 				! And we want it put here
	.level);				! Level of logical file to get
    !
    !	Set up pointers to the block
    !
    index_block = .blk_desc [bld$a_block];	! Point at block
    !
    !	The maximum entry offset in this block is
    !	the size of the block less the size of an entry.
    !	Notice that since the size of a block is given
    !	ala SIXBIT, the size of the header is not included in
    !	the block.  Ergo, add 1 to the computed size.
    !
    max_offset = (.index_block [ibk$h_size]/6) + 1 - .stat_blk [stat$g_idxsiz];

    !+
    !	Starting at the current entry in the block (as recorded
    !	in PATH), loop through the entries in this block until
    !	one of the following occurs:
    !	    1)	a call to NXTIDX/NXTDAT (as appropriate) returns TRUE;
    !	    2)	we find an entry pointing to block 0 (non-existent entry);
    !	    3)	we exceed what should be the offset of the last entry.
    !
    !	In case 1, we have succeeded: store the path data and return TRUE.
    !	In cases 2 and 3, the path does not go through this block, so we
    !	should give back the block and return FALSE to our caller.
    !-

    search_status = false;

    INCR offset					! Scan forward through block
	FROM .path [.level, path$h_offset]	!   from the current entry
	TO .max_offset				!   to the last entry,
	BY .stat_blk [stat$g_idxsiz] DO 	!   entry by entry
	BEGIN

	LOCAL
	    down_status;			! Status of search downward

	index_record = .index_block + .offset;

	!+
	!   If there is no block specified, we
	!   have an empty index entry.
	!-

	IF .index_record [iidx$g_down] EQL 0 THEN EXITLOOP;	! We're done

	!+
	!   Get the result of looking down a bit further.
	!-

	IF .level GTR 1				! Index level or data level
	THEN
	    down_status = nxtidx (.level - 1, .index_record [iidx$g_down])
	ELSE
	    down_status = nxtdat (.index_record [iidx$g_down]);

	IF .down_status				! Success?
	THEN
	    BEGIN				! Save the path
	    path [.level, path$h_offset] = .offset;
	    path [.level, path$h_block] = .this_block;
	    search_status = true;
	    EXITLOOP;
	    END;

	END;

    !
    !	Put away the block we got.
    !
    put_block (.stksec OR .blk_desc, .level);	! Toss the block

    !+
    !	If we did not find an entry in this block, reset
    !	this level's offset (in PATH) so we will start
    !	in the right place when we are called again.
    !-

    IF .search_status				! How did we fare?
    THEN
	RETURN true				! OK
    ELSE
	BEGIN
	path [.level, path$h_offset] = ibk$k_bln;
	RETURN false;
	END;

    END;					! End NXTIDX
ROUTINE nxtdat (check_block) =
    BEGIN

    STACKLOCAL
	dummy_blk_desc : $isam_block_descriptor;

    LOCAL
	record_size,				! Length of record
	record_words,				! Length of record in words
	search_status,				! Status of loop search
	bytes_per_word,				! Bytes per word in this file
	offset,
	blk_desc : REF $isam_block_descriptor,
	data_block,
	data_record : REF $isam_data_record;

    !

    !	Set up the descriptor pointers.  This unusual arrangement is
    !	necessary because the descriptor is on the stack and
    !	is therefore in another section.  This works around the
    !	attempts of BLISS to be devious and efficient.
    !
    blk_desc = .stksec OR dummy_blk_desc;	! Set pointer
    !
    !	Get the required block
    !
    get_block (.check_block, 			! Block to get
	.idafab [fab$v_bls], 			! It's this big (in blocks)
	.blk_desc, 				! And we want it put here
	0);					! Data level
    !
    !	Set up pointers to the block
    !
    data_block = .blk_desc [bld$a_block];	! Point at block

    !+
    !	The offset in PATH may be negative, meaning that
    !	we are to take the first record in this block,
    !	if there is one.  Otherwise, we find
    !	the current record and skip to the next.
    !-

    IF (offset = .path [0, path$h_offset]) LSS 0	! Negative
    THEN
	BEGIN
	offset = 0;				! Use first record
	data_record = .data_block;		! ...
	END
    ELSE
	BEGIN
	!
	!	Point at the current data record.
	!
	offset = .path [0, path$h_offset];
	data_record = .data_block + .offset;

	!+
	!	Get length of record (in bytes) as appropriate
	!	for this type of data.
	!-

	IF .idafab [fab$v_bsz] EQL rms$k_asc_size	!
	THEN
	    BEGIN
	    record_size = .data_record [ida$h_asc_siz];
	    bytes_per_word = 5;			! Really shouldn't use constant
	    END
	ELSE
	    BEGIN
	    record_size = .data_record [ida$h_size];
	    bytes_per_word = %BPVAL/.idafab [fab$v_bsz];
	    END;

	!
	!	Save record length away (for no good reason)
	!
	idxrab [rab$h_rsz] = idxrst [rst$h_record_size] = .record_size;
	!
	!   Figure length of record in words
	!
	record_words = (.record_size + (.bytes_per_word - 1))/	!
	.bytes_per_word;
	offset = .offset + ida$k_bln + .record_words;
	data_record = .data_block + .offset;
	END;

    !

    !	See if we have a record here or not (zero in the first
    !	word says no record exists).
    !

    IF .data_record [ida$h_size] EQL 0		! Length determines existence
    THEN
	BEGIN
	search_status = false;			! No record here
	path [0, path$h_offset] = -1;		! Take first of next block
	END
    ELSE
	BEGIN
	path [0, path$h_block] = .check_block;	! Set this block
	path [0, path$h_offset] = .offset;	! Using correct offset
	search_status = true;			! Yes, we have one.
	END;

    !
    !	Put away the block we got.
    !
    put_block (.stksec OR .blk_desc, 0);	! Toss the block
    !
    !	Return the state of the world.
    !
    RETURN .search_status;
    END;					! End NXTDAT
END

ELUDOM