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