Trailing-Edge
-
PDP-10 Archives
-
tops20-v7-ft-dist1-clock
-
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