include include include include include include include "bu_obj.h" # Constants define MAX_DIM 7 define MAX_RECURSE 20 # Memory management. define Xp Memr[xp+$1-1] define Yp Memr[yp+$1-1] #--------------------------------------------------------------------------- .help bu_obj Jan95 source .ih NAME bu_obj -- Unpack sub-word level information from integer array. .ih DESCRIPTION The Bit Unpack (BU) object handles retrieving, manipulating, and storing of values that come from non-canonical storage structures: i.e. arrays containing data represented by single bits or a small number of bits which are packed into standard integer arrays. Though this was the design goal, the actual algorithm implemented is actually much more general. .ls CONCEPT The basic goal is to find the value of an 'item'. An 'item' is a piece of information in some way encoded into an integer array. This item may just be an integer some offset into the array, a single bit located somewhere in the array, or some multiple set of bits contained within a single integer word, or spanning several words. The original data which contains the encoded value is referred to as the "parent data". To determine the value of the item, it must be decoded, or "extracted" from the parent data. By applying some 'extract' expression, the parent array is transformed, producing the value of the desired item. The item itself may contain encoded information, i.e. the "value" is not necessarily the numerical quantity that the item is equal to. By using a 'format' expression, the value of the item can be (optionally) transformed into a yet more appropriate value. The entire process can be represented by the formulation: .nf item value = format (extract (parent data)) .fi Technically, there is no mathematical reason why two functions, 'extract' and 'format', need be separate; they can be combined into a single function. However, for the specific application developed here, to get values from a bit-packed array, there is a practical reason which is discussed below. .le .ls EXAMPLE PROBLEM The specific problem this object was created was to get items out of bit-packed arrays. An example of such an array is in Hubble Space Telescope (HST) data from the Goddard High Resolution Spectrograph (GHRS). One of the "images" which represents an observation from the GHRS is called the Unique Data Log (UDL). This image is a bit-packed array containing commanding information used to operate the GHRS. Some of the words in the one-dimensional image array are filled with bit-flags indicating status of lamps, shutters, and operation steps. Other words simply contain integer values, while others contain a number of 2, 3, or 4 bit items packed into a single or multiple words. It is necessary to extract these values to be examined by observers, or for programs to key off of. This is why there is a two-step process. For use in calculations and programs, it is simply enough to extract the right bits and create an integer out of it. However, for human examination, the fact that a bit flag is 0 or 1 is still fairly meaningless. Hence, another function is needed, the 'format' expression, to take this numerical information and make it "more meaningful", i.e. to transform 0 and 1 to "off" and "on" or "open" and "closed". .le .ls EXPRESSION DEFINITION The expressions to extract and format items are specified in a "definition file". This file is an IRAF Text DataBase as implemented in the code "dttext.x". See the IRAF xtools$ directory for the source. The format of this definition file is a text file. Each item is defined by a series of lines. The format of each item definition is as follows: .nf begin item_name extract extract_expression format format_expression units units_description descrip general_description .fi An item begins with a line that has "begin" followed by the name of the item. An item name can be anything, as long as it is no more than 19 characters (SZ_COLNAME from tables) long. The following lines define the separate "fields" of the item definition. They can appear in any order and do not all need to be defined. Each line can be up to 1023 characters long (SZ_COMMAND). The fields are as follows: .ls extract The extract expression is found by a line beginning with the word "extract" followed by an arbitrary expression used to extract the item's value from the parent data. .le .ls format The format expression is found by a line beginning with the word "format" followed by an arbitrary expression used to 'format' the item's value. .le .ls units The units field, defined by a line beginning with the word "units", is used when writing a BU object out to a table. The value of the units field is placed in the column's "units" descriptor. The length of the units field should be no more than 19 characters (SZ_COLUNITS). .le .ls descrip The descrip field, defined by a line beginning with the word "descrip", simply contains a description of the item. Currently, the BU object makes no use of this field. .le .le .ls EXPRESSIONS The 'extract' and 'format' expressions are simple mathematical functions which define a formula for transforming values. The expressions are evaluated by the IRAF 'evexpr' interface. See the code evexpr.x in sys$fmtio for more information about this interface. The BU object defines two variables for use in the expression. The first is 'd[i]'. This variable has the value of the i'th element of the parent data array. This is generally used in the 'extract' expression, but can be used in the 'format' expression. The second variable, 'v', can only be used in the 'format' expression. It contains the value of the item after it has been extracted. See the example entries above for examples. Other items found in a definition file may also be used as variables in an expression. When an item name appears in an expression, its value will be the result of that item's "extract" expression. Care must be taken to avoid recursive or circular definitions. The code will abort at around 20 recursions to avoid infinite loops caused by such definitions. There are also a number of additional functions provided to help make bit extraction a bit easiear. See the help for the function "bu_functions" below for a more detailed description. The functions are as follows: .nf and -- Bitwise-AND two arguments together lin -- Linear interpolations shift -- Bitwise-SHIFT a value switch -- Based on the value of the first argument, return one of the subsequent arguments. word_find -- Based on the value of the first argument, return that word in the space/comma separated word list in the second argument. .fi .le .ls BU OBJECT The memory structure which defines the BU object is found in "bu_obj.h". Most of the memory is actually dedicated to handling the generic I/O routines. The only major element is the BU_DB, which is the text database descriptor. .le .ih BUGS The interface provides routines to read from an image and output to a table. There should at least be something to read from a table. It would be nice to be able to "inverse" the expressions so an image could be re-created, but that's a PhD for another time. In leu of that, there could be fields which do define an "inverse" function. Due to the use of the "arbitrary expression", the actual algorithm implemented is much more general than has been discussed. Just need to find such problems to solve. .ih PROCEDURES Below summarizes the procedures defined for the BU object. Memory management routines are: .nf bu_alloc -- Allocate the BU object. bu_free -- Free the BU object. bu_grow -- Enlarge internal arrays. .fi File I/O routines are: .nf bu_read_image -- Fill an object from an image. bu_write_table -- Save an object to a table. .fi Data manipulation routines are: .nf bu_extract -- Extract a value from an array. bu_format -- Format extracted values. .fi Diagnositc routines are: .nf bu_dump -- Diagnostic dump of the contents of a BU object. .fi Internal and miscellaneous routines: .nf bu_copy_op -- Copy an EVEXPR operand. bu_get_op -- Get operand for an expression. bu_functions -- Extra functions for expressions. bu_get_dim -- Retrieve dimensions of a variable from expression. bu_set_items -- Set which items will be retrieved from the list. bu_lin -- Perform the linear interpolation. amovb -- Copy a boolean array. bu_expr -- Construct the expression to be evaluated. bu_field -- Retrieve the value of a field from a record. bu_indef -- Check for undefined values. .fi .ih INTERFACE Below are the individual descriptions of the interface routines. .ih bu_obj = bu_alloc (def_file, items) Allocate the bu object. A definition file is passed to the routine which contains a text database defining how to extract a value from an array, and optionally, how to format the value to make it human-readable. See the general description of the BU object for more information. .ls ARGUMENTS .ls def_file (char[ARB]) The text database file containing the defintions of the bit fields. .le .ls items (char[ARB]) A comma-separated list of patterns used to select which items from the definition file to populate when using the bu_read_image/bu_write_table routines. If blank, all items are selected. A regular expression pattern match is used. See the function strmatch for more information. .le .le .ls RETURNS A pointer of type TY_STRUCT to the BU object. This pointer is used by all other interface routines to access an object's information. This object should be destroyed using "bu_free". .le .ih bu_free (o) Free the memory used by an BU object. This effectively destroys the object. .ls ARGUMENTS .ls o (pointer) The BU object to destroy. On return, obj is set to NULL. .le .le .ih bu_grow (o, size) Make sure that the internal arrays can hold enough information for 'size' number of values. Previous information is not lost if values have already been stored. .ls ARGUMENTS .ls o (pointer) The pointer to a BU object. .le .ls size (int) The number of values that internal data structures must be able to hold. .le .le .ih bu_dump (o) Print to standard output selected diagnostic information about the specified object. .ls ARGUMENTS .ls o (pointer) The pointer to a BU object. .le .le .ih bu_read_image (o, name, fmt) Populate a BU object from the specified image. Values for each item specified in the text database will be read from the data stored in the image and added to the BU object. .ls ARGUMENTS .ls o (pointer) The pointer to a BU object. .le .ls name (char[ARB]) The name of the image file to decode the binary information. .le .ls fmt (bool) If TRUE, then the 'format' expression will also be invoked, formatting the values. If FALSE, the values are simply extracted. .le .le .ih value = bu_extract (o, data, n, item) Extract a value from an array. The specified 'item' is extracted from the array 'data', using the extraction method defined for that particular item. .ls ARGUMENTS .ls o (pointer) The pointer to a BU object. .le .ls data (int[n]) The array containing the undecode raw information from which to extract the specified item. .le .ls n (int) Size of the input data array. Used for consistency checking. .le .ls item (char[ARB]) The item to retrieve. See the general discussion for more information. .le .le .ls RETURNS An OPERAND structure containing the extracted value. See the evexpr source for more information. .le .ih bu_write_table (o, name, mode, template) Save a BU object in a table. Each item in the object becomes a column in the table. If a 'units' field is specified for an item, the column's "units" will be set to this value. The mode specifies how the table should be opened and template is a pointer to another table descriptor. See the routine 'tbtopn' for more information. .ls ARGUMENTS .ls o (pointer) The pointer to a BU object. .le .ls name (char[ARB]) The name of the table to write the information to. .le .ls mode (int) Mode to open the table. See the routine tbtopn for more information. .le .ls template (pointer) Pointer to another table descriptor used to open the current table. This is normally NULL. See the routine tbtopn for more information. .le .le .ih bu_get_op (operand, op) Auxilliary procedure used by the IRAF 'evexpr' interface to retrieves variable values found while parsing an expression. See the help for evexpr under sys$fmtio for more information about the IRAF 'evexpr' interface. Currently, there are only two variables allowed by a BU expression. The variables are: .ls d[x] This variable represents the one-dimensional data array containing the raw, uncoverted bit stream to extract the required information from. 'x' must resolve into a valid index into the array. This is used primarily by the 'extract' expression. .le .ls v Used by the 'format' expression, this variable represents the value of the item being formatted as returned by the 'extract' expression. .le .ls ARGUMENTS .ls operand (char[ARB]) The name of the variable whose value is required by an expression. .le .ls op (pointer) On output, this contains the pointer to the OP object, used by evexpr, which contains the value of the requested variable. .le .le .ih bu_functions (name, args, nargs, op) Auxilliary procedure used by the IRAF 'evexpr' interface to retrieve user-defined function values found while parsing an expression. See the help for the IRAF 'evexpr' interface under sys$fmtio for more information. The following functions, in addition to the default functions defined by 'evexpr', are defined: .ls and (x, y) Bit-wise AND the two arguments. The arguments must be integers. The AND is implemented using the FORTRAN standard library IAND call to actually evaluate the function. .le .ls lin (x, pairs) Linear interpolation between values. The first argument is the "x" value for which a "y" will be interpolated. The bounds of the interpolation are defined in the 'pairs' argument. The argument is specified as a string of values, either space or comma separated. The values are taken as pairs, i.e. the first value is the "x" value and the second value is the "y" value. At least two pairs must be defined. One can define as many pairs as one likes, within the limits of the database string length. For example, to find the "y" value corresponding to the "x" value of 2.5 between the pairs "-100 -43.34", "0 82.3", and "100 100", the function would be defined as: .nf lin (2.5, "-100 -43.34 0 82.3 100 100") .fi .le .ls shift (x, y) Bit-wise SHIFT the first argument by the number of bits specified by the second argument. This function is implemented using the FORTRAN standard library ISHFT call to actually evaluate the function. Both arguments must be integers. If the second argument is positive, a left-bit shift is performed; if negative, a right-bit shift is performed. .le .ls switch (key,v0,v1,...,v14) Depending on the value of 'key', switch returns the values of 'v0' through 'v14'. 'key' must be be an integer between 0 and 14. The 'key'th argument is then returned. There must be at least one value to return, but one does not have to specify all 15 possible return values, only the one that are actually necessary. The types of the return arguments can be anything and they don't necessarily have to be the same as the other arguments. For example: .nf switch (v,"off","on") .fi If 'v' is 0, then switch will return the string "off". If 'v' is 1, then "on" will be returned. If 'v' is outside the possible range, an error will be generated. .le .ls word_find (key,string) This function returns the field from 'string' specified by 'key'. 'string' is a space or comma separated list of words. 'key' indexes into the list, starting from 0. For example: .nf word_find (key, "off,on") .fi If 'key' is 0, then "off" will be returned. If 'key' is 1, then "on" will be returned. The length of the string is arbitrary (though note the limits imposed by the text database format). .le .ls ARGUMENTS .ls name (char[ARB]) The name of the function to execute. .le .ls args (pointer[nargs]) An array of pointers to OP objects which contain the values of the arguments used in the current call to the specified function. .le .ls nargs (int) The number of arguments used for the function. .le .ls op (pointer) On return, this holds a pointer to an OP object which contains the value of the function. .le .ih bu_get_dim (strval, dim, ndim) Internal routine: Intpret a string of the form "[x,y,...z]" and populate the array dim with the numerical values of each dimension. The string must contain at least one value. .ls ARGUMENTS .ls strval (char[ARB]) The string to get the dimension indices from. Must of the form "[x,y,....z]". .le .ls dim (int[MAX_DIM]) On output, this array contains the values of the dimensions found in the input string. .le .ls ndim (int) On output, the number of dimensions found. .le .le .ih value = bu_format (o, item, data, n, value) This formats the value according to the 'format' expression of the specified item. The formatted value is returned. .ls ARGUMENTS .ls o (pointer) The BU object. .le .ls item (char[ARB]) The item defining the 'format' expression. .le .ls data (int[n]) The parent data array. .le .ls n (int) The size of the parent data array. .le .ls value (pointer) An OPERAND containing the value to be transformed. .le .le .ls RETURNS A pointer to an OPERAND containing the transformed value. .le .ih bu_copy_op (op1, op2) Copy OP1 to OP2. NOTE: THIS WILL BREAK IF THE EVEXPR OPERAND STRUCTURE EVER CHANGES. This is needed because, unfortunately, the iraf system does not provide this functionality. .ls op1 (pointer) Source operand .le .ls op2 (pointer) Destination operand. .le .ih bu_set_items (o, pat) Find all items matching the pattern list. .ls o (pointer) The BU object. .le .ls pat (char[ARB]) A comman/space separated list of patterns which determine which items from the definition file should be used in the I/O routines. .le .ih value = bu_lin (x, pairs) Perform linear interpolation, i.e find the Y value for the specified x using the specified pairs as interpolation points. This routine will also extrapolate if x falls outside of the domain specified by the pairs. .ls ARGUMENTS .ls x (real) The x value for which to interpolate a y. .le .ls pairs (char[ARB]) The points which define the interpolation domain. This is a space/comma separated list of numbers which are taken as pairs: .nf "x y x y x y ..." .fi .le .le .ls RETURNS A real which is the interpolated y value. .le .ih expression = bu_expr (db, item, field) Retrieve the expression from the specified field of the item from the text database. This routine will search for any item names present in the field and will recursivly replace the item name with the value of its "extract" field. The level of recursion is 20 at which point it is assumed a recursive or circular definition has been found. .ls ARGUMENTS .ls db (pointer) The text databse descriptor. .le .ls item (char[ARB]) The item for which to the the expression. .le .ls field (char[ARB]) The field from the record to retrieve the expression. .le .le .ls RETURNS A pointer to the string containing the expression to evaluate for the specified field, with all items appearing in the expression expanded into their corresponding "extract" expressions. .le .ih bu_field (db, rec, field, value, size) Retrieve the value of the field from the record from the text database. .ls ARGUMENTS .ls db (pointer) The text database descriptor .le .ls rec (char[ARB]) The record from which to retrieve the field. .le .ls field (char[ARB]) The field to get the value from. .le .ls value (char[size]) The value of the field. .le .ls size (int) The maximum size of the value string. .le .le .ih boolean = bu_indef (v) Return 'true' if the value is undefined. .ls ARGUMENTS .ls v (pointer) An EVEXPR operand .le .le .ls RETURNS 'true' if the value is undefined, otherwise 'false'. .le .ih EXAMPLES For examples of the definition file, see the help for the task "eng2tab". For coding examples, the source for the BU object is below. The task "eng2tab" is an application-level example. .endhelp #--------------------------------------------------------------------------- pointer procedure bu_alloc (def_file, items) char def_file[ARB] # I: Name of the UDL definition table. char items[ARB] # I: List of items that will be extracted. # Declarations pointer dtmap() # Open a text database. char err1[SZ_LINE] # Error message. char err2[SZ_LINE] # Error message. int errget() # Retrieve current error message. int i # Generic. pointer o # The centerflux results object. errchk malloc begin # Allocate the memory structure. call malloc (o, BU_SIZE, TY_STRUCT) # Open the definition database. iferr (BU_DB(o) = dtmap (def_file, READ_ONLY)) { i = errget (err1, SZ_LINE) call sprintf (err2, SZ_LINE, "could not read definition file '%s':%s") call pargstr (def_file) call pargstr (err1) call error (1, err2) } # Initialize item list. call bu_set_items (o, items) # Initialize the value arrays. call malloc (BU_VALUE_ARRAY_PTR(o), BU_N_ITEMS(o), TY_POINTER) BU_MAX_VALUES(o) = 0 BU_N_VALUES(o) = 0 call malloc (BU_IS_NULL_PTR(o), BU_N_ITEMS(o), TY_INT) call amovki (NO, BU_IS_NULL(o,1), BU_N_ITEMS(o)) # Initialize the file name array. BU_FNAME_PTR(o) = NULL # Loop through initializations. do i = 1, BU_N_ITEMS(o) { # No arrays have been allocated. BU_VALUE_ARRAY(o,i) = NULL } # That's all folks. return (o) end #--------------------------------------------------------------------------- # end of bu_alloc #--------------------------------------------------------------------------- procedure bu_free (o) # # 25 June 1998 M. De La Pena: corrected an error in use of BU_N_VALUES. # do j loop used BU_N_VALUES -> now BU_N_VALUES(o) pointer o # IO: SP sp object, NULL on return. int i, j # Generic. errchk dtunmap, mfree begin # Close the definition database. call dtunmap (BU_DB(o)) # Handle loop free. if (BU_MAX_VALUES(o) > 0) do i = 1, BU_N_ITEMS(o) { do j = 1, BU_N_VALUES(o) call mfree (BU_VALUE(o,i,j), TY_STRUCT) call mfree (BU_VALUE_ARRAY(o, i), TY_POINTER) } # Free the file name array. if (BU_FNAME_PTR(o) != NULL) call mfree (BU_FNAME_PTR(o), TY_CHAR) # Handle individual frees. call mfree (BU_LIST_PTR(o), TY_CHAR) call mfree (BU_VALUE_ARRAY_PTR(o), TY_POINTER) call mfree (o, TY_STRUCT) end #--------------------------------------------------------------------------- # end of bu_free #--------------------------------------------------------------------------- procedure bu_grow (o, size) pointer o # I: Object. int size # I: Size to grow to. int i # Generic. bool new_max # True to reallocate the arrays. errchk realloc begin # See if growth is needed. new_max = false while (BU_MAX_VALUES(o) <= size) { new_max = true BU_MAX_VALUES(o) = BU_MAX_VALUES(o) + BU_GROW } # If the max has changed, reallocate the arrays. if (new_max) { do i = 1, BU_N_ITEMS(o) call realloc (BU_VALUE_ARRAY(o,i), BU_MAX_VALUES(o), TY_POINTER) # Reallocate the file name array. call realloc (BU_FNAME_PTR(o), BU_MAX_VALUES(o)*(SZ_PATHNAME+1), TY_CHAR) } # Reset the size. BU_N_VALUES(o) = size end #--------------------------------------------------------------------------- # End of bu_grow #--------------------------------------------------------------------------- procedure bu_dump (o) pointer o # I: SP object. begin call printf ("Number of names = %d.\n") call pargi (BU_N_ITEMS(o)) call printf ("Number of values = %d, max values = %d.\n") call pargi (BU_N_VALUES(o)) call pargi (BU_MAX_VALUES(o)) end #--------------------------------------------------------------------------- # End of bu_dump #--------------------------------------------------------------------------- procedure bu_read_image (o, name, fmt) pointer o # I: Object. char name[ARB] # I: Name of the image. bool fmt # I: Format the values? # Declarations pointer data # Data array. pointer bu_extract() # Get value. pointer bu_format() # Format a value. char err[SZ_LINE] # Error string. int errget() # Retrieve the current error message. int i, j, k # Generic. pointer im # Image descriptor. pointer immap() # Open an image. char item_name[SZ_COLNAME] # Name of the item. pointer imgl1i() # Get image data. pointer v # Temporary value holder. int word_find() # Extract word from list. errchk bu_grow, imgl1i, immap begin # Open the image. im = immap (name, READ_ONLY, NULL) # Get the data array. data = imgl1i (im) # Grow the associated arrays. call bu_grow (o, BU_N_VALUES(o)+1) # Set the file name. call strcpy (name, BU_FNAME(o, BU_N_VALUES(o)), SZ_PATHNAME) # For each item, find it in the data and fill the proper array. do i = 1, BU_N_ITEMS(o) if (BU_IS_NULL(o,i) != YES) { j = word_find (i, BU_LIST(o), item_name, SZ_COLNAME) iferr (BU_VALUE(o,i,BU_N_VALUES(o)) = bu_extract (o, Memi[data], IM_LEN(im,1), item_name)) { k = errget (err, SZ_LINE) call eprintf ("%s\n") call pargstr (err) call eprintf ("Warning: Could not get value for item '%s'.\n Item will be ignored.\n") call pargstr (item_name) BU_IS_NULL(o,i) = YES } # If formatting, do it now if (fmt && BU_IS_NULL(o,i) != YES) { iferr (v = bu_format (o, item_name, Memi[data], IM_LEN(im,1), BU_VALUE(o,i,BU_N_VALUES(o)))) { k = errget (err, SZ_LINE) call eprintf ("%s\n") call pargstr (err) call eprintf ("Warning: Could not format value for item '%s'.\n") call pargstr (item_name) } else { call mfree (BU_VALUE(o,i,BU_N_VALUES(o)), TY_STRUCT) BU_VALUE(o,i,BU_N_VALUES(o)) = v } } } # That's all folks. call imunmap (im) end #--------------------------------------------------------------------------- # End of bu_read_image #--------------------------------------------------------------------------- pointer procedure bu_extract (o, data, n, item) pointer o # I: The object. int data[n] # I: Data array. int n # I: Size of data array. char item[ARB] # I: Item to retrieve. # Declarations. include "bu_obj.com" pointer bu_expr() # Get expression from database. extern bu_functions() # Special functions for expression. extern bu_get_op() # Get operator for expression. pointer evexpr() # Evaluate arbitrary expression. pointer expr # Expression to evaluate. pointer locpr() # Get pointer to a function. int locva() # Get pointer to a variable. pointer result # Result operand of expression. errchk bu_expr, evexpr, locpr, locva begin # Get the extraction expression. expr = bu_expr (BU_DB(o), item, BU_EXTRACT) # Evaluate the expression data_ptr = (locva (data) - locva (Memc))/ SZ_INT + 1 n_pts = n f_val = NULL result = evexpr (Memc[expr], locpr (bu_get_op), locpr (bu_functions)) # That's all folks call mfree (expr, TY_CHAR) return (result) end #--------------------------------------------------------------------------- # End of bu_extract #--------------------------------------------------------------------------- procedure bu_write_table (o, name, mode, template) pointer o # I: Object to save. char name[ARB] # I: Name of table to write. int mode # I: Mode to open table with. pointer template # I: Template table descriptor. # Declarations. pointer col # Column descriptor. int dtlocate() # Find a named record. int i, j # Generic. char item_name[SZ_COLNAME] # Item name. pointer out # Output table descriptor. int size # Maximum size of a string result. int strlen() # Get length of string. pointer tbtopn() # Open a table. char units[SZ_COLUNITS] # Units the column should be representing. int word_find() # Find a word in a list. errchk bu_format, mfree, tbcdef, tbcptb, tbcpti, tbcptr, errchk tbcptt, tbpset, tbtclo, tbtcre, tbtopn begin # Open the table. out = tbtopn (name, mode, template) call tbpset (out, TBL_ALLROWS, BU_N_VALUES(o)) call tbpset (out, TBL_MAXCOLS, BU_N_ITEMS(o)+1) call tbpset (out, TBL_WHTYPE, TBL_TYPE_S_COL) call tbtcre (out) # Write the file names. call tbcdef (out, col, "file", "", "", -1*SZ_PATHNAME, 1, 1) call tbcptt (out, col, BU_FNAME(o,1), SZ_PATHNAME, 1, BU_N_VALUES(o)) # Write the values out. do i = 1, BU_N_ITEMS(o) { # See if there are any values for this particular item. if (BU_IS_NULL(o,i) != YES) { # Get the record name. j = word_find (i, BU_LIST(o), item_name, SZ_COLNAME) # Get units if possible. iferr (call dtgstr (BU_DB(o), dtlocate (BU_DB(o), item_name), BU_UNITS, units, SZ_COLUNITS)) call strcpy ("", units, SZ_COLUNITS) # If the type of the current column is a character, find # the largest string size in the values. size = 0 if (O_TYPE(BU_VALUE(o,i,1)) == TY_CHAR) do j = 1, BU_N_VALUES(o) size = max(size, strlen(O_VALC(BU_VALUE(o,i,j)))) # Create the column if (O_TYPE(BU_VALUE(o,i,1)) == TY_CHAR) call tbcdef (out, col, item_name, units, "", -1*size, 1, 1) else call tbcdef (out, col, item_name, units, "", O_TYPE(BU_VALUE(o,i,1)), 1, 1) # Write the data out. do j = 1, BU_N_VALUES(o) switch (O_TYPE(BU_VALUE(o,i,j))) { case TY_REAL: call tbeptr (out, col, j, O_VALR(BU_VALUE(o,i,j))) case TY_BOOL: call tbeptb (out, col, j, O_VALB(BU_VALUE(o,i,j))) case TY_CHAR: call tbeptt (out, col, j, O_VALC(BU_VALUE(o,i,j))) default: call tbepti (out, col, j, O_VALI(BU_VALUE(o,i,j))) } } } # That's all folks. call tbtclo (out) end #--------------------------------------------------------------------------- # End of bu_write_table #--------------------------------------------------------------------------- procedure bu_get_op (operand, op) char operand[ARB] # I: Name of the operand to get value for. pointer op # I: Operand object to contain the value. # Declarations include "bu_obj.com" int bs # Where dimension bracket starts. int dim[MAX_DIM] # Array indicies. int ndim # Dimensionality of variable. int stridx() # Get index of character in string. int strdic() # Get dictionary index. int strlen() # Get string length. char sx[SZ_LINE] # Generic string. char var[SZ_LINE] # Pointer to variable name. errchk xev_initop begin # Get the array element bs = stridx ("[", operand) if (bs > 0) { call strcpy (operand, var, bs-1) call bu_get_dim (operand[bs+1], dim, ndim) } else { call strcpy (operand, var, strlen (operand)) ndim = 0 } # Now decide which variable is being retreived. switch (strdic (var, sx, SZ_LINE, BU_VARIABLES)) { case BU_VAR_D: if (data_ptr == NULL) call error (1, "d array has not been defined") if (ndim > 1) call error (1, "d variable is only one dimensional") if (ndim == 0) dim[1] = 1 if (dim[1] > n_pts) call error (1, "Index to variable d out of range") call xev_initop (op, 0, TY_INT) O_VALI(op) = Memi[data_ptr+dim[1]-1] case BU_VAR_V: if (f_val == NULL) call error (1, "v variable has not been define") if (ndim > 0) call error (1, "v variable is a scalar") call bu_copy_op (f_val, op) default: call sprintf (sx, SZ_LINE, "no such item '%s'") call pargstr (Var) call error (1, sx) } end #--------------------------------------------------------------------------- # End of bu_get_op #--------------------------------------------------------------------------- procedure bu_functions (name, args, nargs, op) char name[ARB] # I: Name of function to execute pointer args[nargs] # I: Arguments to the function. int nargs # I: Number of arguments. pointer op # I: Operand to contain the result # Declarations include "bu_obj.com" real bu_lin() # Linear interpolate. int i # Generic. real rx # Generic. int strdic() # Get dictionary index. int strlen() # Length of string. char sx[SZ_LINE] # Generic strings. int word_find() # Find a word in a list. int shifti(), andi() errchk xev_initop, bu_lin begin # Execute the appropriate function. switch (strdic (name, sx, SZ_LINE, BU_FUNCTIONS)) { case BU_FUNC_AND: if (nargs != 2) call error (1, "function 'and' requires 2 arguments") if (O_TYPE(args[1]) != TY_INT || O_TYPE(args[2]) != TY_INT) call error (1, "function 'and' requires integer arguments") call xev_initop (op, 0, TY_INT) O_VALI(op) = andi (O_VALI(args[1]), O_VALI(args[2])) case BU_FUNC_SHIFT: if (nargs != 2) call error (1, "function 'shift' requires 2 arguments") if (O_TYPE(args[1]) != TY_INT || O_TYPE(args[2]) != TY_INT) call error (1, "function 'shift' requires integer arguments") call xev_initop (op, 0, TY_INT) O_VALI(op) = shifti (O_VALI(args[1]), O_VALI(args[2])) case BU_FUNC_WRDFND: if (nargs != 2) call error (1, "'word_find' function takes 2 arguments") if (O_TYPE(args[1]) != TY_INT) call error (1, "first arg to 'switch' must be an integer") # Find the word. if (word_find (O_VALI(args[1])+1, O_VALC(args[2]), sx, SZ_COMMAND) > 0) { i = strlen (sx) call xev_initop (op, i, TY_CHAR) call strcpy (sx, O_VALC(op), i) } else { call xev_initop (op, 1, TY_CHAR) call strcpy ("", O_VALC(op), 1) } case BU_FUNC_LIN: if (nargs != 2) call error (1, "'lin' function takes 2 arguments") if (O_TYPE(args[1]) != TY_INT && O_TYPE(args[1]) != TY_REAL) call error (1, "first arg to 'lin' must be numeric") if (O_TYPE(args[2]) != TY_CHAR) call error (1, "second arg to 'lin' must be a string") if (O_TYPE(args[1]) == TY_INT) rx = O_VALI(args[1]) else rx = O_VALR(args[1]) call xev_initop (op, 0, TY_REAL) O_VALR(op) = bu_lin (rx, O_VALC(args[2])) default: call sprintf (sx, SZ_LINE, "unknown function '%s'") call pargstr (name) call error (1, sx) } end #--------------------------------------------------------------------------- # End of bu_functions #--------------------------------------------------------------------------- procedure bu_get_dim (strval, dim, ndim) char strval[ARB] # I: The string to decode. int dim[MAX_DIM] # O: Array indicies. int ndim # O: Acutall dimensionality # Declarations int ctoi() # Character to integer. int i, j # Generic. char sx[SZ_LINE] # Generic string. int word_count() # Get number of words in list. int word_find() # Get i'th word from list. begin ndim = word_count (strval) do i = 1, ndim { if (word_find (i, strval, sx, SZ_LINE) > 0) { j = 1 if (ctoi (sx, j, dim[i]) < 0) dim[i] = 0 } else { ndim = i - 1 break } } end #--------------------------------------------------------------------------- # End of bu_get_dim #--------------------------------------------------------------------------- pointer procedure bu_format (o, item, data, n, value) pointer o # I: The BU object. char item[ARB] # I: The item to format. int data[n] # I: Data array. int n # I: Size of data array. pointer value # I: The value to be formatted. # Declarations include "bu_obj.com" pointer bu_expr() # Get expression from database. extern bu_functions() # Functions for expressions. extern bu_get_op() # Get operand for expressions. bool bu_indef() # Is value indef? pointer evexpr() # Evaluate a generic expression. pointer expr # Expression to evaluate. pointer locpr() # Location of functions. int locva() # Location of variables. pointer result # Result. errchk bu_expr, evexpr, locpr, locva, malloc begin # Get the formatting expression expr = bu_expr (BU_DB(o), item, BU_FORMAT) # If the value is not defined, then just return that value. if (bu_indef (value)) { call malloc (result, LEN_OPERAND, TY_STRUCT) call bu_copy_op (value, result) # Else, evaluate the format expression. } else { data_ptr = (locva (data) - locva (Memc))/ SZ_INT + 1 n_pts = n f_val = value result = evexpr (Memc[expr], locpr (bu_get_op), locpr (bu_functions)) } # That's all folks call mfree (expr, TY_CHAR) return (result) end #--------------------------------------------------------------------------- # End of bu_format #--------------------------------------------------------------------------- procedure bu_copy_op (op1, op2) pointer op1, op2 begin call amovi (Memi[op1], Memi[op2], LEN_OPERAND) end #--------------------------------------------------------------------------- # End of bu_copy_op #--------------------------------------------------------------------------- procedure amovb (a, b, n) bool a[n], b[n] int i, n begin do i = 1, n b[i] = a[i] end #--------------------------------------------------------------------------- # End of amovb #--------------------------------------------------------------------------- procedure bu_set_items (o, pat) pointer o # I: BU object char pat[ARB] # I: Pattern to find items for. # Declarations char apat[SZ_COMMAND] # A single pattern to find. int i, ic, j # Generic. char patbuf[SZ_COMMAND] # A compiled pattern. int patmake() # Complie a pattern. int patmatch() # Find a pattern. pointer sb # String buffer pointer sb_open() # Open a string buffer. pointer sb_string() # Get the string in the buffer. int word_fetch() # Get next word from pattern. begin sb = sb_open() BU_N_ITEMS(o) = 0 ic = 1 # Find all the records that match the list of patterns. while (word_fetch (pat, ic, apat, SZ_COMMAND) > 0) { do i = 1, DT_NRECS(BU_DB(o)) { j = patmake (apat, patbuf, SZ_COMMAND) if (patmatch (DT_NAME(BU_DB(o), i), patbuf) > 0) { BU_N_ITEMS(o) = BU_N_ITEMS(o) + 1 if (BU_N_ITEMS(o) > 1) call sb_cat (sb, ",") call sb_cat (sb, DT_NAME(BU_DB(o),i)) } } } if (BU_N_ITEMS(o) == 0) call error (1, "pattern string does not match any items in the database") BU_LIST_PTR(o) = sb_string (sb) call sb_close (sb) end #--------------------------------------------------------------------------- # End of bu_set_items #--------------------------------------------------------------------------- real procedure bu_lin (x, pairs) real x # I: X value to interpolate for. char pairs[ARB] # I: String of x/y pairs defining function. # Declarations int ctor() # String to real. int i # Generic. int n # Number of pairs. real rx # Generic. pointer sp # Stack pointer. pointer xp # X value of pairs. real y # Interpolated/extrapolated Y value. pointer yp # Y value of pairs. begin call smark (sp) # Determine how many pairs are in the string. i = 1 n = 0 while (ctor (pairs, i, rx) > 0) n = n + 1 # If two pairs have not been defined, abort. if (n < 4) call error (1, "lin: need to define at least two pairs of values") # Read in the values. call salloc (xp, n, TY_REAL) call salloc (yp, n, TY_REAL) i = 1 n = 0 while (ctor (pairs, i, Xp(n+1)) > 0) { if (ctor (pairs, i, Yp(n+1)) <= 0) break n = n + 1 } # Find which pair the X value falls in. if (x < Xp(1)) i = 1 else if ( x >= Xp(n)) i = n else { i = 1 while (x >= Xp(i+1)) i = i + 1 } # Interpolate/extrapolate y = Yp(i) + ((x - Xp(i)) * (Yp(i+1) - Yp(i)) / (Xp(i+1) - Xp(i))) # That's all folks. call sfree (sp) return (y) end #--------------------------------------------------------------------------- # End of bu_lin #--------------------------------------------------------------------------- pointer procedure bu_expr (db, item, field) pointer db # I: Text database object. char item[ARB] # I: Item to get expression for. char field[ARB] # I: Field to get expression from. # Declarations bool again # Reparse the expression again. int ctotok() # Get next token. pointer e # Final expression. char expr[BU_SZ_EXPR] # Expression to evaluate. char expr2[BU_SZ_EXPR] # Subexpression to imbedd in expression. int ip # Character index. int recurse # Number of recursions which have occured. pointer sb # String buffer. pointer sb_open() # Create a string buffer. pointer sb_string() # Convert string buffer to string. int t # Token type. char token[SZ_LINE] # Token. errchk bu_field errchk sb_cat, sb_open, sb_string begin # Find the basic expression call bu_field (db, item, field, expr, BU_SZ_EXPR) # Now parse through the string again = true recurse = 0 call malloc (e, BU_SZ_EXPR, TY_CHAR) call strcpy (expr, Memc[e], BU_SZ_EXPR) while (again) { again = false ip = 1 sb = sb_open() while (true) { t = ctotok (Memc[e], ip, token, SZ_LINE) switch (t) { case TOK_IDENTIFIER: # If an identifier, see if it is an item in the database. # If so, get its "extract" expression and insert it into # the string. This is non-recursive. iferr (call bu_field (db, token, BU_EXTRACT, expr2, BU_SZ_EXPR)) { call sb_cat (sb, token) } else { if (!again) { if (recurse > MAX_RECURSE) call error (1, "infinite loop in expression") recurse = recurse + 1 again = true } call sb_cat (sb, "(") call sb_cat (sb, expr2) call sb_cat (sb, ")") } case TOK_STRING: # If it is a string, make sure the quotes are still # there when placed back in the expression. call sb_cat (sb, "\"") call sb_cat (sb, token) call sb_cat (sb, "\"") case TOK_EOS: # If end of string, then break. break default: # Just concatenate the extracted token. call sb_cat (sb, token) } } # Replace expression with new expression. call mfree (e, TY_CHAR) e = sb_string (sb) call sb_close (sb) } # That's all folks. return (e) end #--------------------------------------------------------------------------- # End of bu_expr #--------------------------------------------------------------------------- procedure bu_field (db, rec, field, value, size) pointer db # I: Text database to search. char rec[ARB] # I: Record to retrieve. char field[ARB] # I: Field of record to retrieve. char value[size] # O: Value of field in record. int size # I: Maximum length of value string. # Declarations int dtlocate() # Find record in database. char err1[SZ_LINE] # Error line. char err2[SZ_LINE] # Error line. int errget() # Retrieve the current error message. int i # Generic. begin iferr (i = dtlocate (db, rec)) { i = errget (err1, SZ_LINE) call sprintf (err2, SZ_LINE, "could not find record '%s':%s") call pargstr (rec) call pargstr (err1) call error (1, err2) } iferr (call dtgstr (db, i, field, value, size)) { i = errget (err1, SZ_LINE) call sprintf (err2, SZ_LINE, "could not find field '%s' for record '%s':%s") call pargstr (field) call pargstr (rec) call pargstr (err1) call error (1, err2) } end #--------------------------------------------------------------------------- # End of bu_field #--------------------------------------------------------------------------- bool procedure bu_indef (v) pointer v # I: EVEXPR operand # Declarations bool r # Result begin switch (O_TYPE(v)) { case TY_INT: r = IS_INDEFI(O_VALI(v)) case TY_REAL: r = IS_INDEFR(O_VALR(v)) default: r = false } return (r) end #--------------------------------------------------------------------------- # End of bu_indef #---------------------------------------------------------------------------