/*
* GO: sets the tree cursors on each term in terms, processes the terms by advancing
* the terms cursors and storing the partial
* results and lastly calculates the top results
* @param results, the priority queue containing the top results
* @param limit, number of results in the priority queue
*/
void FTSSearch::go(Results* results, unsigned limit ) {
vector< shared_ptr<BtreeCursor> > cursors;
for ( unsigned i = 0; i < _query.getTerms().size(); i++ ) {
const string& term = _query.getTerms()[i];
BSONObj min = FTSIndexFormat::getIndexKey( MAX_WEIGHT, term, _indexPrefix );
BSONObj max = FTSIndexFormat::getIndexKey( 0, term, _indexPrefix );
shared_ptr<BtreeCursor> c( BtreeCursor::make( _ns, _id, min, max, true, -1 ) );
cursors.push_back( c );
}
while ( !inShutdown() ) {
bool gotAny = false;
for ( unsigned i = 0; i < cursors.size(); i++ ) {
if ( cursors[i]->eof() )
continue;
gotAny = true;
_process( cursors[i].get() );
cursors[i]->advance();
}
if ( !gotAny )
break;
RARELY killCurrentOp.checkForInterrupt();
}
// priority queue using a compare that grabs the lowest of two ScoredLocations by score.
for ( Scores::iterator i = _scores.begin(); i != _scores.end(); ++i ) {
if ( i->second < 0 )
continue;
// priority queue
if ( results->size() < limit ) { // case a: queue unfilled
if ( !_ok( i->first ) )
continue;
results->push( ScoredLocation( i->first, i->second ) );
}
else if ( i->second > results->top().score ) { // case b: queue filled
if ( !_ok( i->first ) )
continue;
results->pop();
results->push( ScoredLocation( i->first, i->second ) );
}
else {
// else do nothing (case c)
}
}
}
ADIobj adix_prs_cmdlist( ADIobj pstream, char *termlist,
int *choice, ADIstatus status )
{
int len;
ADIlogical more = ADI__true; /* More statements in list? */
ADIobj robj = ADI__nullid; /* Returned object */
ADIobj state; /* Parsed statement */
char *tcur; /* Cursor over terminator list */
ADIobj *ipoint = &robj;
/* Check inherited status on entry */
_chk_stat_ret(ADI__nullid);
/* While more statements */
while ( _ok(status) && more ) {
/* If statement starts with a symbol, test against terminal list */
if ( ADIcurrentToken(pstream,status) == TOK__SYM ) {
tcur = termlist;
*choice = 1;
while ( more && _ok(status) && (*tcur=='|') ) {
len = 0; tcur++;
while ( (tcur[len] != '|') && tcur[len] )
len++;
if ( !strncmp(_strm_data(pstream)->ctok.dat,tcur,len) )
more = ADI__false;
else
(*choice)++;
tcur += len;
}
}
if ( more ) {
state = adix_prs_cmd( pstream, status );
ADInextToken( pstream, status );
if ( _valid_q(state) )
lstx_inscel( state, &ipoint, status );
}
}
/* Use the null list to represent the null statement list */
if ( _null_q(robj) )
robj = adix_clone( ADIcvNulCons, status );
return robj;
}
ADIobj adix_prs_while( int narg, ADIobj args[], ADIstatus status )
{
ADIobj pstream = args[0];
int choice;
ADIobj robj = ADI__nullid; /* Returned object */
ADIobj action; /* Action procedure */
ADIobj test; /* The WHILE test expression */
/* Skip the command name */
ADInextToken( pstream, status );
ADImatchToken( pstream, TOK__LPAREN, status );
test = ADIparseExpInt( pstream, ADI__nullid, 1, status );
ADImatchToken( pstream, TOK__RPAREN, status );
ADImatchToken( pstream, TOK__END, status );
/* Action list */
action = adix_prs_cmdlist( pstream, "|end", &choice, status );
if ( _ok(status) ) {
ADInextToken( pstream, status ); /* Match the "end" */
/* Construct argument list */
robj = lstx_new2( test, action, status );
}
return ADIetnNew( adix_clone( K_While, status ), robj, status );
}
static NodeRef ParsePrimary( char **spec, int *status )
{
NodeRef node = NIL;
if ( !_ok(status) )
node = NIL;
else if ( curtok == TOK_ID )
{
node = NewNode( TOK_ID, curid, NIL, NIL, status );
NextToken( spec, status );
}
else if ( curtok == TOK_OPAREN )
{
NextToken( spec, status );
node = ParseExpr( spec, status );
if ( curtok == TOK_CPAREN )
NextToken( spec, status );
else
{
*status = SAI__ERROR;
ems_rep_c( " ", "Syntax error - right parenthesis expected", status );
}
}
else
{
*status = SAI__ERROR;
ems_rep_c( " ", "Unexpected token in model specification", status );
}
return node;
}
static void FlatShow( int term, int *status )
{
int aterm = term;
int i,word,j;
if ( !_ok(status) )
return;
do
{
for( i=0; i<terms[aterm].len; i++ )
{
if ( i )
putchar('*');
word = terms[aterm].elem[i]-1;
for(j=0; j<modlen[word];j++)
putchar(modpos[word][j]);
}
if ( terms[aterm].next != NullTerm )
{
if ( terms[aterm].t == TOK_PLUS )
printf( "+" );
else
printf( "-" );
}
aterm = terms[aterm].next;
}
while ( aterm != NullTerm );
printf( "\n" );
}
ADIobj adix_prs_defproc( int narg, ADIobj args[], ADIstatus status )
{
ADIobj pstream = args[0];
ADIobj actions;
int choice;
ADIobj defn;
ADIobj robj = ADI__nullid;
/* Skip the DEFPROC keyword */
ADInextToken( pstream, status );
/* Get the definition expression */
defn = ADIparseExpInt( pstream, ADI__nullid, 1, status );
/* Check it */
if ( _ok(status) ) {
if ( ! _etn_q(defn) ) {
adic_setecs( ADI__SYNTAX, "Invalid procedure definition", status );
}
else {
actions = adix_prs_cmdlist( pstream, "|endproc", &choice, status );
ADInextToken( pstream, status );
robj = ADIetnNew( adix_clone( K_DefProc, status ),
lstx_new2( defn, actions, status ),
status );
}
}
/* Create the expression node */
return robj;
}
void _int_is(char* test_name, int i1, int i2, char *file, int linenum) {
_ok(test_name, (i1==i2), file, linenum, "");
if (i1!=i2) {
printf("# got: %d\n", i1);
printf("# expected: %d\n", i2);
}
}
int rec_locate_fns( const struct HAN *han, const char **fns )
{
/*+ */
/* Name: */
/* rec_locate_fns */
/* Purpose: */
/* Obtain a pointer to the file name string for a container file. */
/* Invocation: */
/* rec_locate_fns( han, fns ) */
/* Description: */
/* This function returns a pointer to a file name string for an HDS */
/* container file. A handle to a record in the file must be supplied. */
/* Parameters: */
/* const struct HAN *han */
/* Pointer to a HAN structure containing a handle for any record in */
/* the container file. */
/* const char **fns */
/* Pointer to a char pointer which will be set to point at a */
/* null-terminated file name string for the container file. This */
/* string must not be altered by the calling routine. A null pointer */
/* value will be returned under error conditions. */
/* Returned Value: */
/* int rec_locate_fns */
/* The global status value current on exit. */
/* Authors: */
/* RFWS: R.F. Warren-Smith (STARLINK) */
/* {@enter_new_authors_here@} */
/* History: */
/* 24-APR-1991 (RFWS): */
/* Added prologue and error handling and tidied. */
/* {@enter_changes_here@} */
/* Bugs: */
/* {@note_any_bugs_here@} */
/*- */
/*. */
/* Set an initial null value for the returned pointer. */
*fns = NULL;
/* Check the inherited global status. */
if ( !_ok( hds_gl_status ) ) return hds_gl_status;
/* Return a pointer to the File Name String in the File Control Vector. */
*fns = rec_ga_fcv[ han->slot ].name;
/* Return the current global status value. */
return hds_gl_status;
}
void rec_mark_delete( const struct HAN *han, int *status )
{
/*+ */
/* Name: */
/* rec_mark_delete */
/* Purpose: */
/* Mark an HDS container file for deletion. */
/* Invocation: */
/* rec_mark_delete( han, status ) */
/* Description: */
/* This function marks an HDS container file so that it will be deleted */
/* when it is closed (but note that this function does not itslf close */
/* the file). A single invocation is sufficient to ensure that the file */
/* will eventually be deleted; subsequent invocations have no further */
/* effect. */
/* Parameters: */
/* const struct HAN *han */
/* Pointer to a HAN structure containing a handle to any record in */
/* the file. */
/* int *status */
/* Pointer to the inherited global status. */
/* Returned Value: */
/* void */
/* Copyright: */
/* Copyright (C) 1992 Science & Engineering Research Council */
/* Authors: */
/* RFWS: R.F. Warren-Smith (STARLINK) */
/* {@enter_new_authors_here@} */
/* History: */
/* 23-SEP-1992 (RFWS): */
/* Original version. */
/* {@enter_further_changes_here@} */
/* Bugs: */
/* {@note_any_bugs_here@} */
/*- */
/*. */
/* Check the inherited global status. */
if ( !_ok( *status ) ) return;
/* Set the deletion flag in the file control vector. */
rec_ga_fcv[ han->slot ].dele = 1;
/* Exit the routine. */
return;
}
static void TreeFree( NodeRef node, int *status )
{
if ( !_ok(status) || (! node) )
return;
if ( node->lhs )
TreeFree( node->lhs, status );
if ( node->rhs )
TreeFree( node->rhs, status );
free( node );
}
/*
* Parse a single statement. The token which signifies the end of valid statement
* (an end-of-line or semicolon) is not matched by this routine. Null statements
* are ignored, and the null identifier returned.
*
*/
ADIobj adix_prs_cmd( ADIobj pstream, ADIstatus status )
{
ADIobj cbind;
ADItokenType ctok;
ADIobj name;
ADIobj rval = ADI__nullid;
/* IF command starts with a symbol, look for a command binding */
if ( ADIcurrentToken(pstream,status) == TOK__SYM ) {
name = prsx_symname( pstream, status );
cbind = ADIsymFind( name, -1, ADI__true, ADI__command_sb, status );
/* Located a command symbol? */
if ( _valid_q(cbind) ) {
/* Invoke parser procedure with stream as argument */
rval = adix_exemth( ADI__nullid, _mthd_exec(_sbind_defn(cbind)),
1, &pstream, status );
}
else
rval = ADIparseExpInt( pstream, ADI__nullid, 1, status );
}
else
rval = ADIparseExpInt( pstream, ADI__nullid, 1, status );
/* Check for garbage following statement */
if ( _valid_q(rval) && _ok(status) ) {
ctok = ADIcurrentToken(pstream,status);
if ( ctok != TOK__END && ctok != TOK__SEMICOLON ) {
char *tstr;
int tlen;
ADIdescribeToken( ctok, &tstr, &tlen );
ADIparseError( pstream, ADI__SYNTAX,
"Error reading statement - %*s found where semi-colon or end of line expected",
status, tlen, tstr );
}
}
/* == TOK__END
ADInextToken( pstream, status ); */
return rval;
}
static int GetNewTerm( int *status )
{
int aterm = NullTerm;
int i;
if ( !_ok(status) )
return aterm;
for( i=0; i<MAXTERM; i++ )
if ( ! terms[i].len )
{
terms[i].next = NullTerm; aterm = i; terms[i].len = 1; break;
}
return aterm;
}
static NodeRef NewNode( LegalToken t, int data, NodeRef lhs, NodeRef rhs,
int *status )
{
NodeRef node;
if ( !_ok(status) )
return NIL;
node = (NodeRef) malloc( sizeof(Node) );
node->t = t;
node->lhs = lhs;
node->rhs = rhs;
node->data = data;
return node;
}
static NodeRef ParseTerm( char **spec, int *status )
{
NodeRef node = NIL;
node = ParsePrimary( spec, status );
while ( (curtok == TOK_TIMES) && _ok(status) )
{
NextToken( spec, status );
node = NewNode( TOK_TIMES, 0, node,
ParsePrimary(spec, status),
status );
}
return node;
}
void _is(char* test_name, const char* str1, const char* str2, char *file, int linenum) {
int diff;
if (str1 == NULL || str2 == NULL) {
diff = 1;
} else {
diff = strcmp(str1, str2);
}
if (!test_name) test_name = "()";
_ok(test_name, (diff==0), file, linenum, "");
if (diff) {
printf("# got: %s\n", str1 ? str1 : "(null)");
printf("# expected: %s\n", str2 ? str2 : "(null)");
}
}
static NodeRef ParseExpr( char **spec, int *status )
{
NodeRef node = NIL;
LegalToken optok;
node = ParseTerm( spec, status );
while ( ((curtok == TOK_PLUS) || (curtok==TOK_MINUS)) && _ok(status) )
{
optok = curtok;
NextToken( spec, status );
node = NewNode( optok, 0, node,
ParseTerm( spec, status),
status );
}
return node;
}
void subtest(const char *name, void (*cb)(void))
{
struct test_t test = {0}, *parent_tests;
parent_tests = cur_tests;
cur_tests = &test;
++test_level;
note("Subtest: %s", name);
cb();
done_testing();
--test_level;
cur_tests = parent_tests;
if (test.failed)
cur_tests->failed = 1;
_ok(! test.failed, "%s", name);
}
/*
* Parse and execute commands appearing on an input stream, sending output
* to the output stream if specified
*/
void ADIcmdExec( ADIobj istream, ADIobj ostream, ADIstatus status )
{
ADIobj cmd;
ADIobj res;
_chk_stat;
do {
ADInextToken( istream, status );
cmd = adix_prs_cmd( istream, status );
if ( _valid_q(cmd) ) {
res = ADIexprEval( cmd, ADI__nullid, ADI__true, status );
if ( _valid_q(ADI_G_curint->exec.name) ) {
ADIparseError( istream, ADI_G_curint->exec.code, "Break on unhandled exception %S", status,
ADI_G_curint->exec.name );
if ( _valid_q(ADI_G_curint->exec.errtext) ) {
adic_setecs( ADI_G_curint->exec.code, "%O", status,
ADI_G_curint->exec.errtext );
}
ADIexecAcceptI( ADI_G_curint->exec.name, status );
*status = SAI__OK;
}
else if ( _valid_q(res) ) {
if ( _valid_q(ostream) ) {
adix_print( ostream, res, 0, 1, status );
ADIstrmFprintf( ostream, "\n", status );
ADIstrmFflush( ostream, status );
}
adic_erase( &res, status );
}
/* Destroy the command */
adic_erase( &cmd, status );
}
}
while ( _ok(status) && (ADIcurrentToken(istream,status) != TOK__NOTATOK) );
}
void rec1_open_file( int expand, const char *file, INT file_len, char mode,
INT *slot, int *newslot )
{
/*+ */
/* Name: */
/* rec1_open_file */
/* Purpose: */
/* Open an existing file. */
/* Invocation: */
/* rec1_open_file( expand, file, file_len, mode, slot, newslot ) */
/* Description: */
/* This function opens an existing container file for reading or writing */
/* and allocates a new File Control Vector slot (if necessary) to refer */
/* to the file. Any new FCV slot is initialised and its number is */
/* returned. The file's reference count is left unchanged if it is */
/* already in use, or is set to zero if it is being opened for the first */
/* time. */
/* Parameters: */
/* int expand */
/* If expand is non-zero, then the file name supplied will be */
/* regarded as an abbreviated form of the full name of the file and */
/* will be expanded (according to the underlying operating system's */
/* rules) before use. Otherwise, the file name supplied is regarded */
/* as already fully expanded and will be used literally. This */
/* mechanism is provided to allow previously-expanded file names to */
/* be given, while allowing for the fact that expanding a file name */
/* twice may cause the wrong file to be identified (if the underlying */
/* file system has changed and/or the expanded file name contains */
/* special characters, for instance). */
/* const char *file */
/* Pointer to a char array containing the host file-system name of */
/* the container file to be opened. It should not be null terminated. */
/* If expand is non-zero, then leading and trailing white space will */
/* be ignored. If expand is zero, then the file name must be */
/* fully-expanded and white space may be significant. */
/* INT file_len */
/* Number of characters in the file name (excluding any terminating */
/* null, if present). */
/* char mode */
/* A character specifying the required file access mode: 'R' for */
/* read-only access or 'W' for write (or update) access. */
/* INT *slot */
/* Pointer to an integer in which the File Control Vector slot number */
/* allocated to the file will be returned. */
/* int *newslot */
/* Returns 1 if the FCV slot is a new one, otherwise 0 if the slot */
/* was already in use (i.e. the file was already open). */
/* Returned Value: */
/* void */
/* Copyright: */
/* Copyright (C) 1992 Science & Engineering Research Council */
/* Copyright (C) 2005 Particle Physics and Astronomy Research Council */
/* Licence: */
/* This program is free software; you can redistribute it and/or */
/* modify it under the terms of the GNU General Public License as */
/* published by the Free Software Foundation; either version 2 of */
/* the License, or (at your option) any later version. */
/* This program is distributed in the hope that it will be */
/* useful, but WITHOUT ANY WARRANTY; without even the implied */
/* warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR */
/* PURPOSE. See the GNU General Public License for more details. */
/* You should have received a copy of the GNU General Public */
/* License along with this program; if not, write to the Free */
/* Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, */
/* MA 02110-1301, USA */
/* Authors: */
/* RFWS: R.F. Warren-Smith (STARLINK) */
/* TIMJ: Tim Jenness (JAC, Hawaii) */
/* {@enter_new_authors_here@} */
/* History: */
/* 28-MAR-1991 (RFWS): */
/* Added prologue. */
/* 3-APR-1991 (RFWS): */
/* Fixed bug in passing of file name for error message. */
/* 3-MAY-1991 (RFWS): */
/* Re-structured to return an FCV slot number and to initialise the */
/* slot if necessary. */
/* 7-MAY-1991 (RFWS): */
/* Added a portable implementation. */
/* 21-MAY-1991 (RFWS): */
/* Remove trailing blanks from file names (portable version). */
/* 22-MAY-1991 (RFWS): */
/* Added defaulting of ".sdf" file extension in portable version. */
/* 12-JUN-1991 (RFWS): */
/* Fixed bug in testing of access mode. */
/* 28-JUN-1991 (RFWS): */
/* Removed initialisation of the VMS-specific FCV lid field (not */
/* necessary). Added function prototypes for VMS system calls. */
/* 11-SEP-1992 (RFWS): */
/* Do not increment the file reference count. This is now the */
/* caller's responsibility. */
/* 14-OCT-1992 (RFWS): */
/* Changed to a void function and to use separate string pointer and */
/* length arguments. */
/* 24-NOV-1992 (RFWS): */
/* Fixed error in assigning access mode for error message. */
/* 25-NOV-1992 (RFWS): */
/* Changed to extend the File Control Vector when necessary. */
/* 26-NOV-1992 (RFWS): */
/* Enhanced file name handling by using rec1_get_path. */
/* 1-DEC-1992 (RFWS): */
/* Added the expand parameter. */
/* 28-DEC-2005 (TIMJ): */
/* Use DAT__FLEXT rather than hard-coded ".SDF" */
/* 02-FEB-2006 (TIMJ): */
/* Free malloced memory if the slot is reused. */
/* {@enter_further_changes_here@} */
/* Bugs: */
/* {@note_any_bugs_here@} */
/*- */
/* Local Variables: */
#if defined (vms ) /* VMS version local variables: */
char esabuf[ NAM$C_MAXRSS ]; /* Expanded file name string buffer */
char rsabuf[ NAM$C_MAXRSS ]; /* Resultant file name string buffer */
struct FAB fab; /* RMS file access block */
struct NAM nam; /* RMS NAM block */
unsigned int systat; /* System status code */
unsigned short int iochan; /* File I/O channel */
#else /* Portable version local variables: */
FILE *iochan=NULL; /* File I/O stream */
#endif
INT i; /* Loop counter for FCV slots */
INT lfns; /* Length of File Name String */
INT start; /* Array offset of first non-blank char */
char *fns; /* Pointer to file name string */
int mustopen=0; /* File must be opened? */
struct FCV *fcv; /* Pointer to File Control Vector element */
struct FID *fid; /* Pointer to File ID */
/* External References: */
#if defined( vms ) /* VMS version system calls: */
unsigned int SYS$OPEN( struct FAB *fab );
unsigned int SYS$PARSE( struct FAB *fab );
unsigned int SYS$SEARCH( struct FAB *fab );
#endif
/*. */
/* Check the inherited global status. */
if ( !_ok( hds_gl_status ) ) return;
/* Initialise. */
fns = NULL;
fid = NULL;
/* If necessary, modify the file name length to omit any trailing white */
/* space. */
start = 0;
if ( expand )
{
for ( ; file_len > 0; file_len-- )
{
if ( !isspace( file[ file_len - 1 ] ) ) break;
}
/* Also strip white space from the start of the file name (but leave at */
/* least one character, even if the string is completely blank). */
for ( start = 0; start < ( file_len - 1 ); start++ )
{
if ( !isspace( file[ start ] ) ) break;
}
}
/* VMS version: */
/* =========== */
#if defined( vms )
/* Initialise the file FAB and NAM blocks. */
fab = cc$rms_fab;
fab.fab$l_dna = DAT__FLEXT;
fab.fab$b_dns = DAT__SZFLX;
fab.fab$l_fna = file + start;
fab.fab$b_fns = file_len - start;
fab.fab$l_nam = &nam;
nam = cc$rms_nam;
nam.nam$l_esa = esabuf;
nam.nam$b_ess = NAM$C_MAXRSS;
nam.nam$l_rsa = rsabuf;
nam.nam$b_rss = NAM$C_MAXRSS;
/* Parse the file name, reporting any errors. */
systat = SYS$PARSE( &fab );
if ( !( systat & STS$M_SUCCESS ) )
{
hds_gl_status = ( systat == RMS$_PRV ) ? DAT__FILPR : DAT__FILNF;
emsSetnc( "FILE", file + start, file_len - start );
emsSyser( "MESSAGE", systat );
emsRep( "REC1_OPEN_FILE_1",
"Error in file name \'^FILE\' - ^MESSAGE.",
&hds_gl_status );
}
/* Search for the file, again reporting errors. */
if ( _ok( hds_gl_status ) )
{
systat = SYS$SEARCH( &fab );
if ( !( systat & STS$M_SUCCESS ) )
{
hds_gl_status = ( systat == RMS$_PRV ) ? DAT__FILPR : DAT__FILNF;
emsSetnc( "FILE", esabuf, nam.nam$b_esl );
emsSyser( "MESSAGE", systat );
emsRep( "REC1_OPEN_FILE_2",
"Error searching for file ^FILE - ^MESSAGE.",
&hds_gl_status );
}
/* If the file was found successfully, then allocate memory to hold the */
/* File Name String and the File ID and copy the relevant information from */
/* the NAM block into this memory (adding a terminating null to the file */
/* name). */
else
{
lfns = nam.nam$b_rsl;
rec_alloc_mem( lfns + 1, (void **) &fns );
rec_alloc_mem( sizeof( struct FID ), (void **) &fid );
if ( _ok( hds_gl_status ) )
{
(void) memcpy( (void *) fns, (const void *) nam.nam$l_rsa,
(size_t) lfns );
fns[ lfns ] = '\0';
(void) memcpy( (void *) fid, (const void *) nam.nam$t_dvi,
sizeof( struct FID ) );
}
}
}
/* Portable version: */
/* ================ */
#else
/* If required, obtain the full path name of the file. */
if ( expand )
{
rec1_get_path( file + start, file_len - start, &fns, &lfns );
}
/* Otherwise, allocate space and copy the file name for use directly. */
else
{
lfns = file_len - start;
rec_alloc_mem( lfns + 1, (void **) &fns );
if ( _ok( hds_gl_status ) )
{
(void) memcpy( (void *) fns, (const void *) ( file + start ),
(size_t) lfns );
fns[ lfns ] = '\0';
}
}
/* Allocate memory to hold the File ID and store file identification */
/* information in it. */
rec_alloc_mem( sizeof( struct FID ), (void **) &fid );
rec1_get_fid( fns, fid );
#endif
/* Loop to search the File Control Vector for any slot which is currently */
/* open and associated with the same file. */
if ( _ok( hds_gl_status ) )
{
*slot = rec_gl_endslot;
*newslot = 1;
for ( i = 0; i < rec_gl_endslot; i++ )
{
/* Remember the number of the last slot which is not being used. */
if ( !rec_ga_fcv[ i ].open )
{
*slot = i;
}
/* If a slot is open and the identification matches, then note that a new */
/* slot is not needed and quit searching */
else if ( !memcmp( (const void *) rec_ga_fcv[ i ].fid,
(const void *) fid, sizeof( struct FID ) ) )
{
*slot = i;
*newslot = 0;
break;
}
}
/* If no File ID match or unused FCV slot was found, then a new slot must */
/* be used. */
if ( *slot == rec_gl_endslot )
{
/* If there is insufficient space for another slot in the File Control */
/* Vector, then extend the FCV by doubling its size. If successful, */
/* initialise the new region to zero and record the new size. */
if ( *slot >= rec_gl_mxslot )
{
rec_reall_mem( rec_gl_mxslot * 2 * sizeof( struct FCV ),
(void **) &rec_ga_fcv );
if ( _ok( hds_gl_status ) )
{
(void) memset( (void *) ( rec_ga_fcv + rec_gl_mxslot ), 0,
sizeof( struct FCV ) *
(size_t) rec_gl_mxslot );
rec_gl_mxslot *= 2;
}
}
/* If OK, increment the count of FCV slots used. */
if ( _ok( hds_gl_status ) )
{
rec_gl_endslot++;
}
}
}
/* See if the file needs opening. This will be necessary if a new FCV slot */
/* is being used or if the file is currently open for read-only access and */
/* write access is now required. */
if ( _ok( hds_gl_status ) )
{
mustopen = *newslot ||
( ( mode != 'R' ) &&
( rec_ga_fcv[ *slot ].write == REC__NOIOCHAN ) );
/* If the file is to be opened... */
if ( mustopen )
{
/* VMS version: */
/* =========== */
#if defined( vms )
/* Initialise the FAB block. */
fab.fab$l_fop = FAB$M_UFO | FAB$M_NAM;
fab.fab$b_shr = FAB$M_SHRPUT | FAB$M_SHRGET | FAB$M_UPI;
fab.fab$b_fac = ( mode == 'R' ) ?
FAB$M_GET : ( FAB$M_GET | FAB$M_PUT );
/* Open the file, reporting any errors. */
systat = SYS$OPEN( &fab );
if ( !( systat & STS$M_SUCCESS ) )
{
hds_gl_status = ( systat == RMS$_PRV ) ?
DAT__FILPR : DAT__FILNF;
emsSetnc( "FILE", rsabuf, nam.nam$b_rsl );
emsSetnc( "ACCESS", ( mode == 'R' ) ?
"reading" : "writing", EMS__SZTOK );
emsSyser( "MESSAGE", systat );
emsRep( "REC1_OPEN_FILE_3",
"Unable to open file ^FILE for ^ACCESS - ^MESSAGE.",
&hds_gl_status );
}
/* If the file was opened successfully, extract its I/O channel from the */
/* FAB block. */
else
{
iochan = (int) fab.fab$l_stv;
}
/* Portable version: */
/* ================ */
#else
/* Open the file, checking for errors. */
iochan = fopen( (const char *) fns,
( mode == 'R' ) ? "rb" : "r+b");
if ( iochan == NULL )
{
/* Categorise the possible error conditions, setting the appropriate status */
/* value. */
switch ( errno )
{
case EACCES:
hds_gl_status = DAT__FILPR; /* Access denied */
break;
case EISDIR:
hds_gl_status = DAT__FILIN; /* File is a directory */
break;
case EROFS:
hds_gl_status = DAT__FILPR; /* Read-only file system */
break;
default: /* All other errors ==> */
hds_gl_status = DAT__FILNF; /* File not found */
break;
}
/* Report the error. */
emsSyser( "MESSAGE", errno );
emsSetnc( "FILE", fns, EMS__SZTOK );
emsSetnc( "ACCESS", ( mode == 'R' ) ? "read" : "read/write",
EMS__SZTOK );
emsRep( "REC1_OPEN_FILE_4",
"Error opening file ^FILE for ^ACCESS access - \
^MESSAGE",
&hds_gl_status );
}
#endif
}
}
/* If the file has been opened successfully but an old slot has been used, */
/* then simply store the new I/O channel in the slot. */
if ( _ok( hds_gl_status ) )
{
if ( mustopen )
{
if ( !*newslot )
{
rec_ga_fcv[ *slot ].write = iochan;
}
/* If a new slot is being used, fill in the File Control Vector fields, */
/* marking the slot as open. */
else
{
fcv = &rec_ga_fcv[ *slot ];
fcv->name = fns;
fcv->fid = fid;
fcv->read = ( mode == 'R' ) ? iochan : REC__NOIOCHAN;
fcv->write = ( mode == 'R' ) ? REC__NOIOCHAN : iochan;
fcv->count = 0;
fcv->dele = 0;
fcv->open = 1;
fcv->locked = 0;
fcv->hcb = NULL;
fcv->hcbmodify = 0;
}
}
}
/* If an error occurred, then deallocate any memory allocated for the File */
/* Name String and File ID. */
/* Also free the memory if we are reusing a slot (since the name is already */
/* stored and the copy is not used. */
if ( !_ok( hds_gl_status ) || !*newslot )
{
rec_deall_mem( lfns + 1, (void **) &fns );
rec_deall_mem( sizeof( struct FID ), (void **) &fid );
}
/* Exit the routine. */
return;
}
void ADIpkgRequire( char *name, int nlen, ADIstatus status )
{
ADIobj afname;
ADIobj curp = ADI_G_pkglist;
char fname[ADI_FILENAME_BUF];
FILE *fp;
ADIobj nid, nstr;
char *pptr;
ADIobj pstream;
ADIlogical there = ADI__false;
int ulen = 0, flen;
_chk_init; _chk_stat;
if ( ! ADI_G_getenv ) { /* Not got ADI_LOAD_PATH yet */
ADI_G_ldpath =
getenv( "ADI_LOAD_PATH" );
if ( ADI_G_ldpath )
ADI_G_ldpath_len = strlen( ADI_G_ldpath );
ADI_G_getenv = ADI__true;
}
/* Import name string to an ADI string */
_GET_STRING(name,nlen);
adic_newv0c_n( name, nlen, &nid, status );
/* Search existing list of loaded packages */
while ( _valid_q(curp) && ! there ) {
_GET_CARCDR(nstr,curp,curp);
there = (! strx_cmpi( nid, nstr ) );
}
/* Only load the package if not done so already */
if ( ! there ) {
/* Scan directories looking for file */
pptr = ADI_G_ldpath;
do {
int i;
flen = 0;
if ( pptr ) {
for( ;pptr[ulen] == ' ' && (ulen<ADI_G_ldpath_len) ; ulen++ )
{;}
for( ;pptr[ulen] != PATH_SEPARATOR && (ulen<ADI_G_ldpath_len) ; ulen++ )
fname[flen++] = pptr[ulen];
fname[flen++] = FILE_DELIMITER;
}
for( i=0; i<nlen; i++ )
fname[flen++] = name[i];
strcpy( fname + flen, ".adi" );
fp = fopen( fname, "r" );
if ( pptr && ! fp )
ulen++;
}
while ( pptr && (ulen<flen) && ! fp );
if ( fp ) {
/* Create name string */
adic_newv0c( fname, &afname, status );
/* Set up parser stream */
pstream = ADIstrmNew( "r", status );
ADIstrmExtendFile( pstream, afname, fp, status );
ADIcmdExec( pstream, ADI_G_curint->StdOut, status );
/* Close stream and file */
adic_erase( &pstream, status );
fclose( fp );
/* If ok mark package as loaded */
if ( _ok(status) ) {
lstx_inscel( nid, &ADI_G_pkglisti, status );
}
else
adic_setecs( *status, "Error loading package %*s", status, nlen, name );
}
else {
adic_erase( &nid, status );
adic_setecs( ADI__INVARG, "Package /%*s/ not found", status, nlen, name );
}
}
/* Release temporary string */
else {
adic_erase( &nid, status );
}
}
int rec1_unlock_slot( int slot )
{
/*+ */
/* Name: */
/* rec1_unlock_slot */
/* Purpose: */
/* Unlock a slot in the File Control Vector. */
/* Invocation: */
/* rec1_unlock_slot( slot ) */
/* Description: */
/* This function unlocks a slot in the File Control Vector, thereby */
/* allowing other users to write to the associated file. Before the file */
/* is actually unlocked, any modified Header Control Block information */
/* is written back to it, and associated blocks are removed from the */
/* Working Page List, with modified blocks being written back to the */
/* file. This flushing of cached data occurs even if the slot is not */
/* initially locked. */
/* Parameters: */
/* int slot */
/* Container file slot number in the File Control Vector. */
/* Returned Value: */
/* int rec1_unlock_slot */
/* The global status value current on exit. */
/* Notes: */
/* - This routine attempts to execute even if the HDS global status is */
/* set on entry, although no further error report will be made if it */
/* subsequently fails under these circumstances. */
/* Authors: */
/* RFWS: R.F. Warren-Smith (STARLINK) */
/* {@enter_new_authors_here@} */
/* History: */
/* 26-MAR-1991 (RFWS): */
/* Made into a separate module and added prologue. */
/* 3-APR-1991 (RFWS): */
/* Converted to attempt to execute under error conditions. */
/* 4-APR-1991 (RFWS): */
/* Changed sys_write to rec1_write_file. */
/* 16-APR-1991 (RFWS): */
/* Changed to deallocate the memory used for holding HCB information. */
/* 17-APR-1991 (RFWS): */
/* Only release the lock if all associated data were flushed */
/* successfully. */
/* 22-APR-1991 (RFWS): */
/* Report an error if the unlocking operation fails. */
/* 23-MAY-1991 (RFWS): */
/* Installed a POSIX implementation. */
/* 5-JUN-1991 (RFWS): */
/* Changed to take no action if the slot is not initially locked. */
/* 19-JUN-1991 (RFWS): */
/* Further changed to allow flushing of cached information even if */
/* the file is not locked. */
/* 28-JUN-1991 (RFWS): */
/* Added function prototype for VMS system call. */
/* 24-SEP-1991 (RFWS): */
/* Fixed bug. Modified blocks were deliberately not being written to */
/* their files if the file was marked for deletion. This was unsafe */
/* because the block might subsequently need to be re-read before the */
/* file was actually deleted. All modified blocks are now written */
/* back. */
/* 24-AUG-1992 (RFWS): */
/* Removed illegal casts, replaced with (void **) cast. */
/* 8-NOV-1993 (RFWS): */
/* Added flushing of output I/O streams in POSIX version. */
/* {@enter_further_changes_here@} */
/* Bugs: */
/* {@note_any_bugs_here@} */
/*- */
/* Local Variables: */
#if defined( vms ) /* VMS version local variables: */
unsigned int systat; /* System error code */
#elif HAVE_FCNTL /* POSIX version local variables: */
int fd; /* File descriptor */
struct flock lockbuf; /* Lock structure for fcntl */
#endif
int i; /* Loop counter for cached blocks */
int wplsize; /* Size of working page list */
struct BCP *bcp; /* Pointer to Block Control Packet */
struct BCP *flink; /* Pointer to next Block Control Packet */
struct BID bid; /* Block ID */
unsigned char buf[ REC__SZBLK ]; /* Buffer for packed HCB information */
/* External References: */
#if defined( vms ) /* VMS version system calls: */
unsigned int SYS$DEQ
( unsigned int lkid,
int valblk, /* Not used */
int acmode, /* Not used */
int flags ); /* Not used */
#endif
/*. */
/* Begin a new error reporting context. */
emsBegin( &hds_gl_status );
/* See if the file's Header Control Block information is cached. */
if ( rec_ga_fcv[ slot ].hcb != NULL )
{
/* If so, and it has been modified, then pack the HCB information into a */
/* buffer and write it back to the first block in the file. */
if ( rec_ga_fcv[ slot ].hcbmodify )
{
rec1_pack_hcb( rec_ga_fcv[ slot ].hcb, buf );
rec1_write_file( slot, 1, buf, 1 );
}
/* Reset the HCB modified flag and deallocate the memory used to hold the */
/* HCB information. */
if ( _ok( hds_gl_status ) )
{
rec_ga_fcv[ slot ].hcbmodify = 0;
rec_deall_mem( sizeof( struct HCB ),
(void **) &rec_ga_fcv[ slot ].hcb );
}
}
/* Scan through the Working Page List. */
wplsize = rec_gl_wplsize;
bcp = rec_ga_wpl;
for ( i = 0; i < wplsize; i++ )
{
flink = bcp->flink;
/* Write any modified blocks back to the container file. */
bid = bcp->bid;
if ( bid.slot == slot )
{
rec1_flush_block( bcp );
/* Deallocate the memory used to hold each block and return its Block */
/* Control Packet to the Free Page List. */
rec_deall_mem( REC__SZBLK, (void **) &bcp->bloc );
(bcp->bid).slot = 0;
(bcp->bid).bloc = 0;
bcp->count = 0;
_remque( bcp, rec_ga_wpl );
_insque( bcp, rec_ga_fpl );
rec_gl_wplsize--;
}
bcp = flink;
}
/* POSIX version: */
/* ============= */
#if !defined( vms ) /* Not required on VMS */
/* If the slot is open for writing, then we must flush the I/O stream to */
/* hand off the file handle (POSIX terminology), since the file might next */
/* be accessed by another process. */
if ( _ok( hds_gl_status ) &&
( rec_ga_fcv[ slot ].write != REC__NOIOCHAN ) )
{
/* Flush the stream, checking for errors. */
if ( fflush( rec_ga_fcv[ slot ].write ) )
{
hds_gl_status = DAT__FILWR;
rec1_fmsg( "FILE", slot );
emsSyser( "MESSAGE", errno );
emsRep( "REC1_UNLOCK_SLOT_1",
"Unable to flush written data to the file ^FILE - \
^MESSAGE",
&hds_gl_status );
}
}
void rec1_get_path( const char *fname, INT fname_len, char **path,
INT *path_len )
{
/*+ */
/* Name: */
/* rec1_get_path */
/* Purpose: */
/* Obtain a full path name for a file (UNIX & POSIX only). */
/* Invocation: */
/* rec1_get_path( fname, fname_len, path, path_len ) */
/* Description: */
/* The routine translates a file name, which may be absolute or relative */
/* and which may contain shell meta-characters, into a full path name. A */
/* default file type extension of ".sdf" is added if appropriate. */
/* Leading and trailing white space is ignored. */
/* Parameters: */
/* const char *fname */
/* Pointer to a char array containing the original file name (not */
/* null terminated). The file need not necessarily exist, although */
/* the file system will be searched to identify it if shell */
/* pattern-matching characters are included. */
/* INT fname_len */
/* Number of characters in the original file name. */
/* char **path */
/* The value of *path will be set by this routine to point at a */
/* null-terminated character string containing the fully-expanded */
/* path name for the file. This path name occupies space dynamically */
/* allocated by rec_alloc_mem. It should be deallocated by the caller */
/* (using rec_deall_mem) when no longer required. The amount of space */
/* allocated is equal to (*path_len + 1) bytes. */
/* INT *path_len */
/* Pointer to an integer which will be set to the number of */
/* characters in the expanded path name, excluding the terminating */
/* null. */
/* Returned Value: */
/* void */
/* Notes: */
/* - If the file specification contains pattern matching characters and */
/* matches more than one file, then the first match will be used. */
/* - A value of NULL will be returned in *path and a value of zero in */
/* *path_len if this routine is called with the global status set, or if */
/* it should fail for any reason. */
/* - This routine is only implemented for UNIX & POSIX systems. */
/* Copyright: */
/* Copyright (C) 1992 Science & Engineering Research Council */
/* Copyright (C) 2005 Particle Physics and Astronomy Research Council */
/* Licence: */
/* This program is free software; you can redistribute it and/or */
/* modify it under the terms of the GNU General Public License as */
/* published by the Free Software Foundation; either version 2 of */
/* the License, or (at your option) any later version. */
/* This program is distributed in the hope that it will be */
/* useful, but WITHOUT ANY WARRANTY; without even the implied */
/* warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR */
/* PURPOSE. See the GNU General Public License for more details. */
/* You should have received a copy of the GNU General Public */
/* License along with this program; if not, write to the Free */
/* Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, */
/* MA 02110-1301, USA */
/* Authors: */
/* RFWS: R.F. Warren-Smith (STARLINK, RAL) */
/* PWD: Peter W. Draper (STARLINK, Durham University) */
/* TIMJ: Tim Jenness (JAC, Hawaii) */
/* {@enter_new_authors_here@} */
/* History: */
/* 25-NOV-1992 (RFWS): */
/* Original version. */
/* 9-DEC-1992 (RFWS): */
/* Report an error if the file name is completely blank. */
/* 21-JUL-2004 (PWD): */
/* Add changes to support MinGW under Windows (no process control, */
/* plus Windows filename conventions), so that we can build */
/* shareable libraries for JNIHDS. */
/* 28-DEC-2005 (TIMJ): */
/* Use DAT__FLEXT rather than hard-coded ".sdf" */
/* {@enter_further_changes_here@} */
/* Bugs: */
/* {@note_any_bugs_here@} */
/*- */
/* Local Constants: */
#if defined( PATH_MAX )
const INT mxbuf0 = PATH_MAX; /* Initial size of file name buffer */
#else
const INT mxbuf0 = _POSIX_PATH_MAX;
#endif
/* Local Variables: */
FILE *stream; /* Stream for reading file name */
INT i; /* Loop counter for file name characters */
INT idot=0; /* Character position of last dot */
INT islash=0; /* Character position of last slash */
INT lcwd; /* Length of working directory string */
INT mxbuf=0; /* Allocated size of buffer */
INT start; /* Array index of first non-blank char */
char *buffer; /* Pointer to buffer for reading file name */
char *cwd; /* Pointer to working directory string */
char c; /* File name character read from stream */
const char *basename=NULL; /* Pointer to base file name */
int absolute; /* Absolute path name? */
int extn; /* File type extension present? */
int lbase=0; /* Number of characters in basename string */
int special=0; /* Special characters in file name? */
int stat_val; /* Shell process status information */
pid_t pid; /* ID of shell process */
#if __MINGW32__
/* Use Windows separator */
#define SLASH '\\'
#else
#define SLASH '/'
#endif
/*. */
/* Set initial null values for the returned results. */
*path = NULL;
*path_len = 0;
/* Check the inherited global status. */
if ( !_ok( hds_gl_status ) ) return;
/* Initialise. */
buffer = NULL;
pid = (pid_t) -1;
/* Modify the file name length to omit any trailing white space. */
for ( ; fname_len > 0; fname_len-- )
{
if ( !isspace( fname[ fname_len - 1 ] ) ) break;
}
/* Also strip white space from the start of the file specification. */
for ( start = 0; start < fname_len; start++ )
{
if ( !isspace( fname[ start ] ) ) break;
}
/* If the file name is completely blank, then report an error. */
if ( start == fname_len )
{
hds_gl_status = DAT__FILNF;
emsRep( "REC_GET_PATH_1",
"Invalid blank file name given.",
&hds_gl_status );
}
/* Scan the file name, classifying the characters that appear in it. */
else
{
idot = islash = special = 0;
for ( i = start; i < fname_len; i++ )
{
switch ( fname[ i ] )
{
/* Note where the last dot '.' occurs. */
case '.':
idot = i + 1;
break;
/* Note where the last slash '/' occurs. */
case SLASH:
islash = i + 1;
break;
/* Underscore '_' and hyphen '-' are portable file name characters, so take */
/* no action on these. */
case '_':
case '-':
break;
/* If any other characters which are not in the POSIX.1 portable filename */
/* character set are encountered, then note that the file name contains */
/* special characters. */
default:
if ( !isalnum( fname[ i ] ) )
{
special = 1;
}
break;
}
}
}
/* Ignore the possible presence of special characters if the HDS__SHELL */
/* tuning parameter specifies that shell expansion of such characters is */
/* not to occur. */
#if __MINGW32__
/* MinGW doesn't offer a shell facility so make sure it is disabled */
hds_gl_shell = HDS__NOSHELL;
special = 0;
#else
if ( hds_gl_shell == HDS__NOSHELL ) special = 0;
#endif
/* If there are no speciaal characters present, then the file name can be */
/* used as the basis of the full path name, without further translation. */
if ( !special )
{
basename = fname + start;
/* Note if a file type extension is present, as indicated by a dot '.' in */
/* the final field of the file name (i.e. after the last slash '/'). Find */
/* how much of the file name must be used after omitting exactly one final */
/* dot '.', if present (it is a general rule in HDS that this operation is */
/* performed on file names before use). */
extn = ( idot > islash );
lbase = fname_len - start - ( idot == fname_len );
}
/* If special characters are present in the file name, then we must use a */
/* shell process to interpret them. We only do this if it is really */
/* necessary, since it is slower. Note that file extension information will */
/* be handled and start a shell process for finding files. */
else
{
extn = 1;
rec1_find_file( fname + start, fname_len - start, &pid, &stream );
if ( _ok( hds_gl_status ) )
{
/* Allocate initial space for a buffer to hold the expanded file name. */
rec_alloc_mem( mxbuf0, (void **) &buffer );
if ( _ok( hds_gl_status ) ) mxbuf = mxbuf0;
/* Read the name of the first file found. Loop to read characters one at a */
/* time and append them to the file name until an error or end of file */
/* occurs, or a blank character is read. */
lbase = 0;
while ( _ok( hds_gl_status ) )
{
(void) fread( (void *) &c, sizeof( char ), (size_t) 1,
stream );
/* If an error occurs, then report it and quit reading. */
if ( ferror( stream ) )
{
hds_gl_status = DAT__FATAL;
emsSyser( "MESSAGE", errno );
emsRep( "REC_GET_PATH_2",
"Error reading file names from stream attached \
to shell process - ^MESSAGE",
&hds_gl_status );
break;
}
/* If an end of file occurs, or a blank character is read, then we have */
/* reached the end of the file name, so quit reading. */
else if ( feof( stream ) || isspace( c ) )
{
break;
}
/* The character just read must now be appended to the file name. Check */
/* that the file name buffer is large enough to hold it. If not, then */
/* extend the buffer by doubling its length and record its new size. */
if ( lbase >= mxbuf )
{
rec_reall_mem( mxbuf * 2, (void **) &buffer );
if ( _ok( hds_gl_status ) )
{
mxbuf *= 2;
}
}
/* If OK, append the character to the file name. */
if ( _ok( hds_gl_status ) )
{
buffer[ lbase++ ] = c;
}
}
/* If no file name characters were read, then there was no file name match, */
/* so report an error. */
if ( lbase == 0 )
{
hds_gl_status = DAT__FILNF;
emsSetnc( "FILE", fname + start, fname_len - start );
emsRep( "REC_GET_PATH_3",
"No files found matching the file specification \
\'^FILE\'.",
&hds_gl_status );
}
/* Close the stream and check for errors. Do this inside a new error */
/* reporting environment, since we may be cleaning up after a previous */
/* error. */
emsBegin( &hds_gl_status );
if ( fclose ( stream ) != 0 )
{
hds_gl_status = DAT__FATAL;
emsSyser( "MESSAGE", errno );
emsRep( "REC_GET_PATH_4",
"Error closing stream used to read file names from \
a shell process - ^MESSAGE",
&hds_gl_status );
}
ADIobj adix_prs_try( int narg, ADIobj args[], ADIstatus status )
{
ADIobj pstream = args[0];
int choice; /* Keyword choice */
ADIlogical first = ADI__true; /* First time through complex loop? */
ADIlogical more = ADI__true; /* More ELSE clauses */
ADIobj robj = ADI__nullid; /* Returned object */
ADIobj action; /* Action procedure */
ADIobj *ipoint = &robj; /* List insertion point */
/* Skip the TRY keyword */
ADInextToken( pstream, status );
/* End of line with TRY on it */
ADImatchToken( pstream, TOK__END, status );
/* Get actions which might trigger exceptions */
action = adix_prs_cmdlist( pstream, "|catch|finally|endtry", &choice, status );
lstx_inscel( action, &ipoint, status );
/* While more clauses*/
do {
/* Command list */
action = adix_prs_cmdlist( pstream, "|catch|finally|endtry", &choice, status );
}
while ( more && _ok(status) );
/* There are 2 forms of 'if' statement. The simple form is simply
*
* if ( expr ) statement
*
* which is trapped here on the presence of the 'then' keyword.
*/
if ( ADIisTokenCstring( pstream, "then", status ) ) {
/* While more if..else if..endif clauses */
while ( _ok(status) && more ) {
/* Get the conditional expression unless the first time through */
if ( first )
first = ADI__false;
else {
ADImatchToken( pstream, TOK__LPAREN, status );
lstx_inscel( ADIparseExpInt( pstream, ADI__nullid, 1, status ), &ipoint, status );
ADImatchToken( pstream, TOK__RPAREN, status );
}
/* Skip the 'then' token if present */
if ( ADIisTokenCstring( pstream, "then", status ) ) {
ADInextToken( pstream, status );
ADImatchToken( pstream, TOK__END, status );
}
else
ADIparseError( pstream, ADI__SYNTAX, "THEN keyword expected", status );
/* Append truth action list */
lstx_inscel( adix_prs_cmdlist( pstream, "|else|endif", &choice, status ),
&ipoint, status );
if ( _ok(status) ) {
/* Match the ELSE or ENDIF */
ADInextToken( pstream, status );
/* The keyword was ELSE */
if ( choice == 1 ) {
if ( ADIcurrentToken(pstream,status) == TOK__SYM ) {
if ( ADIisTokenCstring( pstream, "if", status ) )
ADInextToken( pstream, status );
else
ADIparseError( pstream, ADI__SYNTAX,
"Illegal token - can only be IF () THEN or end of line at this point", status );
}
else {
/* Terminal ELSE clause */
ADImatchToken( pstream, TOK__END, status );
lstx_inscel( adix_prs_cmdlist( pstream, "|endif", &choice, status ),
&ipoint, status );
/* Match the "endif" */
ADInextToken( pstream, status );
more = ADI__false;
}
}
/* The keyword was ENDIF. Flag end of loop */
else
more = ADI__false;
}
}
}
else {
/* Parse a single statement, and put into the action list */
action = lstx_cell( adix_prs_cmd( pstream, status ), ADI__nullid, status );
/* Add action list to output args */
lstx_inscel( action, &ipoint, status );
}
/* Return the expression tree */
return ADIetnNew( adix_clone( K_Try, status ), robj, status );
}
int dat1_alloc_lcp( struct LOC **loc, struct LCP **lcp )
{
/*+ */
/* Name: */
/* dat1_alloc_lcp */
/* Purpose: */
/* Allocate a Locator Control Packet and initialise a locator. */
/* Invocation: */
/* dat1_alloc_lcp( loc, lcp ) */
/* Description: */
/* This function allocates a new Locator Control Packet (LCP) to control */
/* user access to an HDS object and initialises a locator, thereby */
/* associating it with the allocated LCP. */
/* Parameters: */
/* struct LOC **loc */
/* Pointer to a pointer to a struct LOC that is to be filled with the */
/* locator information. Will be malloced by this routine and freed */
/* with a datAnnul. *loc Must be NULL on entry. */
/* struct LCP **lcp */
/* Pointer to a pointer which will be set to identify the */
/* newly-allocated LCP. A null pointer will be returned in *lcp if */
/* this routine is invoked with the global status set, or if it */
/* should fail for any reason. */
/* Returned Value: */
/* int dat1_alloc_lcp */
/* The global status value current on exit. */
/* Notes: */
/* The returned LCP will have its data fields and "primary locator" flag */
/* initialised to zero. Its sequence number will be set to match that of */
/* the locator. */
/* Copyright: */
/* Copyright (C) 1992 Science & Engineering Research Council */
/* Copyright (C) 2005-2006 Particle Physics and Astronomy Research Council */
/* Authors: */
/* RFWS: R.F. Warren-Smith (STARLINK) */
/* TIMJ: T. Jenness (JAC, Hawaii) */
/* {@enter_new_authors_here@} */
/* History: */
/* 14-OCT-1992 (RFWS): */
/* Substantially new routine based on old original. */
/* 15-NOV-2005 (TIMJ): */
/* Change API to use the struct LOC explcitly */
/* 23-FEB-2006 (TIMJ): */
/* use rec_alloc_mem */
/* {@enter_changes_here@} */
/* Bugs: */
/* {@note_any_bugs_here@} */
/*- */
/* Local Variables: */
/*. */
/* Set an initial null value for the returned LCP pointer. */
*lcp = NULL;
/* Check the inherited global status. */
if ( !_ok( hds_gl_status ) ) return hds_gl_status;
/* Check that the locator is NULL */
if (*loc != NULL ) {
hds_gl_status = DAT__LOCIN;
emsRep( "DAT1_ALLOC_LCP",
"Supplied locator is not a NULL pointer (Possible programming error)",
&hds_gl_status);
return hds_gl_status;
}
/* Ensure that HDS has been initialised. */
if ( !hds_gl_active )
{
dat1_init( );
}
/* If the Free Locator Queue is empty, then refill it. */
if ( dat_ga_flq == NULL )
{
dau_refill_flq( );
}
/* Allocate a new LCP from the free queue. */
if( _ok( hds_gl_status ) )
{
*lcp = dat_ga_flq;
_remque( *lcp, dat_ga_flq );
/* Clear the LCP data fields and the primary LCP flag. */
(void) memset( (void *) &(*lcp)->data, 0, sizeof( struct LCP_DATA ) );
(*lcp)->primary = 0;
/* Insert the LCP at the head of the Working Locator Queue and increment */
/* the Queue size. */
_insque( *lcp, dat_ga_wlq );
dat_gl_wlqsize++;
/* Initialise the locator information, including the locator sequence */
/* number which is duplicated in the LCP. */
if (rec_alloc_mem( sizeof(struct LOC), (void**)loc ) == DAT__OK) {
(*loc)->check = DAT__LOCCHECK;
(*loc)->lcp = *lcp;
(*loc)->seqno = (*lcp)->seqno = ++hds_gl_locseq;
}
}
/* Exit the routine. */
return hds_gl_status;
}
int rec_get_handle( const struct RID *rid, const struct HAN *kin,
struct HAN *han )
{
/*+ */
/* Name: */
/* rec_get_handle */
/* Purpose: */
/* Obtain a handle for a record in a container file. */
/* Invocation: */
/* rec_get_handle( rid, kin, han ) */
/* Description: */
/* This function returns a handle for a record in a container file whose */
/* record ID is known. A handle for another record in the same file must */
/* also be supplied. */
/* Parameters: */
/* const struct RID *rid */
/* Pointer to a RID structure containing the record ID for the */
/* record. */
/* const struct HAN *kin */
/* Pointer to a HAN structure containing a handle for any other */
/* record in the same container file. */
/* struct HAN *han */
/* Pointer to a HAN structure in which the new handle will be */
/* returned. */
/* Returned Value: */
/* int rec_get_handle */
/* The global status value current on exit. */
/* Authors: */
/* RFWS: R.F. Warren-Smith (STARLINK) */
/* BKM: B.K, McIlwrath (STARLINK) */
/* {@enter_new_authors_here@} */
/* History: */
/* 14-APR-1991 (RFWS): */
/* Added prologue and error handling and tidied. */
/* 19-APR-2004 (BKM): */
/* Revise for 64-bit HDS files. */
/* {@enter_changes_here@} */
/* Bugs: */
/* {@note_any_bugs_here@} */
/*- */
/* Local Variables: */
struct RCL rcl;
/*. */
/* Check the inherited global status. */
if ( !_ok( hds_gl_status ) ) return hds_gl_status;
/* Copy the File Control Vector slot number and read flag from the handle */
/* supplied and insert the record ID into the new handle. */
han->slot = kin->slot;
han->read = kin->read;
han->rid = *rid;
rec_get_rcl(han, &rcl);
/* Return the current global status value. */
return hds_gl_status;
}
void rec_wild_file( const char *fspec, INT fspec_len, struct WLD **context,
int *alldone, char **fname, INT *fname_len )
{
/*+ */
/* Name: */
/* rec_wild_file */
/* Purpose: */
/* Return successive file names matching a wild-card file specification. */
/* Invocation: */
/* rec_wild_file( fspec, fspec_len, context, alldone, fname, fname_len ) */
/* Description: */
/* On the first invocation (when *context is NULL), the routine searches */
/* the host file system for files matching the supplied wild-card file */
/* specification and allocates a struct WLD structure to contain the */
/* resulting list of file names. A pointer to the allocated structure, a */
/* pointer to the first file name and the associated file name length */
/* are returned. On subsequent invocations (when a pointer to a */
/* previously-allocated struct WLD structure is supplied in *context), */
/* the routine simply returns a pointer to the next file name (together */
/* with its length) as stored within the structure. The *alldone flag is */
/* set if no more file names remain. */
/* Parameters: */
/* const char *fspec */
/* Pointer to a char array containing the wild-card file */
/* specification (not null terminated). The syntax depends on the */
/* host operating system. Leading and trailing white space is */
/* ignored. */
/* INT fspec_len */
/* Length of the array holding the wild-card file specification. */
/* struct WLD **context */
/* If *context is NULL on entry, then a new search is initiated and a */
/* pointer to the newly-allocated search context structure is */
/* returned in *context. Otherwise, *context is used to supply a */
/* pointer to a previously-allocated search contect structure from */
/* which the next file name will be returned. The context structure */
/* supplied will be validated to ensure that it was created by a */
/* previous invocation of this routine. */
/* int *alldone */
/* If no more file names remain to be returned, then *alldone will be */
/* set to 1, otherwise it will be set to 0. */
/* char **fname */
/* If the routine returns successfully with *alldone is set to zero, */
/* then *fname will return a pointer to a null-terminated character */
/* string containing the name of the next file matching the wild-card */
/* file specification. This will be a pointer into memory managed by */
/* the search context structure and should not be modified or */
/* deallocated by the caller of this routine. */
/* INT *fname_len */
/* Pointer to an integer to receive the length of the file name */
/* pointed at by *fname (excluding the terminating null). */
/* Returned Value: */
/* void */
/* Notes: */
/* - The files identified by this routine are checked to ensure that */
/* they exist at the time of the initial invocation (when *context is */
/* supplied as NULL on entry). It is not guaranteed that they will also */
/* be accessible (i.e. readable or writable), nor that they will still */
/* exist at the time their names are returned from a previously-created */
/* context structure by subsequent invocations of the routine. */
/* - All memory allocated by this routine is managed via information */
/* stored in the search context structure pointed at by *context. It */
/* should only be deallocated via a call to the routine rec_end_wild, */
/* which should always be used to terminate a wild-card search when it */
/* is complete. */
/* Copyright: */
/* Copyright (C) 1992 Science & Engineering Research Council */
/* Copyright (C) 2005 Particle Physics and Astronomy Research Council */
/* Licence: */
/* This program is free software; you can redistribute it and/or */
/* modify it under the terms of the GNU General Public License as */
/* published by the Free Software Foundation; either version 2 of */
/* the License, or (at your option) any later version. */
/* This program is distributed in the hope that it will be */
/* useful, but WITHOUT ANY WARRANTY; without even the implied */
/* warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR */
/* PURPOSE. See the GNU General Public License for more details. */
/* You should have received a copy of the GNU General Public */
/* License along with this program; if not, write to the Free */
/* Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, */
/* MA 02110-1301, USA */
/* Authors: */
/* RFWS: R.F. Warren-Smith (STARLINK, RAL) */
/* TIMJ: Tim Jenness (JAC, Hawaii) */
/* {@enter_new_authors_here@} */
/* History: */
/* 17-NOV-1992 (RFWS): */
/* Original version. */
/* 9-DEC-1992 (RFWS): */
/* Report an error if the file specification is completely blank. */
/* 28-DEC-2005 (TIMJ): */
/* Use DAT__FLEXT rather than hard-coded ".SDF" */
/* 4-MAR-2006 (TIMJ): */
/* Use emsSetp to create pointer value error token */
/* {@enter_further_changes_here@} */
/* Bugs: */
/* {@note_any_bugs_here@} */
/*- */
/* Local Macros: */
#if defined( vms ) /* VMS version local macros: */
#define SZFIL 512 /* Maximum size of a file name */
#endif
/* Local Constants: */
const INT mxlist0 = 64; /* Initial size of file name list */
#if defined( vms ) /* VMS version local constants: */
/* None required */
#else /* Portable version local constants: */
#if defined( PATH_MAX )
const INT mxbuf0 = PATH_MAX + 1; /* Initial size of file name buffer */
#else
const INT mxbuf0 = _POSIX_PATH_MAX + 1;
#endif
#endif
/* Local Variables: */
#if defined( vms ) /* VMS version local variables: */
INT lname; /* Number of characters in file name */
INT nfile; /* Number of file names found */
char *mem; /* Pointer to allocated memory */
char buffer[ SZFIL ]; /* Buffer for returned file name */
struct dsc$descriptor def; /* Descriptor for default file spec */
struct dsc$descriptor filespec; /* Descriptor for file specification */
struct dsc$descriptor result; /* Descriptor for resultant file name */
unsigned int ictx; /* LIB$FIND_FILE context value */
unsigned int systat; /* System status code */
#else /* Portable version local variables: */
FILE *stream; /* Stream for reading file names */
INT lcwd; /* Length of working directory string */
INT lname; /* Length of full file name */
INT mxbuf=0; /* Allocated size of buffer */
INT nfile; /* Number of file names found */
char *buffer; /* Pointer to buffer for reading file name */
char *cwd; /* Pointer to working directory string */
char *mem; /* Pointer to allocated memory */
char c; /* Character read from pipe */
int absolute; /* Absolute path name obtained? */
int lbase; /* Number of characters in base file name */
int stat_val; /* Shell process status information */
pid_t pid; /* ID of shell process */
#endif
INT current; /* Current file name index */
INT start; /* Array offset of first non-blank char */
int again; /* Loop again? */
int valid; /* Wild-card context ID valid? */
struct WLD *next; /* Next wild-card context in queue */
struct WLD *qpntr; /* Pointer into wild-card context queue */
/* External References: */
#if defined( vms ) /* VMS version system routines: */
unsigned int LIB$FIND_FILE /* Perform wild-card file search */
( struct dsc$descriptor *filespec,
struct dsc$descriptor *result,
unsigned int *context,
struct dsc$descriptor *defspec,
struct dsc$descriptor *relspec,
unsigned int *rmsstat,
unsigned int *flags );
unsigned int LIB$FIND_FILE_END /* End wild-card file search */
( unsigned int *context );
#endif
/*. */
/* Check the inherited global status. */
if ( !_ok( hds_gl_status ) ) return;
/* Validate an existing context. */
/* ============================ */
/* If the wild-card search context supplied was not null, then loop to */
/* validate it by comparing it with each context currently on the wild-card */
/* context queue. */
if ( *context != NULL )
{
valid = 0;
again = 1;
for( qpntr = rec_gl_wldque; again; qpntr = next )
{
/* Quit testing if a match is found. */
if ( qpntr == *context )
{
valid = 1;
break;
}
/* Otherwise return to test against the next queue element, so long as we */
/* have not yet returned to the head of the queue. */
next = qpntr->flink;
again = ( next != rec_gl_wldque );
}
/* If no match was found, then report an error. */
if ( !valid )
{
hds_gl_status = DAT__WLDIN;
emsSetp( "IWLD", *context );
emsRep( "REC_WILD_FILE_1",
"Wild-card search context identifier is invalid; value \
is ^IWLD (possible programming error).",
&hds_gl_status );
}
int
hdsState( int *state,
int *status)
{
/*
*+
* Name:
* HDS_STATE
* Purpose:
* Enquire the current state of HDS.
* Language:
* ANSI C
* Invocation:
* CALL HDS_STATE( STATE, STATUS )
* Description:
* This routine returns a logical value indicating whether HDS is
* currently active or inactive.
* Arguments:
* STATE = LOGICAL (Returned)
* The current state of HDS: .TRUE. for active, .FALSE. for
* inactive.
* STATUS = INTEGER (Given and Returned)
* The global status.
* Authors:
* RFWS: R.F. Warren-Smith (STARLINK, RAL)
* BKM: B.K. McIlwrath (STARLINK, RAL)
* {enter_new_authors_here}
* History:
* 4-APR-1991 (RFWS):
* Added prologue and made portable.
* 6-AUG-1991 (RFWS):
* Changed to handle TRUE/FALSE correctly on all machines.
* 13-DEC-2001 (BKM)
* Convert to a C function with FORTRAN wrapper.
* {enter_further_changes_here}
* Bugs:
* {note_any_bugs_here}
*-
*/
/*. */
/* Check the inherited global status. */
if ( !_ok( *status ) )
return *status;
/* Check if HDS is active. */
*state = hds_gl_active ? TRUE : FALSE;
/* Exit the routine. */
return *status;
}
int main(int argc, char** argv)
{
int nerrs = 0;
int testi;
float testf;
double testd;
dat1_init();
if (!_ok(hds_gl_status)) {
fprintf(stderr, "Can't initialise HDS\n");
exit (1);
}
#define stringize(x) # x
#define testval_prm(ifd, prefix, NUM, num, type) \
if (prefix ## __ ## NUM ## type != dat_gl_ndr[DAT__ ## type].num.type) { \
test ## ifd = prefix ## __ ## NUM ## type; \
printf(stringize(prefix ## __ ## NUM ## type) ": %s", \
tohex(stringize(ifd), (byte*)&test ## ifd)); \
printf(" != %s\n", \
tohex(stringize(ifd), \
(byte*)&dat_gl_ndr[DAT__ ## type].num.type)); \
nerrs++; \
}
#define testval(ifd, prefix, NUM, num, type) \
if (prefix ## __ ## NUM ## type != dat_gl_ndr[DAT__ ## type].num) { \
test ## ifd = prefix ## __ ## NUM ## type; \
printf(stringize(prefix ## __ ## NUM ## type) ": %s", \
tohex(stringize(ifd), (byte*)&test ## ifd)); \
printf(" != %s\n", \
tohex(stringize(ifd), \
(byte*)&dat_gl_ndr[DAT__ ## type].num)); \
nerrs++; \
}
/*
* Compare values in prm_par.h against the values in the struct
* NDR, as initialised by dat1_init_ndr.c. Excerpts:
*
* union PRM
* {
* _BYTE B;
* _DOUBLE D;
* _INTEGER I;
* _LOGICAL L;
* _REAL R;
* _UBYTE UB;
* _UWORD UW;
* _WORD W;
* _CHAR C;
* };
* struct NDR
* {
* union PRM bad; -- "Bad" data value
* union PRM max; -- Maximum value
* union PRM min; -- Minimum (most negative) value
* const char *name; -- Pointer to data type name
* unsigned short int length; -- Size of data element
* unsigned char format; -- Data format code
* unsigned char order; -- Storage order code
* unsigned char digits; -- No. decimal digits of precision
* unsigned char txtsize; -- Characters required for formatting
* };
*
* Some prm_par.h settings have no analogue in NDR:
* val__eps -- Machine precision
* val__max -- Maximum (most positive) non-bad value
* val__min -- Minimum (most negative) non-bad value
* val__sml -- Smallest positive value
*/
/* Bad values, used for flagging undefined data. */
testval_prm(i, VAL, BAD, bad, UB);
testval_prm(i, VAL, BAD, bad, B);
testval_prm(i, VAL, BAD, bad, UW);
testval_prm(i, VAL, BAD, bad, W);
testval_prm(i, VAL, BAD, bad, I);
testval_prm(f, VAL, BAD, bad, R);
testval_prm(d, VAL, BAD, bad, D);
/* Maximum (most positive) number */
testval_prm(i, NUM, MAX, max, UB);
testval_prm(i, NUM, MAX, max, B);
testval_prm(i, NUM, MAX, max, UW);
testval_prm(i, NUM, MAX, max, W);
testval_prm(i, NUM, MAX, max, I);
testval_prm(f, NUM, MAX, max, R);
testval_prm(d, NUM, MAX, max, D);
/* Minimum (most negative) number */
testval_prm(i, NUM, MIN, min, UB);
testval_prm(i, NUM, MIN, min, B);
testval_prm(i, NUM, MIN, min, UW);
testval_prm(i, NUM, MIN, min, W);
testval_prm(i, NUM, MIN, min, I);
testval_prm(f, NUM, MIN, min, R);
testval_prm(d, NUM, MIN, min, D);
/* Number of basic machine units (bytes) used by a value. */
testval(i, VAL, NB, length, UB);
testval(i, VAL, NB, length, B);
testval(i, VAL, NB, length, UW);
testval(i, VAL, NB, length, W);
testval(i, VAL, NB, length, I);
testval(i, VAL, NB, length, R);
testval(i, VAL, NB, length, D);
/* Number of characters required to format value as decimal string. */
testval(i, VAL, SZ, txtsize, UB);
testval(i, VAL, SZ, txtsize, B);
testval(i, VAL, SZ, txtsize, UW);
testval(i, VAL, SZ, txtsize, W);
testval(i, VAL, SZ, txtsize, I);
testval(i, VAL, SZ, txtsize, R);
testval(i, VAL, SZ, txtsize, D);
exit(nerrs);
}
void dat1_cvt_order( UINT_BIG nval, const struct PDD *imp, struct PDD *exp,
int *status )
{
/*+ */
/* Name: */
/* dat1_cvt_order */
/* Purpose: */
/* Convert the (byte) storage order of primitive data. */
/* Invocation: */
/* dat1_cvt_order( nval, imp, exp, status ) */
/* Description: */
/* This function reverses the order of characters (bytes) in each */
/* element of an array of primitive input data as part of converting */
/* between number representations on different machines. */
/* Parameters: */
/* UINT_BIG nval */
/* Number of data elements to be processed. */
/* const struct PDD *imp */
/* Pointer to a PDD descriptor for the array of input data. */
/* struct PDD *exp */
/* Pointer to a PDD descriptor for the array to receive the output */
/* data. */
/* int *status */
/* The inherited global status. */
/* Returned Value: */
/* void */
/* Notes: */
/* - This function will execute if *status is OK on input or if it is */
/* set to DAT__CONER (indicating a previous conversion error). */
/* Authors: */
/* RFWS: R.F. Warren-Smith (STARLINK) */
/* {@enter_new_authors_here@} */
/* History: */
/* 1-JUL-1991 (RFWS): */
/* Original version. */
/* 22-JUL-1991 (RFWS): */
/* Changed to use struct PDD descriptors as arguments. */
/* 26-JUL-1991 (RFWS); */
/* Changed to allow execution if status is set to DAT__CONER on */
/* entry. */
/* 20-NOV-2015 (DSB): */
/* Change nval from int to UNIT_BIG. */
/* {@enter_further_changes_here@} */
/* Bugs: */
/* {@note_any_bugs_here@} */
/*- */
/* Local Variables: */
UINT_BIG i; /* Loop counter for groups of chars */
int j; /* Loop counter for chars within groups */
int nswap; /* Number of characters to swap */
unsigned char *in; /* Pointer to input array */
unsigned char *out; /* Pointer to output array */
/*. */
/* Check the inherited global status. Allow the routine to execute if */
/* status is set to DAT__CONER indicating a previous conversion error. */
if ( !( _ok( *status ) || ( *status == DAT__CONER ) ) ) return;
/* Obtain pointers to the input and output data arrays and determine the */
/* number of characters to be swapped. */
in = imp->body;
out = exp->body;
nswap = imp->length;
/* Test for common special values of nswap. */
switch ( nswap )
{
/* If nswap is 1, simply copy the characters. */
case 1:
memcpy( (void *) out, (void *) in, nval * nswap );
break;
/* If nswap is two, loop to swap characters in pairs. */
case 2:
for ( i = 1; i < nval * nswap; i += 2 )
{
out[ i - 1 ] = in[ i ];
out[ i ] = in[ i - 1 ];
}
break;
/* If nswap is four, loop to swap characters in groups of 4. */
case 4:
for ( i = 3; i < nval * nswap; i += 4 )
{
out[ i - 3 ] = in[ i ];
out[ i - 2 ] = in[ i - 1 ];
out[ i - 1 ] = in[ i - 2 ];
out[ i ] = in[ i - 3 ];
}
break;
/* If nswap is eight, loop to swap characters in groups of 8. */
case 8:
for ( i = 7; i < nval * nswap; i += 8 )
{
out[ i - 7 ] = in[ i ];
out[ i - 6 ] = in[ i - 1 ];
out[ i - 5 ] = in[ i - 2 ];
out[ i - 4 ] = in[ i - 3 ];
out[ i - 3 ] = in[ i - 4 ];
out[ i - 2 ] = in[ i - 5 ];
out[ i - 1 ] = in[ i - 6 ];
out[ i ] = in[ i - 7 ];
}
break;
/* For other values of nswap, cater for the general case. This involves an */
/* extra loop. */
default:
for ( i = nswap - 1; i < nval * nswap; i += nswap )
{
for ( j = 0; j < nswap; j++ )
{
out[ i - j ] = in[ i + j - ( nswap - 1 ) ];
}
}
break;
}
/* Exit the routine. */
return;
}
int rec_get_rcl( const struct HAN *han, struct RCL *rcl )
{
/*+ */
/* Name: */
/* rec_get_rcl */
/* Purpose: */
/* Read a Record Control Label from a container file record. */
/* Invocation: */
/* rec_get_rcl( han, rcl ) */
/* Description: */
/* This function reads and unpacks the contents of the Record Control */
/* Label held in the Control Domain of a container file record for which */
/* a handle is supplied. The information is returned in an RCL */
/* structure. */
/* Parameters: */
/* const struct HAN *han */
/* Pointer to a HAN structure containing a handle for the required */
/* record. */
/* struct RCL *rcl */
/* Pointer to an RCL structure in which the unpacked Record Control */
/* Label information will be returned. */
/* Returned Value: */
/* int rec_get_rcl */
/* The global status value current on exit. */
/* Authors: */
/* RFWS: R.F. Warren-Smith (STARLINK) */
/* {@enter_new_authors_here@} */
/* History: */
/* 2-APR-1991 (RFWS): */
/* Added prologue and changed to unpack the information. */
/* 16-APR-1991 (RFWS): */
/* Eliminated unnecessary local variables and improved error */
/* handling. */
/* {@enter_further_changes_here@} */
/* Bugs: */
/* {@note_any_bugs_here@} */
/*- */
/* Local Variables: */
unsigned char *cdom; /* Pointer to LRB Control Domain */
unsigned char *lrb; /* Pointer to Logical Record Block */
/*. */
/* Check the inherited global status. */
if ( !_ok( hds_gl_status ) ) return hds_gl_status;
/* Find the Logical Record Block which contains the required record. */
rec_locate_block( han->slot, han->rid.bloc, 'R', &lrb );
/* Locate the record's Control Domain and unpack the Record Control Label. */
cdom = lrb + REC__SZCBM + ( han->rid.chip * REC__SZCHIP );
rec1_unpack_rcl( cdom, rcl );
/* Release the Logical Record Block. */
if ( lrb != NULL ) rec_release_block( han->slot, han->rid.bloc );
/* Return the current global status value. */
return hds_gl_status;
}
