Trailing-Edge
-
PDP-10 Archives
-
BB-H138F-BM_1988
-
7-sources/dap.b36
There are 5 other files named dap.b36 in the archive. Click here to see a list.
MODULE DAP( !DAP message processing routines
IDENT='7.0(664) 6-Feb-87'
%BLISS36(,
ENTRY(
D$GCFG, ! DAP$GET_CONFIG, ! Get Config message
D$GATT, ! DAP$GET_ATTRIBUTES, ! Get Attributes -> FAB
D$$GAT, ! DAP$$GET_ATTRIBUTES,! Get Attributes FAB+FST
D$PCFG, ! DAP$PUT_CONFIG, ! Build CONFIG
D$PATT, ! DAP$PUT_ATTRIBUTES, ! Build ATTRIBUTES <- FAB
D$$PAT, ! DAP$$PUT_ATTRIBUTES,! Put Attributes FAB+FST
D$PACC, ! DAP$PUT_ACCESS, ! Build ACCESS message
D$PNAM, ! DAP$PUT_NAME, ! Build a NAME message
D$PCTL, ! DAP$PUT_CONTROL, ! Build CONTROL message
D$GSTS ! DAP$GET_STATUS ! Process a STATUS message
))
)=
BEGIN
!
! COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1981, 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.
!
!++
! FACILITY: RMS-20
!
! ABSTRACT: This is the System-independent part of the DAP protocol.
!
!
! ENVIRONMENT: TOPS-20, Transportable BLISS DecNet Interface
!
! AUTHOR: Andrew Nourse, CREATION DATE: 21-Dec-81
! RMS edit numbers:
!
! 664 - Add output of FFB and EBK fields so that NFT's DIR command works.
! 656 - Implement protection XAB code in get and put attributes messages.
! 653 - Don't default the MRS to 512 unless the RFM is UDF and all of the
! following is true: no MRS was specified, we are talking to a 10 or 20,
! the TYP is IMAGE (correcting part of edit 647).
! 652 - If we are talking to an old non-RMS TOPS-20 program then add two to the
! MRS if the RFM is STM and default the FOP to SUP if none specified.
! 647 - Default the datatype to IMAGE if it wasn't given in the attributes
! message. If we are doing image mode, default the bytesize to 36 and
! MRS of 512 if not given in attribute message and we are talking to an
! LCG machine. The TOPS-10 NFT program depends on this working right
! since it uses SEQ mode for image file transfers.
! 645 - If image mode to another 36 bit system running old FALs, set block
! size 512 and byte size 36 and undefined record format.
! 644 - Insure that all three arguments passed to DAP$GET_CONFIG.
! 641 - Nametype_Nam NAME message must be preceded by structure and
! directory NAME messages, else ignore it.
! 636 - Allow RSTS to read stream files.
! 623 - Construct keyed $GET string keys with proper byte pntr.
! 620 - Old missing dot in D$PCTL caused infinite loop on keyed $GET.
! 617 - Old typo moving DAP FLG bits.
! 613 - Added DIL8 type class to support DIL formatted 8-bit
! records generated (only) by DIU)
! 610 - Fix extended KEY attributes, implement KNM sending/receiving,
! don't compare checksums if requested to do so but we are
! closing and deleting a file, fix "Unsupported DAP operation"
! error for directory/list function from VMS when bit 35 is on.
! 606 - Handle 8-segment keys,
! also add more UAPointer calls to D$Name_Decompose
! 605 - Handle oversize RFA's from/to VMS
! 602 - Default ORG & some other fields if not returned, fix dev & sdc
! 601 - Check for RMS$_SIZ
! 600 - Don't lose RFA on PUT
! 577 - Handle strange ALLOC & KEY messages correctly
! Handle certain status messages better
! 574 - Use FST from global, handle ext attrs better
! 572 - TOPS10
! 571 - Fix returned names & $display
! 557 - Fix multistream
! 555 - Fix LSA
! New names for software version fields
! 515 - Use Xab$v_Cod, not Xab$h_Bid
! 533 - Save Accopt for CRC
!
! Module edit numbers:
! 20 - Handle overlong fields in STATUS message better
! 17 - Handle XABs better
! 16 - RMS'ify. And the DIB is now an FST
! 15 - Make DAP$$(GET|PUT)_ATTRIBUTES, which takes a DIB as an argument
! 14 - Make DAP$GET_ATTRIBUTES return if it gets ACCESS msg
! 13 - Make losing old FAL-20 blocks into pages
! 12 - Handle ADT. also put BDT and PDT in correct order
! 11 - Put nodeid in resultant name generated from 3-part name
! 10 - Send real byte size to 36-bit machines, no byte size to others
! and include node name in remote resultant filespec.
! 07 - Set implied CRLF for ASCII FIXED
! 06 - Workaround RSTS not sending STATUS for file-not-found on directory
! 05 - Put in ENTRY points
! 04 - Fix default for BLS in DAP$PUT_ATTRIBUTES
! and put in bitvectors for workarounds
! - Fix RENAME name type
! 03 - Page mode
! 02 - Make the FOP go out
! 01 - The beginning
!--
!
! Libraries
!
REQUIRE 'RMSREQ';
LIBRARY 'BLISSNET';
LIBRARY 'CONDIT';
!
! Table of Contents
!
FORWARD ROUTINE
DAP$GET_CONFIG, ! Get Config message
DAP$GET_ATTRIBUTES, ! Get Attributes
DAP$$GET_ATTRIBUTES, ! Get Attributes to FAB & FST
D$NAME_DECOMPOSE: NOVALUE, ! decompose remote filespec
DAP$PUT_CONFIG: NOVALUE, ! Build CONFIG
DAP$PUT_ATTRIBUTES: NOVALUE, ! Build ATTRIBUTES from FAB
DAP$$PUT_ATTRIBUTES: NOVALUE, ! Build Attributes from FAB & FST
DAP$PUT_ACCESS: NOVALUE, ! Build ACCESS message
DAP$PUT_NAME: NOVALUE, ! Build a NAME message
DAP$PUT_CONTROL: NOVALUE, ! Build CONTROL message
DAP$GET_STATUS, ! Process a STATUS message
DAP$RFA_RMS_DAP: NOVALUE, ! Convert RMS RFA for DAP
DAP$RFA_DAP_RMS; ! Convert DAP RFA for RMS
!
! Literals
!
%IF NOT %DECLARED(Fab$k_SLf) ! If RMS does not have STREAM_CRLF
%THEN LITERAL Fab$k_SLf = Fab$k_Stm;! make it STREAM
%FI
%IF NOT %DECLARED(Fab$k_SCr) ! If RMS does not have STREAM_CRLF
%THEN LITERAL Fab$k_SCr = Fab$k_Stm;! make it STREAM
%FI
%IF %BLISS(BLISS36)
%THEN
%IF %SWITCHES(TOPS20)
%THEN
LITERAL
OUR_OSTYPE=DAP$K_TOPS20,
OUR_BLOCK_SIZE=512,
DEVICE_NAME_LENGTH=40, ! Including punctuation
DIRECTORY_NAME_LENGTH=41,!
FILE_NAME_LENGTH=40, !
OUR_FILESYS=DAP$K_RMS20;
%ELSE
LITERAL
OUR_OSTYPE=DAP$K_TOPS10,
OUR_BLOCK_SIZE=512,
DEVICE_NAME_LENGTH=40, ! Including punctuation
DIRECTORY_NAME_LENGTH=45,!
FILE_NAME_LENGTH=40, !
OUR_FILESYS=DAP$K_TOPS10;
%FI
%ELSE %ERROR('Not implemented for 16/32 bit architectures')
%FI;
!
! External references
!
EXTERNAL ROUTINE Chazac,
s$fbbyv,
s$fbsiz,
S$StrDt,
S$DtStr,
Dap$Get_Header,
Dap$Unget_Header,
Dap$Get_Byte,
Dap$Get_2byte,
Dap$Get_Date,
Dap$Get_Variable_String,
Dap$Get_Variable_Counted,
Dap$Size_Bitvector,
Dap$Get_Bitvector,
Dap$Get_Longword,
Dap$Get_Variable_Counted,
Dap$Put_Bitvector,
Dap$Put_Header,
Dap$Put_2byte,
Dap$Put_Longword,
Dap$Put_Byte,
Dap$Put_String,
Dap$Put_Variable_Counted,
Dap$Put_Date,
Dap$Unget_Byte,
Dap$Eat_Message,
Dap$Error_Dap_Rms,
UAddr,
UAPointer,
TGUPointer;
EXTERNAL
d$gtrace: BITVECTOR[%BPVAL];
!
! Macros
!
MACRO Dap_Error (Ddesc, Mac, Mic) = Signal ( Err_Ds ( Mac, Mic), Ddesc ) %;
!
! Equated Symbols
!
LITERAL Dap$k_Obj_Fal=17; !The FAL Object Type
!
! GLOBAL Data
!
PSECT GLOBAL=$HIGH$;
PSECT OWN=$HIGH$;
GLOBAL FalObj: INITIAL (Dap$k_Obj_Fal) ;
!+ 610
! Global vector of addresses for dynamically allocated KeyName
! text buffers
!-
GLOBAL KnmBuf: VECTOR[256] INITIAL (0) ; !610
!
! This is the configuration XAB that describes what we are running
!
GLOBAL OurCfg: $XabCfg_decl PRESET
([xab$h_bid] = xab$k_bid, ! Set up header !a545
[xab$h_bln] = xab$k_cfglen, ! !a545
[xab$v_cod] = xab$k_cfg, ! !a545
[xab$b_version]=7,
[xab$b_econum]=0,
[xab$b_softver]=3,
[xab$b_ostype]=Our_OSType,
[xab$b_filesys]=Our_Filesys,
[xab$h_bufsiz]=Dap$k_Buffer_Size,
! System Capabilities
[xab$v_preallocation]=1, ! pre ! Preallocation supported
! File Organizations Supported:
[xab$v_sequential_org]=1, ! sqo ! Sequential
[xab$v_relative_org]=1, ! rlo ! Relative
[xab$v_direct_org]=0, ! dro ! DIRECT (reserved)
[xab$v_control_extend]=0, ! ext ! Control message $EXTEND
!
! File Access Modes Supported:
[xab$v_sequential_transfer]=1, ! sqt ! Sequential File Transfer
! Random access by
[xab$v_random_access_recnum]=1, ! rre ! Record Number
[xab$v_random_access_vbn]=1, ! rvb ! Virtual Block # !m561
[xab$v_random_access_key]=1, ! rke ! Key
[xab$v_random_access_hash]=0, ! rha ! hash code (reserved)
[xab$v_random_access_rfa]=1, ! rrf ! RFA
[xab$v_indexed_multi_key]=1, ! imk ! Multi-key ISAM
[xab$v_switch_access_mode]=1, ! swa ! Change RAC !m545
[xab$v_append_access]=1, ! apa ! APPEND supported
[xab$v_submit_access]=1, ! sba ! Control message $SUBMIT
[xab$v_data_compression]=0, ! cmp ! Reserved
[xab$v_multi_data_streams]=0, ! mds ! Multiple record streams
[xab$v_display]=1, ! dis ! Control message $DISPLAY
! DAP Message blocking:
[xab$v_blocking]=1, ! blr ! Until response needed
[xab$v_unrestricted_blocking]=1, ! blu ! Unrestricted
[xab$v_len256]=1, ! 256 ! Extended length field
[xab$v_checksum]=1, ! chk ! DAP checksumming
! XAB messages supported
[xab$v_key_definition]=1, ! kem ! KEY DEFINITION message
[xab$v_allocation]=1, ! alm ! ALLOCATION message
[xab$v_summary]=1, ! smm ! SUMMARY message
[xab$v_directory]=1, ! dir ! DIRECTORY access
[xab$v_date_time]=1, ! dtm ! DATE/TIME message
[xab$v_protection]=1, ! pro ! PROTECTION message
[xab$v_acl]=0, ! acl ! ACL message (reserved)
! FOP Close bits supported:
[xab$v_fop_print]=1, ! fpr ! FOP SPL bit
[xab$v_fop_submit]=1, ! fsb ! FOP SCF bit
[xab$v_fop_delete]=1, ! fde ! FOP DLT bit
[xab$v_default_filespec]=0, ! dfs ! Default Filespec !m545
[xab$v_sequential_access]=1, ! sqa ! Sequential RECORD access
[xab$v_recovery]=0, ! rec ! Recovery (Reserved)
[xab$v_bitcnt]=1, ! bit ! BITCNT field
[xab$v_warning_status]=0, ! war ! WARNING STATUS message
[xab$v_rename_access]=1, ! ren ! $RENAME
[xab$v_wildcarding]=1, ! wld ! Wildcarding
[xab$v_go_no_go]=0, ! go ! GO/NOGO option
[xab$v_name]=1, ! nam ! NAME message
[xab$v_segmenting]=1, ! seg ! DAP message segmentation
! $CLOSE Options
[xab$v_change_attributes]=0, ! cat ! Change Attributes
[xab$v_change_dtm]=0, ! cdt ! Change Date/Time
[xab$v_change_protection]=0, ! cpr ! Change Protection
[xab$v_change_name]=1, ! cna ! Change Name
[xab$v_modified_attributes]=0, ! mat ! Changed Attributes/Create
[xab$v_display_3_part_name]=1, ! d3n ! 3-part name in $DISPLAY
[xab$v_rename_change_attributes]=0,! rat ! Change Attributes
[xab$v_rename_change_dtm]=0, ! rdt ! Change Date/Time
[xab$v_rename_change_protection]=0,! rpr ! Change Protection
[xab$v_blkcnt]=0, ! bcs ! Block Count
[xab$v_Octal_Version_Numbers]=0 ! ovn ! octal version numbers
);
!
! Canned Messages (Global PLITS)
!
GLOBAL D_Skip: $Xpn_Descriptor (Binary_Data= (3, UPLIT(Char8(Dap$k_Continue,
0,
Dap$k_Con_Skip))));
! Runtime conditionals for workarounds (to other systems' bugs)
GLOBAL
T20bug: BITVECTOR[16] INITIAL(-1), ! Bit map for TOPS-20 workarounds
Vmsbug: BITVECTOR[16] INITIAL(-1), ! for VMS
Rsxbug: BITVECTOR[16] INITIAL(-1), ! for RSX
Rstbug: BITVECTOR[16] INITIAL(-1), ! for RSTS
Rtbug: BITVECTOR[16] INITIAL(-1), ! for RT11
Iasbug: BITVECTOR[16] INITIAL(-1), ! for IAS
Posbug: BITVECTOR[16] INITIAL(-1), ! for POS
Ultbug: BITVECTOR[16] INITIAL(-1), ! for ULTRIX
Msdbug: BITVECTOR[16] INITIAL(-1), ! for MS-DOS
T10bug: BITVECTOR[16] INITIAL(-1); ! for TOPS-10
OWN D_Null: $Str_Descriptor ( String = %CHAR(0) );
GLOBAL ROUTINE Dap$Get_Config ( P_Dd: REF $Dap_Descriptor,
P_Cfg: REF $XabCfg_Decl,
p_fab: REF $fab_decl)= !a637
!++
! FUNCTIONAL DESCRIPTION:
!
! Process a CONFIG message and save the information contained therein
! into the configuration block
!
! FORMAL PARAMETERS:
!
! p_dd: Address of DAP message descriptor
! p_cfg: Address of internal configuration XAB to fill in
! p_fab: Address of user's FAB (so that we may fill in his config XAB)
!
! IMPLICIT INPUTS:
!
! NONE
!
! IMPLICIT OUTPUTS:
!
! Internal configuration block is set up and user's configuration XAB is
! set up (if any).
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! DAP Message type of message we got.
!
! SIDE EFFECTS:
!
! NONE
!
!--
BEGIN
BIND dd=.P_dd: $Dap_Descriptor;
BIND Cfg=.P_Cfg: $XabCfg_Decl;
BIND ufab = .p_fab: $fab_decl;
LOCAL xabptr;
IF Dap$Get_Header (dd) NEQ DAP$K_CONFIG
THEN RETURN Dap$Unget_Header (dd);
Cfg[Xab$h_Bufsiz]=Dap$Get_2byte(dd); !Maximum DAP message size
Cfg[Xab$b_Ostype]=Dap$Get_Byte(dd); !What are we talking to
Cfg[Xab$b_Filesys]=Dap$Get_Byte(dd); !File system type
Cfg[Xab$b_Version]=Dap$Get_Byte(dd); !DAP Version # of remote system
Cfg[Xab$b_Econum]=Dap$Get_Byte(dd); !DAP ECO #
Cfg[Xab$b_Usrnum]=Dap$Get_Byte(dd); !Customer version # for DAP
Cfg[Xab$b_Softver]=Dap$Get_Byte(dd); !Version of cusp
Cfg[Xab$b_Usrsoft]=Dap$Get_Byte(dd); !User cusp version #
Dap$Get_Bitvector(dd,Cfg[Xab$v_Syscap],12); !SYSCAP bits
IF .Dd[Dap$h_Length] GTR 0 !If Message was longer
THEN Dap$Eat_Message (dd); ! ignore the rest
! a637vv
! Fill in user's config xab (if any) from the internal config block
xabptr = .ufab[Fab$a_Xab]; ! Point to the first xab
WHILE .xabptr NEQ 0 ! While the xab chain still points
DO BEGIN ! Look for the config xab
BIND uxab = uaddr(.xabptr): $xabcfg_decl;
IF .uxab[XAB$V_COD] EQL XAB$K_CFG ! Is it a config xab?
THEN BEGIN ! Yes
IF .rmssec EQL 0 ! Copy non-header portion of config
THEN $move_words(cfg+XAB$K_HDRLEN,
uxab+XAB$K_HDRLEN,
XAB$K_CFGLEN-XAB$K_HDRLEN) ! Section 0 mover
ELSE $rms$xcopy(cfg+XAB$K_HDRLEN,
uxab+XAB$K_HDRLEN,
XAB$K_CFGLEN-XAB$K_HDRLEN); ! Section nonzero mover
EXITLOOP; ! We found it now exit
END
ELSE xabptr=.uxab[XAB$A_NXT]; ! On to next XAB
END; ! End of WHILE .xabptr NEQ 0 DO
! a637^^
Dap$k_Config !Return what we got
END; !End of DAP$GET_CONFIG
GLOBAL ROUTINE Dap$Get_Attributes ( P_Dd: REF $Dap_Descriptor,
P_Fab: REF $Fab_Decl)=
!++
! FUNCTIONAL DESCRIPTION:
!
! Process ATTRIBUTES, ATTRIBUTES extensions, NAME and ACCESS messages
! Returns on receipt of ACK or ACCESS (or NAME if DAP$K_RENAME)
!
! FORMAL PARAMETERS:
!
! P_DD: Addr of DAP message descriptor
! P_FAB: Addr of FAB
! This routine uses the FST pointed to by the global FST
!
! ROUTINE VALUE:
!
! DAP Operator code if successful, Signal error otherwise
!
! SIDE EFFECTS:
!
! Memory is allocated for a KDB for each Key message read.
! These are kept in a chain from Fst[Fst$a_Kdb]
!--
BEGIN
DAP$$GET_ATTRIBUTES( .p_dd, .p_Fab, .Fst )
![15] Call this routine to really do the work, using the FST from the FAB
END;
GLOBAL ROUTINE Dap$$Get_Attributes (p_Dd: REF $Dap_Descriptor,
P_Fab: REF $Fab_Decl,
p_Fst: REF $Rms_Fst )=
!++
! FUNCTIONAL DESCRIPTION:
!
! Process ATTRIBUTES, ATTRIBUTES extensions, NAME and ACCESS messages
! Returns on receipt of ACK or ACCESS (or NAME if DAP$K_RENAME)
!
! FORMAL PARAMETERS:
!
! P_DD: Addr of DAP message descriptor
! P_FAB: Addr of (RMS) FAB
! P_FST: Addr of Fst
!
! ROUTINE VALUE:
!
! DAP Operator code if successful, Signal error otherwise
!
! SIDE EFFECTS:
!
! Memory is allocated for a KDB for each Key message read.
! These are kept in a chain from Fst[Fst$a_Kdb]
!--
BEGIN !Expecting ATTRIBUTES, ACCESS, NAME, ACK,
!or any of the Attributes extensions
BIND dd=.P_dd: $Dap_Descriptor,
fab=.p_fab: $Fab_Decl,
fst=.p_fst: $Rms_Fst,
Config=.Fst[Fst$a_Config]: $XabCfg_Decl; ! Configuration block
BIND typ = ( IF .Fab[Fab$a_Typ] NEQ 0
THEN .Fab[Fab$a_Typ]
ELSE 0 ): $Typ_decl; !a504
LOCAL mtype: INITIAL(-1); !DAP message type
LOCAL omtype;
LOCAL nametypes_seen: BITVECTOR[21] INITIAL(0); ! Types of Name messages seen
LOCAL ! Pointers to the various XABs
xabptr,
xaball: VECTOR[32] INITIAL(0),
xabpro: REF $XabPro_decl INITIAL(0),
xabcfg: REF $XabCfg_decl INITIAL(0),
xabsum: REF $XabSum_decl INITIAL(0),
xabdat: REF $XabDat_decl INITIAL(0),
xabkey: VECTOR[256] INITIAL(0); ! We can have 255 of these!
! Find our XABs ![17] Handle XABs better vv
xabptr = .Fab[Fab$a_Xab];
WHILE .xabptr NEQ 0
DO
BEGIN
BIND uxab=UAddr( .xabptr ): $XabKey_decl;
CASE .Uxab[Xab$v_Cod] FROM 0 TO Xab$k_cod_max OF ! COD not BID !m515
SET
[Xab$k_Sum]: XabSum=uxab;
[Xab$k_All]: BEGIN
MAP uxab: $XabAll_decl;
XabAll[ .uxab[Xab$b_aid] ] = uxab;
END;
[Xab$k_Dat]: XabDat=uxab;
[Xab$k_Cfg]: ;
[Xab$k_Key]: XabKey[ .uxab[Xab$b_ref] ] = uxab;
[Xab$k_Pro]: XabPro=uxab;
[OUTRANGE]: SIGNAL( Rms$_Cod, .uxab[Xab$v_cod] );
TES;
xabptr=.uxab[Xab$a_nxt]; ! On to next XAB
END;
WHILE 1 DO
BEGIN
LABEL Do_Name;
omtype=.mtype;
mtype=Dap$Get_Header(DD[$]);
SELECTONE .MTYPE OF SET
[DAP$K_ATTRIBUTES]:
BEGIN
LOCAL attmenu: BITVECTOR[42] INITIAL(0),
datatype: BITVECTOR[14] INITIAL(0),
org: INITIAL(0),
rfm: INITIAL(0),
rat: BITVECTOR[21] INITIAL(0),
bls: INITIAL(0),
mrs: INITIAL(0),
alq: INITIAL(0),
bks: INITIAL(0),
mrn: INITIAL(0),
runsys: VECTOR[CH$ALLOCATION(40)]
INITIAL(REP CH$ALLOCATION(40) OF (0)),
deq: INITIAL(0),
fop: BITVECTOR[42] INITIAL(0),
bsz: INITIAL(0),
dev: BITVECTOR[42] INITIAL(0),
sdc: BITVECTOR[42] INITIAL(0),
lrl: INITIAL(0),
hbk: INITIAL(0),
ebk: INITIAL(0),
ffb: INITIAL(0),
sbn: INITIAL(0);
Dap$Get_Bitvector (dd, attmenu, 6); !Attributes menu bits
! See if there is a datatype and read it. Default the datatype
! to IMAGE if none was specified.
IF .attmenu[DAP$V_ATTMENU_DAT] ! Datatype?
THEN DAP$GET_BITVECTOR (dd, datatype, 2) ! Yes read it
ELSE datatype[DAP$V_DATATYPE_IMAGE] = 1; ! No default it
IF .attmenu[Dap$v_Attmenu_Org] ! File Organization
THEN
BEGIN
org=Dap$Get_Byte(dd);
Fab[Fab$v_Org]=$Dap_Translate_Value(.org,
Dap$k_Org_,Fab$k_,
Seq,Rel,Idx,Hsh);
END
ELSE Fab[Fab$v_Org] = Fab$k_Seq; ! Default !m602
IF .attmenu[Dap$v_Attmenu_Rfm] ! Record Format
THEN
BEGIN
rfm=Dap$Get_Byte(dd);
Fab[Fab$v_Rfm]=$Dap_Translate_Value(.rfm,
Dap$k_Rfm_,Fab$k_,
Udf,Fix,Var,
Vfc,Stm,Lsa,
Slf,Scr); !m572
END
ELSE Fab[Fab$v_Rfm] = Fab$k_Fix; ! Default rfm !a561
IF .attmenu[Dap$v_Attmenu_Rat] ! Record Attributes
THEN
BEGIN
rat=Dap$Get_Byte(dd);
$Dap_Move_Bits ( Rat,Dap$v_Rat_,Fab,Fab$v_,
Ftn,Cr,Prn,Blk,Lsa );
END
ELSE Fab[Fab$h_Rat] = 0; !m602
Fst[Fst$h_Rat] = .Fab[Fab$h_Rat]; ! in FST also !m602
%BLISS36(
IF .rat[Dap$v_Rat_Lsa] ! Line-Sequenced Ascii
THEN
BEGIN
Fab[Fab$v_Rfm]=Fab$k_Lsa;
Fab[Fab$b_Fsz] = 2; ! Size of sequence # !a555
END;
! is a Record Format on the 10 & 20
! and a Record Attribute elsewhere
) !End %BLISS36
IF .attmenu[Dap$v_Attmenu_Bls]
THEN bls=Dap$Get_2byte(dd) ! Physical Block Size
ELSE bls=512; ! default
IF .attmenu[Dap$v_Attmenu_Mrs]
THEN Fab[Fab$h_Mrs]=Dap$Get_2byte(dd) ! Maximum Record Size
ELSE Fab[Fab$h_Mrs]=0; ! Default is 0 (unlimited) !m602
! If an old (non-rms) access from old TOPS-20 or DIL system
! then bump the MRS up by 2
IF .fab[FAB$H_MRS] NEQ 0
AND .fab[FAB$V_RFM] EQL FAB$K_STM
AND .config[XAB$B_OSTYPE] EQL XAB$K_TOPS20
AND .config[XAB$B_VERSION] LSS 7
THEN fab[FAB$H_MRS] = .fab[FAB$H_MRS] + 2;
IF .attmenu[Dap$v_Attmenu_Alq] ! Allocation Quantity
THEN
BEGIN ! in blocks
alq=Dap$Get_Longword (dd); ! of (BLS) bytes
! Convert blocks to pages if old TOPS-20 non-RMS FAL
! New FAL has FILESYS of RMS-20 ![13]
IF .config[Xab$b_Filesys] EQL Xab$k_Filesys_Tops20
THEN alq=.alq/4;
Fab[Fab$g_Alq]=.alq;
END
ELSE Fab[Fab$g_Alq]=0; ! default to 0 !m602
IF .attmenu[Dap$v_Attmenu_Bks] ! Bucket Size
THEN Fab[Fab$v_Bks]=Dap$Get_Byte(dd)
ELSE Fab[Fab$v_Bks]=0; ! Default !m602
IF .attmenu[Dap$v_Attmenu_Fsz] ! Fixed Header Size
THEN Fab[Fab$b_Fsz]=Dap$Get_Byte(dd) ! (of VFC record)
ELSE Fab[Fab$b_Fsz]=0; ! Default !m602
IF .attmenu[Dap$v_Attmenu_Mrn] ! Maximum Record Number
THEN Fab[Fab$g_Mrn]=Dap$Get_Longword(dd)
ELSE Fab[Fab$g_Mrn]=0; ! Default !m602
IF .attmenu[Dap$v_Attmenu_Run] ! Runtime System
THEN Dap$Get_Variable_String (dd,CH$PTR(runsys),40);
! Put in temp and forget it
IF .attmenu[Dap$v_Attmenu_Deq] ! Default Extension Quantity
THEN deq=Dap$Get_2byte(dd); ! Eat it
! Get the FOP. If no FOP specified in the menu and we are
! talking to an old non-RMS TOPS-20 program, set the SUP bit
IF .attmenu[DAP$V_ATTMENU_FOP] ! File Options?
THEN BEGIN ! Yes
DAP$GET_BITVECTOR (dd, fop, 6);
$DAP_MOVE_BITS(Fop,Dap$v_Fop_,Fab,Fab$v_,
Rwo,Rwc,Pos,Dlk,Lck,
Ctg,Sup,Nef,Tmp,Mkd,Dmo,
Wck,Rck,Cif,Lko,Sqo,Mxv,Spl,
Scf,Dlt,Cbt,Wat,Dfw,Tef,Drj);
END
ELSE IF .config[XAB$B_OSTYPE] EQL XAB$K_TOPS20
AND .config[XAB$B_VERSION] LSS 7
THEN fab[FAB$V_SUP] = TRUE;
!
! Set the byte size
!
IF .attmenu[Dap$v_Attmenu_Bsz] !Byte size
THEN bsz=Dap$Get_Byte(dd) !m571
ELSE bsz=8;
! Compute file class if image was specified.
IF .datatype[DAP$V_DATATYPE_IMAGE] ! Image mode?
THEN BEGIN ! Yes, check carefully
! If the machine is not a LCG machine and image was
! specififed, then image mode is really 8 bit byte mode.
! The -10 expects us to default to 36 bit bytes if no bsz
! was specified and we have selected image mode somehow.
fst[FST$H_FILE_CLASS] = TYP$K_BYTE; ! First guess
IF .config[XAB$B_OSTYPE] EQL XAB$K_TOPS20 ! orange
OR .config[XAB$B_OSTYPE] EQL XAB$K_TOPS10 ! blue?
THEN BEGIN
fst[FST$H_FILE_CLASS] = TYP$K_IMAGE; ! 36-bit image
IF NOT .attmenu[DAP$V_ATTMENU_MRS] ! No MRS?
AND .fab[FAB$V_RFM] EQL FAB$K_UDF ! RFM is UDF?
THEN fab[FAB$H_MRS] = 512; ! Default 512
IF NOT .attmenu[DAP$V_ATTMENU_BSZ] ! No bsz?
THEN bsz = 36; ! default 36
END;
! Don't think we need this anymore -GAS
!IF .bsz EQL %BPUNIT ! These are not Bytes
!THEN fst[Fst$h_File_Class] = Typ$k_Image;
! Default RSTS RFM is ASCII stream, and type ASCII.
IF .config[XAB$B_OSTYPE] EQL XAB$K_RSTS ! Is it RSTS
AND .rstbug[RST_BUG_NO_RFM_SPEC] ! always buggy
AND NOT .attmenu[DAP$V_ATTMENU_RFM] ! No RFM spec
THEN fab[FAB$V_RFM] = FAB$K_STM; ! Default rfm
! Non LCG systems call (almost) everything IMAGE because
! it's all bytes to them. Sometimes we can tell by the
! presence of record attributes that are only valid for
! ASCII files. If one of those are seen then set ASCII.
IF (.Fab[Fab$v_Rfm] EQL Fab$k_Stm) !a555
OR (.Fab[Fab$v_Rfm] EQL Fab$k_Lsa)
OR (.Fab[Fab$h_Rat]
AND (Fab$m_CR+Fab$m_Emb+Fab$m_Prn+Fab$m_Ftn))
THEN Fst[Fst$h_File_Class] = Typ$k_Ascii;
! Check for MACY11 format. (NOTE: Nobody uses this and it
! doesn't work right in RMSFAL/RMS/FFF, NFT, FTS, and the
! old FAL.)
IF .Fab[Fab$v_Macy11]
THEN Fst[Fst$h_File_Class] = Typ$k_Macy11;
END; ! End of image mode checks
! Set the byte size (may have been changed above)
fst[FST$H_BSZ] = fab[FAB$V_BSZ] = .bsz; ! Set byte size
IF .attmenu[Dap$v_Attmenu_Dev]
THEN
BEGIN
Dap$Get_Bitvector(dd, dev, 6); !Device characteristics
$Dap_Move_Bits(Dev,Dap$v_Dev_,Fab,Dev$v_,
Rec,Ccl,Trm,Mdi,Sdi,Sqd,Nul,
Fod,Shr,Spl,Mnt,Dmt,All,Idv,
Odv,Swl,Avl,Elg,Mbx,Rtm,Rad,
Rck,Wck,For,Net,Gen); !m602
END;
IF .attmenu[Dap$v_Attmenu_Sdc]
THEN
BEGIN
Dap$Get_Bitvector (dd, sdc, 6);
$Dap_Move_Bits(sdc,Dap$v_Dev_,Fab,Sdc$v_,
Rec,Ccl,Trm,Mdi,Sdi,Sqd,Nul,
Fod,Shr,Spl,Mnt,Dmt,All,Idv,
Odv,Swl,Avl,Elg,Mbx,Rtm,Rad,
Rck,Wck,For,Net,Gen); !m602
END; ! spooling device characteristics
IF .attmenu[Dap$v_Attmenu_Lrl]
THEN lrl=Dap$Get_2byte(dd);
IF .attmenu[Dap$v_Attmenu_Hbk]
THEN hbk=Dap$Get_Longword(dd);
IF .attmenu[Dap$v_Attmenu_Ebk]
THEN ebk=Dap$Get_Longword(dd);
IF .attmenu[Dap$v_Attmenu_Ffb]
THEN ffb=Dap$Get_2byte(dd);
IF .attmenu[Dap$v_Attmenu_Sbn]
THEN sbn=Dap$Get_Longword(dd);
!+
! Return the file class to the user
! unless he wants to override it
!-
IF Typ NEQ 0 !a504
THEN
IF .Typ[Typ$h_Class] EQL 0
THEN Typ[Typ$h_Class] = .Fst[Fst$h_File_Class];
END; ! End of Attributes Message
[DAP$K_DATE_TIME]: !Date & time extension message
BEGIN
LOCAL dtmstr: VECTOR[CH$ALLOCATION(18)];
LOCAL d_dtmstr: $STR_DESCRIPTOR();
LOCAL dtmmenu: BITVECTOR[14]; !Menu for this message
LOCAL rvn; ! Revision number
CLEARV (dtmmenu);
$Str_Desc_Init(Desc=d_Dtmstr, String=(18,CH$PTR(dtmstr)));
!d544
IF .xabdat NEQ 0 ! If we found a Date/Time XAB
THEN
BEGIN
Dap$Get_Bitvector(dd, dtmmenu, 2);
IF .dtmmenu[Dap$v_Dtm_Cdt] ! Creation date time
THEN BEGIN
Dap$Get_Date(dd,CH$PTR(dtmstr));
xabdat[Xab$g_Cdt]=S$Strdt(d_dtmstr);
END;
IF .dtmmenu[Dap$v_Dtm_Rdt] ! Read date time
THEN BEGIN
Dap$Get_Date(dd,CH$PTR(dtmstr));
xabdat[Xab$g_Rdt]=S$Strdt(d_dtmstr);
END;
IF .dtmmenu[Dap$v_Dtm_Edt] ! Scratch date time
THEN BEGIN
Dap$Get_Date(dd,CH$PTR(dtmstr));
xabdat[Xab$g_Edt]=S$Strdt(d_dtmstr);
END;
IF .dtmmenu[Dap$v_Dtm_Rvn] ! Revision number
THEN rvn=Dap$Get_2byte(dd);
IF .dtmmenu[Dap$v_Dtm_Bdt] ! Backup date time
THEN BEGIN
Dap$Get_Date(dd,CH$PTR(dtmstr));
!When we put this in the RMS block we can save it
!xabdat[Xab$g_Bdt]=s$Strdt(d_dtmstr);
END;
IF .dtmmenu[Dap$v_Dtm_Pdt] ! Internal date time
THEN BEGIN
Dap$Get_Date(dd,CH$PTR(dtmstr));
!When we put this in the RMS block we can save it
!xabdat[Xab$g_Pdt]=s$Strdt(d_dtmstr);
END;
IF .dtmmenu[Dap$v_Dtm_Adt] ! Access date time ![12]
THEN BEGIN
Dap$Get_Date(dd,CH$PTR(dtmstr));
!When we put this in the RMS block we can save it
!xabdat[Xab$g_Adt]=s$Strdt(d_dtmstr);
END;
END
ELSE Dap$Eat_Message(dd); ! No place to put it
END;
[DAP$K_PROTECTION]: ! Protection extension message
BEGIN
IF .xabpro NEQ 0 ! If we have a protection XAB
THEN BEGIN ! Then fill it in
LOCAL promenu: BITVECTOR[14] INITIAL(0);
Dap$Get_Bitvector(dd, promenu, 2); ! Get the menu
IF .promenu[Dap$v_Protmenu_Owner] ! Owner protection
THEN BEGIN
%IF %DECLARED (XABPRO$A_OWNER)
%THEN
xabpro[Xabpro$h_Owner_Length]=
Dap$Get_Variable_String(dd,
.xabpro[Xabpro$a_Owner],
.xabpro[Xabpro$h_Owner_Size])
%ELSE
BEGIN ! If owner area then eat the owner string
LOCAL owner: VECTOR[CH$ALLOCATION(40)];
Dap$Get_Variable_String(dd,CH$PTR(owner),40);
END;
%FI;
END;
IF .promenu[DAP$V_PROTMENU_PROTSYS] ! System protection
THEN BEGIN
LOCAL prot: BITVECTOR[21] INITIAL(0);
Dap$Get_Bitvector(dd, prot, 3);
xabpro[XAB$V_PROTSYS] = .prot;
END;
IF .promenu[Dap$v_Protmenu_Protown] ! Owner protection
THEN BEGIN
LOCAL prot: BITVECTOR[21] INITIAL(0);
Dap$Get_Bitvector(dd, prot, 3);
xabpro[XAB$V_PROTOWN] = .prot;
END;
IF .promenu[DAP$V_PROTMENU_PROTGRP] ! Group protection
THEN BEGIN
LOCAL prot: BITVECTOR[21] INITIAL(0);
Dap$Get_Bitvector(dd, prot, 3);
xabpro[XAB$V_PROTGRP] = .prot;
END;
IF .promenu[DAP$V_PROTMENU_PROTWLD] ! World protection
THEN BEGIN
LOCAL prot: BITVECTOR[21] INITIAL(0);
Dap$Get_Bitvector(dd, prot, 3);
xabpro[XAB$V_PROTWLD] = .prot;
END;
END
ELSE Dap$Eat_Message (dd);
END;
[Dap$k_Summary]:
BEGIN
IF .xabsum NEQ 0
THEN
BEGIN
LOCAL SumMenu: BITVECTOR[42] INITIAL(0);
Dap$Get_Bitvector( dd, SumMenu, 6 );
IF .SumMenu[Dap$v_SumMenu_Nok]
THEN xabsum[Xab$b_Nok]=Dap$Get_Byte( Dd );
IF .SumMenu[Dap$v_SumMenu_Noa]
THEN xabsum[Xab$b_Noa]=Dap$Get_Byte( Dd );
! Ignore NOR(1) and PVN(2)
END;
Dap$Eat_Message( Dd );
END;
[Dap$k_Allocation]:
BEGIN !m573v
LOCAL
allmenu: BITVECTOR[42] INITIAL(0),
aid: INITIAL(0), ! Area id for this xab
ad: REF $Rms_Adb[Rms$k_Max_Areas] INITIAL(.Fst[Fst$a_Adb]);
! Make an ADB if we haven't got one (first allocation msg)
IF .ad EQL 0 !a573v
THEN
BEGIN
$XPO_GET_MEM( UNITS=Adb$k_MaxBln, RESULT=ad, FILL=0 );
ad[adb$h_bid]=Adb$k_Bid;
ad[adb$h_bln]=Adb$k_MaxBln;
END; !a573^
Dap$Get_Bitvector( dd, allmenu, 6 );
IF .Allmenu[Dap$v_Allmenu_Vol]
THEN Dap$Get_2Byte( dd ); ! Ignore
IF .Allmenu[Dap$v_Allmenu_Aln]
THEN
BEGIN
LOCAL Aln: BITVECTOR[28];
Dap$Get_Bitvector( dd, Aln, 4 ); ! Ignore !m577
END;
IF .Allmenu[Dap$v_Allmenu_Aop]
THEN
BEGIN
LOCAL Aop: BITVECTOR[28];
Dap$Get_Bitvector( dd, Aop, 4 ); ! Ignore
END;
IF .Allmenu[Dap$v_Allmenu_Loc]
THEN Dap$Get_Byte( dd ); ! Ignore
IF .Allmenu[Dap$v_Allmenu_Rfi]
THEN Dap$Get_Variable_Counted( dd, 0, 16 ); ! Ignore
IF .Allmenu[Dap$v_Allmenu_Alq]
THEN Dap$Get_Longword( dd ); ! Ignore
IF .Allmenu[Dap$v_Allmenu_Aid]
THEN aid=Dap$Get_Byte( Dd ); ! Area Id
If .XabSum NEQ 0
THEN IF .aid GEQ .XabSum[Xab$b_Noa]
THEN XabSum[Xab$b_Noa] = .Aid+1;
IF .Allmenu[Dap$v_Allmenu_Bkz]
THEN ad[Adb$v_bkz,.Aid]=Dap$Get_Byte( Dd );
IF .Allmenu[Dap$v_Allmenu_Deq]
THEN Dap$Get_2Byte( dd ); ! Ignore
IF .xaball[.aid] NEQ 0
THEN
BEGIN
BIND allxab=.xaball[.aid]: $XabAll_decl;
allxab[Xab$b_bkz]=.ad[Adb$v_Bkz,.aid];
END
END; !m573^
[Dap$k_Key]: !610 rewritten
BEGIN
LOCAL
KeyMenu: BITVECTOR[42] INITIAL(0),
krf,
thiskdb: REF $Rms_Kdb,
nsg: INITIAL(0),
flg: BITVECTOR[18] INITIAL(0),
Dfl: INITIAL(0),
Ifl: INITIAL(0),
Ian: INITIAL(0),
Lan: INITIAL(0),
Dan: INITIAL(0),
Dtp: INITIAL(0);
$XPO_GET_MEM( RESULT=thiskdb, UNITS=Kdb$k_Bln, FILL=0 ); !m573
BEGIN !m573v
LOCAL lastkdb: REF $Rms_Kdb INITIAL(.Fst[Fst$a_Kdb]);
IF .lastkdb EQL 0
THEN Fst[Fst$a_Kdb] = .thiskdb
ELSE
BEGIN
WHILE .lastkdb[kdb$a_nxt] NEQ 0
DO lastkdb=.lastkdb[kdb$a_nxt];
lastkdb[kdb$a_nxt]=.thiskdb;
END;
END; !m573^
thiskdb[kdb$h_bid]=kdb$k_bid;
thiskdb[kdb$h_bln]=kdb$k_bln;
!+ 610
! Store every relevant field from the DAP message into the KDB first.
! Then, if there already is a local XAB chain, store the fields there
! too. Note that no local XAB chain will exist when this routine
! is called by the FAL.
!-
Dap$Get_Bitvector( Dd, Keymenu, 6 ); ! Get the menu
IF .Keymenu[Dap$v_Keymenu_Flg]
THEN
BEGIN
Dap$Get_Bitvector( Dd, flg, 2 );
$Dap_Move_Bits( flg, dap$v_flg_, !617
thiskdb, kdb$v_,
dup, chg, hsh );
END;
!+ 610
! DFL and IFL are slightly smelly, since there is no Kdb field
! which is used to store the user's XAB value directly. However,
! storing the user's DAP values in the DFL/IFL offset Kdb fields
! should be OK: If the FAL is calling this routine in response to
! an ACCESS request, it will eventually transfer the Kdb data
! directly to its own XAB chain; if this routine is being called
! by the sender after an ACCESS to process returned attributes,
! it never looks at the Kdb chain anyway...
!-
IF .Keymenu[Dap$v_Keymenu_Dfl]
THEN
thiskdb[kdb$h_dfl_offset] =
dfl =
Dap$Get_2Byte( Dd );
IF .Keymenu[Dap$v_Keymenu_Ifl]
THEN
thiskdb[kdb$h_ifl_offset] =
ifl =
Dap$Get_2Byte( Dd );
!
! Now get the position and size of each segment
!
IF .KeyMenu[Dap$v_Keymenu_Nsg]
THEN nsg = Dap$Get_Byte( Dd ); !m577
INCR i from 0 to .nsg-1
DO
BEGIN
BIND SegVec=thiskdb[Kdb$z_Segments]: BLOCK; !m573
SegVec[ .i, %FIELDEXPAND(xab$h_pos0, 1), 18, 0 ] =
Dap$Get_2Byte( dd );
SegVec[ .i, %FIELDEXPAND(xab$h_siz0, 1), 18, 0 ] =
Dap$Get_Byte( dd );
END;
IF .Keymenu[Dap$v_Keymenu_Ref]
THEN krf = Dap$Get_Byte( Dd )
ELSE krf=0;
thiskdb[Kdb$h_Reference]=.krf; ! Store ref in KDB
!+ 610
! KNM is special. If we have a DAP KNM text but no local key XAB
! chain to store its pointer in, get a block of dynamic memory for
! the text and store a pointer to it in the KNMBUF pointer vector.
! If the KNMBUF pointer already exists, clear its block for re-use.
! If there is a local key XAB and it has a KNM pointer, use that
! pointer and read the DAP text into where it points; if there is
! no pointer in the XAB's KNM field, read the DAP text and ignore it.
! Note the following: DAP KNM fields can be 40 bytes long, while
! RMS-20 limits KNMs to 30 bytes; VMS always sends a DAP KNM of
! 32 (decimal) length padded with null bytes, regardless of the
! actual length of the text.
!-
IF .Keymenu[Dap$v_Keymenu_Knm]
THEN
BEGIN
LOCAL KnmPtr: INITIAL(0);
IF .xabkey[.krf] NEQ 0
THEN
BEGIN
BIND keyxab = UAddr(.xabkey[.krf]): $XabKey_decl;
IF .keyxab[Xab$a_Knm] NEQ 0
THEN
BEGIN
knmPtr = UAddr(.keyxab[Xab$a_Knm]);
$clear (.KnmPtr,(Knmcharsiz/(%BPVAL/7)));
END;
END
ELSE
BEGIN
IF .KnmBuf[.krf] NEQ 0
THEN
BEGIN
KnmPtr = .KnmBuf[.krf];
$clear (.KnmPtr,(40/(%BPVAL/8)));
END
ELSE
BEGIN
$XPO_GET_MEM( RESULT=KnmBuf[.krf],
UNITS=(40/(%BPVAL/8)),FILL=0);
KnmPtr = .KnmBuf[.krf];
END;
END;
BEGIN
LOCAL KnmTxt: BYTE8VECTOR[40] INITIAL(0);
Dap$Get_Variable_String (
dd,
CH$PTR(KnmTxt),
40 );
IF .KnmPtr NEQ 0
THEN
BEGIN
IF .rmssec EQL 0
THEN $move_words ( KnmTxt,
.KnmPtr,
(Knmcharsiz/(%BPVAL/7)))
ELSE $Rms$Xcopy ( KnmTxt,
.KnmPtr,
(Knmcharsiz/(%BPVAL/7)));
END;
END;
END; !KNM
IF .Keymenu[Dap$v_Keymenu_Nul] ! Ignore
THEN Dap$Get_Byte( dd );
IF .Keymenu[Dap$v_Keymenu_Ian]
THEN
thiskdb[kdb$b_ian] =
Ian =
Dap$Get_Byte( Dd );
!+ 610
! Read the LAN (it will go only into the local XAB chain)
!-
IF .Keymenu[Dap$v_Keymenu_Lan]
THEN
Lan =
Dap$Get_Byte( Dd );
IF .Keymenu[Dap$v_Keymenu_Dan]
THEN
thiskdb[kdb$b_dan] =
Dan =
Dap$Get_Byte( Dd );
IF .KeyMenu[Dap$v_Keymenu_Dtp] !m571
THEN
thiskdb[kdb$v_datatype] =
Dtp =
$Dap_Translate_Value( Dap$Get_Byte( Dd ),
Dap$k_dtp_,
Xab$k_,
stg, ebc, six, pac, in4, fl1,
fl2, gfl, in8, as8, bn4, bn8 );
IF .XabSum NEQ 0
THEN
IF .krf GEQ .XabSum[Xab$b_Nok]
THEN XabSum[Xab$b_Nok] = .krf+1;
!+ 610
! Now store the relevant fields into the local XAB chain if one exists
!-
IF .xabkey[.krf] NEQ 0
THEN
BEGIN
BIND keyxab = UAddr(.xabkey[.krf]): $XabKey_decl; !m515
LOCAL keyseg: REF VECTOR;
keyseg=keyxab[xab$h_siz0]; !m515
$Dap_Move_Bits( flg, dap$v_flg_, !617
keyxab, xab$v_,
dup, chg, hsh );
keyxab[xab$b_ref]=.krf; ! key # for this XAB
INCR i from 0 TO .nsg-1
DO (BIND SegVec=thiskdb[Kdb$z_Segments]: VECTOR; !m573
keyseg[.i]=.SegVec[.i]); ! Copy pos/siz pairs
IF .Keymenu[Dap$v_Keymenu_Ian]
THEN keyxab[xab$b_Ian] = .Ian;
IF .Keymenu[Dap$v_Keymenu_Lan]
THEN keyxab[xab$b_Lan]=.Lan;
IF .Keymenu[Dap$v_Keymenu_Dan]
THEN keyxab[xab$b_Dan] = .Dan;
IF .KeyMenu[Dap$v_Keymenu_Dtp] !m571
THEN
keyxab[xab$v_dtp] = .Dtp;
! Ignore the remaining fields
END;
Dap$Eat_Message( Dd );
END;
[DAP$K_NAME]:
Do_Name:BEGIN
BIND nam=UAddr(.Fab[Fab$a_Nam]): $Nam_Decl; !m507
LOCAL filespec: VECTOR[CH$ALLOCATION(255)]; !Store filespec
LOCAL nametype: BITVECTOR[21];
LOCAL
nas; ! Length of name
LOCAL delim;
REGISTER dont_touch_me_there = 6; !m566
! This is because, if you pass a 1-word global byte pointer
! to a MOVSLJ or its fiends, it will turn it into a 2-word
! global. The people who wrote the BLISS compiler do not
! know this, and do not expect this register to get clobbered.
dont_touch_me_there = .dont_touch_me_there;
CLEARV ( nametype );
Dap$Get_Bitvector ( dd, nametype, 3);
IF (.nametype AND .nametypes_seen) NEQ 0
THEN RETURN Dap$Unget_Header(dd);
! If this is the second NAME message of this type for this call
! then it must be for the next file and should not be
! read until the next call (Directory List)
! So we regurgitate it and return
nametypes_seen=.nametypes_seen OR .nametype;
IF Nam EQL 0
THEN
BEGIN
Dap$Eat_Message ( dd );
! Must have a NAM block or ignore this message
LEAVE Do_Name;
END;
IF .nametype[Dap$k_Nametype_Str] ! Structure
THEN
BEGIN
Nam[Nam$a_Dev]=CH$PLUS( .Nam[Nam$a_Rsa],
.Nam[Nam$b_Node] );
Nam[Nam$b_Dev] = ! Store device here !m566
Dap$Get_Variable_String( dd,
UAPointer(.Nam[Nam$a_Dev]),
DEVICE_NAME_LENGTH);
Nam[Nam$a_Dir]=CH$PLUS( .Nam[Nam$a_Dev],
.Nam[Nam$b_Dev] );
Nam[Nam$v_Cha_Str]=1;
Nam[Nam$v_Wildcard]=1; ! Something is wildcarded
! (not necessarily this)
! (3-part name indicates this)
END;
IF .nametype[Dap$k_Nametype_Dir] ! Directory
THEN
BEGIN
Nam[Nam$b_Dir] = ! Store directory & length
Dap$Get_Variable_String(Dd,
UAPointer(.Nam[Nam$a_Dir]),
Directory_Name_Length);
Nam[Nam$a_Name]=CH$PLUS(.Nam[Nam$a_Dir],
.Nam[Nam$b_Dir]);
Nam[Nam$v_Cha_Dir]=1;
Nam[Nam$v_Wildcard]=1; ! Something is wildcarded
END;
IF .nametype[Dap$k_Nametype_Nam] ! File name
THEN
BEGIN
LOCAL D_Filespec: $str_Descriptor(Class=Dynamic);
LOCAL Bd_Filespec: $str_Descriptor(Class=Bounded);
LOCAL nas;
!+ 641
! If we have a name NAME message, but never got a directory
! or volume, eat it.
!-
IF NOT ((.Nametypes_Seen[Dap$k_Nametype_Dir])
AND (.Nametypes_Seen[Dap$k_Nametype_Str]))
THEN
BEGIN
Dap$Eat_Message ( dd );
LEAVE Do_Name;
END;
$STR_DESC_INIT(DESC=D_Filespec, CLASS=Dynamic);
$XPO_GET_MEM(DESC=D_Filespec, CHARACTERS=255);
Nas=Dap$get_Variable_String(Dd, ! Get file name in temp
.d_Filespec[Str$a_Pointer],
255);
$STR_DESC_INIT( DESC=BD_FILESPEC, CLASS=BOUNDED, !a572
STRING=(.nas, .d_filespec[STR$A_POINTER]));
D$Name_Decompose( bd_filespec, nam ); !m572
Nam[Nam$h_Rsl] = ! Recompute resultant length !a566
.Nam[Nam$b_Node] +
.Nam[Nam$b_Dev] +
.Nam[Nam$b_Dir] +
.Nam[Nam$b_Name] +
.Nam[Nam$b_Type] +
.Nam[Nam$b_Ver];
$XPO_FREE_MEM(STRING=D_FILESPEC);
END;
IF .NAMETYPE[DAP$K_NAMETYPE_FSP] ! Resultant filespec
THEN
BEGIN ! Store resultant filespec
LOCAL ressize; ! Length of resultant
IF (ressize=DAP$GET_BYTE(DD[$])) GTR 0 ! if non-null
THEN
BEGIN
Nam[Nam$a_Node]=.Nam[Nam$a_Rsa]; !d571
Nam[Nam$a_Dev]=CH$PLUS(.Nam[Nam$a_Node],
.Nam[Nam$b_Node]);
IF .ressize+.Nam[Nam$b_Node] GEQ .NAM[NAM$H_RSS]
THEN ! Make sure it will fit
SIGNAL(RMS$_NAM, 0, FAB[$]) ![11] Too big
ELSE
BEGIN
LOCAL rptr,
rlen;
rlen=.nam[NAM$H_RSS]-.nam[NAM$B_NODE]; !m571
rptr=UAPointer(.NAM[NAM$A_DEV]); !m571
Dap$Unget_Byte(dd); ! string getter needs count
nam[NAM$H_RSL]
=Dap$Get_Variable_String(dd,.rptr,.rlen)
+.nam[NAM$B_NODE];
IF .NameTypes_Seen[DAP$K_NAMETYPE_NAM] EQL 0 !m575
THEN
BEGIN
LOCAL rdesc: $STR_DESCRIPTOR( CLASS=BOUNDED,
STRING=(.rlen,.rptr) );
d$Name_decompose( rdesc, nam );
! Recompute resultant length
Nam[Nam$h_Rsl] = !a575
.Nam[Nam$b_Node] +
.Nam[Nam$b_Dev] +
.Nam[Nam$b_Dir] +
.Nam[Nam$b_Name] +
.Nam[Nam$b_Type] +
.Nam[Nam$b_Ver];
END;
END;
END;
END; !d571
END;
[Dap$k_Access]: ![14] Regurgitate
BEGIN ! and return
Dap$Unget_Header(dd); ! so access
RETURN Dap$k_Access; ! message getter
END; ! can get it
[Dap$k_Status]: ! Some sort of error from other end
RETURN Dap$Get_Status(dd); ! Get Status !d566
[Dap$k_Access_Complete]: ! Rename & Delete would return ACM
BEGIN
BIND Fst=.Fab[Fab$a_Ifi]: $Rms_Fst;
LOCAL cmpfunc;
LOCAL fop: BITVECTOR[42];
! Get the function code
cmpfunc=Dap$Get_Byte(dd);
! Get the FOP, if any
Dap$Get_Bitvector (dd, fop, 6);
$Dap_Move_Bits(fop,Dap$k_Fop_,Fab,Fab$v_,
Rwo,Rwc,Pos,Dlk,Lck,
Ctg,Sup,Nef,Tmp,Mkd,Dmo,
Wck,Rck,Cif,Lko,Sqo,Mxv,Spl,
Scf,Dlt,Cbt,Wat,Dfw,Tef,
Drj);
IF .dd[Dap$h_Bytes_Remaining] GTR 0
THEN
BEGIN
LOCAL checksum;
checksum=Dap$Get_2byte(dd);
! Do not expect checksum here, ($RENAME, $ERASE)
END;
CASE .cmpfunc FROM 1 TO Dap$k_Accomp_Max OF
SET
[Dap$k_Accomp_Response]:
BEGIN
Fst[Fst$v_File_Open] = ! No file open !a547
Fst[Fst$v_Access_Active]=0; ! Access is no longer active
!% FAL WORKAROUND
! If all we get is an ACCESS COMPLETE (without any attrs first)
! Then assume we cannot access the directory.
! For some reason TOPS-10 & TOPS-20 FALs do not give a status
! for this, but merely return immediate ACCESS COMPLETE!!!
! RSTS does exactly the same thing on file-not-found
IF (.omtype EQL -1) ! First message of this call?
AND (.T20bug[T20_Bug_No_Dir_Prv] ! And workaround enabled
OR .Rstbug[Rst_Bug_No_Dir_Fnf])
AND (.Fst[Fst$v_Display] NEQ 0) ! and we wanted attrs !m574
THEN
BEGIN
SELECT .Config[Xab$b_Ostype] OF
SET
[Dap$k_Tops20,
Dap$k_Tops10]: Fab[Fab$h_Sts]=Rms$_Prv; !m572
[Dap$k_Rsts]: Fab[Fab$h_Sts]=Rms$_Fnf;
[Dap$k_Tops20, Dap$k_Rsts]:
SIGNAL ( .Fab[Fab$h_Sts], 0, Fab);
TES;
END;
END;
[INRANGE]:
RETURN Dap$Unget_Header( dd ); ! Regurgitate
[OUTRANGE]: Dap_Error( dd, Dap$k_Mac_Sync,Dap$k_Access_Complete );
TES;
RETURN Dap$k_Access_Complete
END;
[DAP$K_ACK]:
BEGIN
Fst[Fst$v_Access_Active] = Fst[Fst$v_File_Open] = 1;
RETURN Dap$k_Ack; ! Normal exit from this routine
END;
[DAP$K_CONTINUE]: ! Eat leftover continue message !a566
BEGIN
Dap$Eat_Message( dd );
END;
[OTHERWISE]:
BEGIN
Dap_Error(dd, Dap$k_Mac_Sync,.dd[Dap$b_Operator]);
RETURN .dd[Dap$b_Operator]
END;
TES;
END; !WHILE 1
.mtype ! Return message type if we ever get here
END; !End of DAP$$GET_ATTRIBUTES (D$GATT) (process ATTRIBUTES)
ROUTINE d$name_decompose( pd_filespec: REF $Str_descriptor(CLASS=BOUNDED),
nam: REF $Nam_decl ) : NOVALUE =
BEGIN
BIND bd_filespec=.pd_filespec: $STR_DESCRIPTOR(CLASS=BOUNDED);
LOCAL delim;
DO
BEGIN
$Str_Scan( Remainder=Bd_Filespec, Substring=Bd_Filespec,
Delimiter=Delim,
Stop='.;<:[');
SELECT .delim OF
SET
[%C':']:
BEGIN
Str_Include( Bd_filespec, 1 ); ! Include :
Nam[Nam$b_Dev] = .Bd_filespec[Str$h_Length];
$Str_Copy( String=Bd_Filespec,
Target=(.Nam[Nam$b_Dev],
UAPointer(.Nam[Nam$a_Dev]) ) ); !m606
Nam[Nam$a_Dir] = Nam[Nam$a_Name]
= Nam[Nam$a_Type] = Nam[Nam$a_Ver]
= CH$PLUS( .Nam[Nam$a_Dev], .Nam[Nam$b_Dev] );
END;
[%C'<', %C'[']:
BEGIN
$Str_Scan( Remainder=Bd_Filespec, Substring=Bd_Filespec,
STOP='>]' );
Str_Include( Bd_filespec, 1 ); ! Include close bracket
Nam[Nam$b_Dir] = .Bd_filespec[Str$h_Length];
$Str_Copy( String=Bd_Filespec,
Target=(.Nam[Nam$b_Dir],
UAPointer(.Nam[Nam$a_Dir]) ) ); !m606
Nam[Nam$a_Name] = Nam[Nam$a_Type] = Nam[Nam$a_Ver]
= CH$PLUS( .Nam[Nam$a_Dir], .Nam[Nam$b_Dir] );
END;
[OTHERWISE]: EXITLOOP;
[ALWAYS]: Str_Exclude( Bd_Filespec, .Bd_Filespec[Str$h_Length] );
TES;
END WHILE 1;
Nam[Nam$b_Name]=.BD_Filespec[Str$h_Length];
$Str_Copy( String=Bd_Filespec, ! Store filename
Target=(.Nam[Nam$b_Name], UAPointer(.Nam[Nam$a_Name])) );
Nam[Nam$a_Type] = Nam[Nam$a_Ver]
= CH$PLUS(.Nam[Nam$a_Name], .Nam[Nam$b_Name]);
IF .delim EQL %C'.'
THEN
BEGIN
Bd_Filespec[Str$h_Length]=
.Bd_Filespec[Str$h_Length]+1; ! skip delimiter
$Str_Scan(Remainder=Bd_Filespec,
Substring=Bd_Filespec,
Delimiter=Delim,
Stop='.;<');
Str_Exclude( Bd_Filespec, -1 ); ! Put back . !a566
! a "negative exclude" is a leftward include.
Nam[Nam$b_Type]=.Bd_Filespec[Str$h_Length]; !m566
$Str_Copy( String=Bd_Filespec, !a566
Target=(.Nam[Nam$b_Type],
UAPointer(.Nam[Nam$a_Type])) );
Nam[Nam$a_Ver]=CH$PLUS( .Nam[Nam$a_Type],
.Nam[Nam$b_Type] );
END;
IF (.delim EQL %C';') OR (.delim EQL %C'.')
THEN ! Version/Generation number
BEGIN
$str_Scan(Remainder=Bd_Filespec,
Substring=Bd_Filespec,
Delimiter=.delim,
Span=';.0123456789-*'); ! Generation number
! store the length of generation number
! if it really is a generation number,
! i.e. .### or ;###.
! If we really got ;T or ;Afoo or ;P#####, ignore it.
IF .Bd_Filespec[Str$h_Length] GTR 1
THEN
BEGIN
Nam[Nam$b_Ver]=.Bd_Filespec[Str$h_Length];
$Str_Copy( String=Bd_Filespec,
Target=(.Nam[Nam$b_Ver],
UAPointer(.Nam[Nam$a_Ver])) );
END;
END;
END; !D$name_Decompose !m572^^
GLOBAL ROUTINE Dap$Put_Config (p_dd: REF $Dap_Descriptor, Bufsiz): NOVALUE=
!++
! FUNCTIONAL DESCRIPTION:
!
! Build a CONFIG message, using specified buffer size
!
! FORMAL PARAMETERS:
!
! P_DD: Addr of DAP message descriptor
! BUFSIZ: Buffer size to send to other system
!
!--
BEGIN
BIND dd=.p_dd: $Dap_Descriptor;
Init_Message (dd); !
dd[Dap$b_Operator]=Dap$k_Config; ! Build header
Dap$Put_Header( dd ); !
Dap$Put_2byte( dd, .Bufsiz ); ! Put buffersize
Dap$Put_Byte( dd, .OurCfg[Xab$b_OsType] ); ! Operating system type
Dap$Put_Byte( dd, .OurCfg[Xab$b_FileSys] ); ! File system type
Dap$Put_Byte( dd, .OurCfg[Xab$b_Version] ); ! Dap version (i.e. 7)
Dap$Put_Byte( dd, .OurCfg[Xab$b_EcoNum] ); ! Dap ECO (.e. 0 for 7.0)
Dap$Put_Byte( dd, .OurCfg[Xab$b_UsrNum] ); ! User mod level (7.0-1)
Dap$Put_Byte( dd, .OurCfg[Xab$b_DecVer] ); ! Dec software level
Dap$Put_Byte( dd, .OurCfg[Xab$b_UsrVer] ); ! User software level !m555
Dap$Put_Bitvector ( dd, OurCfg[Xab$v_Syscap], 12 ); ! system capabilities
END; ! DAP$PUT_CONFIG
GLOBAL ROUTINE Dap$Put_Attributes (P_Dd: REF $Dap_Descriptor,
P_Fab: REF $Fab_Decl) : NOVALUE=
!++
! FUNCTIONAL DESCRIPTION:
!
! Build attributes message from associated file block & send it.
!
! FORMAL PARAMETERS:
!
! P_DD: Address of a DAP descriptor
! P_FAB: Address of RMS FAB
! This routine uses the FST pointed to by the FAB
!
! IMPLICIT INPUTS:
!
! FST: Address of FST
!
! IMPLICIT OUTPUTS:
!
! An ATTRIBUTES message is put in the output buffer.
!--
BEGIN
BIND Dd=.P_dd: $Dap_Descriptor;
BIND Fab=.P_Fab: $Fab_Decl;
!d572
LOCAL display: BITVECTOR[32];
LOCAL xabptr;
LITERAL Create_Display_Mask =
NOT ( (1^Dap$v_Display_Summary)
OR 1^Dap$v_Display_3_Part_Name OR (1^Dap$v_Display_Name) ); !m574
! No name or summary message from accessing process, please !a545
display = .Fst[Fst$v_Display]; ! Get display bits from FST !m545
!d545
!
! Only send key & alloc xabs if opening file
!
Fst[Fst$v_Display]=
(SELECT .Fst[Fst$b_Operation] OF
SET
[Dap$k_Open,
Dap$k_Erase,
Dap$k_Rename]:
IF .Fst[Fst$v_Cif]
THEN .display AND Create_Display_Mask ! this may create !m545
ELSE 1^Dap$v_Display_Att; ! Main attributes only
[Dap$k_Create]: .display AND Create_Display_Mask !m545
TES);
!
! Send attributes and xab msgs as required
!
Dap$$Put_Attributes (Dd, Fab, .Fst);
Fst[Fst$v_Display]=.display; ! Set display bits for Access msg
END; ![15] Make this call another, so FAL can specify the FST separately
GLOBAL ROUTINE Dap$$Put_Attributes (P_Dd: REF $Dap_Descriptor,
P_Fab: REF $Fab_Decl,
P_Fst: REF $Rms_Fst): NOVALUE=
!++
! FUNCTIONAL DESCRIPTION:
!
! Build attributes message from associated file block & send it.
!
! FORMAL PARAMETERS:
!
! P_DD: Address of a DAP descriptor
! P_FAB: Address of FAB
! P_FST: Address of FST
!
! IMPLICIT OUTPUTS:
!
! An ATTRIBUTES message is put in the output buffer.
!
!--
BEGIN
BIND
dd=.P_Dd: $Dap_Descriptor,
Fab=.P_Fab: $Fab_Decl,
Fst=.P_Fst: $Rms_Fst,
Typ=UAddr(.Fab[Fab$a_Typ]): $Typ_Decl,
Nam=UAddr(.Fab[Fab$a_Nam]): $Nam_decl,
Config=.Fst[Fst$a_Config]: $XabCfg_Decl;
LOCAL
mlength: INITIAL(0), !Length of this message (data portion)
attmenu: BITVECTOR[42] INITIAL(0), !Attributes menu field
display: BITVECTOR[32] INITIAL(0), !Display bits
class,
datatype: BITVECTOR[14] INITIAL(0), !Data representation
org: INITIAL(0), !File organization
rfm: INITIAL(0), !Record format
rat: BITVECTOR[21] INITIAL(0), !Record attributes
bls: INITIAL(512), ![4] default=512 !Block size
mrs: INITIAL(0), !Record size
bks: INITIAL(0), !Bucket size
fsz: INITIAL(0), !Fixed portion size
runsys: BYTE8VECTOR[41] INITIAL(0), !Runtime system
deq: INITIAL(0), !Default extension quantity
bsz: INITIAL(0), !Byte size
dev: BITVECTOR[42] INITIAL(0), !Device characteristics
sdc: BITVECTOR[42] INITIAL(0), !Spooling dev characteristics
ffb: INITIAL(0), ! First free byte
ebk: INITIAL(0), ! Ending block number
nok: INITIAL(0),
noa: INITIAL(0),
nor: INITIAL(0),
BufKnm: BYTE8VECTOR[40] INITIAL(0), !610
fop: BITVECTOR[42] INITIAL(0);
! Following is duplicated from Dap$$Get_Attributes
LOCAL
xabptr,
xaball: VECTOR[32] INITIAL(0),
xabpro: REF $XabPro_decl INITIAL(0),
xabcfg: REF $XabCfg_decl INITIAL(0),
xabsum: REF $XabSum_decl INITIAL(0),
xabdat: REF $XabDat_decl INITIAL(0),
xabkey: VECTOR[256] INITIAL(0); ! We can have 255 of these!
! Find our XABs
xabptr = .Fab[Fab$a_Xab];
WHILE .xabptr NEQ 0
DO
BEGIN
BIND uxab=UAddr( .xabptr ): $XabKey_decl;
CASE .Uxab[Xab$v_Cod] FROM 0 TO Xab$k_cod_max OF ! COD not BID !m515
SET
[Xab$k_Sum]: XabSum=uxab;
[Xab$k_All]: BEGIN
MAP uxab: $XabAll_decl;
XabAll[ .uxab[Xab$b_aid] ] = uxab;
END;
[Xab$k_Dat]: XabDat=uxab;
[Xab$k_Cfg]: XabCfg=uxab;
[Xab$k_Key]: XabKey[ .uxab[Xab$b_ref] ] = uxab;
[XAB$K_PRO]: xabpro = uxab;
[OUTRANGE]: SIGNAL( Rms$_Cod, .uxab[Xab$v_cod] );
TES;
xabptr=.uxab[Xab$a_nxt]; ! On to next XAB
END;
! End of code duplicated from Dap$$Get_Attributes
Display=.Fst[Fst$v_Display]; ! Display flags
!+
! Build and send Attributes Message
!-
IF .Display[Dap$v_Display_Attributes]
THEN
BEGIN
bsz=.Fab[Fab$v_Bsz]; ! Byte size
mrs=.Fab[Fab$h_Mrs]; ! Max record size !a571
! Set up DATATYPE
Class = .Fst[Fst$h_File_Class]; ! We have determined a file class !m555
! already, use it
CASE .class FROM 0 TO Typ$k_Class_Max OF
SET
[0]: datatype = 0; ! Should not occur
[Typ$k_Ascii]:
BEGIN
datatype[Dap$v_Datatype_Ascii]=1;
bls=Our_Block_Size*(%BPVAL/.bsz); ! Block size in bytes
END; !d555
[Typ$k_Byte,
Typ$k_Image,
Typ$k_DIL8]: datatype[Dap$v_Datatype_Image]=1;
[Typ$k_Macy11]:
BEGIN
datatype[Dap$v_Datatype_Image]=1; ! Looks like image on remote
!% rat[Dap$v_Rat_Macy11]=1;
! Nobody supports this bit
END;
[OUTRANGE]: SIGNAL(Dap$_Aor,0,typ);
TES;
! The following is for support of file bytesize and count for NFT-20's
! directory command.
IF .config[XAB$B_FILESYS] EQL XAB$K_FILESYS_TOPS20 ! NFT?
THEN BEGIN ! It's a NFT directory command
LOCAL f_size, f_bpw, f_byv; ! Holds file size, bytes per wd
f_byv = s$fbbyv (.fab[FAB$H_JFN]); ! Get real byte size word
bsz = .f_byv<24,6>; ! BLISS wants it this way
f_bpw = 36 / .bsz; ! Compute bytes per word
bls = .f_bpw * 512; ! BLS is bytes_per_word * 512
f_size = s$fbsiz (.fab[FAB$H_JFN]); ! Get file size
ebk = 1 + (.f_size / .bls); ! Compute the EBK
ffb = .f_size MOD .bls; ! Compute FFB
END; ! End of filesys TOPS20 (NFT)
! If image mode, we need to supply certain defaults for 36 bit copies.
! A BSZ of other than 8 is not supported on non-36-bit systems. Default
! BSZ to 36 for 36-bit-systems.
!m645v
IF .class EQL TYP$K_IMAGE ! Is it image mode?
THEN BEGIN ! Yes, its image mode
IF .config[XAB$B_OSTYPE] EQL XAB$K_TOPS20 ! Is it a 36 bit
OR .config[XAB$B_OSTYPE] EQL XAB$K_TOPS10 ! system?
THEN BEGIN ! Yes, image/variable byte size systems
IF .config[XAB$B_FILESYS] NEQ XAB$K_FILESYS_RMS20
THEN BEGIN ! non-RMS-20 36-bit system image mode
fab[FAB$V_BSZ] = bsz = 36; ! 36 bit bytes
fab[FAB$V_RFM] = FAB$K_UDF; ! Undefined record format
fab[FAB$H_MRS] = bls = ! Get blocksize
(IF .config[XAB$B_OSTYPE] EQL XAB$K_TOPS10
THEN 128 ! TOPS-10 128 word blocks
ELSE 512); ! TOPS-20 512 word pages
END;
END
ELSE BEGIN ! Image and non-36-bit system
IF .bsz NEQ 8 ! And the bytesize is not 8
THEN BEGIN ! recalculate record size
LOCAL mrsw, bpw;
bpw = %BPVAL / .bsz; ! Bytes per word
mrsw = ( .mrs + .bpw - 1 ) / .bpw; ! words per record
mrs = ( ( .mrsw / 2 ) * 9 )
+ ( ( .mrsw AND 1 ) * 5 ); ! 8-bit bytes per rec
END;
bsz = 0; ! Don't send byte size to non-36-bit
END; ! End of image and non-36-bit system
END; ! End if image mode check
!m645^
! Device is a file-structured disk
Dev[Dap$V_Dev_Mdi]=Dev[Dap$V_Dev_Fod]=Dev[Dap$V_Dev_Shr]
=Dev[Dap$V_Dev_Mnt]=Dev[Dap$V_Dev_Idv]=Dev[Dap$V_Dev_Odv]
=Dev[Dap$V_Dev_Avl]=Dev[Dap$v_Dev_Elg]=Dev[Dap$v_Dev_Rad]=1;
!Turn on extension bits where needed & count # of bytes
BEGIN
LOCAL t;
t=Dap$Size_Bitvector (datatype, 2, 0);
IF (.t GTR 0) THEN
BEGIN
attmenu[Dap$v_Attmenu_Dat]=1; !Remember to send it
mlength=.mlength+.t; !Add approprioate # of bytes
END;
org=$Dap_Translate_Value(.Fab[Fab$v_Org],
Fab$k_,Dap$k_Org_,
Seq,Rel,Idx,Dir);
IF .org NEQ Dap$k_Org_Seq THEN
BEGIN
attmenu[Dap$v_Attmenu_Org]=1;
mlength=.mlength+1;
END;
!+
! Convert the Record Format
!-
BEGIN !m555vv
LITERAL Dap$k_Rfm_Lsa = Dap$k_Rfm_Vfc; ! Lsa is a form of VFC
! on the vax
rfm=$Dap_Translate_Value(.Fab[fab$v_Rfm], !Convert to DAP
Fab$k_,Dap$k_Rfm_, ! ex SCR & SLF
Udf,Fix,Var,Vfc,Stm, %(SCr,SLf,)% Lsa);
!m566
!+ 610
! Most remote systems can't understand TOPS LSA record format, so
! set DAP RAT to LSA only for RMS20 systems. The LSA RFM is converted
! to STM here, reconverted to LSA on the TOPS20 receiving end.
!-
IF .Fab[Fab$v_rfm] EQL Fab$k_Lsa
AND (.Config[Xab$b_FileSys] EQL Xab$k_FileSys_RMS20)
THEN
BEGIN
rfm=Dap$k_Rfm_Stm;
Rat[Dap$v_Rat_Lsa]=1;
END;
END;
IF .rfm NEQ Dap$k_Rfm_Fix THEN
BEGIN
attmenu[Dap$v_Attmenu_Rfm]=1;
mlength=.mlength+1;
END;
$Dap_Move_Bits(Fab,Fab$v_,rat,Dap$v_Rat_,
Ftn,Cr,Blk,Efc,Cbl,Lsa);
t=Dap$Size_Bitvector (rat, 3, 0);
IF .t GTR 0 THEN
BEGIN
attmenu[Dap$v_Attmenu_Rat]=1;
mlength=.mlength+.t;
END;
!
! BLS field
! If talking to NFT-20 always send it
! If talking to RSX-11 never send it
! Otherwise send it if it isn't 512.
!
IF (.bls NEQ 512
OR .config[XAB$B_FILESYS] EQL XAB$K_FILESYS_TOPS20)
AND (.rsxbug[RSX_BUG_NOT_WANT_BLS]
AND (.config[XAB$B_FILESYS] NEQ DAP$K_FILESYS_FCS11))
THEN attmenu[Dap$v_Attmenu_Bls] = 1;
IF .attmenu[Dap$v_Attmenu_Bls] ! If we are sending BLS
THEN mlength=.mlength+2; ! allow 2 bytes for it
!
! MRS field
!
!d571
IF .mrs NEQ 0 THEN
BEGIN
attmenu[Dap$v_Attmenu_Mrs]=1;
mlength=.mlength+2;
END;
IF .Fab[Fab$g_Alq] NEQ 0 THEN
BEGIN
attmenu[Dap$v_Attmenu_Alq]=1;
mlength=.mlength+$Dap_Size_Longword(.Fab[Fab$g_Alq]);
END;
IF .bks NEQ 0 THEN
BEGIN
attmenu[Dap$v_Attmenu_Bks]=1;
mlength=.mlength+1;
END;
IF .fsz NEQ 0 THEN
BEGIN
attmenu[Dap$v_Attmenu_Fsz]=1;
mlength=.mlength+1;
END;
IF .Fab[Fab$g_Mrn] NEQ 0
THEN
BEGIN
attmenu[Dap$v_Attmenu_Mrn]=1;
mlength=.mlength+$Dap_Size_Longword(.Fab[Fab$g_Mrn]);
END;
IF (t=.runsys[0]) NEQ 0 THEN
BEGIN
attmenu[Dap$v_Attmenu_Run]=1;
mlength=.mlength+.t;
END;
IF .deq NEQ 0 THEN
BEGIN
attmenu[Dap$v_Attmenu_Deq]=1;
mlength=.mlength+2;
END;
$Dap_Move_Bits (Fab, Fab$v_, fop, Dap$v_Fop_,
Rwo,Rwc,Pos,Dlk,Lck,
Ctg,Sup,Nef,Tmp,Mkd,Dmo,
Wck,Rck,Cif,Lko,Sqo,Mxv,Spl,
Scf,Dlt,Cbt,Wat,%(Dfw)% ,Tef,Drj); ! DFW not supported
! by most FALs
t=Dap$Size_Bitvector (fop, 6, 0);
IF .t GTR 0 THEN
BEGIN
attmenu[Dap$v_Attmenu_Fop]=1;
mlength=.mlength+.t;
END;
IF (.bsz NEQ 0) THEN ! Send BSZ unless 0
BEGIN
attmenu[Dap$v_Attmenu_Bsz]=1;
mlength=.mlength+1;
END;
t=Dap$Size_Bitvector (dev, 6, 0);
IF .t GTR 0 THEN
BEGIN
attmenu[Dap$v_Attmenu_Dev]=1;
mlength=.mlength+.t;
END;
t=Dap$Size_Bitvector (sdc, 6, 0);
IF .t GTR 0 THEN
BEGIN
attmenu[Dap$v_Attmenu_Sdc]=1;
mlength=.mlength+.t;
END;
IF .ebk NEQ 0 ! Send EBK and FFB if we need to
THEN BEGIN
attmenu[DAP$V_ATTMENU_EBK] = 1;
attmenu[DAP$V_ATTMENU_FFB] = 1;
mlength = .mlength + 2 + $DAP_SIZE_LONGWORD(.ebk);
END;
END; ! **
mlength = .mlength + $Dap_Size_Bitvector (Attmenu, 6);
Init_Message (dd);
Dd[Dap$b_Operator]=Dap$k_Attributes; ! This is attributes message
dd[Dap$v_Mflags_Length]=1; ! We will send length field
Dd[Dap$h_Length]=.mlength; ! Set up message length in header
Dap$Put_Header (dd); ! Build the message header
Dap$Put_Bitvector (dd,attmenu,6); !Menu field
IF .attmenu[Dap$v_Attmenu_Dat] THEN Dap$Put_Bitvector (dd, datatype, 2);
IF .attmenu[Dap$v_Attmenu_Org] THEN Dap$Put_Byte (dd, .org);
IF .attmenu[Dap$v_Attmenu_Rfm] THEN Dap$Put_Byte (dd, .rfm);
IF .attmenu[Dap$v_Attmenu_Rat] THEN Dap$Put_Bitvector (dd, rat, 3);
IF .attmenu[Dap$v_Attmenu_Bls] THEN Dap$Put_2byte (dd, .bls);
IF .attmenu[Dap$v_Attmenu_Mrs] THEN Dap$Put_2byte (dd, .mrs);
IF .attmenu[Dap$v_Attmenu_Alq] THEN Dap$Put_Longword (dd, .Fab[Fab$g_Alq]);
IF .attmenu[Dap$v_Attmenu_Bks] THEN Dap$Put_Byte (dd, .bks);
IF .attmenu[Dap$v_Attmenu_Fsz] THEN Dap$Put_Byte (dd, .fsz);
IF .attmenu[Dap$v_Attmenu_Mrn] THEN Dap$Put_Longword (dd, .Fab[Fab$g_mrn]);
IF .attmenu[Dap$v_Attmenu_Run]
THEN Dap$Put_Variable_Counted (dd, CH$PTR(runsys,0,8));
IF .attmenu[Dap$v_Attmenu_Deq] THEN Dap$Put_2byte (dd, .deq);
IF .attmenu[Dap$v_Attmenu_Fop] THEN Dap$Put_Bitvector (dd, fop, 6);
IF .attmenu[Dap$v_Attmenu_Bsz] THEN Dap$Put_Byte (dd, .bsz);
IF .attmenu[Dap$v_Attmenu_Dev] THEN Dap$Put_Bitvector (dd, dev, 6);
IF .attmenu[Dap$v_Attmenu_Sdc] THEN Dap$Put_Bitvector (dd, sdc, 6);
IF .attmenu[DAP$V_ATTMENU_EBK] THEN DAP$PUT_LONGWORD (dd, .ebk);
IF .attmenu[DAP$V_ATTMENU_FFB] THEN DAP$PUT_2BYTE (dd, .ffb);
END; ! End of Attributes Message
! Now send the DATE & TIME message if needed
IF .Config[Xab$v_Date_Time]
AND .XabDat NEQ 0
AND .Display[Dap$v_Display_DTM]
THEN BEGIN
LOCAL dtmmenu: BITVECTOR[42], !Menu for this message
cdt: VECTOR[CH$ALLOCATION(18)] INITIAL(0), !Create date
rdt: VECTOR[CH$ALLOCATION(18)] INITIAL(0), !Update date
edt: VECTOR[CH$ALLOCATION(18)] INITIAL(0), !Scratch date
cdtdesc: $Str_Descriptor( String=(18,CH$PTR(cdt))),
rdtdesc: $Str_Descriptor( String=(18,CH$PTR(rdt))),
edtdesc: $Str_Descriptor( String=(18,CH$PTR(edt)));
Clearv(dtmmenu); !initially 0
Init_Message(dd);
dd[Dap$h_Length]=1; !The menu field is always sent
dd[Dap$b_Operator] = Dap$k_Date_Time; ! Send a date-time msg !a545
IF .XabDat[Xab$g_Cdt] NEQ 0 THEN
BEGIN
dtmmenu[Dap$v_Dtm_Cdt]=1;
dd[Dap$h_Length]=19;
S$DtStr( .XabDat[Xab$g_Cdt], Cdtdesc );
END;
IF .XabDat[Xab$g_Rdt] NEQ 0 THEN
BEGIN
dtmmenu[Dap$v_Dtm_Rdt]=1;
dd[Dap$h_Length]=.dd[Dap$h_Length]+18;
S$DtStr( .XabDat[Xab$g_Rdt], Rdtdesc );
END;
IF .XabDat[Xab$g_Edt] NEQ 0 THEN
BEGIN
dtmmenu[Dap$v_Dtm_Edt]=1;
dd[Dap$h_Length]=.dd[Dap$h_Length]+18;
S$DtStr( .XabDat[Xab$g_Edt], Edtdesc );
END;
dd[Dap$v_Mflags_Length]=1; !Length field present
Dap$Put_Header (dd);
Dap$Put_Bitvector (dd, dtmmenu, 6); !Send the menu
!Dates are always 18-character fields
IF .dtmmenu[Dap$v_Dtm_Cdt]
THEN Dap$Put_Date (dd,.cdtdesc[Str$a_Pointer]); !Creation date
IF .dtmmenu[Dap$v_Dtm_Rdt]
THEN Dap$Put_Date (dd,.Rdtdesc[Str$a_Pointer]); !Revision date
IF .dtmmenu[Dap$v_Dtm_Edt]
THEN Dap$Put_Date (dd,.Edtdesc[Str$a_Pointer]); !Scratch date
END; !of code to send DATE & TIME message
!
! Send PROTECTION message if needed
!
IF .xabpro NEQ 0 ! If a protection XAB was given
AND .config[XAB$V_PROTECTION] ! and supported on the remote
AND .display[DAP$V_DISPLAY_PRO] ! And it was asked for
THEN BEGIN ! Send PROTECTION message if needed
LOCAL promenu : BITVECTOR[42] INITIAL(0),
vprotsys, ! System protection bitvector
vprotown, ! Owner protection bitvector
vprotgrp, ! Group protection bitvector
vprotwld; ! World protection bitvector
%IF %DECLARED (XABPRO$A_OWNER) ! If ever there is an owner string
%THEN LOCAL owner : BYTE8VECTOR[40] INITIAL(0);
%FI
INIT_MESSAGE (dd); ! Start building the message
! Remember that DAP$PUT_BITVECTOR and DAP$SIZE_BITVECTOR want an
! address of the bitvector, not the value of the bitvector, so move
! the bitvectors out of the XAB and into local storage.
vprotsys = .xabpro[XAB$V_PROTSYS]; ! System
vprotown = .xabpro[XAB$V_PROTOWN]; ! Owner
vprotgrp = .xabpro[XAB$V_PROTGRP]; ! Group
vprotwld = .xabpro[XAB$V_PROTWLD]; ! World
! Compute the length of the message
dd[DAP$H_LENGTH]= ! Compute length of the message
(1 ! The menu is 1 byte long
%IF %DECLARED (XABPRO$A_OWNER)
%THEN ! This code is for illustration only
+(IF (.owner[0] NEQ 0)
THEN (promenu[Dap$v_ProtMenu_Owner]=1;.owner[0]+1)
ELSE 0)
%FI
+ DAP$SIZE_BITVECTOR (vprotsys,3,1)
+ DAP$SIZE_BITVECTOR (vprotown,3,1)
+ DAP$SIZE_BITVECTOR (vprotgrp,3,1)
+ DAP$SIZE_BITVECTOR (vprotwld,3,1));
! Turn on menu bits for each part of the protection we offer.
promenu[DAP$V_PROTMENU_PROTSYS] = ! System
promenu[DAP$V_PROTMENU_PROTOWN] = ! Owner
promenu[DAP$V_PROTMENU_PROTGRP] = ! Group
promenu[DAP$V_PROTMENU_PROTWLD] = 1; ! World
! Send out the header and then bitvectors for each protection field.
dd[DAP$B_OPERATOR] = DAP$K_PROTECTION; ! Message type
dd[DAP$V_MFLAGS_LENGTH] = 1; ! Length field present
DAP$PUT_HEADER (dd); ! Put header there
DAP$PUT_BITVECTOR (dd, promenu, 6); ! Protection menu
%IF %DECLARED (XABPRO$A_OWNER) ! If ever there will be owner string
%THEN ! This code is for illustration only
IF .promenu[DAP$V_PROTMENU_OWNER] ! OWNER string - not used here
THEN DAP$PUT_VARIABLE_COUNTED (dd, CH$PTR(owner,0,8));
%FI
DAP$PUT_BITVECTOR (dd, vprotsys, 3); ! System
DAP$PUT_BITVECTOR (dd, vprotown, 3); ! Owner
DAP$PUT_BITVECTOR (dd, vprotgrp, 3); ! Group
DAP$PUT_BITVECTOR (dd, vprotwld, 3); ! World
END; ! code to send PROTECTION message
!
! Send SUMMARY message if needed
!
IF .xabsum NEQ 0 ! If a Summary XAB was given
AND .Config[Xab$v_Summary] ! and supported on the remote
AND .Display[Dap$v_Display_Sum]
THEN
BEGIN !Send Summary message if needed
LOCAL SumMenu: BITVECTOR[42];
Clearv (SumMenu);
Init_Message (dd);
dd[Dap$b_Operator]=Dap$k_Summary; !Message type
dd[Dap$v_Mflags_Length]=1; !Length field present
SumMenu[Dap$v_SumMenu_NoK]=1;
SumMenu[Dap$v_SumMenu_NoA]=1;
dd[Dap$h_Length]=
1 !The menu is 1 byte long
+.SumMenu[Dap$v_SumMenu_Nok]
+.SumMenu[Dap$v_SumMenu_NoA];
Dap$Put_Header (dd);
Dap$Put_Bitvector (dd, SumMenu, 6); !Menu
IF .SumMenu[Dap$v_SumMenu_NoK] ! NOK field
THEN Dap$Put_Byte (dd, .XabSum[Xab$b_NoK]);
IF .SumMenu[Dap$v_SumMenu_NoA] ! NOA field
THEN Dap$Put_Byte (dd, .XabSum[Xab$b_NoA]);
%BLISS32( ! Not in RMS-20 or RMS-11
IF .SumMenu[Dap$v_SumMenu_NoR] ! NOR field
THEN Dap$Put_Byte (dd, .XabSum[Xab$b_NoR]);
IF .SumMenu[Dap$v_SumMenu_PVn] ! PVN field
THEN Dap$Put_Byte (dd, .XabSum[Xab$b_PVn]);
) ! End of non-20 code
END; !of code to send SUMMARY message
!
! Send KEY DEFINITION messages if needed
!
IF .Config[Xab$v_Key_Definition] ! If supported on the remote
AND .Display[Dap$v_Display_Key] ! And user wanted it !m513
THEN INCR Krf FROM 0 TO 255 ! For each KEY DEFINITION XAB given
DO
BEGIN
LOCAL KeyMenu: BITVECTOR[42] INITIAL(0);
LOCAL NSg;
LOCAL Knmlen: INITIAL(0);
LOCAL Dtp,
Flg: BITVECTOR[21] INITIAL(0);
BIND KeyXab=UAddr(.XabKey[.Krf]): $XabKey_decl; !m515
IF KeyXab EQL 0 THEN EXITLOOP; ! No more keys
Clearv (KeyMenu,Flg);
Init_Message (dd);
dd[Dap$b_Operator]=Dap$k_Key; !Message type
dd[Dap$v_Mflags_Length]=1; !Length field present
Flg[Dap$v_Flg_Dup] = .KeyXab[Xab$v_Dup];
Flg[Dap$v_Flg_Chg] = .KeyXab[Xab$v_Chg];
IF .Flg NEQ 0
THEN KeyMenu[Dap$v_KeyMenu_Flg]=1;
IF .KeyXab[Xab$h_Dfl] NEQ 0
THEN KeyMenu[Dap$v_KeyMenu_DFl]=1;
IF .KeyXab[Xab$h_Ifl] NEQ 0
THEN KeyMenu[Dap$v_KeyMenu_IFl]=1;
KeyMenu[Dap$v_KeyMenu_Ref]=1;
!+ 610
! If there is a KeyName field, set the menu flag, convert the
! user's XAB KNM text into counted ASCII, and calculate the length
! of the DAP field as <length of text>+1 byte for the count.
! Note that if we are sending returned post-access attributes we
! may have a Knm pointer field which points to a null Knm text (there
! was no Knm for this key). Set the menu flag anyway, even with
! a text field length of zero: this way the receiver's Knm pointer
! will get properly updated to point to a null text string, indicating
! the absence of the field in the file being accessed.
!-
IF .KeyXab[Xab$a_Knm] NEQ 0
THEN
BEGIN
KeyMenu[Dap$v_KeyMenu_Knm]=1;
Knmlen = Chazac ( UAPointer(.KeyXab[Xab$a_Knm]),
CH$PTR(BufKnm,0,7))+1;
END;
IF .KeyXab[Xab$b_Ian] NEQ 0
THEN KeyMenu[Dap$v_KeyMenu_IAn]=1;
IF .KeyXab[Xab$b_Dan] NEQ 0
THEN KeyMenu[Dap$v_KeyMenu_DAn]=1;
%BLISS36(
! Count segments, and check the size of each.
! If a segment is over 255 bytes long, DAP won't hack it
NSg=( LOCAL ks;
LABEL CntSeg;
CntSeg:( INCR i FROM 0 TO 7
DO IF (ks = .KeyXab[.i+%FIELDEXPAND(Xab$h_Siz0)]) EQL 0
THEN LEAVE CntSeg WITH .i
ELSE IF .ks GTR 255 THEN UserError( RMS$_SIZ ) ;
8 ) ); ! If none are zero, must be 8, the max !m606
! The above depends on the fact that each Pos/Siz pair is 1 word long
)
%BLISS32( the above will not work on VMS )
Dtp=$Value_Rms_Dap( .KeyXab[Xab$v_Dtp], Xab$k_, Dap$k_Dtp_, Rms$_Dtp,
Stg, %(In2, Bn2,)% In4, Bn4, Pac, In8, %(Bn8)% );
IF .Dtp NEQ 0
THEN KeyMenu[Dap$v_KeyMenu_Dtp]=1;
!+ 610
! Number of segments is always at least 1, since a non-byte-oriented
! key datatype may have defaulted its size to zero.
!-
KeyMenu[Dap$v_KeyMenu_NSg] = 1;
IF .NSg EQL 0 THEN NSg = 1;
dd[Dap$h_Length]=
Dap$Size_Bitvector( Keymenu, 6, 1) ! menu may be longer !m545
+.KeyMenu[Dap$v_Keymenu_Flg]
+.KeyMenu[Dap$v_KeyMenu_DFl]*2
+.KeyMenu[Dap$v_KeyMenu_IFl]*2
+.KeyMenu[Dap$v_KeyMenu_NSg]*(1+(.NSg*3)) !m572
+.KeyMenu[Dap$v_KeyMenu_Ref]
+.Knmlen !610
+.KeyMenu[Dap$v_KeyMenu_Dtp]
+.KeyMenu[Dap$v_KeyMenu_IAn]
+.KeyMenu[Dap$v_KeyMenu_DAn];
! Includes a 2-byte POS field & a 1-byte SIZ field per segment
Dap$Put_Header (dd);
Dap$Put_Bitvector (dd, KeyMenu, 6); !Menu
IF .KeyMenu[Dap$v_KeyMenu_Flg] ! FLG field
THEN Dap$Put_Bitvector (dd, Flg, 3);
IF .KeyMenu[Dap$v_KeyMenu_DFl] ! DFL field
THEN Dap$Put_2Byte (dd, .KeyXab[Xab$h_DFl]);
IF .KeyMenu[Dap$v_KeyMenu_IFl] ! IFL field
THEN Dap$Put_2Byte (dd, .KeyXab[Xab$h_IFl]);
IF .KeyMenu[Dap$v_KeyMenu_NSg] ! NSG, POS, SIZ fields
THEN
BEGIN
Dap$Put_Byte (dd, .NSg); ! Send number of segments
INCR i FROM 0 TO .NSg-1
DO
BEGIN
%BLISS36(
BIND xseg=KeyXab+.i: $XabKey_decl;
! This depends on the fact that a POS/SIZ pair is 1 word
Dap$Put_2Byte( dd, .xseg[Xab$h_Pos0] );
Dap$Put_Byte( dd, .xseg[Xab$h_Siz0] );
)
END;
END;
IF .KeyMenu[Dap$v_KeyMenu_Ref] ! REF field
THEN Dap$Put_Byte (dd, .KeyXab[Xab$b_Ref]);
IF .KeyMenu[Dap$v_KeyMenu_Knm] ! KNM field !610
THEN Dap$Put_Variable_Counted (dd, CH$PTR(BufKnm,0,7));
IF .KeyMenu[Dap$v_KeyMenu_IAn] ! IAN field
THEN Dap$Put_Byte (dd, .KeyXab[Xab$b_IAn]);
!d610
IF .KeyMenu[Dap$v_KeyMenu_LAn] ! LAN field
THEN Dap$Put_Byte (dd, .KeyXab[Xab$b_LAn]);
IF .KeyMenu[Dap$v_KeyMenu_DAn] ! DAN field
THEN Dap$Put_Byte (dd, .KeyXab[Xab$b_DAn]);
IF .KeyMenu[Dap$v_KeyMenu_DTp] ! DTP field
THEN Dap$Put_Byte (dd, .Dtp); !610
END; !of code to send KEY DEFINITION message
!
! Send ALLOCATION messages if needed
!
IF .Config[Xab$v_Allocation] ! If supported on the remote
AND .Display[Dap$v_Display_All] ! And user wanted it !m513
THEN INCR AId FROM 0 TO 31 ! For each ALLOCATION XAB given
DO
BEGIN
LOCAL AllMenu: BITVECTOR[42];
Bind AllXab=.XabAll[.AId]: $XabAll_decl;
IF AllXab EQL 0 THEN EXITLOOP; ! No more Areas
Clearv (AllMenu);
Init_Message (dd);
dd[Dap$b_Operator]=Dap$k_Allocation; !Message type
dd[Dap$v_Mflags_Length]=1; !Length field present
AllMenu[Dap$v_AllMenu_AId]=1;
AllMenu[Dap$v_AllMenu_BKz]=1;
dd[Dap$h_Length]=
Dap$Size_Bitvector( Allmenu, 6, 1) ! menu may be longer !m545
+.AllMenu[Dap$v_AllMenu_AId]
+.AllMenu[Dap$v_AllMenu_BKz];
Dap$Put_Header (dd);
Dap$Put_Bitvector (dd, AllMenu, 6); !Menu
IF .AllMenu[Dap$v_AllMenu_AId] ! AID field
THEN Dap$Put_Byte (dd, .AllXab[Xab$b_AId]);
IF .AllMenu[Dap$v_AllMenu_BKz] ! BKZ field
THEN Dap$Put_Byte (dd, .AllXab[Xab$b_BKz]);
END; !of code to send ALLOCATION messages
!+
! Send Resultant File Name if requested
!-
IF .Display[Dap$v_Display_Name]
THEN Dap$Put_Name( dd, Fab, %REF(1^Dap$k_Nametype_Fsp) );
END; !DAP$PUT_ATTRIBUTES
GLOBAL ROUTINE Dap$Put_Access (P_Dd: REF $Dap_Descriptor,
P_Fab: REF $Fab_Decl,
Accfunc,
P_Accopt: REF BITVECTOR,
P_Display: REF BITVECTOR,
P_NFab: REF $Fab_Decl ): NOVALUE=
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
!
! build ACCESS message & put in output buffer
!
! FORMAL PARAMETERS:
!
! P_DD: Address of DAP descriptor
! P_FAB: " " RMS FAB
! ACCFUNC: Access Function to perform
! P_ACCOPT: Access option bits (DAP)
! P_DISPLAY: Display Bits (DAP)
! P_NFAB: FAB with New name for rename
!
! IMPLICIT OUTPUTS:
!
! An ACCESS msg will be put in the output buffer
!
! ROUTINE VALUE:
!
! NONE
!
! SIDE EFFECTS:
!
! NONE
!
!--
BIND dd=.P_dd: $Dap_Descriptor,
Fab=.p_Fab: $Fab_Decl,
Nfab=.p_Nfab: REF $Fab_Decl,
Accopt=.p_Accopt: BITVECTOR,
Display=.p_Display: BITVECTOR;
BIND Nam=UAddr(.Fab[Fab$a_Nam]): $Nam_Decl; ! Name block (if any) !m507
LOCAL
nptr,
nlen,
fac: BITVECTOR[21],
shr: BITVECTOR[21],
filedesc: $Str_Descriptor(Class=Bounded),
rfiledesc: $Str_Descriptor(Class=Dynamic);
CLEARV (fac,shr);
Init_Message (dd);
dd[Dap$b_Operator]=Dap$k_Access;
dd[Dap$v_Mflags_Length]=1; ! Length field present always
!Make sure we request enough access to do what we want
CASE .accfunc FROM Dap$k_Open TO Dap$k_Accfunc_Max OF
SET
[Dap$k_Open]: Fab[Fab$v_Get]=1; !Ask for GET access
[Dap$k_Create,
Dap$k_Submit]: Fab[Fab$v_Put]=1; !Ask for PUT access
[INRANGE]: ; ! Not needed
[OUTRANGE]: SIGNAL (Dap$_Aor, dd);
TES;
!+
! Massage RMS FAC and SHR bits into DAP bitvectors
!-
$Dap_Move_Bits (Fab, Fab$v_, fac, Dap$v_Fac_, ! FAC
Get,Put,Del,Bio,Trn,Upd,Bro,App);
$Dap_Move_Bits (Fab, Fab$v_Shr, shr, Dap$v_Fac_,
Get,Put,Del,Bio,Upd,Bro); ! SHR
!? We will ignore the multi-stream access bit for now
! If we have a resultant name string, use it.
! If not, try expanded name string.
! If we have neither of those, or no name block at all, use the original string
IF nam NEQ 0
THEN
BEGIN
IF .Nam[Nam$h_Esl] NEQ 0
THEN
BEGIN
nptr=UAPointer(.Nam[Nam$a_Esa]);
nlen=.Nam[Nam$h_Esl];
END
ELSE
BEGIN
nptr=UAPointer(.Fab[Fab$a_Fna]);
nlen=Asciz_Len(.nptr);
END;
END
ELSE
BEGIN
nptr=UAPointer(.Fab[Fab$a_Fna]);
nlen=Asciz_Len(.nptr);
END;
$Str_Desc_Init ( Desc=filedesc,
String=(.nlen, .nptr),
Class=Bounded );
!
! Scan off nodeid and remove access info if any
!
![22] vv
!
! Use the remainder string
!
IF $Str_Scan ( Remainder=filedesc, Find='::', ! Strip up to ::
Substring=filedesc ) ! since we will use remainder
THEN
BEGIN
LOCAL
ptr,
ch;
filedesc[str$h_pfxlen]=.filedesc[str$h_pfxlen]+2;
filedesc[str$a_pointer]= CH$PLUS(.filedesc[str$a_pointer], 2);
filedesc[str$h_length]=.filedesc[str$h_maxlen]-.filedesc[str$h_pfxlen];
! Strip ;USERID ;PASSWORD ;CHARGE (and ;Pnnnnn)
ptr=.filedesc[Str$a_Pointer];
INCR i FROM 0 TO .filedesc[Str$h_Length] DO
BEGIN
IF CH$RCHAR_A(ptr) EQL %c';'
THEN SELECT CH$RCHAR(.ptr) AND %O'137' OF
SET ! Uppercase and compare
[%C'U', %C'P', %C'C']:
BEGIN
filedesc[Str$h_Length] = .i;
EXITLOOP;
END;
TES;
END;
END
ELSE
Filedesc[Str$h_Length] = .Filedesc[Str$h_MaxLen];
! Make the REMAINDER be the STRING
! Make a copy of the string
$Str_Desc_Init ( Desc=rfiledesc, Class=Dynamic );
$Str_Copy ( String=filedesc, Target=rfiledesc );
! Strip ^V
!?SOMEDAY
%(
IF .d$gtrace[1] ! For Debugging
THEN $Xpo_Put_Msg ( String=$Str_Concat('Remote File:',rfiledesc),
Severity=Success );
)%
!Find out how long the message will be (and build a few fields in the process)
dd[Dap$h_Length]=(1 !Length so far=1
+ $Dap_Size_Bitvector (accopt, 5) ! +# of bytes of ACCOPT
+ .rfiledesc[str$h_length] + 1 ! [22] ^^
!Add length of the file name +1 for count byte
+$Dap_Size_Bitvector (fac, 3,
shr, 3,
display, 4)
);
!Now build the message a field at a time
Dap$Put_Header (dd); ! First, the message header
Dap$Put_Byte (dd, .Accfunc); !Access function
Dap$Put_Bitvector (dd, Accopt, 5); !Access options
Dap$Put_Byte (dd, .rfiledesc[Str$h_Length]); !Length of remote filespec
Dap$Put_String (dd, rfiledesc); !Remote file spec ![22]
Dap$Put_Bitvector (dd, fac, 3); !FAC
Dap$Put_Bitvector (dd, shr, 3); !SHR
Dap$Put_Bitvector (dd, display, 4); !DISPLAY
IF .Accfunc EQL Dap$k_Rename
THEN
BEGIN ! [4] Pass address of bitvector
LOCAL nametype: BITVECTOR[24] PRESET([Dap$k_Nametype_Fsp]=1);
Dap$Put_Name (dd, Nfab, Nametype); ! New name for rename
END;
$Xpo_Free_Mem ( String=rfiledesc); ! Free filename now [22]
END; !Dap$Put_Access
GLOBAL ROUTINE Dap$Put_name (P_Dd: REF $Dap_Descriptor,
P_Fab: REF $Fab_Decl,
P_Name_Type: REF BITVECTOR): NOVALUE=
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
!
! Send a NAME message
!
! FORMAL PARAMETERS:
!
! P_DD: addr of DAP descriptor
! P_FAB: addr of RMS FAB
! P_NAME_TYPE: name type (DAP) address of bitvector
!--
BIND
dd=.P_dd: $Dap_Descriptor,
fab=.p_fab: $Fab_Decl,
Nam=UAddr(.Fab[Fab$a_Nam]): $Nam_decl,
Name_type=.P_Name_Type: BITVECTOR;
LOCAL
ptr,
filedesc: $Str_descriptor();
$Str_Desc_Init( Desc=filedesc );
SELECT 1 OF
SET
[ .Name_Type[Dap$k_Nametype_Fsp] ]:
BEGIN
IF Nam NEQ 0
THEN
BEGIN
IF .Nam[Nam$h_Rsl] NEQ 0
THEN $Str_Desc_Init( Desc=Filedesc,
String=(.Nam[Nam$h_Rsl], .Nam[Nam$a_Rsa]) )
ELSE IF .Nam[Nam$h_Esl] NEQ 0
THEN $Str_Desc_Init( Desc=Filedesc,
String=(.Nam[Nam$h_Esl], .Nam[Nam$a_Esa]) );
END;
IF .Filedesc[Str$h_Length] EQL 0 ! Nothing yet
THEN
BEGIN
LOCAL tfiledesc: $Str_descriptor( Class=Bounded, String=(0,0) );
$Str_Desc_Init( Desc=filedesc,
String=Asciz_Str( (UAPointer( .Fab[Fab$a_Fna] ) ) ) ) ;
IF $Str_Scan( String=filedesc,
Find='::',
Substring=tfiledesc )
THEN $Str_Desc_Init( Desc=filedesc,
String=Str_Remainder( tfiledesc ) );
! Strip ;USERID ;PASSWORD ;CHARGE (and ;Pnnnnn)
ptr=.filedesc[Str$a_Pointer];
INCR i FROM 0 TO .filedesc[Str$h_Length] DO
BEGIN
IF CH$RCHAR_A(ptr) EQL %c';'
THEN SELECT CH$RCHAR(.ptr) AND %O'137' OF
SET ! Uppercase and compare
[%C'U', %C'P', %C'C']:
BEGIN
filedesc[Str$h_Length] = .i;
EXITLOOP;
END;
TES;
END;
END;
END;
[ .Name_Type[Dap$k_Nametype_Str] ]:
BEGIN
IF Nam EQL 0
THEN SIGNAL(Rms$_Nam); ! Nam block needed
$Str_Desc_Init( Desc=filedesc,
String=(.Nam[Nam$b_Dev], UAPointer(.Nam[Nam$a_Dev]) ) );
END;
[ .Name_Type[Dap$k_Nametype_Dir] ]:
BEGIN
IF Nam EQL 0
THEN SIGNAL(Rms$_Nam); ! Nam block needed
$Str_Desc_Init( Desc=filedesc,
String=(.Nam[Nam$b_Dir], UAPointer(.Nam[Nam$a_Dir]) ) );
END;
[ .Name_Type[Dap$k_Nametype_Nam] ]:
BEGIN
IF Nam EQL 0
THEN SIGNAL(Rms$_Nam); ! Nam block needed
$Str_Desc_Init( Desc=filedesc,
String=(.Nam[Nam$b_Name]+.Nam[Nam$b_Type]+.Nam[Nam$b_Ver],
UAPointer(.Nam[Nam$a_Name]) ) ); !m561
END;
TES;
Init_Message (dd);
dd[Dap$b_Operator]=Dap$k_Name;
dd[Dap$v_Mflags_Length]=1; !LENGTH field present
dd[Dap$h_Length] = $Dap_Size_Bitvector (Name_Type, 3)
+ .Filedesc[Str$h_Length] + 1;
! Length of message
! add 1 for count byte
Dap$Put_Header (dd);
Dap$Put_Bitvector (dd, Name_Type, 3); ! NAMETYPE field
Dap$Put_Byte( dd, .filedesc[Str$h_Length] ); ! Length byte
Dap$Put_String (dd, filedesc ); ! FILESPEC field
END;
GLOBAL ROUTINE Dap$Put_Control (P_Dd: REF $Dap_Descriptor,
P_Rab: REF $Rab_Decl,
Cfun,
P_Display: REF BITVECTOR) :NOVALUE=
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
!
! Build CONTROL message
!
! FORMAL PARAMETERS:
!
! P_DD: Address of DAP descriptor
! P_RAB: Address of RMS RAB
! CFUN: Control message function code
! P_DISPLAY: Address of display bitvector
!
!--
LOCAL
dtp, ! Key datatype !a504
ctlmenu: BITVECTOR[7],
rac,
key: BYTE8VECTOR[255],
krf,
rop: BITVECTOR[42],
rop_size,
hsh: BITVECTOR[35],
hsh_size,
display_size;
BIND
dd=.p_dd: $Dap_Descriptor,
Rab=.P_Rab: $Rab_Decl,
Rst=.Rab[Rab$a_Isi]: $Rms_Rst, ! Bind the Fst !a557
Fab=UAddr(.Rab[Rab$a_Fab]): $Fab_Decl, ! Find our FAB !m506
Fst=.Fab[Fab$a_Ifi]: $Rms_Fst,
Config=.Fst[Fst$a_Config]: $XabCfg_decl,
Display=.P_Display: BITVECTOR;
Clearv (ctlmenu,key,krf,rop,hsh);
Init_Message (dd);
dd[Dap$b_Operator]=Dap$k_Control; ! This is a CONTROL message
dd[Dap$b_StreamId]=.Rst[Rst$v_StreamId];! Set up stream id !a557
dd[Dap$v_Mflags_Length]=1; ! Always a length field
Ctlmenu[Dap$v_Ctl_Rac]=1; ! Always have to send a RAC
rac=$Dap_Translate_Value (.Rab[Rab$b_Rac],
Rab$k_, Dap$k_Rac_,
Seq,Key,Rfa,Tra,Blk,Bft);
CASE .Rab[Rab$b_Rac] FROM Rab$k_Seq TO Rab$k_Bft OF
SET
[Rab$k_Seq]: ! See if FAL can hack it
IF NOT .config[xab$v_sequential_access]
THEN rac=Dap$k_Rac_Tra; ! It can't, use file xfer mode ![16]
[Rab$k_Tra]:;
[Rab$k_Blk, ! Block Mode
Rab$k_Bft]: ! Block mode file transfer
BEGIN
LOCAL keyval;
ctlmenu[Dap$v_Ctl_Key]=1; ! We will send the KEY
keyval=Rms_Vbn_to_Dap (.Rab[Rab$g_Bkt]);
key[0]=%BPVAL/8; ! Key is converted bucket number
INCR i FROM 1 TO %BPVAL/8 !
DO (key[.i]=.keyval; keyval=.keyval^-8);
END;
[Rab$k_Rfa]: ! RFA access
BEGIN
ctlmenu[Dap$v_Ctl_Key]=1; ! We will send the KEY
Dap$Rfa_Rms_Dap( .Rab[Rab$g_Rfa], key ); ! Make RFA to suit remote !m605
END;
[Rab$k_Key]: ! Key access
BEGIN
ctlmenu[Dap$v_Ctl_Key]=1; ! We will send the key
SELECT .Fab[Fab$v_Org] OF
SET
[Fab$k_Rel]: ! Relative file
dtp = Xab$k_Bn4; !
[Fab$k_Idx]: ! Indexed file
BEGIN
LOCAL thiskdb: REF $Rms_Kdb;
thiskdb=.Fst[Fst$a_Kdb];
dtp=0;
WHILE .thiskdb NEQ 0 ! 620
DO
IF (.thiskdb[kdb$h_Reference] EQL .Rab[Rab$b_Krf])
THEN EXITLOOP ( dtp = .thiskdb[kdb$v_datatype] )
ELSE thiskdb=.thiskdb[kdb$a_nxt];
krf = .thiskdb[kdb$h_Reference]; ! 620
Ctlmenu[Dap$v_Ctl_Krf] = 1; ! 620
END;
TES;
CASE .dtp FROM Xab$k_Stg TO Xab$k_Bn4 OF
SET
[Xab$k_In4, Xab$k_Bn4]:
! KBF is address of record number
! Get value of key from user section
BEGIN ! Key is Record number or other integer
LOCAL keyval; ! KBF is address of record number
keyval=.( UAddr( .Rab[Rab$a_Kbf] ) ); ! get word from user sect !m555
key[0]=%BPVAL/8;
INCR i FROM 1 TO %BPVAL/8
DO (key[.i]=.keyval; keyval=.keyval^-8)
END;
[Xab$k_Stg, Xab$k_Ebc, Xab$k_Pac]:
BEGIN ! Key is a string
LOCAL Keyptr;
Key[0]=.rab[Rab$b_Ksz]; ! KSZ is length of string
Keyptr=.rab[Rab$a_Kbf]; ! Character pointer to key
TGUPointer( Keyptr, .Fst[Fst$h_Bsz] ); ! Make byte pointer !623
INCR i FROM 1 TO .key[0] ! Copy the string
Do (Key[.i]=CH$RCHAR_A(Keyptr));! !623
END;
[INRANGE, OUTRANGE]: SIGNAL( Rms$_Ons ); ! Not supported
TES;
END;
[OUTRANGE]: SIGNAL( Rms$_Rac );
TES;
$Dap_Move_Bits (Rab, Rab$v_, Rop, Dap$v_Rop_,
Eof,Fdl,Uif,Hsh,Loa,Ulk,Tpt,
Rah,Wbh,Kge,Kgt,Nlk,Rlk,Bio,
Lim,Nxr); ! Translate the RMS ROP to a DAP one
Rop_Size=Dap$Size_Bitvector(Rop,6,0); ! Remember the size of this now
IF .rop_Size NEQ 0 THEN Ctlmenu[Dap$v_Ctl_Rop]=1; !Remember to send if needed
!HSH is reserved as of DAP 7.0
HSH_SIZE=0;
! Calculate the size of display bitvector now
Display_Size = Dap$Size_Bitvector (display,4,0); !m571
IF .display_Size NEQ 0 THEN Ctlmenu[Dap$v_Ctl_Display]=1; ! send if needed
Dd[Dap$h_Length]=(1 ! Length of CTLFUNC
+Dap$Size_Bitvector (Ctlmenu,4,0) ! Length of menu
+.ctlmenu[Dap$v_Ctl_Rac] ! Length of RAC
+(IF .ctlmenu[Dap$v_Ctl_Key]
THEN .key[0]+1 ELSE 0) ! Length of KEY
+(.ctlmenu[Dap$v_Ctl_Krf]) ! Length of KRF = 1
+.rop_Size ! Length of ROP
+.hsh_Size ! Length of HSH
+.display_Size ! Length of DISPLAY
);
Dap$Put_Header (dd); ! Send the header
Dap$Put_Byte (dd, .Cfun); !Function code
Dap$Put_Bitvector (dd, ctlmenu, 4); !Send the menu
IF .ctlmenu[Dap$v_Ctl_Rac] !RAC field
THEN Dap$Put_Byte (dd, .rac); !
IF .ctlmenu[Dap$v_Ctl_Key] !Key field
THEN DAP$Put_Variable_Counted (dd, CH$PTR(key,0,8) );
IF .ctlmenu[Dap$v_Ctl_Krf]
THEN Dap$Put_Byte (dd, .krf); ! KRF field
IF .ctlmenu[Dap$v_Ctl_Rop]
THEN Dap$Put_Bitvector (dd, rop, 6); ! ROP field
IF .ctlmenu[Dap$v_Ctl_Hsh]
THEN Dap$Put_Bitvector (dd, hsh, 5); ! HSH field
IF .ctlmenu[Dap$v_Ctl_Display]
THEN Dap$Put_Bitvector (dd, display, 4); ! DISPLAY field
END; !Dap$Put_Control
GLOBAL ROUTINE Dap$Get_Status ( P_DD: REF $Dap_Descriptor )=
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
!
! Routine to process a STATUS message
! Note that the message header must have already been eaten
! Signals error condition & returns code
!
! FORMAL PARAMETERS:
!
! P_DD: Addr of DAP descriptor
!
! IMPLICIT OUTPUTS:
!
! Fst[Fst$v_Error] is set or cleared
! Rab[Rab$g_Rfa] and Rst[Rst$g_Data_Rfa]
! are filled in if an RFA is given in the message
!
! COMPLETION CODES:
!
! System-dependent error code (but we SIGNAL first)
!
! SIDE EFFECTS:
!
! SIGNALs error if the status message indicates one.
!
!--
BIND dd=.p_dd: $Dap_Descriptor;
LOCAL
code;
OWN
rfa: BYTE8VECTOR[9],
recnum: BYTE8VECTOR[9],
stv: BYTE8VECTOR[9];
! Clearv (rfa,recnum,stv);
code=DAP$Get_2byte (dd); !Put maccode+miccode here
SELECT (.code AND Dap$m_Maccode) OF !m577
SET
[Dap$k_Mac_Open]:
Fst[Fst$v_File_Open] = 0;
[Dap$k_Mac_Invalid, ! Protocol Errors do not leave us
Dap$k_Mac_Sync]: ! with a useable access.
Fst[Fst$v_File_Open] ! Usually get this when we get an
= .Fst[Fst$v_Access_Active] ! error and try to skip to a
= 0; ! possible next file.
TES;
IF .dd[Dap$h_Length] GTR 0 ! Get the RFA (up to 8 bytes) [20]
THEN
BEGIN
Dap$Get_Variable_Counted (dd, CH$PTR(rfa,0,8), 8);
IF (.rfa[0] GTR 0) ! Return RFA to user if given !m605
AND (.Rab NEQ 0) ! Provided we have a place to put it
THEN Rab[Rab$g_Rfa] = Rst[Rst$g_Data_Rfa] =Dap$Rfa_Dap_Rms( rfa );
END;
IF .dd[Dap$h_Length] GTR 0 ! Get the RECNUM (up to 8 bytes) [20]
THEN Dap$Get_Variable_Counted (dd, CH$PTR(recnum,0,8), 8); !m561
IF .dd[Dap$h_Length] GTR 0 ! Get the STV (up to 8 bytes) [20]
THEN Dap$Get_Variable_Counted (dd, CH$PTR(stv,0,8), 8); !m561
!
! If we were trying to bail out and remote complains
! we must not have had an active access to begin with
!
IF ( .Code EQL ( Dap$k_Mac_Sync + Dap$k_Access_Complete ) ) !a577
THEN Fst[Fst$v_File_Open] = Fst[Fst$v_Access_Active] = 0; !a577
!
! Ignore errors about CONTINUE or ACCESS COMPLETE
! if we were trying to bail out of an error
!
IF ( .Code EQL ( Dap$k_Mac_Invalid + Dap$k_Mic_Continue + %O'20' ) )
OR ( .Code EQL ( Dap$k_Mac_Sync + Dap$k_Access_Complete ) ) !m577
OR ( .Code EQL ( Dap$k_Mac_Sync + Dap$k_Continue ) ) !m606
THEN IF .Fst[Fst$v_Error] !m577
THEN RETURN .UsrStv; ! Propegate previous error code
UsrStv = .Code; ! Return maccode+micccode as STV !m566
UsrSts = Dap$Error_Dap_Rms( .Code ); ! Make RMS code !m566
SELECTONE .UsrSts OF
SET
[Rms$k_Suc_Min TO Rms$k_Suc_Max]:
Fst[Fst$v_Error]=0; ! Else clear error flag
[Rms$_Eof]: ! End-of-file is different
SIGNAL( .UsrSts, .UsrStv ); ! Signal it
[Rms$k_Err_Min TO Rms$k_Err_Max]: ! If we got an error
BEGIN
Fst[Fst$v_Error]=1; ! Set error flag
SIGNAL( .UsrSts, .UsrStv ) ! Signal it
END;
TES;
.Stv ! Return DAP status code
END; !Dap$Get_Status
GLOBAL ROUTINE Dap$Get_Ack ( P_Dd: REF $Dap_Descriptor )=
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
!
! Routine to expect and process an ACK message,
! or a STATUS message if we aren't lucky
!
! FORMAL PARAMETERS:
!
! DD: Addr of DAP descriptor
!
! IMPLICIT INPUTS:
!
! Input buffer & pipeline
!
! IMPLICIT OUTPUTS:
!
! Fst[Fst$v_Error] is set if error, cleared if not
!
! COMPLETION CODES:
!
! STS$K_NORMAL if we get an ACK,
! error code otherwise
!
!--
BIND dd=.P_Dd: $Dap_Descriptor;
SELECT Dap$Get_Header (dd)
OF SET
[Dap$k_Ack]:
BEGIN
Fst[Fst$v_Error]=0; ! Not an error
STS$K_NORMAL
END;
[Dap$k_Status]: Dap$Get_Status (dd);
[OTHERWISE]: SIGNAL (Dap$_Sync, dd);
TES
END; !DAP$GET_ACK
GLOBAL ROUTINE Dap$Rfa_Rms_Dap( rfanum, pbv: REF Byte8Vector[8] ) : NOVALUE =
!+
! Make an RFA into an image field for DAP
! If it is negative, the sign bit was a flag to reformat it to
! a 6-byte VMS indexed file RFA:
!
! +-+------------------------+--------------------------------------------+
! |1| record within bucket | bucket number |
! +-+------------------------+--------------------------------------------+
! 1 11 24
!-
BEGIN !a605v
IF .Rab[Rab$g_Rfa] GEQ 0
THEN
BEGIN
LOCAL keyval: INITIAL(.rfanum);
pbv[0]=%BPVAL/8; ! Key is converted bucket number
INCR i FROM 1 TO %BPVAL/8 !
DO (pbv[.i]=.keyval; keyval=.keyval^-8);
END
ELSE ! Special case for VMS 6-byte RFAs
BEGIN
pbv[0]=6; ! Length of field
pbv[1]=.rfanum; ! Low-order 8 bits of VBN first
pbv[2]=.rfanum<8,8>; ! Next 8 bits of VBN
pbv[3]=.rfanum<16,8>; ! Next 8 bits of VBN
pbv[4]=0; ! If we get a VBN over 24 bits, too bad
pbv[5]=.rfanum<24,8>; ! Number within record
pbv[6]=.rfanum<32,3>; ! Last 3 bits
END;
END;
GLOBAL ROUTINE Dap$Rfa_Dap_Rms ( pbv: REF Byte8Vector ) =
BEGIN
LOCAL val: INITIAL(0);
IF .pbv[0] LSS 6
THEN
INCR i FROM 1 TO .pbv[0]
DO val = .val + ( .pbv[.i] ^ ( (.i-1) * 8 ) )
ELSE
BEGIN
val=.pbv[1];
val<8,8>=.pbv[2];
val<16,8>=.pbv[3];
val<24,8>=.pbv[5];
val<32,3>=.pbv[6];
val<35,1>=1; ! Flag for this kind of RFA
END;
.val ! Return as value
END; !a605^
END ELUDOM