PACKET eumel coder part 1 m DEFINES bulletin m : (* Author: U.Bartling *) (* modif'd by G.Szalay*) (* 87-03-31 *) (**************************************************************************) (* *) (* This program generates a file "bulletin" containing procedure heads *) (* and the module numbers, to be used by the debugging packet 'trace'. *) (* *) (**************************************************************************) (***** Globale Variable *****) TEXT VAR object name; FILE VAR bulletin file; INT VAR hash table pointer, nt link, permanent pointer, param link, index, mode, word, packet link; BOOL VAR found, end of params; #page# (**************************************************************************) (* *) (* 1. Interface zum ELAN-Compiler 04.08.1986 *) (* 1.8.0 *) (* *) (* 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 ; INT CONST permanent packet := -2 , permanent end := -3 ; (***** 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 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 01.08.1986 *) (* *) (**************************************************************************) INT VAR line number, begin of packet, last packet entry, indentation; TEXT VAR type and mode, pattern, buffer; 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 "DS" 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 ; BOOL PROC not end of chain : permanent pointer <> 0 ENDPROC not end of chain ; 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 ; write bulletin line (text(cdb int(param link+wordlength),5)) ; 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 " C" ELIF param mode = var THEN " V" 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 to packet (TEXT CONST packet name) : to object ( packet name) ; IF found THEN find start of packet objects FI . find start of packet objects : last packet entry := 0 ; 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 . 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 to packet ; 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 : IF exists ("bulletin") THEN IF yes("overwrite old file ""bulletin""") THEN command dialogue (FALSE); forget ("bulletin"); command dialogue (TRUE); bulletin file := sequential file (output, new ("bulletin")) ELSE bulletin file := sequential file (output, old ("bulletin")) FI ELSE bulletin file := sequential file (output, new ("bulletin")) FI; putline ("GENERATING ""bulletin"" ..."); line number := 0 ; buffer := "" ENDPROC prep bulletin ; 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 := "" 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 m (TEXT CONST packet name) : prep bulletin ; scan (packet name) ; next symbol (pattern) ; to packet (pattern) ; IF found THEN list packet ELSE error stop (packet name + " ist kein Paketname") FI . ENDPROC bulletin m; PROC list packet : begin of packet := packet link + word length ; 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 NOT type definition THEN put object definitions FI . type definition : mode = bold AND no params . no params : cdb int (permanent pointer + word length) >= permanent type . put object definitions : WHILE link ok REP put specifications (object name) ; next procedure ENDREP ENDPROC object names into bulletin ; PROC bulletin m: prep bulletin ; packet link := first permanent entry ; REP list packet ; next packet UNTIL NOT found PER ENDPROC bulletin m; PROC put obj name (TEXT CONST name) : buffer := name. ENDPROC put obj name ; bulletin m; ENDPACKET eumel coder part 1 m;