(* ------------------- VERSION 2 19.01.87 ------------------- *)
PACKET thesaurus handling (* Autor: J.Liedtke *)
DEFINES THESAURUS ,
:= ,
empty thesaurus ,
insert, (* fuegt ein Element ein *)
delete, (* loescht ein Element falls vorhanden *)
rename, (* aendert ein Element falls vorhanden *)
CONTAINS , (* stellt fest, ob enthalten *)
link , (* index in thesaurus *)
name , (* name of entry *)
decode invalid chars ,(* Steuerzeichen dekodieren *)
get , (* get next entry ("" is eof) *)
highest entry : (* highest valid index of thes *)
TYPE THESAURUS = TEXT ;
LET nil = 0 ,
niltext = "" ,
max name length = 80 ,
begin entry char = ""0"" ,
end entry char = ""255"" ,
nil entry = ""0""255"" ,
nil name = "" ,
quote = """" ;
TEXT VAR entry ,
dummy ;
INT VAR cache index := 0 ,
cache pos ;
TEXT PROC decode (INT CONST number) :
dummy := " " ;
replace (dummy, 1, number) ;
dummy .
ENDPROC decode ;
INT PROC decode (TEXT CONST string, INT CONST position) :
subtext (string, position, position + 1) ISUB 1 .
ENDPROC decode ;
PROC access (THESAURUS CONST thesaurus, TEXT CONST name) :
construct entry ;
IF NOT cache identifies entry
THEN search through thesaurus list
FI ;
IF entry found
THEN cache index := decode (list, cache pos - 2)
ELSE cache index := 0
FI .
construct entry :
entry := begin entry char ;
entry CAT name ;
decode invalid chars (entry, 2) ;
entry CAT end entry char .
search through thesaurus list :
cache pos := pos (list, entry) .
cache identifies entry :
cache pos <> 0 AND
pos (list, entry, cache pos, cache pos + LENGTH entry) = cache pos .
entry found : cache pos > 0 .
list : CONCR (thesaurus) .
ENDPROC access ;
PROC access (THESAURUS CONST thesaurus, INT CONST index) :
IF cache identifies index
THEN cache index := index ;
construct entry
ELSE cache pos := pos (list, decode (index) + begin entry char) ;
IF entry found
THEN cache pos INCR 2 ;
cache index := index ;
construct entry
ELSE cache index := 0 ;
entry := niltext
FI
FI .
construct entry :
entry := subtext (list, cache pos, pos (list, end entry char, cache pos)) .
cache identifies index :
subtext (list, cache pos-2, cache pos) = decode (index) + begin entry char .
entry found : cache pos > 0 .
list : CONCR (thesaurus) .
ENDPROC access ;
THESAURUS PROC empty thesaurus :
THESAURUS : (""1""0"")
ENDPROC empty thesaurus ;
OP := (THESAURUS VAR dest, THESAURUS CONST source ) :
CONCR (dest) := CONCR (source) .
ENDOP := ;
TEXT VAR insert name ;
PROC insert (THESAURUS VAR thesaurus, TEXT CONST name, INT VAR index) :
insert name := name ;
decode invalid chars (insert name, 1) ;
insert name if possible .
insert name if possible :
IF insert name = "" OR LENGTH insert name > max name length
THEN index := nil ; errorstop ("Name unzulaessig")
ELIF overflow
THEN index := nil
ELSE insert element
FI .
overflow :
LENGTH CONCR (thesaurus) + LENGTH insert name + 4 > max text length .
insert element :
search free entry ;
IF entry found
THEN insert into directory
ELSE add entry to directory if possible
FI .
search free entry :
access (thesaurus, nil name) .
insert into directory :
change (list, cache pos + 1, cache pos, insert name) ;
index := cache index .
add entry to directory if possible :
INT CONST next free index := decode (list, LENGTH list - 1) ;
add entry to directory .
add entry to directory :
list CAT begin entry char ;
cache pos := LENGTH list ;
cache index := next free index ;
list CAT insert name ;
list CAT end entry char + decode (next free index + 1) ;
index := cache index .
entry found : cache index > 0 .
list : CONCR (thesaurus) .
ENDPROC insert ;
PROC decode invalid chars (TEXT VAR name, INT CONST start pos) :
INT VAR invalid char pos := pos (name, ""0"", ""31"", start pos) ;
WHILE invalid char pos > 0 REP
change (name, invalid char pos, invalid char pos, decoded char) ;
invalid char pos := pos (name, ""0"", ""31"", invalid char pos)
PER ;
change all (name, ""255"", quote + "255" + quote) .
decoded char : quote + text(code(name SUB invalid char pos)) + quote.
ENDPROC decode invalid chars ;
PROC insert (THESAURUS VAR thesaurus, TEXT CONST name) :
INT VAR index ;
insert (thesaurus, name, index) ;
IF index = nil AND NOT is error
THEN errorstop ("THESAURUS-Ueberlauf")
FI .
ENDPROC insert ;
PROC delete (THESAURUS VAR thesaurus, TEXT CONST name, INT VAR index) :
access (thesaurus, name) ;
index := cache index ;
delete (thesaurus, index) .
ENDPROC delete ;
PROC delete (THESAURUS VAR thesaurus, INT CONST index) :
access (thesaurus, index) ;
IF entry found
THEN delete entry
FI .
delete entry :
IF is last entry of thesaurus
THEN cut off as much as possible
ELSE set to nil entry
FI .
set to nil entry :
change (list, cache pos, cache pos + LENGTH entry - 1, nil entry) .
cut off as much as possible :
WHILE predecessor is also nil entry REP
set cache to this entry
PER ;
list := subtext (list, 1, cache pos - 1) ;
erase cache .
predecessor is also nil entry :
subtext (list, cache pos - 4, cache pos - 3) = nil entry .
set cache to this entry :
cache pos DECR 4 .
erase cache :
cache pos := 0 ;
cache index := 0 .
is last entry of thesaurus :
pos (list, end entry char, cache pos) = LENGTH list - 2 .
list : CONCR (thesaurus) .
entry found : cache index > nil .
ENDPROC delete ;
BOOL OP CONTAINS (THESAURUS CONST thesaurus, TEXT CONST name ) :
IF name = niltext OR LENGTH name > max name length
THEN FALSE
ELSE access (thesaurus, name) ; entry found
FI .
entry found : cache index > nil .
ENDOP CONTAINS ;
PROC rename (THESAURUS VAR thesaurus, TEXT CONST old, new) :
rename (thesaurus, link (thesaurus, old), new)
ENDPROC rename ;
PROC rename (THESAURUS VAR thesaurus, INT CONST index, TEXT CONST new) :
insert name := new ;
decode invalid chars (insert name, 1) ;
IF overflow
THEN errorstop ("THESAURUS-Ueberlauf")
ELIF insert name = "" OR LENGTH insert name > max name length
THEN errorstop ("Name unzulaessig")
ELSE change to new name
FI .
overflow :
LENGTH CONCR (thesaurus) + LENGTH insert name + 4 > max text length .
change to new name :
access (thesaurus, index) ;
IF cache index <> 0 AND entry <> ""
THEN change (list, cache pos + 1, cache pos + LENGTH entry - 2, insert name)
FI .
list : CONCR (thesaurus) .
ENDPROC rename ;
INT PROC link (THESAURUS CONST thesaurus, TEXT CONST name) :
access (thesaurus, name) ;
cache index .
ENDPROC link ;
TEXT PROC name (THESAURUS CONST thesaurus, INT CONST index) :
access (thesaurus, index) ;
subtext (entry, 2, LENGTH entry - 1) .
ENDPROC name ;
PROC get (THESAURUS CONST thesaurus, TEXT VAR name, INT VAR index) :
identify index ;
REP
to next entry
UNTIL end of list COR valid entry found PER .
identify index :
IF index = 0
THEN cache index := 0 ;
cache pos := 1
ELSE access (thesaurus, index)
FI .
to next entry :
cache pos := pos (list, begin entry char, cache pos + 1) ;
IF cache pos > 0
THEN correct cache pos ;
get entry
ELSE get nil entry
FI .
correct cache pos :
IF (list SUB cache pos + 2) = begin entry char
THEN cache pos INCR 2
ELIF (list SUB cache pos + 1) = begin entry char
THEN cache pos INCR 1
FI .
get entry :
cache index INCR 1 ;
index := cache index ;
name := subtext (list, cache pos + 1, end entry pos - 1) .
get nil entry :
cache index := 0 ;
cache pos := 0 ;
index := 0 ;
name := "" .
end entry pos : pos (list, end entry char, cache pos) .
end of list : index = 0 .
valid entry found : name <> "" .
list : CONCR (thesaurus) .
ENDPROC get ;
INT PROC highest entry (THESAURUS CONST thesaurus) : (*840813*)
decode (list, LENGTH list - 1) - 1 .
list : CONCR (thesaurus) .
ENDPROC highest entry ;
ENDPACKET thesaurus handling ;