diff options
Diffstat (limited to 'app/mpg/2.2/src/GRAPHIK.Configurator')
| -rw-r--r-- | app/mpg/2.2/src/GRAPHIK.Configurator | 946 |
1 files changed, 946 insertions, 0 deletions
diff --git a/app/mpg/2.2/src/GRAPHIK.Configurator b/app/mpg/2.2/src/GRAPHIK.Configurator new file mode 100644 index 0000000..68bf070 --- /dev/null +++ b/app/mpg/2.2/src/GRAPHIK.Configurator @@ -0,0 +1,946 @@ +(**************************************************************************) +(* *) +(* MPG - Graphik - System *) +(* *) +(* Version 2.2 vom 11.11.1987 *) +(* *) +(* (c) 1987 Beat Jegerlehner & Carsten Weinholz *) +(* unter Verwendung der Standard-Graphik *) +(* "Graphik-Konfiguration" geschrieben von C.Weinholz *) +(* *) +(**************************************************************************) +(* *) +(* Graphik-Konfiguration *) +(* *) +(* Erstellung eines fuer alle Engeraete gueltigen *) +(* Basisgraphik-Paketes durch zusammenfuegen *) +(* von '.GCONF'-Dateien *) +(* *) +(* Aufruf durch 'configurate graphik', wenn insertiert *) +(* (normalerweise nicht notwendig) *) +(* Bei 'run' muss 'configurate graphik' ans Dateiende *) +(* geschrieben werden. *) +(* *) +(**************************************************************************) +PACKET graphik configuration DEFINES configurate graphik: + +LET PLOTTERCONF = STRUCT (TEXT name, station, channel, area, prep, init, end, + clear, home, move, draw, pixel, foreground, + background, palette, std colors, circle, box, + fill, cursor, get cursor, set marker, linked, + BOOL editor, + BOOL no plotter); +LET max conf = 15, + dquote = ""34""34"", + interface = "GRAPHIK.Configuration", + env conf file = "ENVIRONMENT.GCONF", + packet header = "PACKET device interface DEFINES prepare, init plot, endplot, clear, home, moveto, drawto, setpixel, foreground, background, set color, stdcolors, color, colors, set palette, circle, box,fill,graphik cursor, get cursor, set marker:", + packet end = "END PACKET device interface", + target = "TARGET VAR plotter; initialize target ( plotter);", + install target= "install plotter ( plotter);", + init set = "PROC initplot: IF wsc THEN palette := std palette + ELSE palette := empty palette FI; initplot; set palette + END PROC initplot;", + end set = "BOOL VAR we::TRUE; + PROCendplot(BOOL CONSTs): we:=s + END PROCendplot; + PROCendplot: IF weTHEN endplotFI + END PROCendplot;", + clear set = "BOOL VAR wc::TRUE; PROCclear(BOOL CONSTs): wc:=s + END PROC clear; PROC clear:IF wcTHEN clearFI END PROC clear;", + color set = "BOOL VAR wsc::TRUE; TEXT VAR palette; PROC setcolor (INT CONST no,rgb): + IF (no+1) <= colors THEN replace( palette,no+1,rgb) + FI END PROC set color;", + color set2 = "INT PROC colors : length ( palette) DIV 2 END PROC colors; + INT PROC color (INT CONST no): IF no >= 0 AND (no+1) <= colors + THEN palette ISUB (no+1) ELSE maxint FI END PROC color;", + std colors = "PROCstdcolors(BOOL CONSTs): wsc:=s END PROCstdcolors; + PROC stdcolors:IF wscTHEN palette := std palette;set palette FI END PROCstdcolors;", + foreground = "INT VAR af::1; INT PROCforeground: af END PROCforeground; + PROCforeground(INT CONSTm): af:=m; foreground( af) END PROCforeground;", + background = "INT VAR ab::0; INT PROCbackground: ab END PROCbackground; + PROCbackground(INT CONSTm): ab:=m; background( ab) END PROCbackground;"; + +ROW max conf PLOTTERCONF VAR plotter; +ROW max conf DATASPACE VAR global data; + +TEXT CONST spaces :: 20 * " "; +INT VAR inst plotter, targets, error line :: 0; +TEXT VAR errorm1, errorm2, procvalue :: "", env conf, error source :: ""; +BOOL VAR errors :: FALSE; +FILE VAR f; +DATASPACE VAR conf ds; +THESAURUS VAR plotconfs; + +PROC configurate graphik: + FOR inst plotter FROM 1 UPTO max conf REP + act plotter.name := ""; + act plotter.area := ""; + act plotter.prep := ""; + act plotter.init := ""; + act plotter.end := ""; + act plotter.clear:= ""; + act plotter.home := ""; + act plotter.move := ""; + act plotter.draw := ""; + act plotter.pixel:= ""; + act plotter.foreground := ""; + act plotter.background := ""; + act plotter.palette := ""; + act plotter.circle := ""; + act plotter.box := ""; + act plotter.fill := ""; + act plotter.cursor := ""; + act plotter.get cursor := ""; + act plotter.set marker := ""; + act plotter.linked := ""; + act plotter.editor := FALSE; + PER; + env conf := ""; + inst plotter := 0; + plotconfs := empty thesaurus; + IF exists (env conf file) + THEN plotconfs := ALL env conf file + FI; + plotconfs := SOME (plotconfs + (all LIKE "*.GCONF") - env conf file); + INT VAR id :: 0; TEXT VAR conf file; + get (plotconfs, conf file, id); + WHILE id > 0 REP + IF exists (conf file) + THEN extract conf data (conf file) + ELSE get environment plotter + FI; + get (plotconfs, conf file, id); + PER; + IF inst plotter > 0 + THEN generate interface + ELSE errorstop ("Kein Interface erzeugt") + FI; + last param (interface). + + get environment plotter: + check sequence (conf file, "PLOTTER *,*,*,*,*,*,*;", + "2|4,3,3,3,3,3,3;", + "PLOTTER erwartet,"+ + "Name erwartet,,"+ + "Station erwartet,,"+ + "Kanal erwartet,,"+ + "XPixel erwartet,,"+ + "YPixel erwartet,,"+ + "Xcm erwartet,,"+ + "Ycm erwartet,,"+ + "Plotterkommando fehlerhaft"); + IF errors + THEN errorstop (errorm2) + ELSE TEXT VAR one int :: ""0""0"", one real :: 8 * ""0""; + replace (one int,1,length(get var (1))); + env conf CAT one int; + env conf CAT get var (1); + replace (one int, 1, int (get var (2))); + env conf CAT one int; + replace (one int, 1, int (get var (3))); + env conf CAT one int; + replace (one int, 1, int (get var (4))); + env conf CAT one int; + replace (one int, 1, int (get var (5))); + env conf CAT one int; + replace (one real, 1, real (get var (6))); + env conf CAT one real; + replace (one real, 1, real (get var (7))); + env conf CAT one real; + FI +END PROC configurate graphik; + +PROC extract conf data (TEXT CONST conf file): + TEXT VAR line; + inst plotter INCR 1; + IF inst plotter > max conf + THEN putline ("Warnung: Es koennen nicht mehr als " + text(max conf) + + " Geraete konfiguriert werden"); + inst plotter DECR 1 + ELSE error source := conf file; + conf ds := old (conf file); + f := sequential file (modify, conf ds); + set line numbers; + IF is plotter configuration + THEN get name and area (line, act plotter.name, + act plotter.station, + act plotter.channel, + act plotter.area); + get linked (act plotter.linked); + get includes; + putline ("""" + act plotter.name + """ wird eingelesen"); + get paramless ("initplot",act plotter.init); + get paramless ("endplot" ,act plotter.end); + get paramless ("clear" ,act plotter.clear); + get paramless ("home" ,act plotter.home); + get paramless ("prepare" ,act plotter.prep); + get koord ("moveto" ,act plotter.move); + get koord ("drawto" ,act plotter.draw); + get koord ("setpixel",act plotter.pixel); + get var param ("foreground",act plotter.foreground); + get var param ("background",act plotter.background); + get paramless ("setpalette",act plotter.palette); + get std colors(act plotter.std colors); + get circle (act plotter.circle); + get box (act plotter.box); + get fill (act plotter.fill); + IF editor available + THEN get graphik cursor (act plotter.cursor); + get get cursor (act plotter.get cursor); + get set marker (act plotter.set marker) + FI; + push error; + IF anything noted + THEN f := sequential file (modify,conf file); + out (""7"");note edit (f);errorstop("") + FI + FI; + global data [inst plotter] := conf ds; + forget (conf ds) + FI. + + is plotter configuration: + plotter [inst plotter].no plotter := NOT sequence found ("PLOTTER", + line, 1,TRUE); + NOT plotter [inst plotter].no plotter. + + editor available: + plotter [inst plotter].editor := sequence found ("EDITOR", line, 1,TRUE); + IF plotter [inst plotter].editor + THEN delete record (f); + check sequence (line, "EDITOR;", "2;", + "EDITOR erwartet,"+ + "Semikolon erwartet," + + "Editorkommando fehlerhaft") + FI; + plotter [inst plotter].editor. + + set line numbers: + INT VAR line number; + to line (f,1); + FOR line number FROM 1 UPTO lines (f)-1 REP + cout (line number); + insert line number; + down (f) + PER; + insert line number. + + insert line number: + TEXT VAR new line; + read record (f, new line); + insert char (new line, " ", 1); + insert char (new line, " ", 1); + replace (new line, 1, line number); + write record (f, new line). + + get includes: + BOOL VAR include found :: sequence found ("INCLUDE",line, 1, TRUE); + WHILE include found REP + push error; + include found := sequence found ("INCLUDE",line, line no (f), TRUE); + IF include found + THEN add to plotconfs + FI + PER. + + add to plotconfs: + check sequence (line, "INCLUDE *;","2|4;", + "INCLUDE erwartet,Dateiname erwartet," + + "Includekommando fehlerhaft"); + IF NOT errors CAND exists (get var (1)) + THEN IF NOT (plotconfs CONTAINS get var (1)) + THEN insert (plotconfs,get var (1)) + FI; + ELIF NOT errors + THEN error ("""" + get var (1) + """ existiert nicht") + FI; + delete record (f) +END PROC extract conf data; + +PROC generate interface: + INT VAR act conf; + conf ds := nilspace; + forget (interface,quiet); + proc value := ""; + FILE VAR f :: sequential file (output, conf ds); + putline (f,packet header); + putline (f,target); + generate target; + putline (f,install target); + putline (f,init set); + putline (f,end set); + putline (f,clear set); + putline (f,color set); + putline (f,color set 2); + putline (f, std colors); + putline (f,foreground); + putline (f,background); + FOR act conf FROM 1 UPTO inst plotter REP + FILE VAR source := sequential file (modify,global data [act conf]); + copy lines (f,source) + PER; + generate proc (""," initplot", TEXT PROC (INT CONST) initplotbody); + generate proc (""," endplot", TEXT PROC (INT CONST) endplotbody); + generate proc (""," clear", TEXT PROC (INT CONST) clearbody); + generate proc ("","prepare", TEXT PROC (INT CONST) prepbody); + proc value := " TEXT"; + generate proc (""," std palette", TEXT PROC (INT CONST) std palette body); + generate proc (""," empty palette", TEXT PROC (INT CONST) empty palette body); + proc value := ""; + generate proc ("","home", TEXT PROC (INT CONST) homebody); + generate proc ("INT CONST x,y","moveto", TEXT PROC (INT CONST) movebody); + generate proc ("INT CONST x,y","drawto", TEXT PROC (INT CONST) drawbody); + generate proc ("INT CONST x,y","set pixel", TEXT PROC (INT CONST) pixelbody); + generate proc ("INT VAR type"," foreground", TEXT PROC (INT CONST) foregroundbody); + generate proc ("INT VAR type"," background", TEXT PROC (INT CONST) backgroundbody); + generate proc ("","set palette", TEXT PROC (INT CONST) set palette body); + generate proc ("INT CONST x,y,rad,from,to","circle", TEXT PROC (INT CONST) circlebody); + generate proc ("INT CONST x1,y1,x2,y2,pattern", "box", TEXT PROC (INT CONST) box body); + generate proc ("INT CONST x,y,pattern","fill", TEXT PROC (INT CONST) fill body); + generate proc ("INT CONST x,y, BOOL CONST on","graphik cursor",TEXT PROC (INT CONST) graphik cursor body); + generate proc ("INT VAR x,y, TEXT VAR exit char","get cursor",TEXT PROC (INT CONST) get cursor body); + generate proc ("INT CONST x,y, type","set marker",TEXT PROC (INT CONST) set marker body); + proc value := "BOOL "; + generate proc ("","graphik cursor",TEXT PROC (INT CONST) editor available); + generate device link; + putline (f,packet end); + copy (conf ds,interface); + IF yes ("""" + interface + """ insertieren") + THEN insert (interface) + FI. + + generate target: + INT VAR devices :: 0; + targets := 0; + FOR act conf FROM 1 UPTO inst plotter REP + TEXT VAR linked :: plotter[act conf].linked, + one int:: ""0""0""; + plotter [act conf].linked := ""; + IF NOT plotter [act conf].no plotter + THEN putline (f,"complete target ( plotter,""" + + plotter [act conf].station + "/" + + plotter [act conf].channel + "/" + + plotter [act conf].name + + """,""" + plotter [act conf].area + """);"); + devices INCR 1; + targets INCR 1; + replace (one int, 1, devices); + plotter [act conf].linked CAT one int; + replace (one int, 1, targets); + plotter [act conf].linked CAT one int; + IF linked > "" + THEN INT VAR x :: 1; + WHILE x <= length (linked) DIV 2 REP + putline (f,"complete target ( plotter, """ + + text(linked ISUB x) + "/" + + text(linked ISUB (x+1)) + "/" + + plotter[act conf].name + """,""" + + plotter[act conf].area + """);"); + targets INCR 1; + replace (one int, 1, targets); + plotter [act conf].linked CAT one int; + x INCR 2 + PER + FI + FI + PER; + WHILE env conf <> "" REP + generate env target (env conf) + PER +END PROC generate interface; + +PROC generate env target (TEXT VAR conf): + INT VAR nlen :: conf ISUB 1; + TEXT VAR tnam :: subtext (conf, 3, 2+nlen); + conf := subtext (conf, nlen + 3); + putline (f,"complete target ( plotter, """ + text (conf ISUB 1) + "/" + + text (conf ISUB 2) + "/" + tnam + """,""" + + text (conf ISUB 3) + "," + text (conf ISUB 4) + "," + + first real + "," + text (conf RSUB 2) + """);"); + conf := subtext (conf, 17). + + first real: + conf := subtext (conf, 9); + text (conf RSUB 1) +END PROC generate env target; + +TEXT PROC initplotbody (INT CONST no): + plotter [no].init +END PROC initplotbody; + +TEXT PROC endplotbody (INT CONST no): + plotter [no].end +END PROC endplotbody; + +TEXT PROC clearbody (INT CONST no): + plotter [no].clear +END PROC clearbody; + +TEXT PROC prepbody (INT CONST no): + plotter [no].prep +END PROC prepbody; + +TEXT PROC homebody (INT CONST no): + plotter [no].home +END PROC homebody; + +TEXT PROC movebody (INT CONST no): + plotter [no].move +END PROC movebody; + +TEXT PROC drawbody (INT CONST no): + plotter [no].draw +END PROC drawbody; + +TEXT PROC pixelbody (INT CONST no): + plotter [no].pixel +END PROC pixelbody; + +TEXT PROC std palette body (INT CONST no): + TEXT CONST rgb codes :: plotter [no].std colors; + TEXT VAR body :: dquote; + INT VAR x; + FOR x FROM 1 UPTO length (rgb codes) DIV 3 REP + INT VAR color :: int (subtext(rgb codes, (x-1)*3+1, x*3)); + body CAT (text (color AND 255) + dquote); + body CAT (text (color DIV 256) + dquote); + PER; + body +END PROC std palette body; + +TEXT PROC empty palette body (INT CONST no): + text (length (plotter[no].std colors) DIV 3) + "*" + dquote + + "255" + dquote + "127" + dquote +END PROC empty palette body; + +TEXT PROC set palette body (INT CONST no): + plotter[no].palette +END PROC set palette body; + +TEXT PROC foregroundbody (INT CONST no): + plotter [no].foreground +END PROC foregroundbody; + +TEXT PROC backgroundbody (INT CONST no): + plotter [no].background +END PROC backgroundbody; + +TEXT PROC circle body (INT CONST no): + plotter [no].circle +END PROC circle body; + +TEXT PROC box body (INT CONST no): + plotter [no].box +END PROC box body; + +TEXT PROC fill body (INT CONST no): + plotter [no].fill +END PROC fill body; + +TEXT PROC graphik cursor body (INT CONST no): + plotter [no].cursor +END PROC graphik cursor body; + +TEXT PROC get cursor body (INT CONST no): + plotter [no].get cursor +END PROC get cursor body; + +TEXT PROC set marker body (INT CONST no): + plotter [no].set marker +END PROC set marker body; + +TEXT PROC editor available (INT CONST no): + IF plotter [no].editor + THEN "TRUE" + ELSE "FALSE" + FI +END PROC editor available; + +PROC generate device link: + INT VAR actconf; + putline (f, "INT PROC act device :"); + putline (f, "SELECT actual plotter OF"); + FOR act conf FROM 1 UPTO inst plotter REP + IF NOT plotter [act conf].no plotter + THEN putline (f,"CASE " + text (plotter[act conf].linked ISUB 2) + ":"); + put (f,text (plotter[act conf].linked ISUB 1)); + IF length (plotter[act conf].linked) > 2 + THEN generate table + FI + FI + PER; + putline (f,"OTHERWISE errorstop (""Kein Endgeraet angekoppelt"");0"); + putline (f,"END SELECT END PROC act device;"). + + generate table: + INT VAR x; + FOR x FROM 3 UPTO length (plotter[act conf].linked) DIV 2 REP + put (f,"CASE"); + put (f,text (plotter[act conf].linked ISUB x)); + put (f,":"); + put (f, text (plotter[act conf].linked ISUB 1)) + PER +END PROC generate device link; + +PROC generate proc (TEXT CONST params,procname,TEXT PROC (INT CONST)procbody): + INT VAR actconf, no plotter :: 0; + IF params = "" + THEN putline (f,procvalue + " PROC " + procname + ":") + ELSE putline (f,procvalue + " PROC " + procname + "(" + params + "):") + FI; + IF procvalue <> "" + THEN putline (f,procvalue + " VAR d;") + FI; + putline (f,"SELECT act device OF"); + FOR act conf FROM 1 UPTO inst plotter REP + IF NOT plotter [act conf].no plotter + THEN putline (f, "CASE " + text (act conf-no plotter) + ":" + + lowercase(plotter[act conf].name) + + plotter [act conf].channel + procname) + ELSE no plotter INCR 1 + FI + PER; + IF procvalue <> "" + THEN putline (f," OTHERWISE d END SELECT") + ELSE putline (f," END SELECT") + FI; + FOR act conf FROM 1 UPTO inst plotter REP + IF NOT plotter [act conf].no plotter + THEN putline (f,"."); + putline (f,lowercase(plotter[act conf].name)+ + plotter[act conf].channel + procname + ":"); + putline (f,procbody (act conf)) + FI + PER; + putline (f,"END PROC "+ procname +";") +END PROC generate proc; + +PROC get name and area (TEXT CONST line, TEXT VAR name, station, channel, area): + push error; + check sequence (line, "PLOTTER *,*,*,*,*,*,*;", + "2|4,3,3,3,3,3,3;", + "PLOTTER erwartet,"+ + "Name erwartet,,"+ + "Station erwartet,,"+ + "Kanal erwartet,,"+ + "XPixel erwartet,,"+ + "YPixel erwartet,,"+ + "Xcm erwartet,,"+ + "Ycm erwartet,,"+ + "Plotterkommando fehlerhaft"); + name := get var (1); + station := get var (2); + channel := get var (3); + area := ""; + area CAT (get var (4) + ","); + area CAT (get var (5) + ","); + area CAT (get var (6) + ","); + area CAT (get var (7) + ","); + delete record (f) +END PROC get name and area; + +PROC get linked (TEXT VAR keep): + TEXT VAR line; + IF sequence found ("LINK", line, 1, TRUE) + THEN extract data; + delete record (f) + FI. + + extract data: + TEXT VAR symbol, one int :: ""0""0""; + INT VAR ltyp :: 2,type :: 0;(* 0 = ',' 1 = '/' 2 = Station 3 = Kanal*) + push error; (* 4 = Ende erwartet ! *) + keep := ""; + errorm1 := line; + scan (line); + next symbol (symbol); + IF symbol <> "LINK" + THEN error ("LINK erwartet") + FI; + WHILE type < 7 AND NOT errors REP + next symbol (symbol, type); + IF ltyp = 0 + THEN IF symbol = "," + THEN ltyp := 2 + ELIF symbol = ";" + THEN ltyp := 4 + ELSE error ("Semikolon oder Komma erwartet") + FI + ELIF ltyp = 1 + THEN IF symbol = "/" + THEN ltyp := 3 + ELSE error ("'/' erwartet") + FI + ELIF ltyp = 4 + THEN IF type = 8 + THEN error ("Kommentarende fehlt") + ELIF type = 9 + THEN error ("Text unzulaessig (Textende fehlt)") + ELIF type <> 7 + THEN error ("Zeilenende nach Semikolon erwartet") + FI + ELIF type = 3 + THEN replace (one int, 1, int (symbol)); + keep CAT one int; + ltyp DECR 1; + IF ltyp = 2 + THEN ltyp := 0 + FI + FI + PER +END PROC get linked; + +PROC get graphik cursor (TEXT VAR keep): + get proc ("graphik cursor","(INT CONST x,y, BOOL CONST on)", + "(2|2 x,y,2|2 on)","INT erwartet, CONST erwartet,"+ + "Formaler Parameter muss x heissen,"+ + "Formaler Parameter muss y heissen,"+ + "BOOL erwartet, CONST erwartet,"+ + "Formaler Parameter muss on heissen", + keep); +END PROC get graphik cursor; + +PROC get get cursor (TEXT VAR keep): + get proc ("get cursor","(INT VAR x,y, TEXT VAR exit char)", + "(2|2 x,y,2|2 exit char)","INT erwartet, VAR erwartet,"+ + "Formaler Parameter muss x heissen,"+ + "Formaler Parameter muss y heissen,"+ + "TEXT erwartet, VAR erwartet,"+ + "Formaler Parameter muss exit char heissen", + keep); +END PROC get get cursor; + +PROC get set marker (TEXT VAR keep): + get proc ("set marker","(INT CONST x,y,type)","(2|2 x,y,type)", + "INT erwartet, CONST erwartet,"+ + "Formaler Parameter muss x heissen,"+ + "Formaler Parameter muss y heissen,"+ + "Formaler Parameter muss type heissen", + keep); +END PROC get set marker; + +PROC get std colors (TEXT VAR keep): + TEXT VAR line; + push error; + IF sequence found ("COLORS", line, 1, TRUE) + THEN extract data + ELSE error ("COLORS fehlt") + FI. + + extract data: + check sequence (line, "COLORS *;","2|4;", + "COLORS erwartet,"+ + "Rgbcodes erwartet,Semikolon fehlt"); + keep := get var (1); + delete record (f); +END PROC get std colors; + +PROC get paramless (TEXT CONST procname, TEXT VAR keep): + get proc (procname, "", "", "", keep) +END PROC get paramless; + +PROC get var param (TEXT CONST procname, TEXT VAR keep): + get proc (procname, "(INT VAR type)","(2|2 type)", + "INT erwartet, VAR erwartet, Formaler Parameter muss type heissen", + keep); +END PROC get var param; + +PROC get koord (TEXT CONST procname, TEXT VAR keep): + get proc (procname, "(INT CONST x,y)","(2|2 x,y)", + "INT erwartet,CONST erwartet,Formaler Parameter muss x heissen,"+ + "Formaler Parameter muss y heissen",keep) +END PROC get koord; + +PROC get circle (TEXT VAR keep): + get proc ("circle","(INT CONST x,y,rad,from,to)","(2|2 x,y,rad,from,to)", + "INT erwartet,CONST erwartet,Formaler Parameter muss x heissen,"+ + "Formaler Parameter muss y heissen,Formaler Parameter muss rad heissen,"+ + "Formaler Parameter muss from heissen,Formaler Parameter muss to heissen", + keep); +END PROC get circle; + +PROC get box (TEXT VAR keep): + get proc ("box","(INT CONST x1,y1,x2,y2,pattern)","(2|2 x1,y1,x2,y2,pattern)", + "INT erwartet,CONST erwartet,Formaler Parameter muss x1 heissen,"+ + "Formaler Parameter muss y1 heissen,Formaler Parameter muss x2 heissen,"+ + "Formaler Parameter muss y2 heissen,Formaler Parameter muss pattern heissen", + keep); +END PROC get box; + +PROC get fill (TEXT VAR keep): + get proc ("fill","(INT CONST x,y,pattern)","(2|2 x,y,pattern)", + "INT erwartet,CONST erwartet,Formaler Parameter muss x heissen"+ + "Formaler Parameter muss y heissen,Formaler Parameter muss pattern heissen", + keep); +END PROC get fill; + +PROC get proc (TEXT CONST procname, psym, ptyp, perr, + TEXT VAR keep): + TEXT VAR line; + push error; + IF sequence found ("PROC"+procname, line, 1, TRUE) + THEN errors := FALSE; + get body (line,procname,psym,ptyp,perr,keep) + ELSE error (procname + " nicht gefunden") + FI +END PROC get proc; + +PROC get body (TEXT CONST header,procname,psyms,ptypes ,perrs, TEXT VAR keep body): + INT VAR start, ende; + start := line no(f); + keep body := ""; + check sequence (header, "PROC " + procname + psyms + ":", + "2|1"+ ptypes + ":", + "PROC erwartet," + + procname + " erwartet,,"+ + perrs+ + ",Fehler in " + procname + "-Header"); + IF NOT errors + THEN get to end of proc + FI. + + get to end of proc: + TEXT VAR last; + errors := FALSE; + IF sequence found ("END PROC " + procname, last, line no(f),FALSE) + THEN ende := line no (f); + check sequence (last, "END PROC " + procname + ";", + "2|2|1;", + "END erwartet,"+ + "PROC erwartet,"+ + "PROC heisst " + procname + + ",Semikolon fehlt"); + IF NOT errors + THEN to line (f,start); + delete record (f); + INT VAR lc; + FOR lc FROM start UPTO ende-2 REP + TEXT VAR scratch; + read record (f,scratch); + scratch := subtext (scratch, 3); + keep body CAT (" " + scratch); + delete record (f); + PER; + delete record (f) + FI + ELSE error ("END PROC " + procname + " nicht gefunden") + FI +END PROC get body; + +BOOL PROC sequence found (TEXT CONST sequence text, + TEXT VAR sequence line, INT CONST from line, + BOOL CONST evtl at): + BOOL VAR found :: FALSE, at char :: evtl at; + to line (f,from line); + col (f,1); + WHILE NOT (found OR eof (f)) REP + cout (line no (f)); + to first char; + IF found + THEN read record (f, sequence line); + error line := sequence line ISUB 1; + sequence line := subtext (sequence line, 3); + scan sequence + FI + PER; + IF NOT found + THEN read record (f, sequence line); + IF pos (first char, sequence line) > 0 + THEN scan sequence + FI + FI; + found. + + to first char: + IF at char + THEN downety (f, first char) + ELSE down (f, first char) + FI; + at char := FALSE; + found := pattern found. + + scan sequence: + TEXT VAR source symbols,symbols; + scan (sequence text); + get symbols; + source symbols := symbols; + scan (sequence line); + get symbols; + found := pos (symbols,source symbols) = 1. + + get symbols: + TEXT VAR symbol; + INT VAR type; + symbols := ""; + REP + next symbol (symbol, type); + symbols CAT symbol + UNTIL type > 6 PER. + + first char: + sequence text SUB 1 +END PROC sequence found; + +PROC error (TEXT CONST emsg): + IF NOT eof (f) + THEN read record (f,errorm1); + errorm1 := """" + error source + """, Zeile " + + text (error line) + ":" + ELSE errorm1 := """" + error source + """, Fileende:" + FI; + errorm2 := spaces + emsg; + errors := TRUE +END PROC error; + +PROC push error: + IF errors + THEN note (errorm1);note line; + note (10* " " + errorm2); note line; + errors := FALSE + FI +END PROC push error; + + (* Hinweis: bei Fehlermeldungen statt Blank ' ' (geschuetzt) verwenden. + Bei verschiedenen Typen ohne trennenden Delimiter zur + Abgrenzung in 'seq typ' '|' verwenden. + '*' wird in 'seq sym' als Wildcard verwendet (Itemweise) + Bei Delimitern wird der 'allgemeine Fehler' (letzter i.d Liste) + verwendet. Jedoch muss auch fuer Delimiter ein Eintrag + in der Liste freigehalten werden (...,,... oder ...,dummy,...). +*) + +ROW 100 STRUCT (TEXT sym, INT typ, BOOL var) VAR seqlist; +INT VAR scanpos; + +TEXT PROC get var (INT CONST no): + INT VAR count :: 0, checkpos :: 1; + WHILE checkpos <= scanpos REP + IF seqlist[checkpos].var + THEN count INCR 1; + IF count >= no + THEN LEAVE get var WITH seqlist[checkpos].sym + FI + FI; + checkpos INCR 1 + PER;"" +END PROC get var; + +PROC check sequence (TEXT CONST seq, seq sym, seq typ, seq err): + ROW 100 TEXT VAR err; + INT VAR checkpos,erpos, typ, error1 :: 0,error2 :: 0; + TEXT VAR sym; + scan (seq err); + next symbol (sym, typ); + erpos := 1; + err[erpos] := ""; + REP + SELECT typ OF + CASE 5: err[erpos] CAT " " + CASE 6: erpos INCR 1; + err [erpos] := "" + OTHERWISE err[erpos] CAT sym + END SELECT; + next symbol (sym, typ) + UNTIL typ >= 7 PER; + scan (seq); + FOR scanpos FROM 1 UPTO 100 REP + next symbol (seqlist[scanpos].sym,seqlist[scanpos].typ); + UNTIL seqlist[scanpos].typ >= 7 PER; + SELECT seqlist[scanpos].typ OF + CASE 8: error ("Kommentarende fehlt") + CASE 9: error ("Textende fehlt") + OTHERWISE IF scanpos = 100 + THEN error ("Kommando zu schwierig") + FI + END SELECT; + scan (seq sym); + FOR checkpos FROM 1 UPTO scanpos REP + next symbol (sym, typ); + IF sym = "*" + THEN seqlist[checkpos].var := TRUE + ELSE seqlist[checkpos].var := FALSE + FI + PER; + scan (seq typ); + next symbol (sym,typ); + FOR checkpos FROM 1 UPTO scanpos REP + WHILE sym = "|" REP + next symbol (sym, typ) + PER; + BOOL VAR std err :: typ <> 3; + IF NOT std err + THEN typ := int(sym); + IF seqlist[checkpos].typ <> typ + THEN error1 := checkpos + FI; + ELIF seqlist[checkpos].sym <> sym + THEN error1 := erpos + FI; + next symbol (sym, typ) + UNTIL error1 > 0 OR typ >= 7 PER; + scan (seq sym); + next symbol (sym,typ); + FOR checkpos FROM 1 UPTO scanpos-1 REP + std err := typ = 6; + IF (seqlist[checkpos].sym <> sym) AND (sym <> "*") + THEN IF std err + THEN error2 := erpos + ELSE error2 := checkpos + FI + FI; + next symbol (sym, typ) + UNTIL error2 > 0 PER; + IF error1 = 0 + THEN error1 := error2 + ELIF error1 = erpos + THEN IF (error2 <> 0) AND (error2 <> erpos) + THEN error1 := error2 + FI + FI; + IF error1 > 0 + THEN error (err [error1]) + FI +END PROC check sequence; + +INT PROC lower pair (INT CONST upper pair): + INT VAR lower :: upper pair; + set bit (lower,5); + set bit (lower,13); + lower +END PROC lower pair; + +TEXT PROC lower case (TEXT CONST uppercase): + TEXT VAR lower :: uppercase; + INT VAR x; + IF length(lower) MOD 2 <> 0 + THEN lower CAT ""0"" + FI ; + FOR x FROM 1 UPTO length(lower)DIV2 REP + replace (lower,x,lower pair (lower ISUB x)) + PER; + lower +END PROC lower case; + +PROC copy lines (FILE VAR dest, source): + INT VAR l; + input(source); + output(dest); + FOR l FROM 1 UPTO lines (source) REP + TEXT VAR scratch,test; + getline (source,scratch); + scratch := subtext (scratch,3); + test := scratch; + change all (test," ",""); + IF test <> "" + THEN putline (dest, scratch) + FI + PER +END PROC copy lines; + +.act plotter: + plotter[inst plotter] + +END PACKET graphik configuration; +configurate graphik + |