Trailing-Edge
-
PDP-10 Archives
-
cuspjul86upd_bb-jf24a-bb
-
10,7/decmai/mx/tbl.bli
There are 21 other files named tbl.bli in the archive. Click here to see a list.
MODULE tbluk ( !
ENTRY(tbl_lookup,
tbl_add,
tbl_delete)
) =
BEGIN
!
! COPYRIGHT (c) 1985 BY
! DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
!
! 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: Table Lookup/Add/Delete Routines
!
! ABSTRACT: These routines emulate the TOPS-20 tbluk jsys for use
! on not only TOPS-20 but TOPS-10 (and potentially others) as well.
!
! ENVIRONMENT: TOPS-10, and TOPS-20
!
! AUTHOR: Richard B. Waddington, CREATION DATE: 11-Jan-85
!
! MODIFIED BY:
!
! , : VERSION
! 01 -
!--
!
! TABLE OF CONTENTS:
!
FORWARD ROUTINE
tbl_compare,
tbl_lookup,
tbl_add,
tbl_delete;
!
! INCLUDE FILES:
!
%IF %SWITCHES(TOPS20) %THEN
LIBRARY 'MONSYM';
LIBRARY 'MXJLNK';
%FI
LIBRARY 'TBL';
REQUIRE 'BLT';
!
! MACROS:
!
!
! EQUATED SYMBOLS:
!
LITERAL
true = (1 EQL 1),
false = (1 EQL 0);
SWITCHES LIST(NOEXPAND);
! The following table is used to convert strings to UPPER CASE.
GLOBAL BIND
uc_tab = CH$TRANSTABLE(seq(%O'0', %O'140'),
seq(%C'A', %C'Z'),
seq(%O'173', %O'177'));
SWITCHES LIST(EXPAND);
!
! OWN STORAGE:
!
!
! EXTERNAL REFERENCES:
!
GLOBAL ROUTINE tbl_lookup (tb_,str,indx_) = !
!++
! FUNCTIONAL DESCRIPTION:
! This routine emulates the TOPS-20 TBLUK JSYS.
!
! FORMAL PARAMETERS:
!
! tb: The address of a TBLUK tbl.
! str: A CH$PTR to the string to look up.
! indx: The address to return the table index in. If str
! uniquely matches, this is the index of str.
! If str does not match, then this is the index where
! str would go if it were in the table.
!
! IMPLICIT INPUTS:
!
! uc_tab is used to convert lowercase to UPPER CASE.
!
! IMPLICIT OUTPUTS:
!
! NONE
!
! ROUTINE VALUE:
! 0 if no match is found
! 1 if an exact match is found
! 2 if str is an ambiguous abreviation
! 3 if str is an unambiguous abreviation
!
! COMPLETION CODES:
!
! NONE
!
! SIDE EFFECTS:
!
! NONE
!
!--
BEGIN
BIND
tb = .tb_: tbl,
lc_ptr = .str,
indx = .indx_;
STACKLOCAL
str_uc_buffer: VECTOR[ch$allocation(132)];
BIND
str_ptr = CH$PTR(str_uc_buffer);
LOCAL
str_len,
key,
top,
bottom,
done,
norec,
indx_first;
IF .tb[TBL_ACTUAL_ENTRIES] LEQ 0
THEN
BEGIN
indx = 1;
RETURN tbl_nomatch; !Table is empty, nomatch...
END;
str_len = ch$len(lc_ptr); !Get the length and convert
CH$TRANSLATE(uc_tab, ! to UPPER CASE
.str_len, lc_ptr,
0,
.str_len + 1, str_ptr);
done = false; !Do the binary search
bottom = 1;
top = .tb[TBL_ACTUAL_ENTRIES];
WHILE NOT .done DO
BEGIN
BUILTIN LSH;
IF .top LEQ .bottom
THEN
done = true;
indx = LSH(.top + .bottom, -1);
CASE tbl_compare(.str_len, str_ptr, tb, .indx)
FROM tbl_lessthan TO tbl_greaterthan OF
SET
[tbl_lessthan]: top = .indx - 1;
[tbl_equalto]: (done = false; EXITLOOP); !Found a match
[tbl_greaterthan]: bottom = indx = .indx + 1;
TES;
END;
IF .indx EQL 0
THEN
indx = 1;
IF .done !No match
THEN
RETURN tbl_nomatch;
indx_first = .indx;
WHILE .indx GTR 1 DO !Perform linear search back to
! first possible match
BEGIN
IF tbl_compare(.str_len, str_ptr, tb, .indx - 1) EQL tbl_greaterthan
THEN
EXITLOOP;
indx = .indx -1
END;
key = key$(tb, .indx, norec); !Check the no-recognize bit
IF .norec
THEN
RETURN tbl_ambiguous;
!Check for exact match
IF CH$RCHAR(CH$PLUS(CH$PTR(.key), .str_len)) EQL 0
THEN
RETURN tbl_exactmatch;
IF .indx EQL .indx_first !Binary search hit first one.
THEN ! See if it's unique...
IF tbl_compare(.str_len, str_ptr, tb, .indx + 1) NEQ tbl_equalto
THEN
RETURN tbl_abreviation;
RETURN tbl_ambiguous !Must be ambiguous
END; !End of TBL_LOOKUP
ROUTINE tbl_compare(len,ptr,tb_,i) =
!++
! FUNCTIONAL DESCRIPTION:
! This routine compares an UPPER CASE string with an entry in a
! TBLUK table.
!
! FORMAL PARAMETERS:
!
! len: The length of the string.
! ptr: The pointer to the string.
! tb: The address of a TBLUK tbl.
! str: The index of the entry to compare with.
!
! IMPLICIT INPUTS:
!
! uc_tab is used to convert lowercase to UPPER CASE.
! ptr is assumed to be pointing to an UPPER CASE string.
!
! IMPLICIT OUTPUTS:
!
! NONE
!
! ROUTINE VALUE:
! -1 if the string is less than the entry.
! 0 if the string matches.
! 1 if the string is greater than the entry.
!
! COMPLETION CODES:
!
! NONE
!
! SIDE EFFECTS:
!
! NONE
!
!--
BEGIN
STACKLOCAL
key_uc_buffer: VECTOR[CH$ALLOCATION(132)];
BIND
tb = .tb_: tbl;
BIND
key_ptr = CH$PTR(key_uc_buffer);
CH$TRANSLATE(uc_tab, !Convert table key to UC
.len, CH$PTR(key$(tb, .i)),
0,
.len, key_ptr);
CASE CH$COMPARE(.len, .ptr, .len, key_ptr) !Compare strings
FROM -1 TO 1 OF
SET
[-1]: RETURN tbl_lessthan;
[0]: RETURN tbl_equalto;
[1]: RETURN tbl_greaterthan;
TES;
END; !End of tbl_compare
GLOBAL ROUTINE tbl_add (tb_,key_,indx_,data) = !
!++
! FUNCTIONAL DESCRIPTION:
! This routine emulates the TOPS-20 TBADD JSYS.
!
! FORMAL PARAMETERS:
!
! tb: The address of a TBLUK tbl.
! key: The address of an ASCIZ string.
! indx: The address to return the new table index to.
! data: The value to be stored in the table's data field.
!
! IMPLICIT INPUTS:
!
! NONE
!
! IMPLICIT OUTPUTS:
!
! NONE
!
! ROUTINE VALUE:
! 0 if table is full
! 1 if successful
! 2 if entry already exists
! COMPLETION CODES:
!
! NONE
!
! SIDE EFFECTS:
!
! NONE
!
!--
BEGIN
BIND
tb = .tb_: tbl,
key = .key_,
indx = .indx_;
IF .tb[TBL_ACTUAL_ENTRIES] EQL .tb[TBL_MAXIMUM_ENTRIES]
THEN
RETURN 0; !Table is full
IF tbl_lookup(tb, CH$PTR(key), indx) EQL tbl_exactmatch
THEN
RETURN 2; !Entry already exists
DECR i FROM .tb[TBL_ACTUAL_ENTRIES] TO .indx DO
tb[.i + 1, TBL_WORD] = .TB[.i, TBL_WORD];
tb[.indx, TBL_KEY] = key;
tb[.indx, TBL_DATA] = .data;
tb[TBL_ACTUAL_ENTRIES] = .tb[TBL_ACTUAL_ENTRIES] + 1;
RETURN 1;
END; !End of tbl_add
GLOBAL ROUTINE tbl_delete (tb_,indx) = !
!++
! FUNCTIONAL DESCRIPTION:
! This routine performs a TBDEL JSYS on TOPS-20, and emulates it
! on TOPS-10.
!
! FORMAL PARAMETERS:
!
! tb: The address of a TBLUK tbl.
! indx: The index of the table_entry to be deleted.
!
! IMPLICIT INPUTS:
!
! NONE
!
! IMPLICIT OUTPUTS:
!
! NONE
!
! ROUTINE VALUE:
! 0 if table is empty
! 1 if element is deleted
! 2 if index is invalid
!
! COMPLETION CODES:
!
! NONE
!
! SIDE EFFECTS:
!
! NONE
!
!--
BEGIN
BIND
tb = .tb_: tbl;
LOCAL
error,
bits; !
BIND
del_addr = tb[.indx, TBL_WORD],
last_addr = tb + .tb[TBL_ACTUAL_ENTRIES];
IF .tb[TBL_ACTUAL_ENTRIES] EQL 0
THEN
RETURN 0; !Table is empty
IF .indx GTR .tb[TBL_ACTUAL_ENTRIES]
THEN
RETURN 2; !Index is invalid
$$BLT(((del_addr +1) ^ 18) + del_addr, last_addr);
last_addr = 0;
tb[TBL_ACTUAL_ENTRIES] = .tb[TBL_ACTUAL_ENTRIES] - 1;
RETURN 1;
END; !End of tbl_delete
END !End of module tbl
ELUDOM