Google
 

Trailing-Edge - PDP-10 Archives - cuspmar86binsrc_2of2_bb-fp63a-sb - 10,7/dil/dilsrc/dixutl.bli
There are 21 other files named dixutl.bli in the archive. Click here to see a list.
%TITLE 'DIX Utility Routines'

MODULE dixutl

!  COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1983, 1985.
!  ALL RIGHTS RESERVED.
!  
!  THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY  BE  USED  AND
!  COPIED ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH
!  THE INCLUSION OF THE ABOVE COPYRIGHT NOTICE.   THIS  SOFTWARE  OR
!  ANY  OTHER  COPIES  THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE
!  AVAILABLE TO ANY OTHER PERSON.  NO TITLE TO AND OWNERSHIP OF  THE
!  SOFTWARE IS HEREBY TRANSFERRED.
!  
!  THE INFORMATION IN THIS SOFTWARE IS  SUBJECT  TO  CHANGE  WITHOUT
!  NOTICE  AND  SHOULD  NOT  BE CONSTRUED AS A COMMITMENT BY DIGITAL
!  EQUIPMENT CORPORATION.
!  
!  DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR  RELIABILITY  OF
!  ITS SOFTWARE ON EQUIPMENT THAT IS NOT SUPPLIED BY DIGITAL.

!++
! .chapter >DIXUTL
!
!   The module DIXUTL contains base routines common to all data types and
! which must be included in all images -- utility routines, as it were.
!
!   FACILITY: Data Conversion Routines (DIX)
!
!   ABSTRACT:
!
!   ENVIRONMENT:
!
!   AUTHOR: David Dyer-Bennet, Creation Date: 11-Jan-82
!--

    (IDENT = '2.0(50)'                  ! \.p;\
                                        ! **EDIT**
    %REQUIRE ('DIXSWI.REQ')             ! [%O'34'] 
%BLISS36 (
    , ENTRY  (                          ! ;  Entry symbols:
        dixpeh, dixadr, dixctp, dixcfd, ! \
        dixdbd, dixifd, dixcpy, dixfbt, dixsbt, ! \
        dixstd, dixbof, dixfbd, dixbpu, dixajx	! \
    )
)
) =
BEGIN

%SBTTL 'Declarations'

!++
! .hl 1 Require files
!--

REQUIRE 'DIXREQ.REQ';                   ! \

!++
! .hl 1 Library files
!--
%sbttl 'Edit History'                   ! [7] Add this entire subsection

!++
! .hl 1 Edit History
!--

LIBRARY 'VERSION';

! ; .autotable

!++ COPY 

new_version (1, 0)

edit (7, '23-Aug-82', 'David Dyer-Bennet')
 %( Change version and revision standards everywhere.
    Files: All. )%

edit (10, '22-Sep-82', 'David Dyer-Bennet')
 %(  Always use long_relative addressing on VAX. )%

Edit (%O'30', '19-Jan-83', 'David Dyer-Bennet')
 %(  Update copyright notices, add mark at end of edit histories.
 )%

Edit (%O'34', '19-May-83', 'David Dyer-Bennet')
 %( Add DIXSWI require file to headings of all modules.  DIXSWI
    contains the BLISS32 addressing-mode declarations and the TOPS-10
    OTS declaration to avoid invoking the losing default of .REQUESTING
    the OTS library from whatever directory the compiler was called from
    when the build ran.
 )%

Edit (%O'35', '8-June-83', 'Charlotte L. Richardson')
 %( Declare version 1 complete.  All modules.
 )%

new_version (1, 1)

new_version (2, 0)

Edit (%O'36', '11-Apr-84', 'Sandy Clemens')
%( Put all Version 2 DIX development files under edit control.  Some of
   the files listed below have major code edits, or are new modules.  Others
   have relatively minor changes, such as cleaning up a comment.
   FILES: COMDIX.VAX-COM, COMPDX.CTL, DIXCST.BLI, DIXDEB.BLI,
   DIXDN.BLI (NEW), DIXFBN.BLI, DIXFP.BLI, DIXGBL.BLI, DIXGEN.BLI,
   DIXHST.BLI, DIXINT.PR1, DIXINT.PR2, DIXLIB.BLI, DIXPD.BLI (NEW),
   DIXREQ.REQ, DIXSTR.BLI, DIXUTL.BLI, DXCM10.10-CTL, MAKDIXMSG.BLI,
   STAR36.BLI, VERSION.REQ.
)%

Edit (%O'50', '8-Oct-84', 'Sandy Clemens')
  %( Add new format of COPYRIGHT notice.  FILES:  ALL )%

! **EDIT**
!-- .autoparagraph

mark_versions ('DIX')
!++
! .hl 1 Debugging declarations
!--

!!dix$module_debug (off);
dix$module_debug (on);

!++
! .hl 1 Macros
!--

!++
! .hl 1 Literals 
!--

!++
! .hl 1 Own storage
!--

! [7] Remove version number word

!++
! .hl 1 Global data
!--

!++
! .hl 2 Miscellaneous structures
!   Small structures are grouped together in this section.
!--

GLOBAL
    !
    ! ;   Table of maximum data type codes within each class, used for 
    ! ; error checking:
    !
    dix$at_max_dt_cod : VECTOR [dix$k_max_class + 1]	! \>\Wanted 1-origin.
    	PSECT (readonly_psect)          ! \\Place in read-only storage.
	PRESET ( [dt_string] = dt_class_string_max,
            [dt_fbin] = dt_class_fbin_max,
            [dt_fp] = dt_class_fp_max,
            [dt_dnum] = dt_class_dnum_max,
            [dt_pdec] = dt_class_pdec_max),
    !
    ! ;   Table of bits per unit for each supported system type:
    !
    dix$ag_sys_bpunit : VECTOR [sys_max + 1]	! \>\Really wanted 1-origin.
    	PSECT (readonly_psect)          ! \\Place in read-only storage.
	PRESET ( [sys_lcg] = 36, [sys_8bit] = 8);

%SBTTL 'Data type tables'

!++
! .hl 2 Data type tables
!
!   Data tables for the various data type classes.
!
! These tables are indexed by the within-class part of the data type code.
!
!   There is one table here for each class of data type supported.  It
! contains information needed in all versions of the library; but it
! does not contain extensive data needed only when conversions
! involving that class are being performed.
!
!  The tables are used mostly in error checking within utility
! routines. 
!--

!++
! .hl 3 Alphanumeric strings
!  The format of this table is defined in DIXLIB (>dtt_st>).
!
!   The values used to initialize it are also there:  they reside in
! macro >dt_class_string_def>.  The table is initialized by declaring
! a macro here which is called when dt_class_string_def gets expanded;
! thus we control exactly how the table is initialized, although the
! data is entered in the library.
!--

MACRO
    decl_string_item                    ! \.P;Macro \:
    !++
    ! This macro gets called for each string data type when dt_class_string_def
    ! gets expanded.  This definition of the macro produces preset-items
    ! which will statically initialize the dix$adtt_st structure.
    !--
    (                                   ! ;  Arguments: 
    class_code, item_name, short_name, type_code, byt_siz, sys_orig, length_spec        ! \\.
    ) =
	[type_code, std$v_byt_siz] = byt_siz,
        [type_code, std$v_sys_orig] = sys_orig,
        [type_code, std$v_lng_indic] = length_spec, 
    %;

GLOBAL                                  ! ;.P;Global table
    dix$adtt_st :                       ! \>\ the string data type table.
        dtt_st                          ! \Type is\.
        PSECT (readonly_psect)          ! \Assign to \.
	PRESET (                        ! ; Initialize by calling
        dt_class_string_def             ! \\.
        [0, std$v_byt_siz] = 0          ! Previous macro call leaves trailing ","
        );				! End PRESET

!++
! .hl 3 Fixed-point binary
!
!  The format of this table is defined in DIXLIB (>dtt_fbin>).
!
!   The values used to initialize it are also there:  they reside in
! macro >dt_class_fbin_def>.  The table is initialized by declaring
! a macro here which is called when dt_class_fbin_def gets expanded;
! thus we control exactly how the table is initialized, although the
! data is entered in the library.
!--

MACRO
    decl_fbin_item                    ! \.P;Macro \:
    !++
    ! This macro gets called for each fbin data type when dt_class_fbin_def
    ! gets expanded.  This definition of the macro produces preset-items
    ! which will statically initialize the dix$adtt_fbin structure.
    !--
    (                                   ! ;  Arguments: 
    class_code, item_name, short_name, type_code, length_type, fld_signed,      ! \\
        min_lng, max_lng, min_scale, max_scale, bpm_code ! \\.
    ) =
        [type_code, fbd$v_variable] = %QUOTE %IF length_type EQL fbd$k_lng_variable
            %THEN 1 %ELSE 0 %FI,
        [type_code, fbd$v_signed] = %QUOTE %IF fld_signed EQL fbd$k_signed
            %THEN 1 %ELSE 0 %FI,
        [type_code, fbd$v_min_lng] = min_lng,
        [type_code, fbd$v_max_lng] = max_lng,
        [type_code, fbd$v_min_scale] = min_scale,
        [type_code, fbd$v_max_scale] = max_scale,
        [type_code, fbd$v_bpm_program] = UPLIT bpm_code,
                                        ! bpm_code provides parens
    %;

GLOBAL                                  ! ;.P;Global table
    dix$adtt_fbin :                     ! \>\ the fbin data type table.
        dtt_fbin                        ! \Type is\.
        PSECT (readonly_psect)          ! \Assign to \.
	PRESET (                        ! ; Initialize by calling
        dt_class_fbin_def               ! \\.
        [0, fbd$v_bpm_program] = 0      ! Previous macro call leaves trailing ","
        );				! End PRESET

!++
! .HL 3 Floating point
!
!   The format of this table is defined in DIXLIB (>dtt_fp>).
!
!   The values used to initialize it are also there: they reside in
! macro >dt_class_fp_def>.  The table is initialized by declaring
! a macro here which is called when dt_class_fp_def gets expanded;
! thus we control exactly how the table is initialized, although the
! data is entered in the library.
!--

MACRO
    decl_fp_item                        ! \.p;Macro \:
!++
! This macro gets called for each FP data type when dt_class_fp_def gets
! expanded.  This definition of the macro produces preset items which will
! statically initialize the dix$adtt_fp structure.
!--
    (                                   ! ;  Arguments:
    class_code, item_name, short_name, type_code, representation,       ! \\
        exp_offset, mant_bits, fpm_code ! \\
    ) = 
        [type_code, fpd$v_representation] = representation,
        [type_code, fpd$v_exp_offset] = exp_offset,
        [type_code, fpd$v_mant_bits] = mant_bits,
        [type_code, fpd$v_fpm_program] = UPLIT fpm_code,
    %;

GLOBAL                                  ! ;.P;Global table
    dix$adtt_fp :                       ! \>\ the fp data type table.
        dtt_fp                          ! \Type is\.
        PSECT (readonly_psect)          ! \Assign to \.
        PRESET (                        ! ; Initialize by calling
            dt_class_fp_def             ! \\.
            [0, fpd$v_fpm_program] = 0  ! Previous macro call leaves trailing ","
        );                              ! end Preset

!++
! .HL 3 Display numeric
!
!   The format of this table is defined in DIXLIB (>dtt_dn>).
!
!   The values used to initialize it are also there: they reside in
! macro >dt_class_dnum_def>.  The table is initialized by declaring a
! macro here which is called when dt_class_dnum_def gets expanded;
! thus we control exactly how the table is initialized, although the
! data is entered in the library.
!--

MACRO
    decl_dnum_item                      ! \.p;Macro \:
!++
! This macro gets called for each DNUM data type when dt_class_dnum_def
! gets expanded.  This definition of the macro produces PRESET items which
! will statically initialize the dix$adtt_dn structure.
!--
    (                                   ! ;  Arguements:
    class_code, item_name, short_name, type_code, byte_size,    ! \\
        sys_orig, sign_type, char_set_name, max_length  ! \\.
    ) =
       [type_code, dnd$v_byt_siz] = byte_size,
       [type_code, dnd$v_sys_orig] = sys_orig,
       [type_code, dnd$v_sign_type] = sign_type,
       [type_code, dnd$v_ovp_max_index] = %NAME ('ovp$k_', char_set_name, '_max'),
       [type_code, dnd$v_max_length] = max_length,
       [type_code, dnd$v_char_set] = %NAME ('cs_', char_set_name),
    %;

GLOBAL                                  ! ;.P;Global table
    dix$adtt_dn :                       ! \>\ the display numeric data type table
       dtt_dn                           ! \Type is \.
       PSECT (readonly_psect)           ! \Assign to \.
       PRESET (                         ! ; Initialize by calling
       dt_class_dnum_def                ! \\.
       [0, dnd$v_byt_siz] = 0           ! Previous macro call leaves trailing ","
       );                               ! End PRESET

!++
! .hl 3 Packed decimal
!
!  The format of this table is defined in DIXLIB (>dtt_pd>).
!
!  The values used to initialize the table are also there:  they reside in
! macro >dt_class_pdec_def>.  The table is initialized by declaring a macro
! here which is called when dt_class_pdec_def gets expanded;  thus we control
! exactly how the table is initialized, although the data is entered in the
! library.
!--

MACRO
     decl_pdec_item                     ! \.p;Macro \:
!++
! This macro gets called for each PDEC data type when dt_class_pdec_def
! gets expanded.  This definition of the macro produces PRESET items which
! will statically initialize the dix$adtt_pd structure.
!--
     (
     class_code, item_name, short_name, type_code, byte_size,   ! \\
         nibble_size, sys_orig, max_length, sign_set    ! !\\.
     ) =
       [type_code, pdd$v_byt_siz] = byte_size,
       [type_code, pdd$v_nbl_siz] = nibble_size,
       [type_code, pdd$v_sys_orig] = sys_orig,
       [type_code, pdd$v_max_length] = max_length,
       [type_code, pdd$v_sign_set] = %NAME ('ss_', sign_set),
     %;

GLOBAL                                  ! ;.P;Global table
    dix$adtt_pd :                       ! \>\ the packed numeric data type table
       dtt_pd                           ! \Type is \.
       PSECT (readonly_psect)           ! \Assign to \.
       PRESET (                         ! ; Initialize by calling
       dt_class_pdec_def                ! \\.
       [0, pdd$v_byt_siz] = 0           ! Previous macro call leavs trailing ","
       );                               ! End PRESET

%SBTTL 'GLOBAL ROUTINE dix$$port_hand'
GLOBAL ROUTINE dix$$port_hand           ! \.!=;.hl 1 \
! ; .index  dix$$port_hand           

!++
!   By convention, this handler should be enabled by all portal
! routines to the DIX.  (User interface routines use a different
! handler, in module DILINT.)
!
!   This handler traps any signals that get up this high and
! returns them to the  routine calling the enabling routine as the
! function return value (if any).  This prevents errors from being
! "lost" in the sense of not being reported to the caller.
!
! Routine Value:
!       Information for CHF, as described in BLISS condition handling
! documentation.
! 
!   Formal arguments:
! .list 1
!--
    (
        sig_vec,                        ! \.le;\: Signal vector, as
                                        ! ; described in BLISS condition
                                        ! ; handling documentation.
        mech_vec,                       ! \.le;\: Mechanism vector, as
                                        ! ; described in BLISS condition
                                        ! ; handling documentation.
        enabl_vec                       ! \.le;\: Enable vector, as
                                        ! ; described in BLISS condition
            ! ; handling documentation.  The first
            ! ; parameter specified by the enabler is a
            ! ; local data segment in the enabler that
            ! ; can be used for temporary storage of
            ! ; error information.
    ) =                                 ! ; .end list

    BEGIN

    MAP
	sig_vec : REF VECTOR,
	mech_vec : REF VECTOR,
	enabl_vec : REF VECTOR;

    BIND
	cond = sig_vec [1] : condition_value,
	return_value = mech_vec [ %BLISS16 (1) %BLISS36 (1) %BLISS32 (3)],
	error_temp = .enabl_vec [1] : condition_value;

    dix$routine_debug (off);

! ; .hl 2 Flow of code

    IF .cond NEQ dix$unwind_cond        ! ; .P;If not unwinding,
    THEN
	BEGIN
	error_temp = .cond;             ! ; store away condition value,
	SETUNWIND ()                    ! ; initiate unwind.
	END
    ELSE                                ! ; .P;When called during unwind,
	return_value = .error_temp      ! ; return condition value saved earlier.

    END;				! END OF DIX$$PORT_HAND
%SBTTL 'GLOBAL ROUTINE dix$$copy_structure'
GLOBAL ROUTINE dix$$copy_structure      ! \.!=;.hl 1 \
! ; .index  dix$$copy_structure      

!++
!   Copy a structure.  This is necessary because BLISS assignment only works
! on field references, which work on at most a fullword.
!
!   Routine value: none
!   Formal arguments:
! .list 1
!--
    (
        src_adr,                        ! \.le;\: Address of structure to copy
        str_siz,                        ! \.le;\: Length in fullwords of structure
        dst_adr                         ! \.le;\: Address of destination field
    ) : NOVALUE =                       ! ; .end list
    BEGIN                               ! dix$$copy_structure
    dix$routine_debug (off);

    LOCAL
        src_pnt,
        dst_pnt;
    dst_pnt = .dst_adr;
    INCRA src_pnt FROM .src_adr TO .src_adr + (.str_siz - 1 ) * %UPVAL BY %UPVAL DO
        BEGIN                           ! INCRA
        .dst_pnt = ..src_pnt;
        dst_pnt = .dst_pnt + %UPVAL;
        END;                            ! INCRA
    END;                                ! Dix$$copy_structure
%SBTTL 'GLOBAL ROUTINE dix$$get_argadr (LCG version)'
! LCG version of DIX$$GET_ARGADR

%IF %BLISS (BLISS36)
%THEN
GLOBAL ROUTINE dix$$get_argadr          ! \.!=;.hl 1 \
! ; .index  dix$$get_argadr          

!++
!   This routine is present only in the LCG/36 bit version.
!
!   When passed the contents of a formal parameter of a routine
! called with the DEC-10/20 standard calling sequence, return the
! actual address of the first word of the argument, regardless of
! whether the field passed is display or computational.
!
!   If an error (such as invalid format in the descriptors) is
! detected, signal that error to the calling routine (no handler
! is enabled at this level).
!
!   Routine Value:
! The address of the first word of the actual argument.
!
!   Side Effects:
! May signal a condition:
! dix$_unkargtyp
!
!   Formal arguments:
! .list 1
!--
    (
        formal_param                    ! \.le;\: The value of a formal 
                                        ! ; parameter from another routine
                                        ! ; called with the standard calling sequence.
    ) =                                 ! ; .end list

    BEGIN

    BUILTIN
        MACHOP, INCP;

    MAP
	formal_param : scs_arg;

    BIND
	arg_descr = .formal_param [scs$v_adr] : scs_descr;

    REGISTER
        arg_adr: REF scs_descr;

! ; .hl 2 Flow of Code

    MACHOP (%O'415', arg_adr, formal_param, 0, on);
                                        ! ; This XMOVEI will place the adr of
                                        ! ; the argument (or its descriptor)
                                        ! ; in arg_adr.

    SELECTONEU .formal_param [scs$v_type] OF
      ! ; .P;Process one alternative based on type field in scs argument
      ! ; list entry passed to us:
	SET

	[scs$k_for36_bool, scs$k_sbf36, scs$k_float36, scs$k_float72, 	!
            scs$k_unspecified,          ! [2] Treat unspecified as by ref
	    scs$k_sbf72, scs$k_fcmplx36, scs$k_asciz] :
	    !
	    ! ;   Argument is passed by reference; the address in the 
            ! ; arg list is the address of the entry.
	    !
            .arg_adr;                   ! ; Return address from arg list.

	[scs$k_display] :
	    !
            ! ;   Argument is passed by descriptor.  Must
            ! ; retrieve address from pointer in descriptor.
	    !
            BEGIN

            LOCAL
                byt_pntr;

            byt_pntr = .arg_adr [scs$v_bytpntr];       ! ; Make local copy of byte pointer from descriptor.
            INCP (byt_pntr);            ! ; Increment to point to first byte of string.
            MACHOP (%O'201', arg_adr, byt_pntr, 0, on);
                                        ! ; This MOVEI will force an effective adr
                                        ! ; calculation on the byte-pointer word
                                        ! ; and store the result in arg_adr;
                                        ! ; Thus the actual argument address becomes known.
                                        ! ; Note: I don't certify this to work in
                                        ! ; an extended addressing environment.
            .arg_adr                    ! ;   Return the address
            END;

	[OTHERWISE] :
	    !
	    ! ;  None of the above.  We don't recognize the type specified.
	    !
	    SIGNAL (dix$_unkargtyp);    ! \So \ to tell user.
	TES				! Value of SELECTONE is value of dix$$get_argadr
    END;				! END OF DIX$$GET_ARGADR

%FI                                     ! %IF %BLISS (BLISS36)

%SBTTL 'GLOBAL ROUTINE dix$$fetch_bits'
GLOBAL ROUTINE dix$$fetch_bits          ! \.!=;.hl 1 \
! ; .index  dix$$fetch_bits          

!++
!   This routine fetches strings of bits (in order of significance) from any
! foreign record (or, for that matter, anywhere else; that's where it's useful)
! in local memory.  It cannot fetch more than %BPVAL bits at a crack.  It can,
! however, fetch across unit boundaries.
!
!   Routine value:
! The bits fetched, or undefined if something failed (signal generated)
!
!   Side Effects:
! Signal generated on error:
! List of conditions TBS
!
!  Formal arguments:
!--
    (                                   ! ; .list 1
        p_unit,                         ! \.le;\: Address of unit containing
                                        ! ; low-order bit to fetch
        p_offset,                       ! \.le;\: Offset within that unit to  !
                                        ! ; low-order bit
        p_num_bits                      ! \.le;\: Number of bits to fetch
                                        ! ; (0 < .p_num_bits <= %bpval)
    ) =                                 ! ; .end list

    BEGIN
    LOCAL
        result,
        unit,
        offset,
        bits_this_cycle,
        bits_left;

    !
    ! Initialize local variables
    !
    result = 0;
    unit = .p_unit;
    offset = .p_offset;
    bits_left = .p_num_bits;
    DO
        BEGIN
        bits_this_cycle = MIN (.bits_left, %BPVAL - .offset);
        result <.p_num_bits - .bits_left, .bits_this_cycle> =
            .(.unit) <.offset, .bits_this_cycle, 0>;
        bits_left = .bits_left - .bits_this_cycle;
        unit = .unit + %UPVAL;
        offset = 0;
        END
    WHILE .bits_left GTR 0;
    .result                             ! Value returned
    END;
%SBTTL 'GLOBAL ROUTINE dix$$stuff_bits'
GLOBAL ROUTINE dix$$stuff_bits          ! \.!=;.hl 1 \
! ; .index  dix$$stuff_bits          

!++
! This routine stuffes strings of bits (in order of significance) into any
! foreign record (or, for that matter, anywhere else; that's where it's useful)
! in local memory.  It cannot stuff more than %BPVAL bits at a crack.  It can,
! however, stuff across unit boundaries.
!
!   Routine value:
! None
!
!   Side Effects:
! Signal generated on error:
! List of conditions TBS
!
!   Formal arguments:
!--
    (                                   ! ; .list 1
        p_unit,                         ! \.le;\: Address of unit 
                                        ! ; containing low-order bit to stuff
        p_offset,                       ! \.le;\: Offset within that unit
                                        ! ; to low-order bit
        p_num_bits,                     ! \.le;\: Number of bits to stuff
                                        ! ; (0 < .p_num_bits <= %bpval)
        p_source_value                  ! \.le;\: Value to stuff
    ) : NOVALUE =                       ! ; .end list

    BEGIN
    LOCAL
        unit,
        offset,
        bits_this_cycle,
        bits_left;
    !
    ! Initialize local variables.
    !
    unit = .p_unit;
    offset = .p_offset;
    bits_left = .p_num_bits;
    DO
        BEGIN
        bits_this_cycle = MIN (.bits_left, %BPVAL - .offset);
        (.unit) <.offset, .bits_this_cycle> =
            .p_source_value <.p_num_bits - .bits_left, .bits_this_cycle>;
        bits_left = .bits_left - .bits_this_cycle;
        unit = .unit + %UPVAL;
        offset = 0;
        END
    WHILE .bits_left GTR 0;
    END;
%SBTTL 'Global Routine dix$$bit_offset'

GLOBAL ROUTINE dix$$bit_offset          ! \.!=;.hl 1 \
! ; .index  dix$$bit_offset          

!++
!   Given a unit and a bit offset (possibly large, positive or negative),
! compute the unit addressed and the offset within it.
!
!   Routine value: NONE
!
!   Formal arguments:
!--

    (                                   ! ; .s 1.list 1
    in_unit,                            ! \.le;\: Base memory address
    in_offset,                          ! \.le;\: bit offset from that address
    out_unit_addr,                      ! \.le;\: Adr to write unit to
    out_offset_addr                     ! \.le;\: Adr to write offset to
    ) : NOVALUE =                       ! ; .end list
BEGIN                                   ! GLOBAL ROUTINE dix$$bit_offset

.out_unit_addr = .in_unit;
.out_offset_addr = .in_offset;

WHILE ..out_offset_addr LSS 0 DO
    BEGIN
    .out_offset_addr = ..out_offset_addr + %BPUNIT;
    .out_unit_addr = ..out_unit_addr - 1;
    END;

.out_unit_addr = ..out_unit_addr + ..out_offset_addr / %BPUNIT;
.out_offset_addr = ..out_offset_addr MOD %BPUNIT;

END;                                    ! GLOBAL ROUTINE dix$$bit_offset
%SBTTL 'ROUTINE dix$$check_alignment'

ROUTINE dix$$check_alignment            ! \.!=;.hl 1 \
! ; .index  dix$$check_alignment            

!++
!   Check to see if the original-system alignment as described by the user
! is valid for the data type specified.  If not, signal an alignment error.
! If so, return with no value.
!
!   Routine value: None.
!
!   Formal arguments:
!--
    (                                   ! ;.s 1.list 1
    data_type,                          ! \.le;\: Data type of field
    sys_origin,                         ! \.le;\: Code for system of origin
    alignment                           ! \.le;\: Alignment value
    ) : NOVALUE =                       ! ;.END LIST
BEGIN                                   ! ROUTINE dix$$check_alignment

MAP
    data_type: data_type_sep;

CASE .data_type [dt_class_sep] FROM 1 TO dix$k_max_class OF     ! ;  Case on dt_class
    SET                                 ! ;.lm +4.!Cases
    [dt_string]:                        ! \
        !++
        !   Strings on the VAX must be byte aligned.  Other systems can be
        ! aligned any old which way.  String:
        !--
        IF .sys_origin EQL sys_8bit AND .alignment NEQ 0 THEN
            SIGNAL (dix$_align);
    [dt_fbin]:                          ! \
        !++
        !   Fixed binary fields are all unit-aligned except for the variable
        ! length ones, which may be anywhere.
        !
        !   On the lcg systems, variable length fields must fit in a word.  This
        ! should be checked for when variable length fbin fields get implemented.
        !--
        IF NOT .dix$adtt_fbin [.data_type [dt_code_sep], fbd$v_variable] AND
            .alignment NEQ 0 THEN
            SIGNAL (dix$_align);
    [dt_fp]:                            ! \
        !++
        !   Floating-point fields are always unit-aligned.
        !--
        IF .alignment NEQ 0 THEN
            SIGNAL (dix$_align);

    [dt_dnum]:                        ! \
        !++
        !   Display Numeric fields on the VAX must be byte aligned.  
        ! Other systems can be aligned in any way.
        !--
        IF .sys_origin EQL sys_8bit AND .alignment NEQ 0 THEN
            SIGNAL (dix$_align);

    [dt_pdec]:                          ! \
        !++
        !  Packed Decimal fields on the VAX must be byte aligned.
        ! Other systems can be aligned in any way.
        !--
        IF .sys_origin EQL sys_8bit AND .alignment NEQ 0 THEN
            SIGNAL (dix$_align);

    TES;                                ! ;.lm -4.!Cases

END;                                    ! ROUTINE dix$$check_alignment
%SBTTL 'GLOBAL ROUTINE DIX$$CHECK_TYPE'
GLOBAL ROUTINE dix$$check_type          ! \.!=;.hl 1 \
! ; .index  dix$$check_type          

!++
!   Check the type-dependent information required in a foreign field 
! descriptor.  If this routine returns, the arguments passed were ok.  
! If they are not ok, an appropriate condition is signalled.
!
!   Routine value: None
!
!   Side effects:
!
!   Signals conditions as appropriate:
! .s 1.list 0, "o"
! dix$_invdattyp                  ! Class or type within class invalid
! dix$_invlng                     ! Length invalid for type specified
! dix$_invscal                    ! Scale invalid for type specified
! dix$_unksys                     ! Unknown system of origin
! .end list
!
!   Formal arguments:
!--
    (                                   ! ;.s 1.list 1
        dat_typ,                        ! \.le;\: Data type code
        sys_orig,                       ! \.le;\: System of origin
        fld_lng,                        ! \.le;\: Field length
        scale 				! \.le;\: Scale factor
    )                                   ! ;.end list
    : NOVALUE =                         ! 

    BEGIN				! Routine dix$$check_type

    MAP
	dat_typ : data_type_sep;

    !
    ! ; .hl 2 Flow of Code
    ! ; Check validity of data class code.
    !

    IF .dat_typ [dt_class_sep] LSS 1 OR .dat_typ [dt_class_sep] GTR dix$k_max_class 
    THEN
        SIGNAL (dix$_invdattyp);        ! \

    !
    ! ; .p;Check validity of within-class data type code.
    !

    IF .dat_typ [dt_code_sep] LSS 1 OR .dat_typ [dt_code_sep] GTR dix$at_max_dt_cod [.dat_typ [dt_class_sep]]
    THEN
        SIGNAL (dix$_invdattyp);        ! \

    !
    ! ; .p;Check system of origin.
    !

    IF .sys_orig LSS 1 OR .sys_orig GTR sys_max 
    THEN
        SIGNAL (dix$_unksys);           ! \

    !++
    !   Check for necessity, presence, and validity of field length and
    ! scale factor.
    !
    !   This code will be implemented piecemeal as data types are
    ! implemented which require it.
    !--

    CASE .dat_typ [dt_class_sep] FROM 1 TO dix$k_max_class OF
	SET

	[dt_string] :
	    !++
	    !   Strings require length specification sometimes (we 
            ! tell by the value in dix$adtt_st).  Lengths must be 
            ! positive if required.
	    !
	    !   Scale factors are never used.
	    !--

	    IF .dix$adtt_st [.dat_typ [dt_code_sep], std$v_lng_indic] EQL std$k_lng_spec
                                        ! Length must be specified
		AND .fld_lng LSS 1
	    THEN 			! Length negative or 0
		SIGNAL (dix$_invlng);   ! \.p;\ if length is invalid.
        [dt_fbin] :
            !++
            !   Fixed-point binary always requires a scale factor.  It
            ! requires a length if fbd$v_variable is set.  The legal range
            ! of scale factors and lengths is stored for each data type.
            !--
            BEGIN                       ! Case dt_fbin
            IF .dix$adtt_fbin [.dat_typ [dt_code_sep], fbd$v_variable]
            THEN
                BEGIN                   ! Type is variable-length
                IF .fld_lng LSS .dix$adtt_fbin [.dat_typ [dt_code_sep], fbd$v_min_lng] OR
                    .fld_lng GTR .dix$adtt_fbin [.dat_typ [dt_code_sep], fbd$v_max_lng]
                THEN
                    SIGNAL (dix$_invlng);       ! \.p;\ if length is invalid.
                END;                    ! Type is variable-length
            IF .scale LSS .dix$adtt_fbin [.dat_typ [dt_code_sep], fbd$v_min_scale] OR
                .scale GTR .dix$adtt_fbin [.dat_typ [dt_code_sep], fbd$v_max_scale]
            THEN
                SIGNAL (dix$_invscal);  ! \.p;\ if scale is invalid.
            END;                        ! Case dt_fbin
        [dt_fp]:                        ! \.p;\
            BEGIN                       ! ;.LM +4.!Case dt_fp
            IF .fld_lng NEQ 0 THEN SIGNAL (dix$_invlng);        ! ; Field length must be 0.
            IF .scale NEQ 0 THEN SIGNAL (dix$_invscal); ! ; Scale factor must be 0.
            END;                        ! ;.LM -4.!Case dt_fp
        [dt_dnum]:                      ! \.p;\

            !++
            !   Display numeric fields require a length specification.
            ! A maximum length is specified for each data type in the
            ! dix$adtt_dn table in the dnd$v_max_length entry.  The
            ! field length must be less than or equal to the maximum
            ! length for the data type.  For any field with a separate
            ! sign, the field length must be greater than or equal to 2.
            ! For any other sign type the field length must be greater
            ! than 1.
            !--

            BEGIN
            IF (SELECTONE .dix$adtt_dn[.dat_typ[dt_code_sep], dnd$v_sign_type] OF
                SET
                [dnd$k_lead_sep, dnd$k_trail_sep] : .fld_lng LSS 2;
                [OTHERWISE] : .fld_lng LSS 1;
                TES)
            OR
               (.fld_lng GTR .dix$adtt_dn[.dat_typ[dt_code_sep], dnd$v_max_length])
	    THEN 			! Length out of range
		SIGNAL (dix$_invlng);   ! \.p;\ if length is invalid.

            !++
	    !   The scale factor must be valid.  The legal scale
            ! factor range is dependant upon the data type and the
            ! length of the specified field.  The following formula
            ! defines the valid scale factor values:
            ! .literal
            !		(-m + l) <= s <= m
            ! .end literal
            ! where "m" is the maximum field length for the given data
            ! type (minus 1 for a data type with a separate sign), "l"
            ! is the field length specified (minus 1 for a data type
            ! with a separate sign), and "s" is the specified scale
            ! factor.   Note that the maximum field length value for
            ! each data type is located in the table dix$adtt_dn.
	    !--

            SELECTONE .dix$adtt_dn[.dat_typ[dt_code_sep], dnd$v_sign_type] OF
            SET
            [dnd$k_lead_sep, dnd$k_trail_sep] :
                IF (.scale GTR .dix$adtt_dn[.dat_typ[dt_code_sep], dnd$v_max_length] - 1)
                OR (.scale LSS -.dix$adtt_dn[.dat_typ[dt_code_sep], dnd$v_max_length] + .fld_lng)
                THEN SIGNAL (dix$_invscal);     ! \.p;\ if scale is invalid.

            [OTHERWISE] :
                IF (.scale GTR .dix$adtt_dn[.dat_typ[dt_code_sep], dnd$v_max_length])
                OR (.scale LSS -.dix$adtt_dn[.dat_typ[dt_code_sep], dnd$v_max_length] + .fld_lng)
                THEN SIGNAL (dix$_invscal);     ! \.p;\ if scale is invalid.

            TES
            END;

        [dt_pdec]:                      ! \.p;\
           !++
           !  Packed decimal fields require a length specification.
           ! A maximum length is specified for each data type in the
           ! dix$adtt_pd table in the pdd$v_max_length entry.  The
           ! field length must be less than or equal to the maximum
           ! length for the data type and greater than or equal to one.
           !--

           BEGIN
           IF .fld_lng LSS 1 OR
               .fld_lng GTR .dix$adtt_pd[.dat_typ[dt_code_sep], pdd$v_max_length]
           THEN                         ! Length out of range
               SIGNAL (dix$_invlng);    ! \.p;\ if length is invalid.

           !++
           !   The scale factor must be valid.  The legal scale factor range
           ! is dependant upon the data type and the length of the specified
           ! field.  The following formula defines the valid scale factor
           ! values:
           ! .literal
           !           (-m + 1) <= s <= m
           ! .end literal
           ! where "m" is the maximum field length for the given data type,
           ! "l" is the field length specified, and "s" is the specified
           ! scale factor.  Note the the maximum field length value for each
           ! data type is located in the table dix$adtt_pd.
           !--

           IF (.scale GTR .dix$adtt_pd[.dat_typ[dt_code_sep], pdd$v_max_length])
             OR (.scale LSS -.dix$adtt_pd[.dat_typ[dt_code_sep], pdd$v_max_length] + .fld_lng)
           THEN SIGNAL (dix$_invscal)   ! \.p;\ if scale is invalid.
           END;

	TES;

    END;				! Routine dix$$check_type
%SBTTL 'GLOBAL ROUTINE DIX$$CHECK_FFD'
GLOBAL ROUTINE dix$$check_ffd           ! \.!=;.hl 1 \
! ; .index  dix$$check_ffd           

!++
!   Perform the checks on an FFD that are to be performed on each entry from
! a user routine that passes an FFD.  If the FFD passes, the routine returns
! with no value.  If the FFD fails, an appropriate condition is signalled.
!
!   The checks performed by dix$$check_type are used here.  In addition,
! Alignment checks are performed based on the data type.
!
!   Routine value: None.
!
!   Side effects:
!
! May signal any condition signalled by dix$$check_type.
!
!  Formal arguments:
!--
    (                                   ! ; .s 1.list 1
        ffd                             ! \.le;\: The address of a foreign field descriptor
    )                                   ! ; .end list
    : NOVALUE =

    BEGIN				! Routine dix$$check_ffd

    MAP
	ffd : REF forgn_descr;

    dix$$check_type (.ffd [ffd$v_type], .ffd [ffd$v_sys_orig], .ffd [ffd$v_length], .ffd [ffd$v_scale]);
    dix$$check_alignment (.ffd [ffd$v_type], .ffd [ffd$v_sys_orig], .ffd [ffd$v_align]);
    END;				! Routine dix$$check_ffd
%SBTTL 'GLOBAL ROUTINE dix$$des_by_det'
GLOBAL ROUTINE dix$$des_by_det          ! \.!=;.hl 1 \
! ; .index  dix$$des_by_det          

!++
!
!   Make DIX Descriptor From Detailed Description
!
!   Level = 1, DD = 1.  Portal routine.
!   Algorithm:  Brute force.  All information necessary is available.
!
!   Routine value: Status value.
!
!   Side Effects:
!
! May signal any condition signalled by dix$$check_type or dix$$check_alignment.
! May signal dix$_invbytsiz.
!
!   Formal arguments:
!--
    (                                   ! ;.s 1.list 1
        res_ffd,                        ! \.le;\: (by reference, written) The DIX descriptor to be produced
        con_rec,                        ! \.le;\: (by reference) The record in which the field exists
        sys_orig,                       ! \.le;\: (integer) A code for
                                        ! ; the system on which the record
                                        ! ; originated
        byt_siz,                        ! \.le;\: (integer) The byte size to interpret the offset in
        byt_off,                        ! \.le;\: (integer) The offset to the
                                        ! ; field in the record, in bytes (as
                                        ! ; defined above)
        bit_off,                        ! \.le;\: (integer) The bit offset to
                                        ! ; the  field  within  the  selected
                                        ! ; byte
        dat_typ,                        ! \.le;\: (integer) The code for the data type of the field
        fld_lng,                        ! \.le;\: (integer) The length of
                                        ! ; the field in the  natural  
                                        ! ; units  for the data type (value
                                        ! ; ignored if field is not variable length)
        scal_fac                        ! \.le;\: (integer) The scale factor
            ! ; of the field if it is a fixed-point
            ! ; binary or display-numeric field
            ! ; (including packed decimal)
    ) =                                 ! ; .end list

    BEGIN

    MAP
	res_ffd : REF forgn_descr;

    LOCAL
	bit_disp;

    !++
    ! .hl 2 Flow of Code
    !   This routine is an exception to the rule that checking of user
    ! arguments should be done at the interface level.  The arguments for
    ! FFD making are checked here to avoid a horrible amount of code
    ! duplication in the routines for the umpteen interfaces to this.
    !--

    dix$$check_type (.dat_typ, .sys_orig, .fld_lng, .scal_fac);	! \\ Signals if fails

    IF (.byt_siz LSS 1) OR (.byt_siz GTR .dix$ag_sys_bpunit [.sys_orig]) THEN
	SIGNAL (dix$_invbytsiz);	! \  If byte size too small or large, 

    !
    ! ;   Compute bit offset to lsb of field
    !
    bit_disp = (CASE  .sys_orig FROM 1 to sys_ult OF
        SET
        [sys_8bit]: .byt_siz * .byt_off + .bit_off;     ! ;   On VAX this is simple
        [sys_lcg]: (((.dix$ag_sys_bpunit [.sys_orig] - 1) - .byt_siz + 1)
                                        ! ;   On LCG, not so simple
                                        ! ; Offset to first byte in first unit
        + .dix$ag_sys_bpunit [.sys_orig]*(.byt_off/(.dix$ag_sys_bpunit [.sys_orig]/.byt_siz))
                                        ! ; Offset to that byte in unit containing LSB of field
        - .byt_siz*(.byt_off MOD (.dix$ag_sys_bpunit [.sys_orig]/.byt_siz))	
                                        ! ; Offset to byte containing LSB of field
        + .bit_off);                    ! ; Include specified bit offset
        [INRANGE, OUTRANGE]:            ! ;   If no known system,
            SIGNAL (dix$_unksys);       ! \
        TES);                                      
    ! ; .p;Compute FFD fields from bit displacement
    res_ffd [ffd$v_unit] = .con_rec + .bit_disp/%BPUNIT;
    res_ffd [ffd$v_offset] = .bit_disp MOD %BPUNIT;
    res_ffd [ffd$v_align] = .bit_disp MOD .dix$ag_sys_bpunit [.sys_orig];
    res_ffd [ffd$v_length] = .fld_lng;
    res_ffd [ffd$v_scale] = .scal_fac;
    res_ffd [ffd$v_type] = .dat_typ;
    res_ffd [ffd$v_sys_orig] = .sys_orig;
    dix$$check_alignment (.dat_typ, .sys_orig, .res_ffd [ffd$v_align]);
    dix$success_cond
    END;				! END OF dix$$des_by_det
%SBTTL 'GLOBAL ROUTINE dix$$incr_des'
GLOBAL ROUTINE dix$$incr_des            ! \.!=;.hl 1 \
! ; .index  dix$$incr_des            

!++
!   Increment String Descriptor.
! 
!   Level = 3, DD = 3.
! 
!   Algorithm:  based on data type specified, increment spot pointed to by
! descriptor past one character, taking into account synchronization and
! alignment (this is a problem with  all  DEC-10/20  strings,  and  with
! PASCAL packed arrays of characters in packed records).
! 
!   Routine Value:  None
! 
!   Side Effects: Signals if error detected.
! 
!   Formal arguments:
!--
    (                                   ! ;.s 1.list 1
        ffd                             ! \.le;\: Address of descriptor pointing to
                                        ! ; string-type field.  Descriptor is modified.
    ) : NOVALUE =                       ! ;.end list

    BEGIN

    LOCAL
	delta,
	byt_siz;

    MAP
	ffd : REF forgn_descr;

    BIND
	orig_bpu = dix$ag_sys_bpunit [.ffd [ffd$v_sys_orig]];

! ;   Currently, this routine deals with class string, class display
! ; numeric and class packed decimal data only.

    byt_siz =
        (SELECTONE .ffd[ffd$v_dt_class] OF
         SET
         [dt_string] : .dix$adtt_st [.ffd [ffd$v_dt_type], std$v_byt_siz];
         [dt_dnum] : .dix$adtt_dn [.ffd [ffd$v_dt_type], dnd$v_byt_siz];
         [dt_pdec] : .dix$adtt_pd [.ffd [ffd$v_dt_type], pdd$v_byt_siz];
         TES);

!
! ;   Since this routine is roughly third level in the conversion routines, no
! ; check is necessary for validity of data type.
!
    CASE .ffd [ffd$v_sys_orig] FROM 1 TO sys_max OF
	SET

	[sys_lcg] :
	    !
	    ! 36-bit system specific
	    !
	    BEGIN

	    IF .ffd [ffd$v_align] LSSU .byt_siz
	    THEN
		BEGIN			! Byte is at start of next word
		delta = 2*.orig_bpu - .ffd [ffd$v_align];
		ffd [ffd$v_align] = .orig_bpu;
		END
	    ELSE
		delta = 0;

	    delta = .delta - .byt_siz;
	    ffd [ffd$v_align] = .ffd [ffd$v_align] - .byt_siz;
	    END;			! 36-bit system-specific

	[sys_8bit] :
	    !
	    ! 8-bit system specific
	    !
	    BEGIN			! 8-bit system-specific
	    ffd [ffd$v_align] = (.ffd [ffd$v_align] + .byt_siz) MOD .orig_bpu;
	    delta = .byt_siz
	    END;			! 8-bit system-specific
!
! We could insert a check for invalid sys_orig here with an OUTRANGE
! CASE label.  I'm not sure if we want to or not.
!
	TES;				! Value of CASE is not used

    !
    ! Common to all systems
    !
    delta = .delta + .ffd [ffd$v_offset];

    WHILE .delta LSS 0 DO 		! Grind down if we moved backwards
	BEGIN
	ffd [ffd$v_unit] = .ffd [ffd$v_unit] - 1;
	delta = .delta + %BPUNIT
	END;

    ffd [ffd$v_unit] = .ffd [ffd$v_unit] + .delta/%BPUNIT;
    ffd [ffd$v_offset] = .delta MOD %BPUNIT;
    END;				! END OF dix$$incr_des

%SBTTL 'GLOBAL ROUTINE dix$$adj_xi_scal'
GLOBAL ROUTINE dix$$adj_xi_scal         ! \.!=;.hl 1 \
! ; .index  dix$$adj_xi_scal

!++
!   Adjust XI Field to correspond to given Scale.
! 
!   Algorithm:  Keeping the decimal point aligned, shift the decimal
! places of the XI field.  In order to facilitate this, copy the XI
! digits into a temporary XI field (xi_tmp) as they are shifted.
!
!   Routine value:  Status value, either dix$_rounded or dix$status_cond.
!
!   Formal Arguements:
!--
   (                                    ! ; .s 1 .list 1
    dst_scal,                           ! \.le;\: the destination scale desired
    xi_field                            ! \.le;\: the address of the XI field (the XI field is modified)
   ) =                                  ! ; .end list

    BEGIN                               ! begin dix$$adj_xi_scal routine

    MAP xi_field : REF xi;

    LOCAL c1,
          shift : INITIAL(0),
          xi_tmp : xi,
          lowsig_lost;

    lowsig_lost = 0;                    ! initialize

    shift = .dst_scal - .xi_field[xi$v_scale];  ! calculate required shift

    IF .shift GTR 0                     ! if it is a positive shift
    THEN BEGIN
         INCR c1 FROM 0 TO .shift - 1 DO        ! then shift in low order zeros
              xi_tmp[xi$v_digit, .c1] = 0;
         INCR c1 FROM xi$k_digits - .shift + 1 TO xi$k_digits DO  ! be sure high order
              IF .xi_field[xi$v_digit, .c1] NEQ 0       ! digits shifted out are zero
                 THEN SIGNAL (dix$_toobig);     ! if not, signal an error.
         END
    ELSE IF .shift LSS 0                ! If it's a negative shift
         THEN BEGIN                     ! then shift in high order zeros
              INCR c1 FROM xi$k_digits + .shift + 1 TO xi$k_digits DO
                   xi_tmp[xi$v_digit, .c1] = 0;
              INCR c1 FROM 0 TO -.shift - 1 DO          ! & make sure low order digits shifted out
                   IF .xi_field[xi$v_digit, .c1] NEQ 0  ! are also zero, if any aren't zero then we 
                      THEN BEGIN        ! will lose a non-zero low order digit
                           lowsig_lost = 1;     ! so indicate rounded and
                           EXITLOOP     ! don't waste any time looking for more
                           END;
              END;

    ! Now that the shift has been aligned, fill the rest of xi_tmp
    ! with the digits from xi_field.  What we are doing here is making
    ! a temporary copy of the XI form which has the scale adjusted for
    ! our use.

    IF .shift GEQ 0
    THEN INCR c1 FROM 0 TO xi$k_digits - .shift DO
              xi_tmp[xi$v_digit, .c1 + .shift] = .xi_field[xi$v_digit, .c1]
    ELSE                                ! (if shift < 0)
         INCR c1 FROM 0 TO xi$k_digits + .shift DO
              xi_tmp[xi$v_digit, .c1] = .xi_field[xi$v_digit, .c1 - .shift];

    INCR c1 FROM 0 TO xi$k_digits DO    ! copy scale-adjusted temp XI form into
         xi_field[xi$v_digit, .c1] = .xi_tmp[xi$v_digit, .c1];  ! perm XI form

    (IF .lowsig_lost                    ! return status dix$_rounded if we
         THEN dix$_rounded              ! lost low order significant digits,
     ELSE dix$success_cond)             ! else return success status

END;                                    ! end of routine DIX$$ADJ_XI_SCAL

END					! End of module

ELUDOM