Google
 

Trailing-Edge - PDP-10 Archives - bb-lw55a-bm - language-sources/dapt20.b36
There are 20 other files named dapt20.b36 in the archive. Click here to see a list.
MODULE DAPT20(
              IDENT='1',
              ENTRY(S$DTSTR, S$STRDT, S$JFN_STR, S$RMS_VER,
                                      S$JFNSTR,  S$RMSVER,  RMSv3  )
              )=
BEGIN
!  COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1981, 1986.
!  ALL RIGHTS RESERVED.
!  
!  THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY  BE  USED  AND
!  COPIED ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH
!  THE INCLUSION OF THE ABOVE COPYRIGHT NOTICE.   THIS  SOFTWARE  OR
!  ANY  OTHER  COPIES  THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE
!  AVAILABLE TO ANY OTHER PERSON.  NO TITLE TO AND OWNERSHIP OF  THE
!  SOFTWARE IS HEREBY TRANSFERRED.
!  
!  THE INFORMATION IN THIS SOFTWARE IS  SUBJECT  TO  CHANGE  WITHOUT
!  NOTICE  AND  SHOULD  NOT  BE CONSTRUED AS A COMMITMENT BY DIGITAL
!  EQUIPMENT CORPORATION.
!  
!  DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR  RELIABILITY  OF
!  ITS SOFTWARE ON EQUIPMENT THAT IS NOT SUPPLIED BY DIGITAL.

!++
! FACILITY:
!   DAP-20.
!
! ABSTRACT:
!   This module contains various interface routines to TOPS-20.
!
! ENVIRONMENT:
!   TOPS-20 user mode, XPORT.
!
! AUTHOR: Larry Campbell, CREATION DATE: 21 Oct 1982
!
! MODIFIED BY: Andrew Nourse
!
! 01 -    Move these routines from FTST20 to DAPT20 (this module)
!--

FORWARD ROUTINE
    s$dtstr : NOVALUE,                  ! Convert date/time to string
    s$strdt,                            ! convert string to date/time
    s$jfn_str;                          ! Convert JFN to string

!
! INCLUDE FILES:
!
LIBRARY 'BLI:XPORT';
LIBRARY 'BLI:MONSYM';
REQUIRE 'RMSOSD';


!
! MACROS:
!
MACRO
    lh = 18, 18 %,
    rh =  0, 18 %,
    xwd ( lft, rgt ) = (lft^18) OR (rgt) %,
    asciz_len (string) =
        BEGIN
        LOCAL
            tptr;
        tptr = string;
        INCR i FROM 0
        DO
        IF CH$RCHAR_A (tptr) EQL 0
        THEN
            EXITLOOP .i
        END %;

!
! EQUATED SYMBOLS:
!
LITERAL
    minute = %O'1000000' / (24 * 60);   ! One minute

!
! GLOBAL DATA
!
GLOBAL RMSv3;
GLOBAL ROUTINE s$dtstr (date_time, p_descr) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!   Convert internal date/time to string.
!
! FORMAL PARAMETERS:
!   date_time           - date and time in universal internal format
!                         (-1 means now)
!   p_descr             - pointer to descriptor to receive string
!
! IMPLICIT INPUTS:
!   NONE
!
! IMPLICIT OUTPUTS:
!   NONE
!
! ROUTINE VALUE and
! COMPLETION CODES:
!   NONE
!
! SIDE EFFECTS:
!   NONE
!
!--
    BEGIN

    BIND
        descr = .p_descr : $STR_DESCRIPTOR ();

    LOCAL
        ptr,
        length,
        string_buffer : VECTOR [CH$ALLOCATION (32)];

    ODTIM (CH$PTR (string_buffer), .date_time, 0);
    ptr = CH$PTR (string_buffer);
    length = 0;
    UNTIL (CH$RCHAR_A (ptr) EQL 0)
    DO
        length = .length + 1;
    $STR_COPY (STRING = (.length, CH$PTR (string_buffer)), TARGET = descr,
               OPTION = TRUNCATE);
    END;                                ! End of s$dtstr
GLOBAL ROUTINE s$strdt (p_descr) =
!++
! FUNCTIONAL DESCRIPTION:
!   Convert string to internal date/time
!
! FORMAL PARAMETERS:
!   p_descr             - pointer to descriptor to string
!
! IMPLICIT INPUTS:
!   NONE
!
! IMPLICIT OUTPUTS:
!   NONE
!
! ROUTINE VALUE
!   Internal Date/Time
!
! SIDE EFFECTS:
!   NONE
!
!--
    BEGIN

    BIND
        descr = .p_descr : $STR_DESCRIPTOR ();

    LOCAL
        internal_date_time,
        result,
        string_buffer : VECTOR [CH$ALLOCATION (32)];

    $STR_COPY (STRING = $STR_CONCAT (descr, %CHAR(0)),
               TARGET = (31, CH$PTR (string_buffer)),
               OPTION = TRUNCATE);

    IF IDTIM (CH$PTR (string_buffer), 0; result, internal_date_time)
    THEN
        RETURN (.internal_date_time)    ! Returned value
    ELSE
        SIGNAL (.result)                ! String was trash or something
    END;                                ! End of s$strdt
GLOBAL ROUTINE s$jfn_str (jfn, p_desc, bits) =
!++
! FUNCTIONAL DESCRIPTION:
!   Convert a JFN to a filespec string.
!
! FORMAL PARAMETERS:
!   jfn         - the JFN
!   p_desc      - address of descriptor to receive the string
!   bits        - format control bits (AC3 of JFNS call).  If 0, this
!                 defaults to the usual case (supply and punctuate everything)
!
! IMPLICIT INPUTS:
!   NONE
!
! IMPLICIT OUTPUTS:
!   NONE
!
! ROUTINE VALUE and
! COMPLETION CODES:
!   The length of the filespec string is returned, or 0 if any errors (which
!   are also signalled).
!
! SIDE EFFECTS:
!   NONE
!
!--
    BEGIN

    BIND
        desc = .p_desc : $STR_DESCRIPTOR ();

    LOCAL
	temp_desc : $STR_DESCRIPTOR (CLASS = FIXED),
        temp_desc_buffer : VECTOR [CH$ALLOCATION (255)],
        adjusted_length,
        jfns_bits,
        new_ptr;

    $STR_DESC_INIT (DESCRIPTOR = temp_desc,
                    STRING = (255, CH$PTR (temp_desc_buffer)));
    IF .bits EQL 0
    THEN
        jfns_bits = %O'111110000001'    ! Return all the usual fields
    ELSE
        jfns_bits = .bits;
    IF NOT JFNS (.temp_desc[STR$A_POINTER], .jfn, .jfns_bits, 0; new_ptr)
    THEN
        RETURN (SIGNAL (XPO$_CHANNEL); 0);
    temp_desc[STR$H_LENGTH] = ABS (CH$DIFF (.new_ptr,
                                            .temp_desc[STR$A_POINTER])) + 1;
    $STR_COPY (STRING = temp_desc, TARGET = desc, OPTION = TRUNCATE);
    !
    ! Unless the target descriptor was too short, we also copied the trailing
    ! null.  Here we account for that.  If the last character of the target
    ! is null, we copied the null, so must return a length one less.
    !
    adjusted_length = MIN (.desc[STR$H_LENGTH],
                           .temp_desc[STR$H_LENGTH]);
    IF CH$RCHAR (CH$PLUS (.desc[STR$A_POINTER], .adjusted_length - 1)) EQL 0
    THEN
        adjusted_length = .adjusted_length - 1;
    RETURN (.adjusted_length)
    END;                                ! End of s$jfn_str
GLOBAL ROUTINE S$RMS_ver =
!+
!   Functional Description:
!
!     Check Which version of RMS we have
!
!   Implicit Outputs:
!
!     RMSv3 set if this is RMS version 3 or later
!     
!   Return Value:
!
!     Version number of RMS
!-
    BEGIN                               ![4] vv
    LOCAL
         t2,
         t3,
         dvec: REF BLOCK;

    XGSEV_( XWD( $XSEVD, $FHSLF ); t2, t3 );  ! Get RMS entry vector

    dvec = .t3<0,29>;                   ! Mask out flag bits

    IF .dvec[2, 24, 9, 0] GEQ 3         ![72] typo
    THEN RMSv3 = -1;                    ! We have RMS version 3

    .dvec[2, 0, 36, 0]                  ! Return RMS version number
    END;                                ![4] ^^

GLOBAL BIND ROUTINE S$JFNSTR = S$JFN_STR;
GLOBAL BIND ROUTINE S$RMSVER = S$RMS_VER;
END ELUDOM			! End of Module