Google
 

Trailing-Edge - PDP-10 Archives - TOPS-20_V6.1_DECnetSrc_7-23-85 - mcb/sc/scxsub.bli
There is 1 other file named scxsub.bli in the archive. Click here to see a list.
module SCXSUB (
		ident = 'X01150'
		) =
begin
!
!                    COPYRIGHT (c) 1980, 1981, 1982
!                    DIGITAL EQUIPMENT CORPORATION
!                        Maynard, Massachusetts
!
!     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  which  is  not supplied by
!     DIGITAL.
!

!++
!
! FACILITY:	Task Session Control
!
! ABSTRACT:	Subroutine support to the task interface SCX
!
! ENVIRONMENT:	MCB (RSX-11 user)
!
! AUTHOR:	Buren Hoffman		CREATION DATE: 5-Aug-80
!
! MODIFIED BY:
!	X01010	Changed code to use $byt_ptr macro in place of the
!		ch$ptr macro.
!	X01020	Fixed SIGNAL_STOP macro to output more info, as required
!	X01030	Fixed redundant coding problem in FNDOBJ.
!	X01040	Use new Comm/Exec to process linkage (.CRDAT for database)
!	X01050	Updated to use library calls, instead of requires.
!	X01060	Modified KOMPLT to put status in C_PRM2
!	X01070	Added AST queueing routine.
!	X01080	Fixed bug in above ast queueing routine.
!	X01090	Fixed DEACB problem.
!	X01100	Fixed link counter problem.
!	X01110	X01060 should have put status in C_STS.
!	X01120	Optimization work.
!	X01130	?
!	X01140	Fixed LCB unlink and deallocation problem.
!	x01150	Ron Platukis 17-aug-81
!		-Set C_CNT to 0 in MBPROC before issueing S$REJ call
!
!
!--
!
! INCLUDE FILES:
!
library 'SCPRM';
library 'MCB:MCBLIB';
library 'MCB:RSXLIB';
library 'MCB:XPORTX';
library 'MCB:SCSYS';

require 'SCRSX';

!
! TABLE OF CONTENTS:
!
forward routine
    BUFCHK,				! Validate user buffer
    DO$XME: linkage_ccb novalue,	! Do XME processing
    FNDOBJ,				! Locate specified object
    GETLCB,				! Get LCB and ULA, and init it
    LCBKIL: novalue,			! Unlink and deallocate LCB
    MBPROC: novalue,			! Process mailbox connects
    NOOP: novalue,			! Do nothing; just return
    QUEAST,				! Queue an AST
    STXMAP,				! Map from SC codes to RSX codes
    ULAGET,				! Allocate a ULA to use
    ULARD,				! Read contents of ULA
    ULASET: novalue,			! Set contents of ULA
    $C5TA: novalue,			! Convert rad50 to ascii
    $CAT5,				! Convert ascii to rad50
    $SCQHD: novalue,			! Queue to head of list
    $SCQIN: novalue,			! Queue to tail of list
    $SCQRM;				! Remove from head of list

!
! MACROS:
!

!
! EQUATED SYMBOLS:
!

!
! OWN STORAGE:
!

!
! EXTERNAL REFERENCES:
!
global routine BUFCHK (USR, SYS, SIZE) =

!++
! FUNCTIONAL DESCRIPTION:
!	Validate user buffers, and remap for APR6 usage.
!
! FORMAL PARAMETERS:
!	USR	User buffer specification
!	SYS	Output area for system buffer specification
!	SIZE	Maximum buffer size
!
! IMPLICIT INPUTS:
!	USR and SYS areas formatted according to standard
!	USR_BUFF and SYS_BUFF definitions.
!
! IMPLICIT OUTPUTS:
!	None
!
! ROUTINE VALUE:
!	Status code for any error detected.
!
! COMPLETION CODES:
!	None
!
! SIDE EFFECTS:
!	None
!--

    begin
    map
	USR: ref block field (USR_BUFF),
	SYS: ref block field (SYS_BUFF);
    local
	USR_TMP: block [2] field (USR_BUFF);

    if (USR_TMP [USR_ADDR] = .USR [USR_ADDR]) eql 0
    then
	begin
	SYS [SYS_SIZE] = 0;		! No buffer, so
	SYS [SYS_BIAS] = 0;		!   set zeroes
	SYS [SYS_ADDR] = 0;
	end
    else
	begin
	USR_TMP [USR_SIZE] = .USR [USR_SIZE];
	if (.USR_TMP [USR_SIZE] leq 0) or ((.SIZE neq 0) and (.USR_TMP [USR_SIZE] gtr .SIZE))
	  then return IE_BAD;			! Bad parameter
	SYS [SYS_SIZE] = .USR_TMP [USR_SIZE];
	if not ACHKB$ (.USR_TMP [USR_ADDR], .USR_TMP [USR_SIZE])
	  then return IE_SPC;			! Invalid buffer parameter
	RELOC$ (.USR_TMP [USR_ADDR], SYS [SYS_BIAS], SYS [SYS_ADDR])
	end;

    return IS_SUC
    end;
global routine DO$XME (CCB, MDF, IOP, LCB, BUF): linkage_ccb novalue =

!++
! FUNCTIONAL DESCRIPTION:
!	Do XME processing
!
! FORMAL PARAMETERS:
!	CCB	CCB address
!	MDF	RCP modifier
!	IOP	IOP address
!	LCB	LCB address (may be zero)
!	BUF	3-word buffer-descriptor address
!
! IMPLICIT INPUTS:
!	LLT mapped
!
! IMPLICIT OUTPUTS:
!	CCB scheduled
!
! ROUTINE VALUE:
! COMPLETION CODES:
!	None
!
! SIDE EFFECTS:
!	None
!--
    begin
    $scx_get_data_base (SCXDB);
    map CCB: ref block field (C_FIELDS),
	LCB: ref block field (LCB_FIELDS),
	BUF: ref vector [3];

    CCB [C_FNC] = FC_XME;
    CCB [C_MOD] = .MDF;
    CCB [C_PIX] = .SCXDB [SCX_SCPIX];
    CCB [C_PRM5] = .IOP;

    if .BUF neq 0
    then
	begin
	CCB [C_BIAS] = .BUF [0];
	CCB [C_ADDR] = .BUF [1];
	CCB [C_CNT] = .BUF [2]
	end;

    if .LCB neq 0
    then
	begin
	CCB [C_LIX] = .LCB [LC_LLA];
	CCB [$sub_field (C_PRM1, LO_BYTE)] = .LCB [LC_ULA]
	end;

    $MCB_SCHEDULE_CCB (.CCB)
    end;
global routine FNDOBJ (DST, TCB) =

!++
! FUNCTIONAL DESCRIPTION:
!	Locate object type, and return TCB address
!
! FORMAL PARAMETERS:
!	DST	Destination portion of connect block
!	TCB	Address of word to receive TCB address
!
! IMPLICIT INPUTS:
!	The connect block is mapped (i.e., DST).
!
! IMPLICIT OUTPUTS:
!	None
!
! ROUTINE VALUE:
!	True if object found
!	False if object not found
!
! COMPLETION CODES:
!	None
!
! SIDE EFFECTS:
!	None
!--

    begin
    $scx_get_data_base (SCXDB);
    map DST: ref block field (CBSD_FIELDS);
    local
	PROC_NAM,
	NAM_LEN,
	NAM_PTR,
	NAME: vector [byt$allocation (6)],
	%if %bliss (bliss36) %then R50_NAME %else R50_NAME: vector [2] %fi;

    bind
	OTN = SCXDB [SCX_OTN_ADDR]: ref blockvector [,OTN_SIZE] field (OTN_FIELDS);

    case .DST [CB_FMT] from 0 to 2 of
	set

	[0]:			! Format 0
	    begin
	    local
		OBJ,
		SAV_MAP;

	    SMAP$ (SAV_MAP);			! Save mapping
	    OBJ = .DST [CB_OBJ];		! Get obj before changing map
	    MAP$ (.SCXDB [SCX_OTN_BIAS]);	! Set to object table map
	    NAM_LEN = 0;			! Be pessimistic
	    incr I from 0 to .SCXDB [SCX_OTN_LEN]-1 do
		begin
		if .OBJ eql .OTN [.I, OTN_TYPE]
		then
		    begin
		    NAM_PTR = byt$ptr (NAME);	! Copy name to local store
		    ch$move (6, byt$ptr (OTN [.I, OTN_NAME]), .NAM_PTR);
		    NAM_LEN = .OTN [.I, OTN_NLEN];
		    exitloop
		    end
		end;

	    MAP$ (.SAV_MAP);			! Restore mapping
	    if .NAM_LEN eql 0 then return false
	    end;

	[1]:			! Format 1
	    begin
	    NAM_PTR = byt$ptr (DST [CB_NAM]);
	    NAM_LEN = .DST [CB_LEN]
	    end;

	[2]:			! Format 2
	    begin
	    NAM_PTR = byt$ptr (DST [CB_NM2]);
	    NAM_LEN = .DST [CB_LN2]
	    end;

	[outrange]:
	    return false;
	tes;

    %if %bliss (bliss36)
    %then
	R50_NAME = $CAT5 (NAM_PTR, true);
    %else
	R50_NAME [0] = $CAT5 (NAM_PTR, true);
	R50_NAME [1] = $CAT5 (NAM_PTR, true);
    %fi

    $rsx_get_tcb( R50_NAME, .TCB)
    end;
global routine GETLCB (TNBP, LCBP, TKBA) =

!++
! FUNCTIONAL DESCRIPTION:
!	Get LCB memory and ULA.
!
! FORMAL PARAMETERS:
!	TNBP	Address of word to receive address of TNB
!	LCBP	Address of word to receive address of LCB
!	TKBA	TKB address
!
! IMPLICIT INPUTS:
!	None
!
! IMPLICIT OUTPUTS:
!	LCB initialized
!
! ROUTINE VALUE:
!	True if successful, else false
!
! COMPLETION CODES:
!	None
!
! SIDE EFFECTS:
!	None
!--

    begin
    $scx_get_data_base (SCXDB);
    local
	TNB: ref block field (TNB_FIELDS),
	LCB: ref block field (LCB_FIELDS),
	ULA;

    if $MCB_GET_DSR (LCB_SIZE*bytes_word, LCB)
    then
	begin
	if not ULAGET (ULA)
	then
	    begin
	    $MCB_RETURN_DSR (LCB_SIZE*bytes_word, .LCB);
	    return false
	    end
	end
    else return false;

    ch$fill (0, LCB_SIZE*bytes_word, .LCB);
    .LCBP = .LCB;
    ULASET (.ULA, .LCB);
    LCB [LC_ULA] = .ULA;
    LCB [LC_TASK] = .TKBA;
    LCB [LC_OQTL] = LCB [LC_OQHD];
    LCB [LC_NQTL] = LCB [LC_NQHD];

    TNB = SCXDB [SCX_TNB];
    while (TNB = .TNB [TN_LINK]) neq 0 do
	begin
	if .TNB [TN_TASK] eql .LCB [LC_TASK]
	then
	    begin
	    LCB [LC_TNB] = .TNB;
	    exitloop
	    end
	end;

    if .TNB eql 0 then SIGNAL_STOP (SCX$_ILE);
    .TNBP = .TNB;
    LCB [LC_LINK] = .TNB [TN_LCB];
    TNB [TN_LCB] = .LCB;
    return true
    end;
global routine LCBKIL (LCB): novalue =

!++
! FUNCTIONAL DESCRIPTION:
!	Unlink and deallocate specified LCB
!
! FORMAL PARAMETERS:
!	LCB	Address of LCB to get rid of
!
! IMPLICIT INPUTS:
!	It is assumed that the link is closed, and the
!	output queue is empty.
!
! IMPLICIT OUTPUTS:
!	None
!
! ROUTINE VALUE:
! COMPLETION CODES:
!	None
!
! SIDE EFFECTS:
!	None
!--

    begin
    map LCB: ref block field (LCB_FIELDS);
    local
	LC: ref block field (LCB_FIELDS),
	LC_PREV: ref block field (LCB_FIELDS);
    bind
	TNB = LCB [LC_TNB]: ref block field (TNB_FIELDS);

    LC = TNB [TN_LCB];			! Point to first LCB pointer
    while (LC_PREV = .LC; LC = .LC [LC_LINK]) neq 0 do
	begin
	if .LC eql .LCB
	then
	    begin
	    LC_PREV [LC_LINK] = .LC [LC_LINK];		! Remove LCB from list
	    $MCB_RETURN_DSR (LCB_SIZE*bytes_word, .LC);	! and release memory
	    exitloop
	    end
	end
    end;
global routine MBPROC (QUEUE): novalue =

!++
! FUNCTIONAL DESCRIPTION:
!	Process waiting connect packets on the specified queue
!
! FORMAL PARAMETERS:
!	QUEUE	Address of mailbox queue header
!
! IMPLICIT INPUTS:
!	None
!
! IMPLICIT OUTPUTS:
!	Appropriate packets are dequeued, and rejected.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!	None
!
! SIDE EFFECTS:
!	None
!--

    begin
    $scx_get_data_base (SCXDB);
    map QUEUE: ref block field (QHD_FIELDS);
    local
	CCB: ref block field (C_FIELDS),
	MB_PREV: ref block field (MBP_FIELDS),
	MB: ref block field (MBP_FIELDS);

    MB = .QUEUE;			! Initialize queue pointer
    while (MB_PREV = .MB; MB = .MB [MB_LINK]) neq 0 do
	begin
	if (.MB [MB_FNC] eql MB$CON) or (.MB [MB_FNC] eql MB$CNP)
	then
	    begin
	    if .MB [MBF_REQ] then MB [MBF_REQ] = not TSKRT$ (.MB [MB_TASK], 0);
	    if .MB [MB_TIME] neq 0	! Active timer ?
	    then
		begin				! Yes, check it
		if (MB [MB_TIME] = .MB [MB_TIME] - 1) eql 0
		then
		    begin			! It has expired
		    if CCBGT$ (CCB)		! Get a CCB to reject connect
		    then
			begin
			if (MB_PREV [MB_LINK] = .MB [MB_LINK]) eql 0
			then QUEUE [Q_TAIL] = .MB_PREV;	! Dequeue the entry
			CCB [C_LIX] = .MB [MB_LLA];
			ccb [c_cnt] = 0;		! no optional data.
			CCB [C_PRM2] = S_ENRO;
			CCB [C_PRM4] = .MB [MB_TNB];	! Remember which TNB
			$SCX_DO_XME (.CCB, S$REJ, 0, 0, 0);
			$MCB_RETURN_DSR (MBP_SIZE*bytes_word + .MB [MB_CNT], .MB);
			MB = .MB_PREV
			end
		    else
			MB [MB_TIME] = 1	! Let it blow on next tick
		    end
		end
	    end
	end
    end;
global routine NOOP: novalue =

!++
! FUNCTIONAL DESCRIPTION:
!	This routine simply returns
!
! FORMAL PARAMETERS:
!	None
!
! IMPLICIT INPUTS:
!	None
!
! IMPLICIT OUTPUTS:
!	None
!
! ROUTINE VALUE:
! COMPLETION CODES:
!	None
!
! SIDE EFFECTS:
!	None
!--

    begin
    return
    end;
global routine QUEAST (TNB) =

!++
! FUNCTIONAL DESCRIPTION:
!	Queue an AST to RSX
!
! FORMAL PARAMETERS:
!	TNB	TNB address for task
!
! IMPLICIT INPUTS:
!	None
!
! IMPLICIT OUTPUTS:
!	None
!
! ROUTINE VALUE:
! COMPLETION CODES:
!	False if memory allocation fails, else true.
!
! SIDE EFFECTS:
!	None
!--

    begin
    map
	TNB: ref block field (TNB_FIELDS);
    local
	AST: ref block field (AST_FIELDS);
    literal
	AST_SIZE = %fieldexpand (A_PRM, 0) * bytes_word;

    if .TNB [TN_SPA] eql 0 then return true;
    if not ALOCB$ (AST_SIZE, AST) then return false;

    AST [A_CBL] = AST_SIZE;
    AST [A_BYT] = 7 * %upval;
    AST [A_AST] = .TNB [TN_SPA];
    AST [A_NPR] = 0;
    QASTT$ (.TNB [TN_TASK], .AST);
    return true
    end;
global routine STXMAP (CODE) =

!++
! FUNCTIONAL DESCRIPTION:
!	Map from SC error codes to RSX codes
!
! FORMAL PARAMETERS:
!	CODE	SC error code
!
! IMPLICIT INPUTS:
!	None
!
! IMPLICIT OUTPUTS:
!	None
!
! ROUTINE VALUE:
!	The equivalent RSX error code
!
! COMPLETION CODES:
!	None
!
! SIDE EFFECTS:
!	None
!--

    begin

    macro
	C (SC_CODE, RSX_CODE) = ((SC_CODE - S_ELO)^1, RSX_CODE) %;

    bind
	STATUS_MAP = TABLE$ (IE_PRI, (S_EHI - S_ELO)^1,
	    C (S_SSUC, IS_SUC),		! Success
	    C (S_EABL, IE_ABO),		! Abort
	    C (S_EABM, IE_ABO),		! ...
	    C (S_EABO, IE_ABO),		! ...
	    C (S_EABS, IE_ABO),		! ...
	    C (S_ENUR, IE_ABO),		! ...
	    C (S_ERNS, IE_ABO),		! ...
	    C (S_EACR, IE_URJ),		! User reject
	    C (S_EOTB, IE_URJ),		! ...
	    C (S_ERBO, IE_URJ),		! ...
	    C (S_ECBE, IE_BAD),		! Bad parameter
	    C (S_ELST, IS_DAO),		! Data overrun
	    C (S_EMTL, IE_SPC),		! Invalid buffer parameter
	    C (S_ENRO, IE_NNT),		! Not a network task
	    C (S_EURO, IE_NNT),		! ...
	    C (S_ERES, IE_RSU),		! Resources unavailable
	    C (S_EUNN, IE_NRJ)): vector; ! Network rejection

    .STATUS_MAP [.CODE - S_ELO]
    end;
global routine ULAGET (ULA) =

!++
! FUNCTIONAL DESCRIPTION:
!	Locate an available ULA and assign it.
!
! FORMAL PARAMETERS:
!	ULA	Address of word to receive ULA number
!
! IMPLICIT INPUTS:
!	The vector at SCX_ULA is used
!
! IMPLICIT OUTPUTS:
!	The vector entry in SCX_ULA is set to true
!
! ROUTINE VALUE:
!	True if ULA allocated, else false
!
! COMPLETION CODES:
!	None
!
! SIDE EFFECTS:
!	None
!--

    begin
    $scx_get_data_base (SCXDB);
    local
	SAV_MAP;
    bind
	ULA_VEC = SCXDB [SCX_ULA_ADDR]: ref vector;

    SMAP$ (SAV_MAP);
    MAP$ (.SCXDB [SCX_ULA_BIAS]);

    incr I from 1 to .SCXDB [SCX_LINKS]-1 do	! Don't assign zero
	begin
	if .ULA_VEC [.I] eql 0
	then
	    begin
	    ULA_VEC [.I] = true;
	    .ULA = .I;
	    MAP$ (.SAV_MAP);
	    return true
	    end
	end;

    MAP$ (.SAV_MAP);
    return false
    end;
global routine ULARD (ULA) =

!++
! FUNCTIONAL DESCRIPTION:
!	Return contents of ULA vector entry
!
! FORMAL PARAMETERS:
!	ULA	The ULA
!
! IMPLICIT INPUTS:
!	The vector at SCX_ULA is used
!
! IMPLICIT OUTPUTS:
!	None
!
! ROUTINE VALUE:
!	The ULA vector contents, which is
!		True, if just allocated
!		LCB address when in use
!
! COMPLETION CODES:
!	None
!
! SIDE EFFECTS:
!	None
!--

    begin
    $scx_get_data_base (SCXDB);
    local
	SAV_MAP,
	TEMP;
    bind
	ULA_VEC = SCXDB [SCX_ULA_ADDR]: ref vector;

    SMAP$ (SAV_MAP);
    MAP$ (.SCXDB [SCX_ULA_BIAS]);

    TEMP = .ULA_VEC [.ULA];    
    MAP$ (.SAV_MAP);
    return .TEMP
    end;
global routine ULASET (ULA, VALUE): novalue =

!++
! FUNCTIONAL DESCRIPTION:
!	Set value into ULA vector.
!
! FORMAL PARAMETERS:
!	ULA	The ULA
!	VALUE	Value to be written into ULA vector
!
! IMPLICIT INPUTS:
!	The vector at SCX_ULA is used
!
! IMPLICIT OUTPUTS:
!	None
!
! ROUTINE VALUE:
! COMPLETION CODES:
!	None
!
! SIDE EFFECTS:
!	None
!--

    begin
    $scx_get_data_base (SCXDB);
    local
	SAV_MAP;
    bind
	ULA_VEC = SCXDB [SCX_ULA_ADDR]: ref vector;

    SMAP$ (SAV_MAP);
    MAP$ (.SCXDB [SCX_ULA_BIAS]);

    ULA_VEC [.ULA] = .VALUE;
    MAP$ (.SAV_MAP)
    end;
global routine $C5TA (RAD50_NAME, PTR_ADDR, LNG_ADDR): novalue =

!++
! FUNCTIONAL DESCRIPTION:
!	Convert RAD50 value to ascii string.
!
! FORMAL PARAMETERS:
!	RAD50_NAME	The RAD50 value to convert
!	PTR_ADDR	Address of pointer to buffer to receive ascii
!	LNG_ADDR	Address of word to receive string length
!
! IMPLICIT INPUTS:
!	None
!
! IMPLICIT OUTPUTS:
!	The buffer pointer is updated to point to next position in buffer
!	following information inserted.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!	None
!
! SIDE EFFECTS:
!	None
!--

    begin
    local
	CH;

    CH = .RAD50_NAME mod 40;
    RAD50_NAME = .RAD50_NAME / 40;
    if .RAD50_NAME neq 0 then $C5TA (.RAD50_NAME, .PTR_ADDR, .LNG_ADDR);

    CH = (selectone .CH of
	set
	%if %bliss (bliss36)
	%then
	    [0]:	%c' ';
	    [1 to 10]:	%c'0' + .CH - 1;
	    [11 to 36]:	%c'A' + .CH - 11;
	    [37]:	%c'.';
	    [38]:	%c'$';
	    [39]:	%c'%';
	%else
	    [0]:	%c' ';
	    [1 to 26]:	%c'A' + .CH - 1;
	    [27]:	%c'$';
	    [28]:	%c'.';
	    [30 to 39]:	%c'0' + .CH - 30;
	    [otherwise]: %c'_';
	%fi
	tes);

    .LNG_ADDR = ..LNG_ADDR + 1;			! Count the character
    ch$wchar_a (.CH, .PTR_ADDR)		!   and put it into string
    end;
global routine $CAT5 (PTR_ADDR, FLAG) =

!++
! FUNCTIONAL DESCRIPTION:
!	Convert ascii string to RAD50 format
!
! FORMAL PARAMETERS:
!	PTR_ADDR	Address of pointer which contains ascii string
!	FLAG		If nonzero, period is accepted as a character
!
! IMPLICIT INPUTS:
!	None
!
! IMPLICIT OUTPUTS:
!	The pointer addressed by PTR_ADDR is updated past characters converted.
!
! ROUTINE VALUE:
!	The RAD50 equivalent of the characters converted.
!
! COMPLETION CODES:
!	None
!
! SIDE EFFECTS:
!	None
!--

    begin
    local
	R50;
    literal
	NCH = %if %bliss (bliss36) %then 5 %else 2 %fi;

    R50 = 0;
    incr I from 0 to NCH do
	begin
	R50 = (.R50 * 40) +
	    begin
	    local CH;
	    selectoneu (CH = ch$rchar_a (.PTR_ADDR)) of
		set
		%if not %bliss (bliss36)
		%then	! (bliss16 or bliss32)
		    [%c'A' to %c'Z']: .CH - %c'A' + 1;
		    [%c'0' to %c'9']: .CH - %c'0' + 30;
		    [%c'$']: 27;
		    [%c' ']: 0;
		    [%c'.']: if .FLAG neq 0 then 28 else (.PTR_ADDR = ch$plus (..PTR_ADDR, -1); 0);
		    [otherwise]: (.PTR_ADDR = ch$plus (..PTR_ADDR, -1); 0);
		%else	! (bliss36)
		    [%c'A' to %c'Z']: .CH - %c'A' + 11;
		    [%c'0' to %c'9']: .CH - %c'0' + 1;
		    [%c'$']: 38;
		    [%c'%']: 39;
		    [%c' ']: 0;
		    [%c'.']: if .FLAG neq 0 then 37 else exitloop;
		    [otherwise]: exitloop;
		%fi
		tes
	    end
	end;

    return .R50
    end;
global routine $SCQHD (QHD, STR): novalue =

!++
! FUNCTIONAL DESCRIPTION:
!    Queue STR to head of queue defined by QHD.
!
! FORMAL PARAMETERS:
!	QHD	2-word queue header
!	STR	Structure to be queued (link in first word)
!
! IMPLICIT INPUTS:
!	None
!
! IMPLICIT OUTPUTS:
!	None
!
! ROUTINE VALUE:
! COMPLETION CODES:
!	None
!
! SIDE EFFECTS:
!	None
!--

    begin
    map
	QHD: ref block field (QHD_FIELDS),
	STR: ref block field (QHD_FIELDS);

    if (STR [Q_HEAD] = .QHD [Q_HEAD]) eql 0 then QHD [Q_TAIL] = STR [Q_HEAD];
    QHD [Q_HEAD] = STR [Q_HEAD]
    end;
global routine $SCQIN (QHD, STR): novalue =

!++
! FUNCTIONAL DESCRIPTION:
!    Queue STR to tail of queue defined by QHD.
!
! FORMAL PARAMETERS:
!	QHD	2-word queue header
!	STR	Structure to be queued (link in first word)
!
! IMPLICIT INPUTS:
!	None
!
! IMPLICIT OUTPUTS:
!	None
!
! ROUTINE VALUE:
! COMPLETION CODES:
!	None
!
! SIDE EFFECTS:
!	None
!--

    begin
    map
	QHD: ref block field (QHD_FIELDS),
	STR: ref block field (QHD_FIELDS);
    bind
	LAST_STR = QHD [Q_TAIL]: ref block field (QHD_FIELDS);

    STR [Q_HEAD] = 0;
    LAST_STR [Q_HEAD] = STR [Q_HEAD];
    QHD [Q_TAIL] = STR [Q_HEAD]
    end;
global routine $SCQRM (QHD, STR) =

!++
! FUNCTIONAL DESCRIPTION:
!    Remove structure from queue defined by QHD, and return
!    its address in STR.
!
! FORMAL PARAMETERS:
!	QHD	2-word queue header
!	STR	Word to receive structure address
!
! IMPLICIT INPUTS:
!	None
!
! IMPLICIT OUTPUTS:
!	None
!
! ROUTINE VALUE:
! COMPLETION CODES:
!	True if something dequeued
!	False if nothing dequeued
!
! SIDE EFFECTS:
!	None
!--

    begin
    map QHD: ref block field (QHD_FIELDS);

    if (.STR = .QHD [Q_HEAD]) eql 0 then return false;
    ..STR = 0;
    if (QHD [Q_HEAD] = .(.QHD [Q_HEAD])) eql 0
    then QHD [Q_TAIL] = QHD [Q_HEAD];
    return true
    end;

end
eludom