PACKET eumel coder part 1 (* Autor: U. Bartling *)
DEFINES run, run again,
insert,
prot, prot off,
check, check on, check off,
warnings, warnings on, warnings off,
help, bulletin, packets
:
(**************************************************************************)
(* *)
(* E U M E L - C O D E R *)
(* *)
(* *)
(* Zur Beschreibung des Coders siehe *)
(* U.Bartling, J. Liedtke: EUMEL-Coder-Interface *)
(* *)
(* Stand der Dokumentation : 13.02.1986 *)
(* Stand der Implementation : 16.04.1986 *)
(* *)
(* *)
(**************************************************************************)
(***** Globale Variable *****)
TEXT VAR object name;
FILE VAR bulletin file;
INT VAR hash table pointer, nt link, permanent pointer, param link,
index, mode, word;
BOOL VAR found, end of params;
#page#
(**************************************************************************)
(* *)
(* 1. Interface zum ELAN-Compiler 10.04.1986 *)
(* 1.7.5.4 *)
(* *)
(* Beschreibung der Tabellen (-groessen), *)
(* internen Vercodung von Typen *)
(* und Kennungen . *)
(* Initialisieren und Beenden des Compilers, *)
(* Lesen aus und Schreiben in Namens- bzw. Permanent-Tabelle *)
(* *)
(**************************************************************************)
LET begin of hash table = 0 ,
end of hash table = 1023 ,
begin of permanent table = 22784 ,
before first pt entry = 22784 ,
first permanent entry = 22785 ,
end of permanent table = 32767 ,
wordlength = 1 , (* compile u n d run time *)
two word length = 2 ,
three word length = 3 ,
permanent param const = 10000 ,
permanent param var = 20000 ,
permanent proc op = 30000 ,
permanent type = 30000 ,
permanent row = 10 ,
permanent struct = 11 ,
permanent param proc = 12 ,
(* permanent param proc end marker = 0 , *)
permanent type field = 0 ,
ptt limit = 10000 ,
begin of pt minus ptt limit = 12784 ,
void = 0 ,
int = 1 ,
real = 2 ,
string = 3 ,
bool = 5 ,
bool result = 6 ,
dataspace = 7 ,
row = 10 ,
struct = 11 ,
const = 1 ,
var = 2 ,
(* proc = 3 , *)
(* denoter = 5 , *)
bold = 2 ,
ins = TRUE ,
no ins = FALSE ,
no lst = FALSE ,
sermon = TRUE ,
no sermon = FALSE ,
run again mode = 0 ,
compile file mode = 1 ,
warning message = 2 ,
error message = 4 ,
point line = "..............." ;
INT CONST permanent packet := -2 ,
permanent end := -3 ;
INT VAR run again mod nr := 0 ;
(***** Start/Ende *****)
PROC elan (INT CONST mode, FILE VAR source, TEXT CONST line,
INT VAR start module number, BOOL CONST ins, lst, rtc, ser) :
EXTERNAL 256
ENDPROC elan ;
(***** Hash/Namenstabelle *****)
.
next hash entry :
hash table pointer INCR wordlength .
end of hash table reached :
hash table pointer > end of hash table .
yet another nt entry :
nt link := cdb int (nt link) ;
nt link <> 0 . ;
PROC declare object (TEXT CONST name, INT VAR nt link, pt pointer) :
EXTERNAL 10031
ENDPROC declare object ;
PROC to object (TEXT CONST searched object) :
hash ;
search nt entry .
hash :
hash code := 0 ;
FOR index FROM 1 UPTO LENGTH searched object REP
addmult cyclic
ENDREP .
addmult cyclic :
hash code INCR hash code ;
IF hash code > end of hash table THEN wrap around FI ;
hash code := (hash code + code (searched object SUB index)) MOD 1024 .
wrap around :
hash code DECR end of hash table .
hash code : nt link .
search nt entry :
found := FALSE ;
WHILE yet another nt entry REP
read current entry ;
IF object name = searched object
THEN found := TRUE ;
LEAVE to object
FI
PER .
read current entry :
permanent pointer := cdb int (nt link + wordlength) ;
object name := cdb text (nt link + two word length)
ENDPROC to object ;
(***** Permanent Tabelle *****)
.
next procedure :
permanent pointer := cdb int (permanent pointer) . ;
PROC next pt param :
mode := cdb int (param link) MOD ptt limit ;
param link INCR wordlength ;
IF mode = permanent row THEN skip over permanent row
ELIF mode = permanent struct THEN skip over permanent struct
FI ;
set end marker if end of list .
skip over permanent row :
param link INCR wordlength ;
next pt param .
skip over permanent struct :
REP
next pt param ;
mode := cdb int (param link)
UNTIL mode = permanent type field PER ;
param link INCR wordlength
ENDPROC next pt param ;
PROC set end marker if end of list :
mode := cdb int (param link) ;
end of params := mode >= permanent proc op OR mode <= 0
ENDPROC set end marker if end of list ;
PROC get type and mode (INT VAR type) :
mode := cdb int (param link) ;
IF mode = permanent param proc THEN type of param proc
ELSE type of object
FI .
type of param proc :
param link INCR wordlength ;
get type and mode (type) ;
mode := permanent param proc .
type of object :
IF mode < 0 THEN type := 2769 + (32767 + mode) ;
mode := 0
ELSE type := mode MOD ptt limit ;
mode DECR type ;
translate type if necessary ;
translate mode if necessary
FI .
translate type if necessary :
IF permanent row or struct THEN translate type FI .
translate type :
type := param link - begin of pt minus ptt limit .
translate mode if necessary :
IF mode = permanent param const THEN mode := const
ELIF mode = permanent param var THEN mode := var
FI .
permanent row or struct :
type = permanent row OR type = permanent struct
ENDPROC get type and mode ;
(***** Allgemeine Zugriffsprozeduren *****)
INT PROC cdb int (INT CONST index) :
EXTERNAL 116
ENDPROC cdb int ;
TEXT PROC cdb text (INT CONST index) :
EXTERNAL 117
ENDPROC cdb text ;
#page#
(**************************************************************************)
(* *)
(* 10. Inspector 16.04.1986 *)
(* *)
(**************************************************************************)
INT VAR line number, pattern length, packet link,
begin of packet, last packet entry, indentation;
TEXT VAR bulletin name, type and mode, pattern, buffer;
DATASPACE VAR bulletin ds :: nilspace ;
.packet name :
cdb text (cdb int(packet link + wordlength) + two word length) .
.within editor :
aktueller editor > 0 . ;
PROC name of type (INT CONST type) :
SELECT type OF
CASE void :
CASE int : type and mode CAT "INT"
CASE real : type and mode CAT "REAL"
CASE string : type and mode CAT "TEXT"
CASE bool, bool result : type and mode CAT "BOOL"
CASE dataspace : type and mode CAT "DATASPACE"
CASE row : type and mode CAT "ROW "
CASE struct : type and mode CAT "STRUCT"
OTHERWISE : complex type
ENDSELECT .
complex type :
IF type > ptt limit THEN perhaps permanent struct or row
ELSE get complex type
FI .
perhaps permanent struct or row :
index := type + begin of pt minus ptt limit ;
mode := cdb int (index) MOD ptt limit ;
IF mode = permanent row THEN get permanent row
ELIF mode = permanent struct THEN get permanent struct
ELSE type and mode CAT "-"
FI .
get complex type :
index := type + begin of permanent table ;
IF is complex type THEN get name
ELSE type and mode CAT "-"
FI .
is complex type :
permanent type definition mode = permanent type .
get name :
type and mode CAT cdb text (link to type name + two word length) .
link to type name :
cdb int (index + three word length) .
permanent type definition mode :
cdb int (index + wordlength) .
get permanent row :
INT VAR t;
type and mode CAT "ROW " ;
type and mode CAT text (cdb int (index + wordlength)) ;
type and mode CAT " " ;
param link := index + two wordlength ;
get type and mode (t) ;
name of type (t) .
get permanent struct :
type and mode CAT "STRUCT ( ... )"
ENDPROC name of type ;
PROC help (TEXT CONST proc name) :
prep bulletin ;
prep help ;
scan (object name) ;
next symbol (pattern) ;
packet link := end of permanent table ;
IF function = 0 THEN standard help
ELSE asterisk help
FI .
prep help :
object name := compress (proc name) ;
INT VAR function :: 0 ;
INT CONST l :: LENGTH object name ;
IF l > 1 AND object name <> "**"
THEN IF (object name SUB l) = "*"
THEN function INCR 2 ;
delete char (object name, l)
FI ;
IF (object name SUB 1) = "*"
THEN function INCR 1 ;
delete char (object name, 1)
FI ;
IF another asterisk THEN wrong function FI
FI.
another asterisk :
pos (object name, "*") <> 0 .
wrong function :
errorstop ("unzulaessige Sternfunktion") .
standard help :
to object (pattern) ;
IF found THEN display
ELSE error stop ("unbekannt: " + proc name)
FI .
display :
WHILE permanent pointer <> 0 REP
put name of packet if necessary ;
put specifications (pattern) ;
next procedure
ENDREP ;
show bulletin file .
put name of packet if necessary :
IF new packet THEN packet link := permanent pointer ;
find begin of packet ;
writeline (2) ;
write packet name
FI .
find begin of packet :
REP
packet link DECR wordlength
UNTIL begin of packet found PER .
begin of packet found :
cdb int (packet link) = permanent packet .
new packet :
permanent pointer < packet link .
asterisk help :
hash table pointer := begin of hash table ;
pattern length := LENGTH pattern - 1 ;
REP
list all objects in current hash table chain ;
next hash entry
UNTIL end of hash table reached ENDREP ;
show bulletin file .
list all objects in current hash table chain :
nt link := hash table pointer ;
WHILE yet another nt entry REP
permanent pointer := cdb int (nt link + wordlength) ;
object name := cdb text (nt link + two word length) ;
IF matching THEN into bulletin FI
PER .
matching :
INT CONST p :: pos (object name, pattern) ;
SELECT function OF
CASE 1 : p <> 0 AND p = LENGTH object name - pattern length
CASE 2 : p = 1
CASE 3 : p <> 0
OTHERWISE FALSE
ENDSELECT .
into bulletin :
object names into bulletin (BOOL PROC not end of chain)
ENDPROC help ;
BOOL PROC not end of chain :
permanent pointer <> 0
ENDPROC not end of chain ;
PROC write packet name :
indentation := 0 ;
write line ;
write bulletin line ("PACKET ") ;
indentation := 7 ;
object name := packet name ;
write bulletin line (object name) ;
write bulletin line (":") ;
writeline (2)
ENDPROC write packet name ;
PROC put specifications (TEXT CONST proc name) :
put obj name (proc name) ;
to first param ;
IF NOT end of params THEN put param list FI ;
put result ;
writeline .
to first param :
param link := permanent pointer + word length ;
set end marker if end of list .
put result :
INT VAR type;
get type and mode (type) ;
IF type <> void THEN type and mode := " --> " ;
name of type (type) ;
write bulletin line (type and mode)
FI
ENDPROC put specifications ;
PROC put param list :
write bulletin line (" (") ;
REP
INT VAR type, param mode;
get type and mode (type) ;
param mode := mode ;
put type and mode ;
maybe param proc ;
next pt param ;
IF end of params THEN write bulletin line (")") ;
LEAVE put param list
FI ;
write bulletin line (", ") ;
PER .
put type and mode :
type and mode := "" ;
name of type (type) ;
type and mode CAT name of mode ;
write bulletin line (type and mode) .
name of mode :
IF param mode = const THEN " CONST"
ELIF param mode = var THEN " VAR"
ELSE " PROC"
FI .
maybe param proc :
IF mode = permanent param proc THEN put virtual params FI .
put virtual params :
skip over result type if complex type ;
IF NOT end of virtual params THEN put param list FI.
skip over result type if complex type :
next pt param .
end of virtual params :
end of params
ENDPROC put param list ;
PROC next packet :
REP
packet link INCR wordlength ;
word := cdb int (packet link) ;
IF word = permanent packet THEN true return
ELIF end of permanents THEN false return
FI ;
ENDREP .
true return :
found := TRUE ;
LEAVE next packet .
false return :
found := FALSE ;
LEAVE next packet .
end of permanents :
word = permanent end OR packet link > end of permanent table
ENDPROC next packet ;
PROC prep bulletin :
forget (bulletin ds) ;
bulletin ds := nilspace ;
bulletin file := sequential file (output, bulletin ds) ;
line number := 0 ;
buffer := ""
ENDPROC prep bulletin ;
PROC show bulletin file :
IF within editor THEN ueberschrift neu FI ;
DATASPACE VAR local ds :: bulletin ds ;
FILE VAR local file :: sequential file (modify, local ds) ;
show (local file) ;
forget (local ds)
ENDPROC show bulletin file ;
PROC write bulletin line (TEXT CONST line) :
IF LENGTH buffer + LENGTH line > 75 THEN writeline FI ;
buffer CAT line
ENDPROC write bulletin line ;
PROC writeline :
write (bulletin file, buffer) ;
line (bulletin file) ;
line number INCR 1 ;
cout (line number) ;
buffer := indentation * " "
ENDPROC writeline ;
PROC writeline (INT CONST times) :
IF LENGTH compress(buffer) <> 0 THEN index := times - 1 ;
writeline
ELSE index := times
FI ;
line (bulletin file, index) ;
line number INCR index;
indentation := 0 ;
cout (line number)
ENDPROC writeline ;
PROC bulletin (TEXT CONST packet name) :
prep bulletin ;
scan (packet name) ;
next symbol (pattern) ;
to packet ;
IF found THEN list packet ;
show bulletin file
ELSE error stop (packet name + " ist kein Paketname")
FI .
to packet :
last packet entry := 0 ;
get nametab link of packet name ;
packet link := before first pt entry ;
REP
packet link INCR wordlength ;
word := cdb int (packet link) ;
IF word < 0 THEN IF word = permanent packet THEN packet found
ELIF word = permanent end THEN return
FI
FI
ENDREP .
get nametab link of packet name :
to object (pattern) ;
IF NOT found THEN error stop ("unbekanntes Paket :" + packet name) ;
LEAVE to packet
FI .
packet found :
IF cdb int (packet link + wordlength) = nt link
THEN last packet entry := packet link FI .
return :
IF last packet entry <> 0 THEN found := TRUE ;
packet link := last packet entry
ELSE found := FALSE
FI ;
LEAVE to packet
ENDPROC bulletin ;
PROC list packet :
begin of packet := packet link + word length ;
write packet name ;
find end of packet ;
run through nametab and list all packet objects .
find end of packet :
last packet entry := begin of packet ;
REP
last packet entry INCR wordlength ;
word := cdb int (last packet entry) ;
UNTIL end of packet entries PER .
end of packet entries :
word = permanent packet OR word = permanent end .
run through nametab and list all packet objects :
hashtable pointer := begin of hashtable ;
REP
nt link := hashtable pointer ;
list objects of current packet in this chain ;
next hash entry
UNTIL end of hashtable reached ENDREP .
list objects of current packet in this chain :
WHILE yet another nt entry REP
permanent pointer := cdb int (nt link + wordlength) ;
put objects of this name
PER .
put objects of this name :
IF there is at least one object of this name in the current packet
THEN into bulletin FI .
there is at least one object of this name in the current packet :
REP
IF permanent pointer >= begin of packet AND
permanent pointer < last packet entry
THEN LEAVE there is at least one object of this name
in the current packet WITH TRUE FI ;
next procedure
UNTIL permanent pointer = 0 PER ;
FALSE .
into bulletin :
object name := cdb text (nt link + two word length) ;
object names into bulletin (BOOL PROC within packet)
ENDPROC list packet ;
BOOL PROC within packet :
permanent pointer >= begin of packet AND
permanent pointer < last packet entry
ENDPROC within packet ;
PROC object names into bulletin (BOOL PROC link ok) :
scan (object name) ;
next symbol (object name, mode) ;
IF type definition THEN put type definition
ELSE put object definitions
FI .
type definition :
mode = bold AND no params .
no params :
cdb int (permanent pointer + word length) >= permanent type .
put type definition :
put obj name (object name) ;
write bulletin line ("TYPE ") ;
writeline (1) .
put object definitions :
WHILE link ok REP
put specifications (object name) ;
next procedure
ENDREP
ENDPROC object names into bulletin ;
PROC bulletin :
prep bulletin ;
packet link := first permanent entry ;
REP
list packet ;
write line (4) ;
next packet
UNTIL NOT found PER ;
show bulletin file
ENDPROC bulletin ;
PROC put obj name (TEXT CONST name) :
buffer := " " ;
bulletin name := point line ;
change (bulletin name, 1, end of line or name, name) ;
buffer CAT bulletin name ;
indentation := LENGTH buffer + 1 .
end of line or name :
min (LENGTH name, LENGTH bulletin name)
ENDPROC put obj name ;
PROC packets :
prep bulletin ;
packet link := first permanent entry ;
REP
object name := packet name ;
put obj name (object name) ;
write line ;
next packet
UNTIL NOT found PER ;
show bulletin file
ENDPROC packets ;
#page#
(**************************************************************************)
(* *)
(* 11. ELAN Run-Interface 09.01.1986 *)
(* *)
(* Uebersetzen von ELAN-Programmen *)
(* Bereitstellen der Ausgabeprozeduren fuer den ELAN-Compiler *)
(* *)
(**************************************************************************)
BOOL VAR list option := FALSE ,
check option := TRUE ,
warning option := FALSE ,
listing enabled := FALSE ;
FILE VAR listing file ;
TEXT VAR listing file name := "" ;
PROC run (TEXT CONST file name) :
enable stop ;
IF NOT exists (file name)
THEN errorstop ("""" + file name + """ gibt es nicht")
FI ;
last param (file name) ;
run elan (file name, no ins)
END PROC run;
PROC run :
run (last param)
ENDPROC run ;
PROC run again :
IF run again mod nr <> 0
THEN elan (run again mode, bulletin file, "", run again mod nr,
no ins, no lst, check option, no sermon)
ELSE errorstop ("'run again' nicht moeglich")
FI
ENDPROC run again ;
PROC insert (TEXT CONST file name) :
enable stop ;
IF NOT exists (file name)
THEN errorstop ("""" + file name + """ gibt es nicht")
FI ;
last param (file name) ;
run elan (file name, ins)
ENDPROC insert ;
PROC insert :
insert (last param)
ENDPROC insert ;
PROC run elan (TEXT CONST file name, BOOL CONST insert option) :
FILE VAR source := sequential file (modify, file name) ;
IF listing enabled
THEN open listing file
FI ;
disable stop ;
no do again ;
elan (compile file mode, source, "" , run again mod nr,
insert option, list option, check option, sermon) ;
IF anything noted AND command dialogue
THEN ignore halt during compiling ;
note edit (source) ;
last param (file name) ;
errorstop ("")
FI .
ignore halt during compiling :
IF is error
THEN put error ;
clear error ;
pause (5)
FI .
open listing file :
listing file := sequential file (output, listing file name) ;
max line length (listing file, 130)
ENDPROC run elan ;
PROC out text (TEXT CONST text, INT CONST out type) :
INTERNAL 257 ;
IF online
THEN out (text)
FI ;
IF out type = error message OR (warning option AND out type = warning message)
THEN note (text) ;
FI ;
IF listing enabled
THEN write (listing file, text)
FI
ENDPROC out text ;
PROC out line (INT CONST out type) :
INTERNAL 258 ;
IF online
THEN out (""13""10"")
FI ;
IF out type = error message
OR (warning option AND out type = warning message)
THEN note line
ELIF listing enabled
THEN line (listing file)
FI
ENDPROC out line ;
PROC prot (TEXT CONST file name) :
list option := TRUE ;
listing file name := file name ;
listing enabled := TRUE
ENDPROC prot ;
PROC prot off :
list option := FALSE ;
listing enabled := FALSE
ENDPROC prot off ;
BOOL PROC prot :
list option
ENDPROC prot ;
PROC check on :
check option := TRUE
ENDPROC check on ;
PROC check off :
check option := FALSE
ENDPROC check off ;
BOOL PROC check :
check option
ENDPROC check ;
PROC warnings on :
warning option := TRUE
ENDPROC warnings on ;
PROC warnings off :
warning option := FALSE
ENDPROC warnings off ;
BOOL PROC warnings :
warning option
ENDPROC warnings ;
ENDPACKET eumel coder part 1 ;