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 ;