Google
 

Trailing-Edge - PDP-10 Archives - bb-h138f-bm - 7-sources/fgnlib.r36
There are 3 other files named fgnlib.r36 in the archive. Click here to see a list.
!<BLF/REQUIRE 'BLF.REQ'>
! FGNLIB.R36
!
!
!	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.
!
!
%SBTTL 'FST/RST field values'
LITERAL
    FFF$m_Left_Half     = %O'777777000000',
    FFF$m_Section       = %O'007777000000',
    FFF$m_Local_Address = %O'000000777777';

LITERAL
!+
!   Foreign file classes
!-
       Fst$k_Sixbit         = -1,	! COBOL SIXBIT
       Fst$k_Ebcdic         = -2,	! COBOL EBCDIC
       Fst$k_Isam_Sixbit    = -3,
       Fst$k_Isam_Ebcdic    = -4,
       Fst$k_Isam_Ascii     = -5,
       Fst$k_Fortran_Binary = -6,	! FORTRAN BINARY

       Fst$k_FFF_Class_Min = -6,
       Fst$k_FFF_Class_Max = -1;

LITERAL
!+
!   Default file byte size
!-
    rms$k_six_size = 6,
    rms$k_asc_size = 7,
    rms$k_ebc_size = 9,
    rms$k_bin_size = 36;

LITERAL
!+
!   Default buffer sizes
!-
    rms$k_record_size = 250,                    ! Record buffer (in characters)
    rms$k_buffer_size = 1;                      ! default = 1 page

LITERAL 
!+
!   Default number of buffer 
!-

    rms$k_number_buffers = 2;                   ! 2 pages (any file type)

LITERAL 
!+
!   Default number of buffer (for file types)
!-

    rms$k_num_buf_asc = 1,
    rms$k_num_buf_bin = 1,
    rms$k_num_buf_six = 1,
    rms$k_num_buf_ebc = 2,

!+
!   Minimum number of buffers (for file types)
!-

    rms$k_min_buf_asc = 1,
    rms$k_min_buf_bin = 1,
    rms$k_min_buf_six = 1,
    rms$k_min_buf_ebc = 2;

LITERAL
!+
!   Record header sizes for foreign files (in words). 
!-

    rms$k_header_asc = 0,
    rms$k_header_img = 0,
    rms$k_header_fbin = 1,
    rms$k_header_six = 6,			! This is also in bytes
    rms$k_header_ebc = 4,			! This one is in bytes!!!
    rms$k_header_Isam = 1;

LITERAL
    yes = 1,					! ...
    no = 0,					! ...
    rms$k_initial_nrp = 0,			! Initial NRP for EBCDIC file
    rms$k_w_p_pg = %O'1000',			! Words in TOPS-20 page
    rms$k_w_p_bl = %O'200',			! Words in TOPS-10 block
    rms$k_bl_p_pg = rms$k_w_p_pg/rms$k_w_p_bl,	! Blocks in a page
    rms$k_w_p_bkt = rms$k_buffer_size*rms$k_w_p_pg,	! Words per bucket
    rms$k_bl_p_bkt = rms$k_w_p_bkt/rms$k_w_p_bl,	! Blocks per bucket
    rms$k_ebc_bpw = %BPVAL/rms$k_ebc_size,	! EBCDIC bytes per word
    rms$k_ebc_b_p_bl = rms$k_ebc_bpw*rms$k_w_p_bl,	! EBCDIC bytes per blk
    rms$k_six_bpw = %BPVAL/rms$k_six_size,	! SIXBIT bytes per word
    rms$k_six_b_p_bl = rms$k_six_bpw*rms$k_w_p_bl;	! SIXBIT bytes per blk
    

LITERAL
!+
!   Last operation bits (6 bit maximum - use last 6 bits of op-code)
!-
    op$k_get = %O'02',
    op$k_put = %O'03',
    op$k_update = %O'04',
    op$k_delete = %O'05',
    op$k_find = %O'06',
    op$k_truncate = %O'07',
    op$k_connect = %O'10',
    op$k_release = %O'14',
    op$k_free = %O'22';
%SBTTL 'Macros'
MACRO Usererror ( Code ) = SIGNAL( Code ) %;

!
! MACROS:
!

MACRO
    Build_List ( Blk ) [ Lst ] = Blk[%COUNT] = LST %,

    $FFunc ( Func ) =
	BEGIN
	external
	    FFFSEC,
	    uab : block [];
	BIND Args = Uab[1,0,0,0]: VECTOR;

	Build_List( Args, %REMAINING );
	Uab[0,0,18,0] = Func;
	Uab[0,18,18,0] = 1 - %LENGTH;
	$FFFint( Uab= .FFFSEC OR Uab );
	.uab[0,0,36,0]
	end %;


KEYWORDMACRO
    set_environment (rab) =
	($ffunc (u$setenvir, rab)) %,
    Get_page (page_count = 1) =
       ($FFunc( U$Gpage, page_count)
        ) %,

    Put_page (page_count = 1, page_number, kill_pages = true) =
       ($FFunc( U$Ppage, page_number, page_count, kill_pages)
        ) %,

    Get_memory (length) =
       ($FFunc( U$Gmem, length)
        ) %,

    Put_memory (length, address) =
       ($FFunc( U$Pmem, address, length)
        ) %,

    Get_Bucket ( Rab=Same_Rab, Bucket, Bucket_Size=1, Lock=0, Desc )=
       (%IF NOT %IDENTICAL( Rab, Same_Rab )
        %THEN $FFunc( U$Setenvir, Rab );
        %FI
        $FFunc( U$Getbkt, Bucket, Bucket_Size, Lock, Desc)
        ) %,

    Put_Bucket ( Rab=Same_Rab, Desc, Update=1 )=
       (%IF NOT %IDENTICAL( Rab, Same_Rab )
        %THEN $FFunc( U$Setenvir, Rab );
        %FI
        $FFunc( U$Putbkt, Update, Desc)
        ) %;

MACRO  Free_Bucket ( A ) = Put_Bucket( A, %REMAINING, Update=0 ) %;

MACRO
!
!   Disguise a field in the RST for blocked EBCDIC files
!
    rst$g_blkbyt =				! Bytes in a block
 
 rst$g_nrp_rrv %,
!
!   Create a One-Word Global Byte Pointer
!
    ea_ch$ptr (address, offset, bsz) =
	!
	!   EA_CH$PTR builds a one-word global byte
	!   pointer, given the same arguments as
	!   the BLISS CH$PTR function:
	!
	!	ADDRESS	- global address of string
	!	OFFSET	- offset in string (defaults to 0)
	!	BSZ	- byte size (must be 6,7,8,9, or 18)
	!		  and defaults to 7
	!
	BEGIN
	LOCAL
	    the_pointer;
	%IF %NULL (address) %THEN
	    %ERRORMACRO ('Address argument is required')
	%FI
	%IF %NULL (bsz) %THEN
	    the_pointer = %O'61'^30 OR (address);
	%ELSE %IF %CTCE (bsz) %THEN
	    %IF (bsz) EQL 6 %THEN
		the_pointer = %O'45'^30 OR (address);	! SIXBIT
	    %ELSE %IF (bsz) EQL 7 %THEN
		the_pointer = %O'61'^30 OR (address);	! ASCII
	    %ELSE %IF (bsz) EQL 8 %THEN
		the_pointer = %O'54'^30 OR (address);	! 8-Bit
	    %ELSE %IF (bsz) EQL 9 %THEN
		the_pointer = %O'67'^30 OR (address);	! EBCDIC
	    %ELSE %IF (bsz) EQL 18 %THEN
		the_pointer = %O'74'^30 OR (address);	! Halfword
	    %ELSE
		%ERRORMACRO ('Invalid byte size')	! Error
	    %FI %FI %FI %FI %FI
	%ELSE
	SELECTONE (bsz) OF
	    SET
	    [6]:
		the_pointer = %O'45'^30 OR (address);
	    [7]:
		the_pointer = %O'61'^30 OR (address);
	    [8]:
		the_pointer = %O'54'^30 OR (address);
	    [9]:
		the_pointer = %O'67'^30 OR (address);
	    [18]:
		the_pointer = %O'74'^30 OR (address);
	    [OTHERWISE]:
		BEGIN
		rab [rab$h_sts] = rms$_bug;
		rab [rab$h_stv] = UPLIT(		    !
		    %ASCIZ %STRING ('?Illegal byte size for EA_CH$PTR', !
		    %CHAR(13,10)));
		RETURN false;
		END;
	    TES;
	%FI %FI
	%IF %NULL (offset) %THEN
	    .the_pointer
	%ELSE
	    CH$PLUS (.the_pointer, (offset))
	%FI
	END %;

!
! EQUATED SYMBOLS:
!

LITERAL First_Vbn=1;

! UTLINT function codes and arguments

LITERAL
    U$SETENVIR=0,                ! SETENVIR(RAB)
    U$GMEM=1,                    ! GMEM(Len)
    U$GPAGE=2,                   ! GPAGE(Numberofpages)
    U$PMEM=3,                    ! PMEM(Len,Addr)
    U$PPAGE=4,                   ! PPAGE(Pagenum,Numberofpages,KillFlag)

! ** Functions below this require SETENVIR to be done first

    U$CHKDUP=6,                  ! CHKDUP(RecDesc_FirstSidr,BktDesc)
    U$CKEYKU=7,                  ! CKEYKU(RDPptr,RECptr)
    U$CKEYKK=%O'10',             ! CKEYKK(RDPptr,KeyStringptr)
    U$FBYRRV=%O'11',             ! FBYRRV(RecDesc_Target,BktDesc)
    U$FBYRFA=%O'12',             ! FBYRFA(RecDesc_Target,BktDesc)
    U$FNDDATA=%O'13',            ! FNDDATA(RecDesc_Keystring,BktDesc)
    U$FOLOPATH=%O'14',           ! FOLOPATH(RecDesc_Searchkey,BktDesc)
    U$GETBKT=%O'15',             ! GETBKT(Bktno,Bktsize,Lockflag,BktDesc)
    U$GETIDB=%O'16',             ! GETIDB(BktDesc)
    U$GETKDB=%O'17',             ! GETKDB(Krf)
    U$GETROOT=%O'20',            ! GETROOT(RecDesc)
    U$GTBKTPTR=%O'21',           ! GTBKTPTR(RecDesc,BktDesc_curr,BktDesc_next)
    U$MOVEKEY=%O'22',            ! MOVEKEY(RecPtr,KeybufPtr)
    U$PATH=%O'23',               ! PATH()
    U$PUTBKT=%O'24',             ! PUTBKT(UpdateFlag,BktDesc)
    U$PUTSIDR=%O'25';            ! PUTSIDR(RecDesc)
%SBTTL 'COBOL SIXBIT RECORD FORMAT'

FIELD hdr$r_fields =
    SET
    hdr$h_code = [0,18,18,0],
    hdr$h_record_length = [0,0,18,0]
    TES;

MACRO $hdr = BLOCK [1] FIELD( hdr$r_fields ) %;
%SBTTL'Logical Segment Control Word'

!++
!
!   The Logical Segment Control Word (LSCW) is a 36-bit data
!   word used to delimit each record in a Fortran binary file.
!   It consists of an octal code value (1, 2, or 3) in the
!   first nine bits of the word and a count value in the
!   right half word.
!   
!   For random and sequential files that do not cross block 
!   boundaries, the count values are as follows:
!
!   CODE 1            Number of words in record + 1
!   CODE 3            Number of words in record + 2
!
!   For sequential records that cross a block boundary, the 
!   count values are as follows:
!
!   CODE 1            Number of words in the block
!   CODE 2            Number of words in the record that cross
!                     the block boundary + 1
!   CODE 3            Number of words in the record + 3
!

!   The format of a LSCW is as follows:
!
!    +-------------------------------------+
!    !  CODE  !/////////!     COUNT        !
!    !-------------------------------------!
!
!
!--

FIELD
    lscw$r_fields =
	SET
	lscw$h_count_value = [0, 0, 18, 0],	! Count value
!	lscw$b_unused = [0, 18, 9, 0],		! UNUSED
	lscw$b_code = [0, 27, 9, 0]		! Code
	TES;

LITERAL
    lscw$k_bln = 1;				! Length

MACRO
    $rms_lscw =                                 ! Define a LSCW
BLOCK [lscw$k_bln] FIELD (lscw$r_fields) %;

LITERAL
    !
    !	LSCW sizes 
    !
    lscw$k_lscw1_size = 1,
    lscw$k_lscw2_size = 1,
    lscw$k_lscw3_size = 1;
%SBTTL 'Useful terms from RMSLIB'

LITERAL
!
!   Shifting contants
!
    s2p = -9,					! LH (SECTIONS) TO PAGES
    w2p = -9,					! SHIFTING CONSTANT FOR WORDS 
                                                !  TO PAGES
    p2w = 9;                                    ! PAGES/WORDS

!+
!   Macros for accessing -20 address word
!-

MACRO
    wrd =
	0, 36, 0 %,				! Contents of entire word
    rh =
	0, 18, 0 %,				! Right half of word
    lh =
	18, 18, 0 %,				! Left half of word
    ofset =
	0, 0, 9, 0 %,				! Offset into page
    page =
	0, 9, 9, 0 %;				! Page number (bits 18-26)

!+
!    RFA for sequential files
!-

MACRO
    rfapage =
	0, 9, 18, 0 %;				! Page number of file page
                                                ! (bits 9-26)

MACRO
    xwd ( left, right ) = ( (left ^ 18 ) + (right AND %O'777777') ) %;

!+
!    Some constants
!-

LITERAL
    nullbp = %O'440000',			! a left-justified byte ptr
    plusinfinity = %O'377777777777';		! Positive infinity


!+
!    Compute total size of data record (in bytes)
!-

MACRO
    $size_in_bytes (byte_size, words) =
	BEGIN

	LOCAL
	    bytes;

	bytes = 36/byte_size;			! Number of bytes/word
        (words * .bytes)                        ! Return bytes
	END
    %;


!+
!    Macros for accessing fields in the current bucket descriptor
!-

MACRO
    currentwindow =
	cbd [bkt$a_address]^w2p %,		! CURRENT WINDOW
    currentfilepage =
	cbd [bkt$h_number] %,			! FILE PAGE IN WINDOW
    curentbufferadr =
	cbd [bkt$a_address] %;			! ADDR OF BUFFER


!+
!    Macro to get address of first buffer descriptor
!-

MACRO
    bfdoffset = (rst [rst$g_buffer_desc]) %;


!+
!    Macros for accessing the "success" flag
!-

MACRO
    setsuccess (op_flag) =
	BEGIN
	rst [rst$h_flags] = .rst [rst$h_flags] OR rst$m_success;
	rst [rst$v_last_operation] = op_flag;
	END
    %;
%SBTTL 'Error handling macros for FORGN'

LITERAL
!
!   Size of GRABIT_TABLE (the error message table)
!
    ff$_number_messages = 18;

LITERAL
!
!   Error codes                                    
!
    ff$_cannot_open_file = 0 ,
    ff$_bad_input_moverec = 1 ,
    ff$_bkt_get_failed = 2 ,
    ff$_buffer_get_failed = 3 ,
    ff$_end_of_file = 4 ,
    ff$_dvchr_failed = 5 ,
    ff$_find_failed = 6 ,
    ff$_fst_not_init = 7 ,
    ff$_get_failed = 8 ,
    ff$_moverec_failed = 9 ,
    ff$_no_action = 10 ,
    ff$_page_not_exist = 11 ,
    ff$_pmap_failed  = 12 ,
    ff$_putbuf_failed = 13 ,
    ff$_rpacs_failed = 14 ,
    ff$_rst_not_init = 15 ,
    ff$_window_failed = 16 ,
    ff$_zero_crp = 17 ,
    ff$_error_min = 0 ,
    ff$_error_max = 17 ;
%SBTTL 'Miscellaneous'

!+
!    "Nicknames" for the $FIND and $GET routines
!-

MACRO
    getftnimg =
 gftimg %,
    getftnasc =
 gftasc %,
    getftnbin =
 gftbin %,
    getcblasc =
 gcbasc %,
    getcblsix =
 gcbsix %,
    getcblebc =
 gcbebc %,
    getcblbin =
 gcbbin %,
    findftnimg =
 fftimg %,
    findftnasc =
 fftasc %,
    findftnbin =
 fftbin %,
    findcblasc =
 fcbasc %,
    findcblsix =
 fcbsix %,
    findcblebc =
 fcbebc %,
    findcblbin =
 fcbbin %,
    six_rd_hdr = s_rhdr %,
    ebc_new_block = e_nblk %,
    ebc_rd_hdr = e_rhdr %;


! FGNLIB.R36 -- LAST LINE