diff options
Diffstat (limited to 'system/std.zusatz/1.7.3/src')
26 files changed, 6324 insertions, 0 deletions
diff --git a/system/std.zusatz/1.7.3/src/17CHARS.ELA b/system/std.zusatz/1.7.3/src/17CHARS.ELA new file mode 100644 index 0000000..160997a --- /dev/null +++ b/system/std.zusatz/1.7.3/src/17CHARS.ELA @@ -0,0 +1,44 @@ +PACKET special 17 chars DEFINES chars 17 :
+
+TEXT VAR rec , schar ;
+FILE VAR f ;
+
+PROC chars 17 :
+
+ REP
+ down ("""") ;
+ get schar ;
+ UNTIL perhaps schar ("225", "217")
+ COR perhaps schar ("239", "218")
+ COR perhaps schar ("245", "219")
+ COR perhaps schar ("193", "214")
+ COR perhaps schar ("207", "215")
+ COR perhaps schar ("213", "216")
+ COR perhaps schar ("235", "220")
+ COR perhaps schar ("173", "221")
+ COR perhaps schar ("163", "222")
+ COR perhaps schar ("160", "223")
+ COR perhaps schar ("194", "251")
+ COR eof
+ PER ;
+ zeile neu .
+
+get schar :
+ f := editfile ;
+ read record (f, rec) ;
+ schar := subtext (rec, col + 1, col + 3) .
+
+ENDPROC chars 17 ;
+
+BOOL PROC perhaps schar (TEXT CONST old, new) :
+
+ IF schar = old
+ THEN change (rec, col + 4, col + 3, new) ;
+ write record (f, rec) ;
+ TRUE
+ ELSE FALSE
+ FI .
+
+ENDPROC perhaps schar ;
+
+ENDPACKET special 17 chars ;
diff --git a/system/std.zusatz/1.7.3/src/EMU16.ELA b/system/std.zusatz/1.7.3/src/EMU16.ELA new file mode 100644 index 0000000..a8e1292 --- /dev/null +++ b/system/std.zusatz/1.7.3/src/EMU16.ELA @@ -0,0 +1,109 @@ +PACKET emulator 16 DEFINES (* Autor: J.Liedtke *)
+ (* Stand: 11.10.83 *)
+ killer , (* F. Klapper, 26.03.84 *)
+ command handler ,
+ set command ,
+ to archive,
+ from archive,
+ load archive,
+ save archive,
+ list archive,
+ release archive:
+
+PROC list archive:
+ list (archive)
+
+END PROC list archive;
+
+PROC release archive:
+ release (archive)
+
+END PROC release archive;
+
+PROC to archive:
+ save (last param, archive)
+
+END PROC to archive;
+
+PROC to archive (TEXT CONST t):
+ save (t, archive)
+
+END PROC to archive;
+
+PROC from archive (TEXT CONST t):
+ fetch (t, archive)
+
+END PROC from archive;
+
+PROC load archive:
+ fetch all (archive)
+
+END PROC load archive;
+
+PROC save to archive (THESAURUS CONST thes):
+ disable stop;
+ all to archive (thes);
+ IF is error
+ THEN put error;
+ line;
+ clear error;
+ IF yes ("naechste Archivfloppy eingelegt")
+ THEN save to archive (remainder)
+ FI
+ FI;
+ enable stop
+
+END PROC save to archive;
+
+PROC all to archive (THESAURUS CONST thes):
+ enable stop;
+ save (thes, archive)
+
+END PROC all to archive;
+
+PROC save archive:
+ save to archive (ALL myself)
+
+END PROC save archive;
+
+PROC save archive (TEXT CONST liste):
+ save to archive (ALL liste)
+
+END PROC save archive;
+
+PROC killer :
+ forget (ALL myself)
+
+ENDPROC killer ;
+
+TEXT VAR command line;
+INT VAR permitted type := 0 ;
+
+PROC set command (TEXT CONST command text, INT CONST type) :
+
+ command line := command text;
+ permitted type := type
+
+ENDPROC set command ;
+
+PROC command handler (TEXT CONST command list,
+ INT VAR command index , number of params ,
+ TEXT VAR param 1, param 2) :
+
+ analyze command (command list, command line, permitted type, command index,
+ number of params, param 1, param 2)
+
+ENDPROC command handler ;
+
+PROC command handler (TEXT CONST command list,
+ INT VAR command index , number of params ,
+ TEXT VAR param 1, param 2,
+ TEXT CONST command text) :
+
+ get command (command text, command line) ;
+ analyze command (command list, command line, 0,
+ command index, number of params, param 1, param 2)
+
+ENDPROC command handler ;
+
+ENDPACKET emulator 16 ;
diff --git a/system/std.zusatz/1.7.3/src/EMU16M.ELA b/system/std.zusatz/1.7.3/src/EMU16M.ELA new file mode 100644 index 0000000..ed8cff4 --- /dev/null +++ b/system/std.zusatz/1.7.3/src/EMU16M.ELA @@ -0,0 +1,162 @@ +PACKET emulator 16 multi DEFINES (* Autor: J.Liedtke *)
+ (* Stand: 11.10.83 *)
+ killer , (* F. Klapper, 16.05.84 *)
+ file names ,
+ out ,
+ command handler ,
+ set command ,
+ call ,
+ read ,
+ to archive,
+ from archive,
+ load archive,
+ save archive,
+ list archive,
+ release archive,
+ forward,
+ backward,
+ to eof,
+ to first record,
+ is first record:
+
+PROC list archive:
+ list (archive)
+END PROC list archive;
+
+PROC release archive:
+ release (archive)
+END PROC release archive;
+
+PROC to archive:
+ save (last param, archive)
+END PROC to archive;
+
+PROC to archive (TEXT CONST t):
+ save (t, archive)
+END PROC to archive;
+
+PROC from archive (TEXT CONST t):
+ fetch (t, archive)
+END PROC from archive;
+
+PROC load archive:
+ fetch all (archive)
+END PROC load archive;
+
+PROC save to archive (THESAURUS CONST thes):
+ disable stop;
+ all to archive (thes);
+ IF is error
+ THEN put error;
+ line;
+ clear error;
+ IF yes ("naechste Archivfloppy eingelegt")
+ THEN save to archive (remainder)
+ FI
+ FI;
+ enable stop
+END PROC save to archive;
+
+PROC all to archive (THESAURUS CONST thes):
+ enable stop;
+ save (thes, archive)
+END PROC all to archive;
+
+PROC save archive:
+ save to archive (ALL myself)
+END PROC save archive;
+
+PROC save archive (TEXT CONST liste):
+ save to archive (ALL liste)
+END PROC save archive;
+
+PROC killer :
+ forget (ALL myself)
+ENDPROC killer ;
+
+THESAURUS VAR cat ;
+TEXT VAR file name ;
+
+PROC file names (FILE VAR f) :
+ file names (f, name (myself))
+ENDPROC file names ;
+
+PROC file names (FILE VAR f, TEXT CONST manager name) :
+ INT VAR index := 0 ;
+ cat := ALL task (manager name) ;
+ REP
+ get (cat, file name, index) ;
+ IF file name = ""
+ THEN LEAVE file names
+ FI ;
+ putline (f, file name)
+ PER
+ENDPROC file names ;
+
+PROC out (FILE VAR f, TEXT CONST t) :
+ write (f,t)
+ENDPROC out ;
+
+TEXT VAR command line;
+INT VAR permitted type := 0 ;
+
+PROC set command (TEXT CONST command text, INT CONST type) :
+ command line := command text;
+ permitted type := type
+ENDPROC set command ;
+
+PROC command handler (TEXT CONST command list,
+ INT VAR command index , number of params ,
+ TEXT VAR param 1, param 2) :
+
+ analyze command (command list, command line, permitted type, command index,
+ number of params, param 1, param 2)
+
+ENDPROC command handler ;
+
+PROC command handler (TEXT CONST command list,
+ INT VAR command index , number of params ,
+ TEXT VAR param 1, param 2,
+ TEXT CONST command text) :
+
+ get command (command text, command line) ;
+ analyze command (command list, command line, 0,
+ command index, number of params, param 1, param 2)
+
+ENDPROC command handler ;
+
+PROC call (TEXT CONST dest name, INT CONST order code,
+ DATASPACE VAR ds, INT VAR reply code) :
+
+ call (task (dest name), order code, ds, reply code)
+
+ENDPROC call ;
+
+PROC read (TEXT CONST file name) :
+ fetch (file name)
+ENDPROC read ;
+
+PROC read (TEXT CONST file name, manager name) :
+ fetch (file name, task(manager name))
+ENDPROC read ;
+
+PROC forward (FILE VAR f):
+ down (f)
+END PROC forward;
+
+PROC backward (FILE VAR f):
+ up (f)
+END PROC backward;
+
+PROC to first record (FILE VAR f):
+ to line (f, 1)
+END PROC to first record;
+
+BOOL PROC is first record (FILE VAR f):
+ line no (f) = 1
+END PROC is first record;
+
+PROC to eof (FILE VAR f):
+ to line (f, lines (f))
+END PROC to eof;
+ENDPACKET emulator 16 multi ;
diff --git a/system/std.zusatz/1.7.3/src/FONTR16.ELA b/system/std.zusatz/1.7.3/src/FONTR16.ELA new file mode 100644 index 0000000..91acfe0 --- /dev/null +++ b/system/std.zusatz/1.7.3/src/FONTR16.ELA @@ -0,0 +1,360 @@ +PACKET fonts routines
+(**************************************************************************
+***** Verwaltung der Schriftfontstabelle ** Author : R. Nolting *****
+***** Benoetigt von allen Druckertreibern ** Version: 0.1 / 3.5.82 *****
+***** ** Version: 1.0 / 8.6.82 *****
+***** ** Version: 2.0 / 1. 8. 82 *****
+***** Schrittweite in x und y in Tabelle ** Version: 3.0 / 1. 9. 83 *****
+***** Zeilenhoehe in cm ** Version: 3.1 / 2. 4. 84 *****
+**************************************************************************)
+
+ DEFINES
+ load font table,
+ get font,
+ list fonts,
+ inch,
+ current font number,
+ lf height of current font,
+ x factor per inch,
+ y factor per inch:
+
+LET max fonts = 8;
+LET max nr points = 4;
+LET PRINTTYPE = STRUCT (INT x steps per inch, y steps per inch,
+ ROW max nr points INT point size,
+ TEXT name, pitch table, codetable);
+ROW max fonts PRINTTYPE VAR font;
+FILE VAR font file;
+INT VAR font number := 1, point number := 1;
+TEXT VAR record := " ",
+ symb;
+INT VAR i;
+REAL CONST inch := 2.54;
+
+INT PROC x factor per inch:
+ x step
+END PROC x factor per inch;
+
+INT PROC y factor per inch:
+ lf
+END PROC y factor per inch;
+
+REAL PROC lf height of current font:
+ real(point (point number)) * inch / real (lf) (* 9.1.84 Nolting *)
+END PROC lf height of current font;
+
+INT PROC current font number:
+ font number
+END PROC current font number;
+(*******************************************************************
+********* Setzen und Liefern von Schriftsaetzen ******
+*******************************************************************)
+PROC init font:
+FOR font number FROM 1 UPTO max fonts REP;
+ lf := 1;
+ x step := 1;
+ FOR point number FROM 1 UPTO max nr points REP
+ point(point number) := 1;
+ PER;
+ kode := "";
+ name := "";
+ pitch:= "";
+ PER;
+END PROC init font;
+(******************************************************************)
+
+PROC list fonts:
+ line;
+ FOR font number FROM 1 UPTO max fonts REP
+ IF name <> "" AND name <> " "
+ THEN put typ name
+ FI;
+ line;
+ PER;
+ font number := 1; point number := 1;
+.
+put typ name:
+ put (font number); put (".");
+ put ("'"); put (name); put ("'");
+ IF length (pitch) > 1
+ THEN put ("proportional mit Blankbreite"); put (code (pitch SUB 32))
+ ELSE put ("fest mit Blankbreite"); put (code (pitch));
+ FI;
+ put ("und Zeilenhoehe"); put (point (1));
+END PROC list fonts;
+
+BOOL PROC font is in table (TEXT CONST name of font):
+ record := name of font;
+ changeall (record, " ","");
+ IF record = ""
+ THEN font number := 1; TRUE
+ ELSE search through the table
+ FI
+.
+search through the table:
+(* der Name des gewuenschten Types darf noch ein angehaengtes Attribut haben *)
+ FOR font number FROM 1 UPTO max fonts REPEAT
+ IF pos (record, name) = 1
+ THEN LEAVE search through the table WITH TRUE
+ FI;
+ PER;
+ font number := 1;
+ FALSE
+ENDPROC font is in table;
+
+PROC get font (TEXT VAR name of font,
+ TEXT VAR font pitch table, font code table,
+ BOOL VAR success):
+INT VAR lf size := 0;
+ get font (name of font, lf size,
+ font pitch table, font code table, success);
+ replace (font pitch table, 10, code(lfsize));
+END PROC get font;
+
+PROC get font (TEXT VAR name of font, INT VAR size,
+ TEXT VAR font pitch table, font code table,
+ BOOL VAR success):
+ success := font is in table (name of font);
+ name of font := name;
+ (* hiermit wird eine Ueberpruefung 'alter Typ = neuer Typ'
+ im aufrufenden Programm ermoeglicht *)
+ font code table := kode;
+ font pitch table := pitch;
+ point number := max nr points;
+ WHILE point (point number) <> size REP
+ point number DECR 1;
+ UNTIL point number = 1 PER;
+ size := point (point number);
+ IF size = point (1)
+ THEN font pitch table := pitch;
+ LEAVE get font
+ ELSE font pitch table := ""
+ FI;
+ INT VAR j := point (1);
+ FOR i FROM 1 UPTO length (pitch) REP
+ font pitch table CAT code(code (pitch SUB i) * size DIV j)
+ PER;
+
+END PROC get font;
+
+LET tag = 1 ,
+ bold = 2 ,
+ number = 3 ,
+ string = 4 , (* = text; aber PROC text wird benoetigt *)
+ operator = 5 ,
+ delimiter = 6 ,
+ end of file = 7 ,
+ within comment = 8 ,
+ within text = 9 ;
+
+PROC load font table (TEXT CONST font file name):
+BOOL VAR prop font;
+INT VAR type of symbol := 0;
+REAL VAR blank in cm ,
+ lf in cm;
+REAL VAR width, inch factor;
+INT VAR factor width;
+
+enable stop;
+IF NOT exists (font file name)
+ THEN errorstop ("Fontdatei nicht vorhanden")
+ FI;
+font file := sequential file (input, font file name);
+ init font;
+ font number := 0;
+ getline (font file, record);
+ protline (record);
+ WHILE NOT eof (font file) REP
+ font number INCR 1;
+ get font name and parameters;
+ get char width and output function;
+ UNTIL eof (font file) COR font number >= max fonts PER;
+ font number := 1; point number := 1;
+.
+get font name and parameters:
+ get font name;
+ get fixed or prop;
+ get blank width;
+ get linefeed height;
+ get pointsizes;
+ get optional x steps per inch;
+ fill pitch and code table with default;
+.
+get font name:
+ next entry; prot (symb);
+ IF (symb SUB 1) = "#"
+ THEN symb := subtext (symb, 2);
+ WHILE (symb SUB length(symb)) <> "#" REP
+ name CAT symb;
+ next entry; prot (symb);
+ IF symb = ""
+ THEN errorstop ("# fehlt beim Fontnamen");
+ FI;
+ PER;
+ name CAT subtext (symb, 1, length (symb)-1)
+ ELSE error stop ("1. Symbol kein Fontname")
+ FI;
+.
+get fixed or prop:
+ next entry;
+ prop font := (symb SUB 1) = "p" OR (symb SUB 1) = "P";
+ prot (symb);
+.
+get blank width:
+ next entry;
+ blank in cm := real (symb);
+ IF NOT last conversion ok COR blank in cm < 0.01
+ THEN errorstop ("Blankbreite falsch")
+ FI;
+ prot ("Blank=");prot (symb);
+.
+get linefeed height:
+ next entry;
+ lf in cm := real (symb);
+ IF NOT last conversion ok COR lf in cm < 0.01
+ THEN errorstop ("Linefeedhoehe falsch")
+ FI;
+ prot ("lf="); prot(symb);
+.
+get pointsizes:
+ next entry;
+ IF symb <> "("
+ THEN protline ("alle Pointgroessen = 1 per Voreinstellung") ;
+ LEAVE get pointsizes
+ FI;
+ protline(" "); prot ("lf in punkten=");
+ get one lf size;
+ lf := int (inch * real (point (1))/ lf in cm + 0.5);
+.
+get one lf size:
+ FOR i FROM 1 UPTO max nr points REP
+ next entry;
+ IF symb = ")"
+ THEN LEAVE get one lf size
+ ELIF symb = ""
+ THEN errorstop ("Pointangaben unvollstaendig")
+ FI;
+ point(i) := int (symb);
+ IF NOT last conversion ok COR point (i) < 1
+ THEN errorstop ("Pointgroesse falsch")
+ FI;
+ prot (symb); prot (",");
+ PER;
+.
+get optional x steps per inch:
+ IF symb = ")"
+ THEN next entry FI;
+ IF symb = ""
+ THEN width := 1.0
+ ELSE width := real (symb)
+ FI;
+ x step := int (inch * width / blank in cm + 0.5);
+ factor width := int (width + 0.5);
+ IF NOT last conversion ok COR x step < 1
+ THEN errorstop ("minimale Schritte falsch")
+ FI;
+ protline(" "); prot ("Schritte pro Inch="); prot (text(x step)); prot(","); prot (text(lf)); protline(" ");
+.
+fill pitch and code table with default:
+ IF prop font
+ THEN pitch := 255 * code (factor width)
+ ELSE pitch := code (factor width)
+ FI;
+ kode := 31 * ""0"";
+ kode CAT 224 * ""1""; (* print all *)
+ inch factor := real (x step)
+.
+get char width and output function:
+ WHILE NOT eof (font file) REP
+ getline (font file, record);
+ protline (record);
+ IF (record SUB 1) = "#" AND pos (record, "#", 2, length (record)) > 2
+ THEN LEAVE get char width and output function
+ FI;
+ get internal code for char;
+ IF char code > 0 AND char code <= 255
+ THEN IF prop font
+ THEN get char width;
+ prot (text(factor width));
+ replace (pitch, char code, code (factor width))
+ FI;
+ get output function
+ FI;
+ PER;
+.
+get internal code for char:
+INT VAR char code;
+ next entry; prot (symb);
+ IF length(symb) = 1
+ THEN char code := code (symb SUB 1)
+ ELIF symb >= "000" AND symb <= "255"
+ THEN char code := int (symb);
+ IF NOT last conversion ok
+ THEN errorstop ("Zeichen falsch")
+ FI
+ ELSE errorstop ("Zeichen falsch")
+ FI;
+
+.
+get char width:
+ next entry;
+ IF pos (symb, ".") > 0
+ THEN width := real (symb);
+ factor width := int (round(((width * inch factor) / inch), 0))
+ ELSE factor width := int (symb)
+ FI;
+ IF NOT last conversion ok
+ THEN errorstop ("Breitenangabe falsch")
+ FI
+.
+get output function:
+ next entry; prot (symb); protline(" ");
+ IF symb = ""
+ THEN symb := "1"
+ FI;
+ replace (kode, char code, code (int (symb)));
+ IF NOT last conversion ok
+ THEN errorstop ("Ausgabefunktion falsch")
+ FI;
+END PROC load font table;
+
+PROC next entry:
+INT VAR next blank pos;
+WHILE (record SUB 1) = " " REP
+ record := subtext (record, 2, length (record)) PER;
+next blank pos := pos (record, " ");
+IF next blank pos >= 1
+ THEN symb := subtext (record, 1, next blank pos - 1);
+ record := subtext (record, next blank pos + 1)
+ ELSE symb := record;
+ record := ""
+ FI;
+END PROC next entry;
+
+PROC prot (TEXT CONST t):
+ IF online
+ THEN put (t)
+ FI;
+END PROC prot;
+
+PROC protline (TEXT CONST t):
+ IF online
+ THEN putline (t)
+ FI;
+END PROC protline;
+
+init font; (* PACKET Initialisierung ******************************)
+.
+name: font[font number].name
+.
+pitch: font[font number].pitch table
+.
+kode: font [font number].code table
+.
+lf: font [fontnumber].y steps per inch
+.
+x step: font [font number].x steps per inch
+.
+point: font [font number].point size
+.
+END PACKET fonts routines;
diff --git a/system/std.zusatz/1.7.3/src/MINPRINT.ELA b/system/std.zusatz/1.7.3/src/MINPRINT.ELA new file mode 100644 index 0000000..a0bd44a --- /dev/null +++ b/system/std.zusatz/1.7.3/src/MINPRINT.ELA @@ -0,0 +1,94 @@ +PACKET minimal font routines DEFINES lf height of current font,
+ x factor per inch,
+ y factor per inch:
+
+REAL CONST lf height of current font :: 2.54 / 6.0;
+INT CONST x factor per inch :: 10,
+ y factor per inch :: 6;
+
+END PACKET minimal font routines;
+
+PACKET minimal printer (* 25.04.84 *)
+ DEFINES material,
+ start,
+ new page,
+ reset printer,
+ line,
+ print text ,
+ printer cmd,
+ on,
+ off,
+ x pos,
+ y pos,
+ papersize,
+ limit,
+ change type:
+
+
+PROC change type (TEXT CONST name of type): ENDPROC change type;
+
+PROC material (TEXT CONST value): END PROC material;
+
+PROC start (REAL CONST x,y): END PROC start;
+
+PROC papersize (REAL CONST x,y): END PROC papersize;
+
+PROC limit (REAL CONST l): END PROC limit;
+
+PROC on (TEXT CONST cmd): END PROC on;
+
+PROC off (TEXT CONST cmd): END PROC off;
+
+PROC xpos (REAL CONST cm): END PROC xpos;
+
+PROC ypos (REAL CONST cm): END PROC ypos;
+
+PROC printer cmd (TEXT CONST cmd):
+ out (buffer); buffer := "";
+ out(cmd)
+END PROC printer cmd;
+
+INT VAR actual line ;
+
+TEXT VAR buffer;
+
+PROC reset printer:
+ buffer := "";
+ actual line := 0
+ENDPROC reset printer;
+
+PROC print text (TEXT CONST content, INT CONST mode):
+ buffer CAT content
+ENDPROC print text;
+
+PROC new page:
+ IF buffer <> ""
+ THEN line (1.0)
+ FI;
+ actual line := actual line MOD 72 ;
+ IF actual line > 0
+ THEN page feed
+ FI .
+
+page feed :
+ INT VAR i ;
+ FOR i FROM actual line UPTO 71 REP
+ out(" "13""10"")
+ PER ;
+ actual line := 0
+
+ENDPROC new page;
+
+PROC line (REAL CONST lf):
+ out (buffer); buffer := "";
+ IF lf > 0.0
+ THEN REAL VAR ist := 0.0 ;
+ REP
+ out (""13""10"") ;
+ actual line INCR 1 ;
+ ist INCR 1.0
+ UNTIL ist >= floor (lf) PER
+ FI
+ENDPROC line;
+
+ENDPACKET minimal printer;
diff --git a/system/std.zusatz/1.7.3/src/TO16.ELA b/system/std.zusatz/1.7.3/src/TO16.ELA new file mode 100644 index 0000000..94cfc73 --- /dev/null +++ b/system/std.zusatz/1.7.3/src/TO16.ELA @@ -0,0 +1,102 @@ +PACKET to 16 DEFINES to 16 :
+
+
+LET OLDRECORD = STRUCT (INT succ, pred, x, y, TEXT line) ,
+ OLDFILE = BOUND ROW 4075 OLDRECORD ;
+
+LET free root = 1 ,
+ used root = 2 ;
+
+LET file type 16 = 1002 ;
+
+
+FILE VAR file 17 ;
+OLDFILE VAR file 16 ;
+DATASPACE VAR file space ;
+
+
+PROC to 16 :
+ to 16 (last param)
+ENDPROC to 16 ;
+
+PROC to 16 (TEXT CONST file name) :
+
+ last param (file name) ;
+ file 17 := sequential file (input, file name) ;
+ disable stop ;
+ file space := nilspace ;
+ file 16 := file space ;
+ type (file space, file type 16) ;
+ copy 17 to 16 ;
+ IF NOT is error
+ THEN replace 17 by 16 file
+ FI ;
+ forget (file space) .
+
+replace 17 by 16 file :
+ forget (file name, quiet) ;
+ copy (file space, file name) .
+
+ENDPROC to 16 ;
+
+PROC copy 17 to 16 :
+
+ enable stop ;
+ build used record chain ;
+ build free record chain .
+
+build used record chain :
+ copy all records ;
+ construct used chains head and circular links .
+
+copy all records :
+ INT VAR line ;
+ FOR line FROM 1 UPTO lines (file 17) REP
+ copy one record ;
+ cout (line)
+ PER .
+
+copy one record :
+ INT VAR index := line + 2 ;
+ TEXT VAR line 17;
+ record.pred := index - 1 ;
+ record.succ := index + 1 ;
+ getline (file 17, line 17) ;
+ change special 17 chars;
+ record.line := line 17.
+
+change special 17 chars:
+ change all (line 17, ""217"", ""225"");
+ change all (line 17, ""218"", ""239"");
+ change all (line 17, ""219"", ""245"");
+ change all (line 17, ""214"", ""193"");
+ change all (line 17, ""215"", ""207"");
+ change all (line 17, ""216"", ""213"");
+ change all (line 17, ""220"", ""235"");
+ change all (line 17, ""221"", ""173"");
+ change all (line 17, ""222"", ""163"");
+ change all (line 17, ""223"", ""160"");
+ change all (line 17, ""251"", ""194"").
+
+construct used chains head and circular links :
+ record.succ := used root ;
+ used root record.pred := index ;
+ used root record.succ := used root + 1 ;
+ used root record.line := headline (file 17) .
+
+build free record chain :
+ free root record.pred := free root ;
+ free root record.succ := free root ;
+ free root record.y := index + 1 ;
+ free root record.line := " 0 1 1" ;
+ free root record.line CAT text (maxlinelength (file 17), 5) .
+
+record : CONCR (file 16) (index) .
+
+used root record : CONCR (file 16) (used root) .
+
+free root record : CONCR (file 16) (free root) .
+
+ENDPROC copy 17 to 16 ;
+
+ENDPACKET to 16 ;
diff --git a/system/std.zusatz/1.7.3/src/complex b/system/std.zusatz/1.7.3/src/complex new file mode 100644 index 0000000..d62085b --- /dev/null +++ b/system/std.zusatz/1.7.3/src/complex @@ -0,0 +1,133 @@ +
+PACKET complex DEFINES COMPLEX,:=,complex zero,complex one,complex i,
+ complex,realpart,imagpart,CONJ,+,-,*,/,=,<>,
+ put,get, ABS, sqrt, phi, dphi :
+
+TYPE COMPLEX = STRUCT(REAL re,im);
+COMPLEX PROC complex zero: COMPLEX :(0.0,0.0). END PROC complex zero;
+COMPLEX PROC complex one : COMPLEX :(1.0,0.0). END PROC complex one;
+COMPLEX PROC complex i : COMPLEX :(0.0,1.0). END PROC complex i;
+
+OP := (COMPLEX VAR dest, COMPLEX CONST source) :
+
+ CONCR (dest) := CONCR (source)
+
+ENDOP := ;
+
+COMPLEX PROC complex(REAL CONST re,im):
+ COMPLEX :(re,im).
+END PROC complex;
+
+REAL PROC realpart(COMPLEX CONST number):
+ number.re.
+END PROC realpart;
+
+REAL PROC imagpart(COMPLEX CONST number):
+ number.im.
+END PROC imagpart ;
+
+COMPLEX OP CONJ(COMPLEX CONST number):
+ COMPLEX :( number.re,- number.im).
+END OP CONJ;
+
+BOOL OP =(COMPLEX CONST a,b):
+ IF a.re=b.re
+ THEN a.im=b.im
+ ELSE FALSE
+ FI.
+END OP =;
+
+BOOL OP <>(COMPLEX CONST a,b):
+ IF a.re=b.re
+ THEN a.im<>b.im
+ ELSE TRUE
+ FI.
+END OP <>;
+
+COMPLEX OP +(COMPLEX CONST a,b):
+ COMPLEX :(a.re+b.re,a.im+b.im).
+END OP +;
+
+COMPLEX OP -(COMPLEX CONST a,b):
+ COMPLEX :(a.re-b.re,a.im-b.im).
+END OP -;
+
+COMPLEX OP *(COMPLEX CONST a,b):
+ REAL VAR re of a::a.re,im of a ::a.im,
+ re of b::b.re,im of b ::b.im;
+ COMPLEX :(re of a*re of b- im of a *im of b,
+ re of a*im of b+ im of a*re of b).
+END OP *;
+
+COMPLEX OP /(COMPLEX CONST a,b):
+ REAL VAR re of a::a.re,im of a::a.im,
+ re of b::b.re,im of b::b.im;
+ REAL VAR sqare sum of re and im ::b.re*b.re+b.im*b.im;
+ COMPLEX :( (re of a * re of b + im of a * im of b)/sqare sum of re and im,
+ (im of a *re of b - re of a*im of b)/sqare sum of re and im).
+END OP /;
+
+PROC get(COMPLEX VAR a):
+ REAL VAR realpart,imagpart;
+ get(realpart);get(imagpart);
+ a:= COMPLEX :(realpart,imagpart);
+END PROC get;
+
+PROC put(COMPLEX CONST a):
+ put(a.re);put(" ");put(a.im);
+END PROC put;
+
+REAL PROC dphi(COMPLEX CONST x):
+ IF imagpart(x)=0.0 THEN reell
+ ELIF realpart(x)=0.0 THEN imag
+ ELIF realpart(x)>0.0 THEN realpositiv
+ ELSE realnegativ
+ FI.
+reell: IF sign(realpart(x)) < 0 THEN 180.0 ELSE 0.0 FI.
+imag: IF imagpart(x)>0.0 THEN 90.0 ELSE 270.0 FI.
+realpositiv:IF imagpart(x)>0.0 THEN arctand(realpart(x)/imagpart(x))
+ ELSE
+arctand(realpart(x)/imagpart(x))+360.0 FI.
+realnegativ: arctand(realpart(x)/imagpart(x))+180.0.
+END PROC dphi;
+
+REAL PROC phi(COMPLEX CONST x):
+dphi(x)*3.141592653689793/180.0.
+END PROC phi;
+
+REAL PROC dphi(COMPLEX CONST x):
+ IF imagpart(x)=0.0 THEN reell
+ ELIF realpart(x)=0.0 THEN imag
+ ELIF realpart(x)>0.0 THEN realpositiv
+ ELSE realnegativ
+ FI.
+reell: IF sign(realpart(x)) < 0 THEN 180.0 ELSE 0.0 FI.
+imag: IF imagpart(x)>0.0 THEN 90.0 ELSE 270.0 FI.
+realpositiv:IF imagpart(x)>0.0 THEN arctand(realpart(x)/imagpart(x))
+ ELSE
+arctand(realpart(x)/imagpart(x))+360.0 FI.
+realnegativ: arctand(realpart(x)/imagpart(x))+180.0.
+END PROC dphi;
+
+
+REAL PROC phi(COMPLEX CONST x):
+dphi(x)*3.141592653689793/180.0.
+END PROC phi;
+
+COMPLEX PROC sqrt(COMPLEX CONST x):
+IF x=complex zero THEN x
+ELIF realpart(x)<0.0 THEN
+complex(imagpart(x)/(2.0*real(sign(imagpart(x)))
+ *sqrt((ABSx-realpart(x))/2.0)),
+ real(sign(imagpart(x)))*sqrt((ABS x-realpart(x))/2.0))
+ELSE complex(sqrt((ABS x+realpart(x))/2.0),
+ imagpart(x)/(2.0*sqrt((ABS x+realpart(x))/2.0)))
+FI.
+
+END PROC sqrt;
+
+REAL OP ABS(COMPLEX CONST x):
+ sqrt(realpart(x)*realpart(x)+imagpart(x)*imagpart(x)).
+END OP ABS;
+
+END PACKET complex;
diff --git a/system/std.zusatz/1.7.3/src/crypt b/system/std.zusatz/1.7.3/src/crypt new file mode 100644 index 0000000..f6711fa --- /dev/null +++ b/system/std.zusatz/1.7.3/src/crypt @@ -0,0 +1,139 @@ +PACKET cryptograf DEFINES (* Autor: J.Liedtke *)
+ (* Stand: 01.10.80 *)
+ crypt ,
+ decrypt :
+
+TEXT VAR char , in buffer, out buffer ;
+INT VAR in pos , key index ;
+DATASPACE VAR scratch space := nilspace ;
+FILE VAR in, out;
+
+PROC crypt (TEXT CONST file, key) :
+
+ open (file) ;
+ initialize crypt (key) ;
+ WHILE NOT eof REP
+ read char ;
+ crypt char ;
+ write char
+ PER ;
+ close (file) .
+
+crypt char :
+ char := code (( character + random char + key char ) MOD 250) ;
+ IF key index = LENGTH key
+ THEN key index := 1
+ ELSE key index INCR 1
+ FI .
+
+character : code (char) .
+
+random char : random (0,250).
+
+key char : code (key SUB key index) .
+
+ENDPROC crypt ;
+
+PROC decrypt (TEXT CONST file, key) :
+
+ open (file) ;
+ initialize crypt (key) ;
+ WHILE NOT eof REP
+ read char ;
+ decrypt char ;
+ write char
+ PER ;
+ close (file) .
+
+decrypt char :
+ char := code (( character - random char - key char ) MOD 250) ;
+ IF key index = LENGTH key
+ THEN key index := 1
+ ELSE key index INCR 1
+ FI .
+
+character : code (char) .
+
+random char : random (0,250) .
+
+key char : code (key SUB key index) .
+
+ENDPROC decrypt ;
+
+PROC initialize crypt (TEXT CONST key) :
+
+ INT VAR random key := 0 ;
+ FOR key index FROM 1 UPTO LENGTH key REP
+ random key := (random key + code (key SUB key index)) MOD 32000
+ PER ;
+ initialize random (random key) ;
+ key index := 1
+
+ENDPROC initialize crypt ;
+
+PROC open (TEXT CONST source file) :
+
+ in := sequential file (input, source file) ;
+ getline (in, in buffer) ;
+ in pos := 1 ;
+ out := sequential file (output, scratch space) ;
+ out buffer := "" .
+
+ENDPROC open ;
+
+PROC close (TEXT CONST source file) :
+
+ IF out buffer <> ""
+ THEN putline (out, out buffer)
+ FI ;
+ forget (source file, quiet) ;
+ copy (scratch space, source file) ;
+ forget (scratch space) .
+
+ENDPROC close ;
+
+BOOL PROC eof :
+
+ IF in pos > LENGTH in buffer
+ THEN eof (in)
+ ELSE FALSE
+ FI
+
+ENDPROC eof ;
+
+PROC read char :
+
+ IF in pos > 250
+ THEN getline (in, in buffer) ;
+ in pos := 1 ;
+ read char
+ ELIF in pos > LENGTH in buffer
+ THEN in pos := 1 ;
+ getline (in, in buffer) ;
+ char := ""13""
+ ELSE char := in buffer SUB in pos ;
+ in pos INCR 1
+ FI .
+
+ENDPROC read char ;
+
+PROC write char :
+
+ IF char = ""13""
+ THEN putline (out, out buffer) ;
+ out buffer := ""
+ ELSE out buffer CAT char
+ FI ;
+ IF LENGTH out buffer = 250
+ THEN putline (out, out buffer) ;
+ out buffer := ""
+ FI .
+
+ENDPROC write char ;
+
+ENDPACKET cryptograf ;
+
+
+
+
+
diff --git a/system/std.zusatz/1.7.3/src/elan lister b/system/std.zusatz/1.7.3/src/elan lister new file mode 100644 index 0000000..dc34176 --- /dev/null +++ b/system/std.zusatz/1.7.3/src/elan lister @@ -0,0 +1,263 @@ +PACKET elan lister DEFINES (* Autor: J.Liedtke *)
+ (* Stand: 22.03.84 *)
+ is elan source ,
+ elan list :
+
+
+LET source lines per page = 64 ,
+ x start = 1 ,
+ y start = 2 ,
+
+ tag = 1 ,
+ bold = 2 ,
+
+ linelength = 120 ,
+ struct comment length = 32 ,
+ max name length = 25 ,
+ struct comment blanks = " " ,
+ refinement layout line = " |" ,
+ headline pre =
+ " Zeile ***** E L A N EUMEL 1.7 ***** " ;
+
+INT VAR symbol type ,
+ line nr ,
+ page nr ,
+ line at page ;
+
+BOOL VAR within defines list ;
+
+TEXT VAR record,
+ list pre ,
+ source name ,
+ source prefix ,
+ symbol,
+ ahead symbol ,
+ bottom blanks := (linelength) * " " ;
+
+
+PROC elan list (FILE VAR source) :
+
+ initialize listing ;
+ within defines list := FALSE ;
+ WHILE NOT eof (source) REP
+ list one source line ;
+ line nr INCR 1
+ PER ;
+ page bottom ;
+ start (0.0,0.0) ;
+ new page .
+
+initialize listing :
+ reset printer ;
+ construct source name and prefix ;
+ print first page head ;
+ line nr := 1 .
+
+construct source name and prefix :
+ source name := headline (source) ;
+ INT CONST slash pos := pos (source name, "/") ;
+ IF slash pos = 0
+ THEN source prefix := ""
+ ELSE source prefix := subtext (source name, slash pos+1) + "/" ;
+ source name := subtext (source name, 1, slash pos-1)
+ FI .
+
+list one source line :
+ getline (source, record) ;
+ print list pre ;
+ printline (record) ;
+ page if necessary .
+
+print list pre :
+ list pre := text (line nr, 5) ;
+ IF pos (record, "P") = 0 AND pos (record, ":") = 0
+ THEN empty layout
+ ELSE analyze source line
+ FI ;
+ list pre CAT ("|") ;
+ print text (list pre, 0) .
+
+empty layout :
+ list pre CAT struct comment blanks .
+
+analyze source line :
+ scan (record) ;
+ next symbol (symbol, symbol type) ;
+ next symbol (ahead symbol) ;
+ IF begin of packet THEN packet layout
+ ELIF within defines list THEN check end of defines part
+ ELIF begin of proc op THEN proc op layout
+ ELIF begin of refinement THEN refinement layout
+ ELSE empty layout
+ FI .
+
+begin of packet :
+ symbol = "PACKET" .
+
+begin of proc op :
+ IF is proc or op (symbol)
+ THEN TRUE
+ ELIF (symbol <> "END") AND is proc or op (ahead symbol)
+ THEN symbol := ahead symbol ;
+ next symbol (ahead symbol) ; TRUE
+ ELSE FALSE
+ FI .
+
+begin of refinement :
+ symbol type = tag AND ahead symbol = ":" AND NOT within defines list .
+
+packet layout :
+ IF not at page head
+ THEN page bottom ;
+ page head
+ FI ;
+ layout (" ", ahead symbol, "*") ;
+ within defines list := TRUE .
+
+check end of defines part :
+ empty layout ;
+ scan (record) ;
+ REP
+ nextsymbol (symbol) ;
+ IF symbol = ":"
+ THEN within defines list := FALSE
+ FI
+ UNTIL symbol = "" PER .
+
+proc op layout :
+(*printline ("") ;*)
+ printline ("") ;
+ printline ("") ;
+ IF not two free lines
+ THEN page bottom ;
+ page head
+ FI ;
+ layout (" ", ahead symbol, ".") .
+
+refinement layout :
+(*print line (refinement layout line) ;*)
+ print line (refinement layout line) ;
+ IF not two free lines THEN page bottom; page head FI;
+ layout (" ", symbol, " ") .
+
+
+print first page head :
+ page nr := 1 ;
+ page head .
+
+page if necessary :
+ IF line at page > source lines per page
+ THEN page bottom ;
+ page head
+ FI .
+
+not two free lines :
+ line at page >= source lines per page - 2 .
+
+not at page head :
+ line at page > 5 .
+
+ENDPROC elan list ;
+
+BOOL PROC is proc or op (TEXT CONST symbol) :
+
+ symbol = "PROC" OR symbol = "PROCEDURE"
+ OR symbol = "OP" OR symbol = "OPERATOR"
+
+ENDPROC is proc or op ;
+
+PROC layout (TEXT CONST pre, TEXT VAR name, TEXT CONST post) :
+
+ list pre CAT pre ;
+ name := subtext (name, 1, max name length) ;
+ list pre CAT name ;
+ list pre CAT " " ;
+ generate remaining struct comment .
+
+generate remaining struct comment :
+ INT VAR i ;
+ FOR i FROM 1 UPTO remaining struct comment length REP
+ list pre CAT post
+ PER .
+
+remaining struct comment length :
+ struct comment length - LENGTH pre - min(LENGTH name,max name length) - 1.
+
+ENDPROC layout ;
+
+PROC print line (TEXT CONST line text) :
+
+ print text (line text, 0) ;
+ line (1.0) ;
+ line at page INCR 1
+
+ENDPROC print line ;
+
+PROC printtext (TEXT CONST t, BOOL CONST b) :
+ out (t)
+ENDPROC printtext ; (*** sonst im Hardwaretreiber *********)
+
+PROC page head :
+
+ new page ;
+ print text (headline pre, 0) ;
+ print text (date, 0); (* R. Nolting 27.10.83 *)
+ print text (" ***** ",0);
+ print text (source name, 0) ;
+ line (4.0) ;
+ line at page := 1
+
+ENDPROC page head ;
+
+PROC page bottom :
+
+ WHILE line at page < source lines per page REP
+ line (1.0) ;
+ line at page INCR 1
+ PER ;
+ line (1.0) ;
+ printtext (text (source prefix + text (page nr), 8), FALSE) ;
+ printtext (bottom blanks, FALSE) ;
+ printtext (source prefix + text (page nr), FALSE) ;
+ line (1.0) ;
+ page nr INCR 1 .
+
+ENDPROC page bottom ;
+
+BOOL PROC is elan source (FILE VAR source) :
+
+ input (source) ;
+ get first symbol ;
+ symbol type = tag COR is bold begin of program COR is comment .
+
+is bold begin of program :
+ symbol type = bold CAND is elan bold .
+
+is elan bold :
+ symbol = "PACKET" COR is proc or op (symbol) COR is data declaration .
+
+is data declaration :
+ next symbol (symbol) ;
+ symbol = "VAR" OR symbol = "CONST" .
+
+is comment :
+ pos (record, "(*") > 0 OR pos (record, "{") > 0 .
+
+
+get first symbol :
+ get first non blank record ;
+ scan (record) ;
+ next symbol (symbol, symbol type) ;
+ reset (source) .
+
+get first non blank record :
+ REP
+ getline (source, record)
+ UNTIL record contains non blank OR eof (source) PER .
+
+record contains non blank :
+ pos (record, ""33"",""254"", 1) > 0 .
+
+ENDPROC is elan source ;
+
+ENDPACKET elan lister ;
diff --git a/system/std.zusatz/1.7.3/src/eumel printer b/system/std.zusatz/1.7.3/src/eumel printer new file mode 100644 index 0000000..79a4b2c --- /dev/null +++ b/system/std.zusatz/1.7.3/src/eumel printer @@ -0,0 +1,369 @@ +PACKET eumel printer DEFINES
+(***************************************************************************
+***** EUMEL - DRUCKER ** Author: A. Reichpietch **
+***** ** R. Nolting **
+***** ** Date: 30.09.81 Vers. 0 **
+***** ** 15.03.82 Vers. 1.0 **
+***** ** 22.07.82 Vers. 1.1 **
+***** ** 01.10.82 Vers. 1.2 **
+***** reelle Werte fuer limit etc. ** 15.01.83 Vers. 2.0 **
+***** direkte Druckerkommandos (Hardware) ** 15.08.83 Vers. 2.1 **
+***** ** 15.12.83 Vers. 2.2 **
+***** alle Zeilen-/Spaltenprocs entfernt ** 9.1.84 Vers. 2.3 **
+***** neue 'print text' prozedur ** 04.03.84 Vers. 2.4 **
+***************************************************************************)
+
+ print,
+ reset print,
+ print line,
+ pages printed,
+
+ is elan source , (* dummy Prozeduren , koennen von *)
+ elan list : (* 'elan lister' ueberdeckt werden *)
+
+
+LET blank = " " ,
+ backspace = ""8"" ,
+ begin mark underline = ""15"" ,
+ end mark underline = ""14"" ;
+LET paragraph end = " ";
+TEXT VAR inline := blank,
+ outline := blank,
+ type := blank,
+ command char,
+ help := blank;
+TEXT VAR command,
+ par 1, par 2,
+ skip end text;
+REAL VAR y position, y step, y max, y factor;
+INT VAR pagenr, from, to;
+INT VAR printed pages;
+BOOL VAR not skipped, lines to be skipped,
+ first text line, end of paragraph,
+ linefeed needed;
+LET std pagelength = 25.4;
+
+INT VAR print mode set := left adj, collumn print possible;
+LET left adj= 0;
+LET right adj= 1;
+LET centre adj= 2;
+LET block line= 3;
+LET left col= 4;
+LET right col= 5;
+LET centre col= 6;
+LET block col= 7;
+LET collumn print = 4;
+
+
+PROC print (FILE VAR f):
+ enable stop;
+ reset printer;
+ reset print;
+ print (f, from, to);
+END PROC print;
+
+PROC print (FILE VAR f, INT CONST first page, last page):
+ enable stop;
+ from := first page;
+ to := last page;
+ IF from > 1 THEN not skipped := FALSE FI;
+ WHILE (NOT eof(f)) AND (pagenr <= to) REP
+ getline (f, inline);
+ print input line;
+ ENDREP;
+ start(0.0, 0.0); make page;
+ENDPROC print;
+
+PROC reset print:
+ first text line := TRUE;
+ not skipped := TRUE;
+ lines to be skipped := FALSE;
+ command char := "#";
+ print mode set := left adj;
+ end of paragraph := TRUE;
+ inline := "";
+ y max := stdpagelength ;
+ y position := 10000.0;
+ y step := lf height of current font;
+ y factor := 1.0;
+ pagenr := 0;
+ from := 1; to := maxint;
+ printed pages := -1; (* move to top of first page will set to 0 *)
+ENDPROC reset print;
+
+INT PROC pages printed:
+ printed pages
+END PROC pages printed;
+
+PROC print line (TEXT CONST in):
+ inline := in;
+ print input line;
+END PROC print line;
+
+PROC print input line:
+(* debug out ("print line:"); out (in); out (""10""13""); debug *)
+INT VAR compos;
+INT VAR endpos := 0, tpos := 1;
+IF lines to be skipped
+ THEN IF pos (inline, skip end text) > 1 AND (inline SUB 1) = command char
+ THEN lines to be skipped := FALSE
+ FI;
+ LEAVE print input line
+ FI;
+ linefeed needed := FALSE;
+IF end of paragraph
+ THEN collumn print possible := collumn print
+ ELSE collumn print possible := 0
+ FI;
+compos := LENGTH inline;
+IF (inline SUB compos) = paragraph end
+ THEN end of paragraph := TRUE;
+ inline := subtext (inline, 1, compos -1)
+ ELSE end of paragraph := FALSE;
+ FI;
+ compos := pos (inline, command char);
+ IF compos <= 0
+ THEN print the line (inline);
+ new line;
+ LEAVE print input line
+ FI;
+ outline := "";
+ extract commands from input;
+ IF outline <> ""
+ THEN print the line (outline); new line
+ ELIF linefeed needed
+ THEN new line FI;
+.
+extract commands from input:
+WHILE compos > 0 REP
+ outline CAT subtext (inline, tpos, compos-1);
+ endpos := pos ( inline, command char, compos +1);
+ IF endpos <= compos
+ THEN endpos := compos - 1;
+ compos := 0
+ ELSE command := subtext ( inline, compos +1, endpos -1);
+ analyze command ( command);
+ tpos := endpos +1;
+ compos := pos(inline, command char, tpos);
+ FI;
+ PER;
+outline CAT subtext (inline, endpos + 1);
+
+ENDPROC print input line;
+
+
+TEXT VAR comlist:="ub:1.0ue:2.0type:4.1linefeed:5.1limit:6.1free:7.1page:8.01
+pagenr:9.2pagelength:10.1start:11.2foot:12.0end:13.0head:15.0headeven:16.0
+headodd:17.0bottom:19.0bottomeven:20.0bottomodd:21.0"
+LET com list 2 =
+"on:22.1off:23.1block:24.0left:25.0right:26.0centre:27.0center:28.0material:31.1papersize:32.2print:33.2";
+comlist CAT comlist 2;
+
+PROC analyze command (TEXT CONST command):
+(* debug out ("analyze command:"); out (command); out (""10""13""); debug *)
+IF pos (command, "-") = 1
+ THEN LEAVE analyze command
+ ELIF pos (command, "/") = 1
+ THEN help := subtext (command, 2);
+ print line so far;
+ printer cmd (help);
+ LEAVE analyze command
+ FI;
+INT VAR comindex := -1, number := 0;
+ par 1 := ""; par 2 := "";
+ disable stop;
+ analyze command ( com list, command, 3, comindex, number, par 1, par 2);
+ IF is error
+ THEN clear error
+ ELSE select command
+ FI;
+ enable stop;
+.
+select command :
+ SELECT comindex OF
+ CASE 1 : print line so far; on ("u");
+ CASE 2 : print line so far; off ("u");
+ CASE 4 : print line so far; set type (par 1)
+ CASE 5 : set linefeed ( par 1)
+ CASE 6 : set limit (par 1)
+ CASE 7 : print line so far; free (par 1)
+ CASE 8 : print line so far; make page
+ CASE 9 :
+ CASE 10 : set pagelength (par 1)
+ CASE 11 : set start (par 1, par 2)
+ CASE 12 : (* skip text ("end") *)
+ CASE 15,16,17 : (* skip text ("end") *)
+ CASE 19,20,21 : (* skip text ("end") *)
+ CASE 22 : print line so far; on (par1)
+ CASE 23 : print line so far; off (par1)
+ CASE 24 : print line so far; print mode set := block line;
+ CASE 25 : print line so far; print mode set := left adj;
+ CASE 26 : print line so far; print mode set := right adj
+ CASE 27 : print line so far; print mode set := centre adj
+ CASE 28 : comindex := print mode set MOD 4;
+ IF comindex = block line
+ THEN inline CAT "#block#"
+ ELIF comindex = left adj
+ THEN inline CAT "#left#"
+ ELIF comindex = right adj
+ THEN inline CAT "#right#"
+ FI;
+ print mode set := centre adj;
+(* the following commands must appear before any text *)
+ CASE 31 : IF first text line THEN material (par1) FI
+ CASE 32 : IF first text line THEN do papersize (par1, par2) FI
+ CASE 33 : IF first text line THEN print from page till page (par1, par2) FI
+ OTHERWISE
+ END SELECT ;
+.
+print line so far:
+ IF outline <> ""
+ THEN print the line (outline);
+ outline := "";
+ linefeed needed := TRUE
+ FI;
+
+ENDPROC analyze command;
+
+PROC do papersize (TEXT CONST s, t):
+REAL VAR w, l;
+ IF ok (par1, w) AND ok (par2, l)
+ THEN papersize (w, l)
+ FI;
+END PROC do papersize;
+
+PROC print from page till page(TEXT VAR s, t):
+INT VAR i, j;
+ IF ok (par1, i) AND ok (par2, j)
+ THEN from := i;
+ to := j;
+ FI;
+END PROC print from page till page;
+
+PROC set type (TEXT CONST new type):
+ change type (new type);
+ y step := lf height of current font;
+ENDPROC set type;
+
+PROC make page :
+ IF y position > 0.0 CAND NOT first text line
+ THEN y position := y max + 1.0; new line
+ FI;
+ end of paragraph := TRUE;
+ inline := ""; (* this stops further processing of the input line *)
+ENDPROC make page;
+
+PROC skip text (TEXT CONST endword):
+ lines to be skipped := TRUE;
+ skip end text := endword;
+ inline := ""; (* possible rest of the line is not examined *)
+END PROC skip text;
+
+PROC set linefeed ( TEXT CONST lf):
+REAL VAR l:= real (lf);
+ IF last conversion ok THEN y factor := l FI;
+ENDPROC set linefeed;
+
+PROC set limit ( TEXT CONST l):
+ REAL VAR len;
+ IF ok (l, len)
+ THEN limit (len)
+ FI;
+ENDPROC set limit;
+
+BOOL PROC ok ( TEXT CONST param, INT VAR number):
+ number := int (param) ;
+ last conversion ok
+ENDPROC ok;
+
+BOOL PROC ok ( TEXT CONST param, REAL VAR number):
+ number := real (param) ;
+ last conversion ok
+ENDPROC ok;
+
+PROC set pagelength (TEXT CONST y):
+REAL VAR iy ;
+ IF ok (y, iy )
+ THEN y max := iy;
+FI;
+ENDPROC set pagelength;
+
+PROC set start (TEXT CONST x, y):
+REAL VAR rx, ry;
+ IF ok (x, rx) AND ok (y, ry)
+ THEN start (rx, ry)
+ FI;
+ENDPROC set start;
+
+PROC free (TEXT CONST p):
+REAL VAR x, y := y factor;
+ IF ok (p, x)
+ THEN advance
+ FI;
+y factor := y;
+end of paragraph := TRUE;
+ inline := ""; (* this stops further processing of the input line *)
+.
+advance:
+ y factor := x / y step;
+ IF outline <> ""
+ THEN print the line (outline);
+ outline := ""
+ FI;
+ IF first text line
+ THEN new line FI;
+new line;
+END PROC free;
+
+PROC print the line ( TEXT CONST in):
+(* debug out ("print the line:"); out (in); out (print mode set);
+out (""10""13""); debug *)
+IF first text line
+ THEN first text line := FALSE; new line FI;
+IF not skipped
+ THEN IF print mode set = blockline
+ THEN IF end of paragraph
+ THEN print text (in, left adj + collumn print possible)
+ ELSE print text (in, blockline + collumn print possible)
+ FI
+ ELSE print text (in, print mode set + collumn print possible)
+ FI
+ FI;
+ENDPROC print the line;
+
+PROC new line:
+(* debug out ("new line: lf="); out (text(yfactor)); out (""10""13""); debug *)
+IF page is full
+ THEN pagenr INCR 1;
+ IF not skipped
+ THEN printed pages INCR 1;
+ new page
+ FI;
+ check printmodes;
+ y position := 0.0
+ ELSE IF not skipped
+ THEN line (y factor)
+ FI;
+ y position INCR yfactor * y step
+ FI;
+ENDPROC new line;
+
+PROC check printmodes:
+ not skipped := ( pagenr >= from) AND ( pagenr <= to);
+ENDPROC check printmodes;
+
+BOOL PROC page is full:
+ y position + yfactor * y step > y max
+ENDPROC page is full;
+
+(********** dummys ************)
+
+BOOL PROC is elan source (FILE VAR source) :
+ FALSE
+ENDPROC is elan source ;
+
+PROC elan list (FILE VAR source) :
+ print (source)
+ENDPROC elan list ;
+
+ENDPACKET eumel printer;
diff --git a/system/std.zusatz/1.7.3/src/eumelmeter b/system/std.zusatz/1.7.3/src/eumelmeter new file mode 100644 index 0000000..24f5833 --- /dev/null +++ b/system/std.zusatz/1.7.3/src/eumelmeter @@ -0,0 +1,130 @@ + (* Author: J.Liedtke*)
+PACKET eumelmeter DEFINES (* Stand: 11.10.83 *)
+
+ init log ,
+ log :
+
+
+LET snapshot interval = 590.0 ;
+
+REAL VAR next snapshot time ,
+ time , timex ,
+ paging wait , paging wait x ,
+ paging busy , paging busy x ,
+ fore cpu , fore cpu x ,
+ back cpu , back cpu x ,
+ system cpu , system cpu x ,
+ delta t ;
+INT VAR storage max, used ;
+TEXT VAR record ;
+
+PROC init log :
+
+ time := clock (1) ;
+ paging wait := clock (2) ;
+ paging busy := clock (3) ;
+ fore cpu := clock (4) ;
+ back cpu := clock (5) ;
+ system cpu := clock (6) ;
+ next snapshot time := time + snapshot interval
+
+ENDPROC init log ;
+
+PROC log (INT CONST active terminals, active background) :
+
+ new snapshot time if was clock reset ;
+ IF clock (1) >= next snapshot time
+ THEN save values ;
+ get new values ;
+ create stat record ;
+ put log (record) ;
+ define next snapshot time
+ FI .
+
+new snapshot time if was clock reset :
+ IF clock (1) < next snapshot time - snapshot interval
+ THEN next snapshot time := clock (1)
+ FI .
+
+save values :
+ time x := time ;
+ paging wait x := paging wait ;
+ paging busy x := paging busy ;
+ fore cpu x := fore cpu ;
+ back cpu x := back cpu ;
+ system cpu x := system cpu .
+
+get new values :
+ time := clock (1) ;
+ paging wait := clock (2) ;
+ paging busy := clock (3) ;
+ fore cpu := clock (4) ;
+ back cpu := clock (5) ;
+ system cpu := clock (6) ;
+ storage (storage max, used) .
+
+create stat record :
+ record := text (used, 5) ;
+ record CAT text (active terminals,3) ;
+ record CAT text (active background,3) ;
+ delta t := (time - time x) ;
+ percent (paging wait, paging wait x) ;
+ percent (paging busy, paging busy x) ;
+ percent (fore cpu, fore cpu x) ;
+ percent (back cpu, back cpu x) ;
+ percent (system cpu, system cpu x) ;
+ percent (last, 0.0) ;
+ percent (nutz, 0.0) .
+
+last : paging wait + paging busy + fore cpu + back cpu + system cpu
+ - paging waitx - paging busyx - fore cpux - back cpux - system cpux .
+
+nutz : time - paging wait - system cpu
+ - timex + paging waitx + system cpux .
+
+define next snapshot time :
+ next snapshot time := time + snapshot interval .
+
+ENDPROC log ;
+
+PROC percent (REAL CONST neu, alt ) :
+
+ record CAT text ( (neu-alt) / delta t * 100.0, 6,1) + "%"
+
+ENDPROC percent ;
+
+ENDPACKET eumelmeter ;
+
+INT VAR active terminals , active background ;
+
+task password ("-") ;
+break ;
+command dialogue (FALSE) ;
+forget ("eumelmeter") ;
+init log ;
+REP
+ pause (6000) ;
+ count active processes (active terminals, active background) ;
+ log (active terminals, active background)
+PER ;
+
+PROC count active processes (INT VAR active terminals, active background) :
+
+ active terminals := 0 ;
+ active background := 0 ;
+ TASK VAR process := myself ;
+ REP
+ next active (process) ;
+ IF user process
+ THEN IF process at terminal
+ THEN active terminals INCR 1
+ ELSE active background INCR 1
+ FI
+ FI
+ UNTIL process = myself PER .
+
+user process : NOT (process < supervisor) .
+
+process at terminal : channel (process) >= 0 .
+
+ENDPROC count active processes ;
diff --git a/system/std.zusatz/1.7.3/src/free channel b/system/std.zusatz/1.7.3/src/free channel new file mode 100644 index 0000000..89f7ce0 --- /dev/null +++ b/system/std.zusatz/1.7.3/src/free channel @@ -0,0 +1,292 @@ +PACKET free channel DEFINES (* Autor: J.Liedtke *)
+ (* Stand: 05.10.82 *)
+ FCHANNEL ,
+ := ,
+ free channel ,
+ open ,
+ close ,
+ out ,
+ in ,
+ dialogue :
+
+
+
+LET ack = 0 ,
+ nak = 1 ,
+ break code = 6 ,
+ empty message code = 256 ,
+ long message code = 257 ,
+ file message code = 1024 ,
+ open code = 1000 ,
+ close code = 1001 ,
+
+ cr = ""13"" ;
+
+INT CONST task not existing := - 1 ;
+
+
+TYPE FCHANNEL = STRUCT (TASK server, TEXT input buffer, server name) ;
+
+INT VAR message code , response code ;
+TASK VAR partner , used by ;
+DATASPACE VAR ds ;
+
+BOUND TEXT VAR msg ;
+TEXT VAR response, char, esc char , record ;
+
+FILE VAR file ;
+
+
+OP := (FCHANNEL VAR dest, FCHANNEL CONST source) :
+
+ dest.server := source.server ;
+ dest.input buffer := "" ;
+ dest.server name := source.server name ;
+ open (dest)
+
+ENDOP := ;
+
+FCHANNEL PROC free channel (TEXT CONST channel name) :
+
+ FCHANNEL:(niltask,"", channel name)
+
+ENDPROC free channel ;
+
+PROC open (FCHANNEL VAR channel) :
+
+ TASK VAR task id ;
+ INT VAR receipt ;
+
+ initialize message dataspace ;
+ send open code ;
+ IF receipt <> ack
+ THEN errorstop ("channel not free")
+ FI .
+
+initialize message dataspace :
+ forget (ds) ;
+ ds := nilspace .
+
+send open code :
+ ping pong (channel.server, open code, ds, receipt) ;
+ IF receipt = task not existing
+ THEN channel.server := task (channel.server name) ;
+ ping pong (channel.server, open code, ds, receipt)
+ FI .
+
+ENDPROC open ;
+
+PROC close (FCHANNEL VAR channel) :
+
+ call (channel.server, close code, ds, response code)
+
+ENDPROC close ;
+
+PROC close (TEXT CONST channel server) :
+
+ call (task (channel server), close code, ds, response code)
+
+ENDPROC close ;
+
+
+PROC out (FCHANNEL VAR channel, TEXT CONST message) :
+
+ send message ;
+ get response .
+
+send message :
+ IF message = ""
+ THEN call (channel.server, empty message code, ds, response code)
+ ELSE msg := ds ;
+ CONCR (msg) := message ;
+ call (channel.server, long message code, ds, response code)
+ FI .
+
+get response :
+ IF response code < 0
+ THEN errorstop ("channel not ready")
+ ELIF response code < 256
+ THEN channel.input buffer CAT code (response code)
+ ELIF response code = long message code
+ THEN msg := ds ;
+ channel.input buffer CAT CONCR (msg)
+ FI .
+
+ENDPROC out ;
+
+PROC in (FCHANNEL VAR channel, TEXT VAR response) :
+
+ out (channel, "") ;
+ response := channel.input buffer ;
+ channel.input buffer := ""
+
+ENDPROC in ;
+
+PROC out (FCHANNEL VAR channel, DATASPACE CONST file space) :
+
+ out (channel, file space, ""0"")
+
+ENDPROC out ;
+
+PROC out (FCHANNEL VAR channel, DATASPACE CONST file space,
+ TEXT CONST handshake char) :
+
+ forget (ds) ;
+ ds := file space ;
+ call (channel.server, file message code + code (handshake char) ,
+ ds, response code) ;
+ forget (ds) ;
+ ds := nilspace
+
+ENDPROC out ;
+
+
+PROC dialogue (FCHANNEL CONST channel, TEXT CONST esc) :
+
+ forget (ds) ;
+ ds := nilspace ;
+ partner := channel.server ;
+ esc char := esc ;
+ enable stop ;
+
+ response code := empty message code ;
+ REP
+ get and send message charety ;
+ out response option
+ PER .
+
+get and send message charety :
+ IF response code = empty message code
+ THEN char := incharety (10)
+ ELSE char := incharety
+ FI ;
+ IF char = ""
+ THEN call (partner, empty message code, ds, response code)
+ ELIF char = esc char
+ THEN LEAVE dialogue
+ ELSE call (partner, code (char), ds, response code)
+ FI .
+
+out response option :
+ IF response code < 256
+ THEN out (code (response code))
+ ELIF response code = long message code
+ THEN msg := ds ;
+ out (CONCR (msg))
+ FI .
+
+ENDPROC dialogue ;
+
+PROC free channel (INT CONST nr) :
+
+ INT CONST my channel := nr ;
+ break ;
+ disable stop ;
+ REP
+ wait (ds, message code, partner) ;
+ IF message code = open code
+ THEN connect to my channel ;
+ use channel ;
+ break without advertise ;
+ send handshake ack
+ ELSE send (partner, nak, ds)
+ FI
+ PER .
+
+use channel :
+ ping pong (partner, ack, ds, message code) ;
+ REP
+ execute message ;
+ response option
+ PER .
+
+execute message :
+ IF message code < 0
+ THEN LEAVE use channel
+ ELIF message code < 256
+ THEN out (code (message code))
+ ELIF message code = long message code
+ THEN msg := ds ;
+ out (CONCR (msg))
+ ELIF message code >= file message code
+ THEN send file ;
+ clear error
+ ELIF message code = close code
+ THEN LEAVE use channel
+ FI .
+
+response option :
+ response := incharety (1) ;
+ IF response = ""
+ THEN ping pong (partner, empty message code, ds, message code)
+ ELSE short or long response
+ FI .
+
+short or long response :
+ char := incharety ;
+ IF char = ""
+ THEN short response
+ ELSE long response
+ FI .
+
+short response :
+ ping pong (partner, code (response), ds, message code) .
+
+long response :
+ msg := ds ;
+ response CAT char ;
+ REP
+ char := incharety ;
+ response CAT char
+ UNTIL char = "" PER ;
+ CONCR (msg) := response ;
+ ping pong (partner, long message code, ds, message code) .
+
+connect to my channel :
+ continue (my channel) ;
+ WHILE is error REP
+ clear error ;
+ pause (100) ;
+ continue (my channel)
+ PER .
+
+break without advertise :
+ INT VAR receipt ;
+ call (supervisor, break code, ds, receipt) .
+
+send handshake ack :
+ send (partner, ack, ds) .
+
+ENDPROC free channel ;
+
+PROC send file :
+
+ enable stop ;
+ get handshake ;
+ file := sequential file (input,ds) ;
+ REP
+ getline (file, record) ;
+ out (record) ;
+ out (cr) ;
+ handshake option
+ UNTIL eof (file) PER .
+
+get handshake :
+ TEXT CONST handshake char := code (message code - file message code) .
+
+handshake option :
+ IF handshake char <> ""0""
+ THEN wait for handshake or time out
+ FI .
+
+wait for handshake or time out :
+ REP
+ char := incharety (300)
+ UNTIL char = handshake char OR char = "" PER ;
+ IF char = ""
+ THEN LEAVE send file
+ FI .
+
+ENDPROC send file ;
+
+ENDPACKET free channel ;
diff --git a/system/std.zusatz/1.7.3/src/longint b/system/std.zusatz/1.7.3/src/longint new file mode 100644 index 0000000..ac3dad5 --- /dev/null +++ b/system/std.zusatz/1.7.3/src/longint @@ -0,0 +1,422 @@ +PACKET longint DEFINES LONGINT, (* Autoren: S.Baumann,A.Bentrup *)
+ :=, (* T.Sillke *)
+ <, (* Stand: 17.03.81 *)
+ >,
+ <=,
+ >=,
+ <>,
+ =,
+ -,
+ +,
+ *,
+ **,
+ ABS,
+ abs,
+ DECR,
+ DIV,
+ get,
+ INCR,
+ int,
+ (*last rest,*)
+ longint,
+ max,
+ max longint,
+ min,
+ MOD,
+ put,
+ random,
+ SIGN,
+ sign,
+ text,
+ zero:
+
+TYPE LONGINT = TEXT;
+
+LONGINT VAR result,aleft,aright;
+TEXT VAR ergebnis,x,y,z,h;
+INT VAR v byte,slr,sll;
+INT CONST snull :: code("0"), mtl :: 300 ;
+TEXT CONST negativ :: code(127),max digit :: code(99),null :: code(0),
+ overflow :: "LONGINT overflow",eins :: code(1);
+BOOL VAR vorl,vorr,vleft,vright;
+
+OP := (LONGINT VAR left, LONGINT CONST right) :
+ CONCR(left) := CONCR(right)
+END OP :=;
+
+BOOL OP < (LONGINT CONST left,right) :
+ slr := sign(right)*length(right);
+ sll := sign(left )*length(left );
+ IF slr <> sll THEN
+ IF slr > sll THEN TRUE ELSE FALSE FI
+ ELSE IF slr>0
+ THEN CONCR(left) < CONCR(right)
+ ELSE CONCR(left) > CONCR(right) FI
+ FI
+END OP < ;
+
+BOOL OP > (LONGINT CONST left,right) :
+ slr := sign(right)*length(right);
+ sll := sign(left )*length(left );
+ IF slr <> sll THEN
+ IF slr < sll THEN TRUE ELSE FALSE FI
+ ELSE IF slr>0
+ THEN CONCR(left) > CONCR(right)
+ ELSE CONCR(left) < CONCR(right) FI
+ FI
+END OP > ;
+
+BOOL OP <= (LONGINT CONST left,right) :
+ NOT (left > right)
+END OP <=;
+
+BOOL OP >= (LONGINT CONST left,right) :
+ NOT (left < right)
+END OP >=;
+
+BOOL OP <> (LONGINT CONST left,right) :
+ CONCR (left) <> CONCR (right)
+END OP <>;
+
+BOOL OP = (LONGINT CONST left,right) :
+ CONCR (left) = CONCR (right)
+END OP = ;
+
+LONGINT OP - (LONGINT CONST arg) :
+ SELECT code(CONCR(arg)SUB1) OF
+ CASE 0 : zero
+ CASE 127: LONGINT : (subtext(CONCR(arg),2))
+ OTHERWISE LONGINT : (negativ + CONCR(arg))
+ END SELECT
+END OP -;
+
+LONGINT OP + (LONGINT CONST arg) : arg END OP +;
+
+LONGINT OP - (LONGINT CONST left,right) :
+ IF CONCR(left ) = null THEN LEAVE - WITH -right
+ ELIF CONCR(right) = null THEN LEAVE - WITH left
+ ELIF sign(left) <> sign(right) THEN LEAVE - WITH left + (-right) FI;
+ betrag(left,right);
+ BOOL CONST betrag max :: aleft > aright;
+ IF betrag max
+ THEN result := LONGINT : (CONCR(aleft ) SUB CONCR(aright))
+ ELSE result := LONGINT : (CONCR(aright) SUB CONCR(aleft )) FI;
+ kuerze fuehrende nullen(CONCR(result),null);
+ IF vleft XOR betrag max THEN -result ELSE result FI
+END OP -;
+
+LONGINT OP + (LONGINT CONST left,right) :
+ IF sign(left) <> sign(right) THEN LEAVE + WITH left - (-right) FI;
+ betrag(left,right);
+ IF aleft > aright
+ THEN result := LONGINT : (CONCR(aleft ) ADD CONCR(aright))
+ ELSE result := LONGINT : (CONCR(aright) ADD CONCR(aleft )) FI;
+ IF vleft THEN result ELSE -result FI
+END OP +;
+
+LONGINT OP * (LONGINT CONST left,right) :
+ IF CONCR(left) = null OR CONCR(right) = null THEN LEAVE * WITH zero
+ ELIF length(left) + length(right) > mtl THEN errorstop (overflow) FI;
+ betrag(left,right);
+ IF aleft < aright
+ THEN result := LONGINT : (CONCR(aright) MUL CONCR(aleft ))
+ ELSE result := LONGINT : (CONCR(aleft ) MUL CONCR(aright)) FI;
+ IF length(CONCR(result)) = mtl THEN errorstop(overflow) FI;
+ IF vleft XOR vright THEN -result ELSE result FI
+END OP *;
+
+LONGINT OP ** (LONGINT CONST arg,exp) :
+ IF exp > longint(max int) THEN errorstop (overflow) FI;
+ arg ** int(exp)
+END OP **;
+
+LONGINT OP ** (LONGINT CONST arg,INT CONST exp) :
+ IF exp < 0 THEN errorstop ("LONGINT OP ** : negativ exp")
+ ELIF CONCR(arg)=null AND exp=0 THEN errorstop(text(0 ** 0)) FI;
+ IF exp = 0 THEN one
+ ELIF exp = 1 THEN arg
+ ELIF sign(arg) = -1 AND exp MOD 2 <> 0
+ THEN -LONGINT:(CONCR(abs(arg))EXPexp)
+ ELSE LONGINT:(CONCR(abs(arg))EXPexp) FI
+END OP **;
+
+LONGINT OP ABS (LONGINT CONST arg) : abs(arg) END OP ABS;
+
+LONGINT PROC abs (LONGINT CONST a) :
+ IF (CONCR(a)SUB1)=negativ THEN LONGINT:(subtext(CONCR(a),2)) ELSE a FI
+END PROC abs;
+
+OP DECR (LONGINT VAR result,LONGINT CONST ab) :
+ result := result - ab;
+END OP DECR;
+
+LONGINT OP DIV (LONGINT CONST left,right) :
+ IF CONCR(right) = null THEN error stop("LONGINT OP DIV by zero") FI;
+ betrag(left,right); h := CONCR(aright);
+ y := null + CONCR(aleft ); vorl := vleft;
+ z := null + CONCR(aright); vorr := vright;
+ IF aleft < aright THEN y:=CONCR(aleft); LEAVE DIV WITH zero FI;
+ INT VAR try,i,cr1 :: code(z SUB 2),cr2,cr3,zw;
+ BOOL VAR sh :: length(z) <> 2;
+ IF sh THEN cr3:=code(zSUB3); cr2:=10*cr1+cr3DIV10; cr3:=100*cr1+cr3 FI;
+ CONCR(result) := "";
+ FOR i FROM 0 UPTO length(y)-length(z) REP
+ laufe eine abschaetzung durch;
+ CONCR (result) CAT code(try)
+ PER; kuerze fuehrende nullen(y,null);
+ IF(CONCR(result)SUB1)=nullTHEN CONCR(result):=subtext(CONCR(result),2)FI;
+ IF vleft XOR vright THEN -result ELSE result FI.
+
+ laufe eine abschaetzung durch :
+ zw := 100*code(y SUB i+1) + code(y SUB i+2);
+ IF zw < 3276 AND sh THEN IF zw < 327
+ THEN try := min((100*zw + code(ySUBi+3)) DIV cr3, 99)
+ ELSE try := min(( 10*zw + code(ySUBi+3)DIV10)DIV cr2, 99) FI
+ ELSE try := min( zw DIV cr1, 99) FI;
+ x := z MUL code(try);
+ WHILE x > subtext(y,i+1,i+length(x)) REP
+ try DECR 1; x := x SUB z PER;
+ replace(y,i + 1,subtext(y,i + 1,i + length(x)) SUB x)
+END OP DIV;
+
+PROC get (LONGINT VAR result) :
+ get (ergebnis);
+ result := longint(ergebnis);
+END PROC get;
+
+PROC get (FILE VAR file,LONGINT VAR result) :
+ get(file,ergebnis);
+ result := longint(ergebnis);
+END PROC get;
+
+OP INCR (LONGINT VAR result,LONGINT CONST dazu) :
+ result := result + dazu;
+END OP INCR;
+
+INT PROC int (LONGINT CONST longint) :
+ IF length(longint) > 3
+ THEN max int + 1
+ ELSE ergebnis := (3-length(longint))*null + CONCR(abs(longint));
+ (code(ergebnis SUB 1) * 10000 +
+ code(ergebnis SUB 2) * 100 +
+ code(ergebnis SUB 3)) * sign(longint)
+ FI
+END PROC int;
+
+LONGINT PROC longint (INT CONST int) :
+ CONCR(result) := code( abs(int) DIV 10000) +
+ code((abs(int) MOD 10000) DIV 100) +
+ code( abs(int) MOD 100);
+ kuerze fuehrende nullen (CONCR(result),null);
+ IF int < 1 THEN -result ELSE result FI
+END PROC longint;
+
+LONGINT PROC longint (TEXT CONST text) :
+ INT VAR i;
+ ergebnis := compress(text);
+ BOOL VAR minus :: (ergebnisSUB1) = "-";
+ IF (ergebnisSUB1)="+" OR minus THEN ergebnis:=subtext(ergebnis,2) FI;
+ kuerze fuehrende nullen(ergebnis,"0");
+ kuerze die unzulaessigen zeichen aus ergebnis;
+ schreibe ergebnis im hundertersystem in result;
+ result mit vorzeichen.
+
+ kuerze die unzulaessigen zeichen aus ergebnis :
+ ergebnis := subtext(ergebnis,1,letztes zulaessiges zeichen).
+ letztes zulaessiges zeichen :
+ FOR i FROM 1 UPTO length(ergebnis) REP
+ UNTIL pos("0123456789", ergebnis SUB i) = 0 PER;
+ i - 1.
+ schreibe ergebnis im hundertersystem in result :
+ sll := length(ergebnis);
+ IF sll MOD 2 <> 0 THEN ergebnis := "0"+ergebnis; sll INCR 1 FI;
+ i := 1; CONCR(result) := "";
+ REP schreibe ein zeichen im hundertersystem in result;
+ i INCR 2
+ UNTIL i >= sll PER.
+ schreibe ein zeichen im hundertersystem in result :
+ CONCR(result) CAT code((code(ergebnis SUB i ) - snull) * 10 +
+ code(ergebnis SUB i + 1) - snull).
+ result mit vorzeichen :
+ IF ergebnis="" THEN zero ELIF minus THEN -result ELSE result FI
+END PROC longint;
+
+LONGINT PROC max (LONGINT CONST left,right) :
+ IF left > right THEN left ELSE right FI
+END PROC max;
+
+LONGINT PROC max longint :
+ LONGINT : ((mtl - 1) * max digit)
+END PROC max longint;
+
+LONGINT PROC min (LONGINT CONST left,right) :
+ IF left < right THEN left ELSE right FI
+END PROC min;
+
+LONGINT OP MOD (LONGINT CONST left,right) :
+ IF CONCR(right) = null THEN errorstop("LONGINT OP MOD by zero") FI;
+ result := left DIV right; last rest
+END OP MOD;
+
+PROC put (LONGINT CONST longint) :
+ INT VAR i :: 1,zwei ziffern;
+ IF sign(longint) = -1 THEN out("-"); i:=2 FI;
+ out(text(code(CONCR(longint) SUB i)));
+ FOR i FROM i + 1 UPTO length(CONCR(longint)) REP
+ zwei ziffern := code(CONCR(longint) SUB i);
+ out(code(zwei ziffern DIV 10 + snull));
+ out(code(zwei ziffern MOD 10 + snull));
+ PER;out(" ")
+END PROC put;
+
+PROC put (FILE VAR file,LONGINT CONST longint) :
+ put(file,text(longint));
+END PROC put;
+
+LONGINT PROC random (LONGINT CONST lower bound,upper bound) :
+ INT VAR i; x := CONCR(upper bound - lower bound - one); y := "";
+ FOR i FROM 1 UPTO length(x) REP y CAT code(random(0,99)) PER;
+ upper bound - (LONGINT : (y) MOD LONGINT : (x))
+END PROC random;
+
+INT OP SIGN (LONGINT CONST arg) : sign(arg) END OP SIGN;
+
+INT PROC sign (LONGINT CONST arg) :
+ SELECT code(CONCR(arg) SUB 1) OF
+ CASE 0 : 0
+ CASE 127 : -1
+ OTHERWISE 1
+ END SELECT
+END PROC sign;
+
+TEXT PROC text (LONGINT CONST longint) :
+ INT VAR i::1,zwei ziffern; ergebnis := "";
+ IF sign(longint) = -1 THEN ergebnis := "-"; i:=2 FI;
+ ergebnis CAT text (code (CONCR (longint) SUB i ) ) ;
+ FOR i FROM i+1 UPTO length(CONCR(longint)) REP
+ zwei ziffern := code(CONCR(longint) SUB i);
+ ergebnis CAT code(zwei ziffern DIV 10 + snull);
+ ergebnis CAT code(zwei ziffern MOD 10 + snull)
+ PER; ergebnis
+END PROC text;
+
+TEXT PROC text (LONGINT CONST longint,INT CONST length) :
+ x := text(longint); sll := LENGTH x;
+ IF sll > length THEN length * "*" ELSE (length - sll)*" " + x FI
+END PROC text;
+
+LONGINT PROC last rest :
+ IF y=null THEN LEAVE last rest WITH zero FI;
+ IF vorl XOR vorr THEN y := h SUB y; kuerze fuehrende nullen(y,null);
+ vorl := TRUE FI;
+ IF NOTvorr THEN y:=negativ+y; vorr := TRUE FI; LONGINT:(y)
+END PROC last rest;
+
+LONGINT PROC zero : LONGINT : (null) END PROC zero;
+LONGINT PROC one : LONGINT : (""1"") END PROC one;
+
+
+(* ----------------------- INTERNE HILFSPROZEDUREN ----------------------- *)
+
+TEXT OP ADD (TEXT CONST left,right) :
+ INT VAR carrybit :: 0,i,dif :: length(left) - length(right);
+ ergebnis := left;
+ FOR i FROM length(left) DOWNTO dif + 1 REP
+ replace(ergebnis,i,das result der addition)
+ PER;
+ IF carrybit = 1 THEN addiere den uebertrag FI;
+ ergebnis.
+
+ das result der addition :
+ v byte := (code(left SUB i) + code(right SUB i - dif) + carrybit);
+ IF v byte > 99
+ THEN carrybit := 1; code(v byte - 100)
+ ELSE carrybit := 0; code(v byte)
+ FI.
+ addiere den uebertrag :
+ FOR i FROM i DOWNTO 1
+ WHILE (ergebnis SUB i) >= max digit REP
+ replace(ergebnis,i,null)
+ PER;
+ IF (ergebnis SUB 1) = null OR dif = 0
+ THEN pruefe auf longint overflow
+ ELSE replace(ergebnis,i,code(code(ergebnis SUB i) + 1))
+ FI.
+ pruefe auf longint overflow :
+ IF length(ergebnis) = mtl - 1 THEN errorstop(overflow) FI;
+ ergebnis := eins + ergebnis
+END OP ADD;
+
+PROC betrag (LONGINT CONST a, b) :
+ vleft := (CONCR(a)SUB1)<>negativ; vright := (CONCR(b)SUB1)<>negativ;
+ IF vleft THEN aleft :=a ELSE CONCR(aleft ):=subtext(CONCR(a),2) FI;
+ IF vright THEN aright:=b ELSE CONCR(aright):=subtext(CONCR(b),2) FI
+END PROC betrag;
+
+TEXT OP EXP (TEXT CONST arg,INT CONST exp) :
+ INT VAR zaehler :: exp;
+ x := arg; z := eins;
+ REP IF zaehler MOD 2 = 1 THEN z := z MUL x FI;
+ zaehler := zaehler DIV 2; x := x MUL x
+ UNTIL zaehler = 1 PER;
+ x MUL z
+END OP EXP;
+
+PROC kuerze fuehrende nullen ( TEXT VAR text,TEXT CONST snull) :
+ INT VAR i;
+ text := subtext(text,erste nicht snull).
+
+ erste nicht snull :
+ FOR i FROM 1 UPTO length (text) - 1 REP
+ UNTIL (text SUB i) <> snull PER;
+ i
+END PROC kuerze fuehrende nullen;
+
+INT PROC length (LONGINT CONST a) :
+ IF (CONCR(a)SUB1)=negativ THEN length(CONCR(a))-1 ELSE length(CONCR(a)) FI
+END PROC length;
+
+TEXT OP MUL (TEXT CONST left,right) :
+ INT VAR i,j,carrybit,v,w;
+ ergebnis := (length(left) + length(right) - 1) * null;
+ FOR i FROM length(ergebnis) DOWNTO length(left) REP
+ v := i - length(left); w := length(right) - length(ergebnis) + i;
+ carrybit := 0;
+ FOR j FROM length(left) DOWNTO 1 REP
+ replace(ergebnis,v + j,result der addition)
+ PER;
+ replace(ergebnis,v,code(code(ergebnis SUB v) + carrybit));
+ PER;
+ IF carrybit = 0 THEN ergebnis ELSE code(carrybit) + ergebnis FI.
+
+ result der addition :
+ v byte := code(right SUB w) * code(left SUB j) + carrybit +
+ code(ergebnis SUB v + j);
+ carrybit := v byte DIV 100;
+ code(v byte MOD 100)
+END OP MUL;
+
+TEXT OP SUB (TEXT CONST left,right) :
+ INT VAR carrybit :: 0,i,dif :: length(left) - length(right);
+ ergebnis := left;
+ FOR i FROM length(left) DOWNTO dif + 1 REP
+ replace(ergebnis,i,das result der subtraktion);
+ PER;
+ IF carrybit = 1 THEN subtrahiere den uebertrag FI;
+ ergebnis.
+
+ das result der subtraktion :
+ v byte := (code(left SUB i) - code(right SUB i - dif) - carrybit);
+ IF v byte < 0
+ THEN carrybit := 1;code(v byte + 100)
+ ELSE carrybit := 0;code(v byte)
+ FI.
+ subtrahiere den uebertrag :
+ FOR i FROM i DOWNTO 2
+ WHILE (ergebnis SUB i) = null REP
+ replace(ergebnis,i,max digit)
+ PER;
+ replace(ergebnis,i,code(code(ergebnis SUB i) - 1))
+END OP SUB;
+
+END PACKET longint;
diff --git a/system/std.zusatz/1.7.3/src/matrix b/system/std.zusatz/1.7.3/src/matrix new file mode 100644 index 0000000..fbc5ffc --- /dev/null +++ b/system/std.zusatz/1.7.3/src/matrix @@ -0,0 +1,470 @@ +PACKET matrix DEFINES MATRIX, matrix, idn, (* Stand : 21.10.83 *)
+ :=, sub, (* Autor : H.Indenbirken *)
+ row, column,
+ COLUMNS,
+ ROWS,
+ DET,
+ INV,
+ TRANSP,
+ transp,
+ replace row, replace column,
+ replace element,
+ get, put,
+ =, <>,
+ +, -, * :
+
+TYPE MATRIX = STRUCT (INT rows, columns, VECTOR elems);
+TYPE INITMATRIX = STRUCT (INT rows, columns, REAL value, BOOL idn);
+
+MATRIX VAR a :: idn (1);
+INT VAR i;
+
+(****************************************************************************
+PROC dump (MATRIX CONST m) :
+ put line (text (m.rows) + " Reihen, " + text (m.columns) + " Spalten.");
+ dump (m.elems) .
+
+END PROC dump;
+****************************************************************************)
+
+OP := (MATRIX VAR l, MATRIX CONST r) :
+ CONCR (l) := CONCR (r);
+END OP :=;
+
+OP := (MATRIX VAR l, INITMATRIX CONST r) :
+ l.rows := r.rows;
+ l.columns := r.columns;
+ l.elems := vector (r.rows*r.columns, r.value);
+ IF r.idn
+ THEN idn FI .
+
+idn :
+ INT VAR i;
+ FOR i FROM 1 UPTO r.rows
+ REP replace (l.elems, calc pos (l.columns, i, i), 1.0) PER
+
+END OP :=;
+
+INITMATRIX PROC matrix (INT CONST rows, columns, REAL CONST value) :
+ IF rows <= 0
+ THEN errorstop ("PROC matrix : rows <= 0")
+ ELIF columns <= 0
+ THEN errorstop ("PROC matrix : columns <= 0") FI;
+
+ INITMATRIX : (rows, columns, value, FALSE)
+
+END PROC matrix;
+
+INITMATRIX PROC matrix (INT CONST rows, columns) :
+ matrix (rows, columns, 0.0)
+
+END PROC matrix;
+
+INITMATRIX PROC idn (INT CONST size) :
+ IF size <= 0
+ THEN errorstop ("MATRIX PROC idn : size <= 0") FI;
+
+ INITMATRIX : (size, size, 0.0, TRUE)
+
+END PROC idn;
+
+VECTOR PROC row (MATRIX CONST m, INT CONST i) :
+ VECTOR VAR v :: vector (m.columns);
+ INT VAR j, k :: 1, pos :: (i-1) * m.columns;
+ FOR j FROM pos+1 UPTO pos + m.columns
+ REP replace (v, k, m.elems SUB j);
+ k INCR 1
+ PER;
+ v
+
+END PROC row;
+
+VECTOR PROC column (MATRIX CONST m, INT CONST j) :
+ VECTOR VAR v :: vector (m.rows);
+ INT VAR i, k :: j;
+ FOR i FROM 1 UPTO m.rows
+ REP replace (v, i, m.elems SUB k);
+ k INCR m.columns
+ PER;
+ v
+
+END PROC column;
+
+INT OP COLUMNS (MATRIX CONST m) :
+ m.columns
+
+END OP COLUMNS;
+
+INT OP ROWS (MATRIX CONST m) :
+ m.rows
+
+END OP ROWS;
+
+REAL PROC sub (MATRIX CONST a, INT CONST row, column) :
+ a.elems SUB calc pos (a.columns, row, column)
+
+END PROC sub;
+
+PROC replace row (MATRIX VAR m, INT CONST rowindex, VECTOR CONST rowvalue) :
+ test ("PROC replace row : ", "LENGTH rowvalue", "COLUMNS m",
+ LENGTH rowvalue, m.columns);
+ test ("PROC replace row : row ", rowindex, m.rows);
+
+ INT VAR i, pos :: (rowindex-1) * m.columns;
+ FOR i FROM 1 UPTO m.columns
+ REP replace (m.elems, pos+i, rowvalue SUB i) PER
+
+END PROC replace row;
+
+PROC replace column (MATRIX VAR m, INT CONST columnindex,
+ VECTOR CONST columnvalue) :
+ test ("PROC replace column : ", "LENGTH columnvalue", "ROWS m",
+ LENGTH columnvalue, m.rows);
+ test ("PROC replace column : column ", columnindex, m.columns);
+
+ INT VAR i;
+ FOR i FROM 1 UPTO m.rows
+ REP replace (m.elems, calc pos (m.columns, i, columnindex),
+ columnvalue SUB i) PER
+
+END PROC replace column;
+
+PROC replace element (MATRIX VAR a, INT CONST row, column, REAL CONST x) :
+ test ("PROC replace element : row ", row, a.rows);
+ test ("PROC replace element : column ", column, a.columns);
+ replace (a.elems, calc pos (a.columns, row, column), x)
+
+END PROC replace element;
+
+BOOL OP = (MATRIX CONST l, r) :
+ IF l.rows <> r.rows
+ THEN FALSE
+ ELIF l.columns <> r.columns
+ THEN FALSE
+ ELSE l.elems = r.elems FI
+
+END OP =;
+
+BOOL OP <> (MATRIX CONST l, r) :
+ IF l.rows <> r.rows
+ THEN TRUE
+ ELIF l.columns <> r.columns
+ THEN TRUE
+ ELSE l.elems <> r.elems FI
+
+END OP <>;
+
+INT PROC calc pos (INT CONST columns, z, s) :
+ (z-1) * columns + s
+END PROC calc pos;
+
+MATRIX OP + (MATRIX CONST m) :
+ m
+
+END OP +;
+
+MATRIX OP + (MATRIX CONST l, r) :
+ test ("MATRIX OP + : ", "ROWS l", "ROWS r", l.rows, r.rows);
+ test ("MATRIX OP + : ", "COLUMNS l", "COLUMNS r", l.columns, r.columns);
+
+ a := l;
+ INT VAR i;
+ FOR i FROM 1 UPTO l.rows * l.columns
+ REP replace (a.elems, i, (l.elems SUB i) + (r.elems SUB i))
+ PER;
+ a
+
+END OP +;
+
+MATRIX OP - (MATRIX CONST m) :
+ a := m;
+ INT VAR i;
+ FOR i FROM 1 UPTO m.rows * m.columns
+ REP replace (a.elems, i, -a.elems SUB i)
+ PER;
+ a
+
+END OP -;
+
+MATRIX OP - (MATRIX CONST l, r) :
+ test ("MATRIX OP - : ", "ROWS l", "ROWS r", l.rows, r.rows);
+ test ("MATRIX OP - : ", "COLUMNS l", "COLUMNS r", l.columns, r.columns);
+
+ a := l;
+ INT VAR i;
+ FOR i FROM 1 UPTO l.rows * l.columns
+ REP replace (a.elems, i, (l.elems SUB i) - (r.elems SUB i))
+ PER;
+ a
+
+END OP -;
+
+MATRIX OP * (REAL CONST x, MATRIX CONST m) :
+ m*x
+
+END OP *;
+
+MATRIX OP * (MATRIX CONST m, REAL CONST x) :
+ a := m;
+ INT VAR i;
+ FOR i FROM 1 UPTO m.rows * m.columns
+ REP replace (a.elems, i, x*m.elems SUB i) PER;
+ a
+
+END OP *;
+
+VECTOR OP * (VECTOR CONST v, MATRIX CONST m) :
+ test ("VECTOR OP * : ", "LENGTH v", "ROWS m", LENGTH v, m.rows);
+ VECTOR VAR result :: vector (m.rows);
+ INT VAR i;
+ FOR i FROM 1 UPTO m.rows
+ REP replace (result, i, v * column (m, i)) PER;
+ result .
+
+END OP *;
+
+VECTOR OP * (MATRIX CONST m, VECTOR CONST v) :
+ test ("VECTOR OP * : ", "COLUMNS m", "LENGTH v", COLUMNS m, LENGTH v);
+ VECTOR VAR result :: vector (m.columns);
+ INT VAR i;
+ FOR i FROM 1 UPTO m.columns
+ REP replace (result, i, row (m, i) * v) PER;
+ result .
+
+END OP *;
+
+MATRIX OP * (MATRIX CONST l, r) :
+ test ("MATRIX OP * : ","COLUMNS l","ROWS r", l.columns, r.rows);
+
+ a.rows := l.rows;
+ a.columns := r.columns;
+ a.elems := vector (a.rows*a.columns)
+ INT VAR i, j;
+ FOR i FROM 1 UPTO a.rows
+ REP FOR j FROM 1 UPTO a.columns
+ REP VECTOR VAR rl :: row (l, i), cr :: column (r, j);
+ replace (a.elems, calc pos (a.columns, i, j), rl * cr)
+ PER
+ PER;
+ a .
+
+END OP *;
+
+PROC get (MATRIX VAR a, INT CONST rows, columns) :
+
+ a := matrix (rows,columns);
+ INT VAR i, j;
+ VECTOR VAR v;
+ FOR i FROM 1 UPTO rows
+ REP get (v, columns);
+ store row
+ PER .
+
+store row :
+ FOR j FROM 1 UPTO a.columns
+ REP replace (a.elems, calc pos (a.columns, i, j), v SUB j)
+ PER .
+
+END PROC get;
+
+PROC put (MATRIX CONST a, INT CONST length, fracs) :
+ INT VAR i, j;
+ FOR i FROM 1 UPTO a.rows
+ REP FOR j FROM 1 UPTO a.columns
+ REP put (text (sub (a, i, j), length, fracs)) PER;
+ line (2);
+ PER
+
+END PROC put;
+
+PROC put (MATRIX CONST a) :
+ INT VAR i, j;
+ FOR i FROM 1 UPTO a.rows
+ REP FOR j FROM 1 UPTO a.columns
+ REP TEXT CONST number :: " " + text (sub (a, i, j));
+ put (subtext (number, LENGTH number - 15))
+ PER;
+ line (2);
+ PER
+
+END PROC put;
+
+TEXT VAR error :: "";
+PROC test (TEXT CONST proc, l text, r text, INT CONST left, right) :
+ IF left <> right
+ THEN error := proc;
+ error CAT l text;
+ error CAT " (";
+ error CAT text (left);
+ error CAT ") <> ";
+ error CAT r text;
+ error CAT " (";
+ error CAT text (right);
+ error CAT ")";
+ errorstop (error)
+ FI .
+
+END PROC test;
+
+PROC test (TEXT CONST proc, INT CONST i, n) :
+ IF i < 1
+ THEN error := proc;
+ error CAT "subscript underflow (";
+ error CAT text (i);
+ error CAT ")";
+ errorstop (error)
+ ELIF i > n
+ THEN error := proc;
+ error CAT "subscript overflow (i=";
+ error CAT text (i);
+ error CAT ", max=";
+ IF n <= 0
+ THEN error CAT "undefined"
+ ELSE error CAT text (n) FI;
+ error CAT ")";
+ errorstop (error)
+ FI
+
+END PROC test;
+
+
+MATRIX OP TRANSP (MATRIX CONST m) :
+ MATRIX VAR a :: m;
+ transp (a);
+ a
+
+END OP TRANSP;
+
+PROC transp (MATRIX VAR m) :
+ INT VAR k :: 1, n :: m.rows*m.columns;
+ a := m;
+ FOR i FROM 2 UPTO n
+ REP replace (m.elems, i, a.elems SUB position) PER;
+ a := idn (1);
+ i := m.rows;
+ m.rows := m.columns;
+ m.columns := i .
+
+position :
+ k INCR m.columns;
+ IF k > n
+ THEN k DECR (n-1) FI;
+ k .
+END PROC transp;
+
+MATRIX OP INV (MATRIX CONST m) :
+ a := m;
+ ROW 32 INT VAR pivots;
+ INT VAR i, j, k :: ROWS a, n :: COLUMNS a, pos;
+
+ IF n <> k
+ THEN errorstop ("MATRIX OP INV : no square matrix") FI;
+
+ initialisiere die pivotpositionen;
+
+ FOR j FROM 1 UPTO n
+ REP pivotsuche (a, j, pos);
+ IF sub (a, pos, pos) = 0.0
+ THEN errorstop ("MATRIX OP INV : singular matrix") FI;
+ zeilentausch (a, j, pos);
+ merke dir die vertauschung;
+ transformiere die matrix
+ PER;
+
+ spaltentausch;
+ a .
+
+initialisiere die pivotpositionen :
+ FOR i FROM 1 UPTO n
+ REP pivots [i] := i PER .
+
+merke dir die vertauschung :
+ IF pos > j
+ THEN INT VAR hi :: pivots [j];
+ pivots [j] := pivots [pos];
+ pivots [pos] := hi
+ FI .
+
+transformiere die matrix :
+ REAL VAR h := 1.0/sub (a, j, j);
+
+ FOR k FROM 1 UPTO n
+ REP IF k <> j
+ THEN FOR i FROM 1 UPTO n
+ REP IF i <> j
+ THEN replace element (a, i, k, sub (a, i, k) -
+ sub (a, i, j)*sub (a, j, k)*h);
+ FI
+ PER;
+ FI
+ PER;
+
+ FOR k FROM 1 UPTO n
+ REP replace element (a, j, k, -h*sub (a, j, k));
+ replace element (a, k, j, h*sub (a, k, j))
+ PER;
+ replace element (a, j, j, h) .
+
+spaltentausch :
+ VECTOR VAR v :: vector (n);
+ FOR i FROM 1 UPTO n
+ REP FOR k FROM 1 UPTO n
+ REP replace (v, pivots [k], sub (a, i, k)) PER;
+ replace row (a, i, v)
+ PER .
+
+END OP INV;
+
+REAL OP DET (MATRIX CONST m) :
+ IF COLUMNS m <> ROWS m
+ THEN errorstop ("REAL OP DET : no square matrix") FI;
+
+ a := m;
+ INT VAR i, j, k, n :: COLUMNS m, pos;
+ FOR j FROM 1 UPTO n
+ REP pivotsuche (a, j, pos);
+ zeilentausch (a, j, pos);
+ transformiere die matrix
+ PER;
+ produkt der pivotelemente .
+
+transformiere die matrix :
+ REAL VAR h := 1.0/sub (a, j, j);
+ FOR i FROM j+1 UPTO n
+ REP FOR k FROM j+1 UPTO n
+ REP replace element (a, i, k, sub (a, i, k) -
+ sub (a, i, j)*h*sub (a, j, k))
+ PER
+ PER .
+
+produkt der pivotelemente :
+ REAL VAR produkt :: sub (a, 1, 1);
+ FOR j FROM 2 UPTO n
+ REP produkt := produkt * sub (a, j, j) PER;
+ a := idn (1);
+ produkt .
+
+END OP DET;
+
+PROC pivotsuche (MATRIX CONST a, INT CONST start pos, INT VAR pos) :
+ REAL VAR max :: abs (sub (a, start pos, start pos));
+ INT VAR i;
+ pos := start pos;
+
+ FOR i FROM start pos+1 UPTO COLUMNS a
+ REP IF abs (sub (a, i, start pos)) > max
+ THEN max := abs (sub (a, i, start pos));
+ pos := i
+ FI
+ PER .
+
+END PROC pivotsuche;
+
+PROC zeilentausch (MATRIX VAR a, INT CONST old pos, pos) :
+ VECTOR VAR v := row (a, pos);
+ replace row (a, pos, row (a, old pos));
+ replace row (a, old pos, v) .
+
+END PROC zeilentausch;
+
+END PACKET matrix;
diff --git a/system/std.zusatz/1.7.3/src/minimal fonts routines b/system/std.zusatz/1.7.3/src/minimal fonts routines new file mode 100644 index 0000000..adcfc66 --- /dev/null +++ b/system/std.zusatz/1.7.3/src/minimal fonts routines @@ -0,0 +1,9 @@ +PACKET minimal fonts routines DEFINES lf height of current font,
+ x factor per inch,
+ y factor per inch:
+
+REAL CONST lf height of current font :: 2.54 / 6.0;
+INT CONST x factor per inch :: 10,
+ y factor per inch :: 6;
+
+END PACKET minimal fonts routines;
diff --git a/system/std.zusatz/1.7.3/src/printer-M b/system/std.zusatz/1.7.3/src/printer-M new file mode 100644 index 0000000..45b1381 --- /dev/null +++ b/system/std.zusatz/1.7.3/src/printer-M @@ -0,0 +1,69 @@ +PACKET multi user printer :
+
+INT VAR printer channel ;
+
+ put ("Druckerkanal:") ;
+ get (printer channel) ;
+ server channel (printer channel);
+
+ command dialogue (FALSE) ;
+ spool manager (PROC printer) ;
+
+
+LET ack = 0 ,
+ fetch code = 11 ,
+ file type = 1003 ;
+
+INT VAR reply , old heap size ;
+
+DATASPACE VAR ds ;
+
+FILE VAR file ;
+
+PROC printer :
+
+ disable stop ;
+ continue (server channel) ;
+ IF is error
+ THEN clear error ;
+ end
+ FI ;
+
+ old heap size := heap size ;
+ REP
+ forget (ds) ;
+ execute print ;
+ IF is error AND online
+ THEN put error
+ FI ;
+ clear error ;
+ IF heap size > old heap size + 4
+ THEN collect heap garbage ;
+ old heap size := heap size
+ FI
+ PER
+
+ENDPROC printer ;
+
+PROC execute print :
+
+ enable stop ;
+ REP
+ ds := nilspace ;
+ call (father, fetch code, ds, reply) ;
+ IF reply = ack CAND type (ds) = file type
+ THEN print file
+ FI ;
+ forget (ds)
+ PER .
+
+print file :
+ file := sequential file (input, ds) ;
+ IF is elan source (file)
+ THEN elan list (file)
+ ELSE print (file)
+ FI .
+
+ENDPROC execute print ;
+
+ENDPACKET multi user printer ;
diff --git a/system/std.zusatz/1.7.3/src/printer-S b/system/std.zusatz/1.7.3/src/printer-S new file mode 100644 index 0000000..5124cc4 --- /dev/null +++ b/system/std.zusatz/1.7.3/src/printer-S @@ -0,0 +1,36 @@ +PACKET single user print cmd DEFINES print :
+
+INT VAR print channel ;
+FILE VAR print file ;
+
+put ("Druckerkanal:") ;
+get (print channel) ;
+
+PROC print :
+
+ print (last param)
+
+ENDPROC print ;
+
+PROC print (TEXT CONST file name) :
+
+ last param (file name) ;
+ print file := sequential file (input, file name) ;
+ continue (print channel) ;
+ disable stop ;
+ execute print ;
+ continue (0)
+
+ENDPROC print ;
+
+PROC execute print :
+
+ enable stop ;
+ IF is elan source (print file)
+ THEN elan list (print file)
+ ELSE print (print file)
+ FI
+
+ENDPROC execute print ;
+
+ENDPACKET single user print cmd ;
diff --git a/system/std.zusatz/1.7.3/src/purge b/system/std.zusatz/1.7.3/src/purge new file mode 100644 index 0000000..e325646 --- /dev/null +++ b/system/std.zusatz/1.7.3/src/purge @@ -0,0 +1,85 @@ +
+PACKET purge DEFINES purge :
+
+
+TEXT VAR task name, record, file name, dummy ;
+
+FILE VAR permit ;
+
+
+PROC purge :
+
+ IF exists ("permitted tasks")
+ THEN access catalogue ;
+ permit := sequential file (input, "permitted tasks") ;
+ say (""10""13"TASKS :"10""10""13"") ;
+ IF myself < supervisor
+ THEN purge son tasks (brother (supervisor))
+ ELSE purge son tasks (myself)
+ FI
+ FI ;
+ IF exists ("permitted files")
+ THEN permit := sequential file (input, "permitted files") ;
+ say (""10""13"DATEIEN :"10""10""13"") ;
+ purge files
+ FI
+
+ENDPROC purge ;
+
+PROC purge son tasks (TASK CONST father task) :
+
+ TASK VAR actual task := son (father task) ;
+ WHILE NOT is niltask (actual task) REP
+ purge son tasks (actual task) ;
+ IF NOT actual task permitted
+ THEN erase actual task
+ FI ;
+ actual task := brother (actual task)
+ END REP .
+
+erase actual task :
+ say ("""") ; say (task name) ; say ("""") ;
+ IF yes (" loeschen")
+ THEN end (actual task)
+ FI .
+
+actual task permitted :
+ task name := name (actual task) ;
+ reset (permit) ;
+ WHILE NOT eof (permit) REP
+ getline (permit, record) ;
+ IF task name = record
+ THEN LEAVE actual task permitted WITH TRUE
+ FI
+ END REP ;
+ FALSE .
+
+ENDPROC purge son tasks ;
+
+PROC purge files :
+
+ begin list ;
+ get list entry (file name, dummy) ;
+ WHILE file name <> "" REP
+ IF NOT file permitted
+ THEN forget (file name)
+ FI ;
+ get list entry (file name, dummy)
+ END REP .
+
+file permitted :
+ IF file name = "permitted tasks" OR file name = "permitted files"
+ THEN LEAVE file permitted WITH TRUE
+ FI ;
+ reset (permit) ;
+ WHILE NOT eof (permit) REP
+ getline (permit, record) ;
+ IF file name = record
+ THEN LEAVE file permitted WITH TRUE
+ FI
+ END REP ;
+ FALSE .
+
+ENDPROC purge files ;
+
+ENDPACKET purge ;
diff --git a/system/std.zusatz/1.7.3/src/referencer b/system/std.zusatz/1.7.3/src/referencer new file mode 100644 index 0000000..5606e4c --- /dev/null +++ b/system/std.zusatz/1.7.3/src/referencer @@ -0,0 +1,1077 @@ +PACKET referencer errors DEFINES report referencer error:
+
+(* Programm zur Fehlerbehandlung des referencers.
+ Autor: Rainer Hahn
+ Stand: 04.05.83
+*)
+TEXT VAR fehlerdummy,
+ message;
+
+PROC report referencer error (INT CONST error nr,
+ INT CONST line nr,
+ TEXT CONST addition):
+
+ einfache fehlermeldung aufbauen;
+ diese auf terminal ausgeben;
+ fehlermeldung in fehlerdatei ausgeben.
+
+einfache fehlermeldung aufbauen:
+ message := "WARNUNG in Zeile ";
+ message CAT text (line nr);
+ message CAT " : ";
+ message CAT simple message.
+
+diese auf terminal ausgeben:
+ line;
+ out (message);
+ line.
+
+fehlermeldung in fehlerdatei ausgeben:
+ note (message);
+ note line;
+ fehlerdummy := " >>> ";
+ fehlerdummy CAT zusatz;
+ note (fehlerdummy);
+ note line.
+
+simple message:
+ SELECT error nr OF
+ CASE 1: "Text Denoter ueber mehr als eine Zeile"
+ CASE 2: "Nicht beendeter Text Denoter bei Programmende"
+ CASE 3: "Kommentar ueber mehr als eine Zeile"
+ CASE 4: "Nicht beendeter Kommentar bei Programmende"
+ CASE 5: "Ueberdeckung"
+ CASE 6, 9: "Refinement mehrmals eingesetzt"
+ CASE 7, 10: "Refinement wird nicht aufgerufen"
+ CASE 8: "Objekt wird nicht angesprochen"
+ OTHERWISE ""
+ ENDSELECT.
+
+zusatz:
+ SELECT error nr OF
+ CASE 1, 2, 3, 4: "Ueber " + addition + " Zeilen"
+ CASE 5: addition
+ CASE 6, 7, 8: addition
+ CASE 9, 10: addition + " in mindestens einer Prozedur"
+ OTHERWISE "interner Fehler: HRZ Bielefeld benachrichtigen!"
+ END SELECT.
+END PROC report referencer error
+END PACKET referencer errors;
+(************************************************************************)
+
+PACKET name table handling
+ DEFINES NAMETABLE,
+ empty name table,
+ put name,
+ get name,
+ dump table:
+
+(* Programm zur Speicherung von Namen.
+ Autor: Rainer Hahn
+ Stand: 04.05.83
+*)
+LET hash table length = 1024,
+ hash table length minus one = 1023,
+ start of name table = 255,
+ name table length = 2000;
+
+TYPE NAMETABLE = STRUCT (INT number of entries,
+ ROW hash table length INT hash table,
+ ROW name table length INT next,
+ ROW name table length TEXT name table);
+
+TEXT VAR dummy, f;
+
+PROC put name (NAMETABLE VAR n, TEXT CONST name, INT VAR pointer):
+ INT VAR errechneter index;
+ hash (name, errechneter index);
+ IF noch kein eintrag
+ THEN gaenzlich neuer eintrag
+ ELSE name in vorhandener kette
+ FI.
+
+noch kein eintrag:
+ n . hash table [errechneter index] = 0.
+
+gaenzlich neuer eintrag:
+ n . hash table [errechneter index] := n . number of entries;
+ neuer eintrag (n, name, pointer).
+
+name in vorhandener kette:
+ INT VAR dieser eintrag :: n. hash table [errechneter index];
+ REP
+ IF name ist vorhanden
+ THEN pointer := dieser eintrag;
+ LEAVE put name
+ ELIF kette zu ende
+ THEN neuer eintrag an vorhandene kette anketten;
+ neuer eintrag (n, name, pointer);
+ LEAVE put name
+ ELSE naechster eintrag in der kette
+ FI
+ END REP.
+
+name ist vorhanden:
+ n . name table [dieser eintrag] = name.
+
+kette zu ende:
+ n . next [dieser eintrag] = 0.
+
+neuer eintrag an vorhandene kette anketten:
+ n . next [dieser eintrag] := n . number of entries.
+
+naechster eintrag in der kette:
+ dieser eintrag := n . next [dieser eintrag].
+END PROC put name;
+
+PROC neuer eintrag (NAMETABLE VAR n, TEXT CONST name, INT VAR pointer):
+ n . name table [n . number of entries] := name;
+ n . next [n . number of entries] := 0;
+ pointer := n . number of entries;
+ n . number of entries INCR 1;
+ IF n . number of entries > name table length
+ THEN errorstop ("volle Namenstabelle")
+ FI
+END PROC neuer eintrag;
+
+PROC hash (TEXT CONST name, INT VAR index) :
+ INT VAR i;
+ index := code (name SUB 1);
+ FOR i FROM 2 UPTO length (name) REP
+ addmult cyclic
+ ENDREP.
+
+addmult cyclic :
+ index INCR index ;
+ IF index > hash table length minus one
+ THEN wrap around
+ FI;
+ index := (index + code (name SUB i)) MOD hash table length.
+
+wrap around :
+ index DECR hash table length minus one
+ENDPROC hash ;
+
+PROC get name (NAMETABLE CONST n, INT CONST index, TEXT VAR t):
+ IF index < n . number of entries AND index >= start of name table
+ THEN t := n . name table [index]
+ ELSE errorstop ("Interner Fehler 1")
+ FI
+END PROC get name;
+
+PROC empty name table (NAMETABLE VAR n):
+INT VAR i;
+ n . number of entries := start of name table;
+ FOR i FROM 1 UPTO hash table length REP
+ n . hash table [i] := 0
+ END REP
+END PROC empty name table;
+
+PROC dump table (NAMETABLE CONST n):
+ line;
+ put ("Bitte Name der Datei, in die die Namenstabelle gehen soll:");
+ getline (f);
+ line;
+ file assoziieren;
+ dump namens ketten;
+ zusammenfassung.
+
+file assoziieren:
+ FILE VAR file :: sequential file (output, f).
+
+dump namens ketten:
+ INT VAR i,
+ anz hash eintraege :: 0,
+ kette 3 eintraege :: 0;
+ FOR i FROM 1 UPTO hash table length REP
+ IF n . hash table [i] <> 0
+ THEN anz hash eintraege INCR 1;
+ INT VAR naechster eintrag :: n . hash table [i];
+ dump hash eintrag;
+ ketten eintraege
+ FI
+ END REP.
+
+dump hash eintrag:
+ dummy := text (i);
+ WHILE length (dummy) < 4 REP dummy CAT " " END REP;
+ dummy CAT ": ".
+
+ketten eintraege:
+ INT VAR anz eintraege pro kette :: 0;
+ WHILE naechster eintrag > 0 REP
+ anz eintraege pro kette INCR 1;
+ dummy CAT " ";
+ dummy CAT text (naechster eintrag);
+ dummy CAT " -> ";
+ dummy CAT n . name table [naechster eintrag];
+ naechster eintrag := n . next [naechster eintrag];
+ END REP;
+ IF anz eintraege pro kette > 2
+ THEN kette 3 eintraege INCR 1
+ FI;
+ putline (file, dummy).
+
+zusammenfassung:
+ statistik ueberschrift;
+ anzahl hash eintraege;
+ anzahl namens eintraege;
+ verkettungsfaktor;
+ anzahl laengerer ketten.
+
+statistik ueberschrift:
+ line (file, 2);
+ dummy := " ---------- ";
+ dummy CAT "S T A T I S T I K:";
+ dummy CAT " ---------- ";
+ putline (file, dummy);
+ line (file, 2).
+
+anzahl hash eintraege:
+ dummy := "Anzahl Hash-Eintraege (max. ";
+ dummy CAT text (hash table length);
+ dummy CAT "): ";
+ dummy CAT text (anz hash eintraege);
+ putline (file, dummy).
+
+anzahl namens eintraege:
+ dummy := "Anzahl Namen (max. ";
+ dummy CAT text (name table length - start of name table + 1);
+ dummy CAT "): ";
+ dummy CAT text (n . number of entries - start of name table);
+ putline (file, dummy).
+
+verkettungsfaktor:
+ dummy := "Verkettungsfaktor (Anzahl Namen / Anzahl Ketten): ";
+ dummy CAT text (real (n . number of entries - start of name table) /
+ real (anz hash eintraege));
+ putline (file, dummy).
+
+anzahl laengerer ketten:
+ dummy := "Anzahl Ketten > 2 Eintraege: ";
+ dummy CAT text (kette 3 eintraege);
+ putline (file, dummy).
+END PROC dump table;
+END PACKET name table handling;
+(***************************************************************************)
+
+PACKET scanner DEFINES init scanning,
+ init name table with,
+ dump name table,
+ get name,
+ end scanning,
+ line number,
+ symbol:
+
+(* Programm zum scannen von ELAN-Programmen.
+ Autor: Rainer Hahn
+ Stand: 04.05.83
+*)
+FILE VAR eingabe;
+
+DATASPACE VAR ds alt := nilspace,
+ ds neu := nilspace;
+
+BOUND NAMETABLE VAR tabelle;
+
+TEXT VAR zeile,
+ zeichen,
+ dummy;
+
+LET end of program = ""30"",
+ eop = 1,
+ identifier = 2,
+ keyword = 3,
+ delimiter = 4,
+ klammer auf = 40,
+ punkt = 46,
+ doppelpunkt = 58,
+ init symbol = 30,
+ assign symbol = 31;
+
+INT VAR zeilen nr,
+ zeichen pos;
+
+PROC init name table with (TEXT CONST worte):
+INT VAR index;
+ forget (ds alt);
+ ds alt := nilspace;
+ tabelle := dsalt;
+ empty name table (CONCR (tabelle));
+ INT VAR anf :: 1,
+ ende :: pos (worte, ",", 1);
+ WHILE ende > 0 REP
+ dummy := subtext (worte, anf, ende - 1);
+ put name (CONCR (tabelle), dummy, index);
+ anf := ende + 1;
+ ende := pos (worte, ",", ende + 1)
+ END REP;
+ dummy := subtext (worte, anf);
+ put name (CONCR (tabelle), dummy, index)
+END PROC init name table with;
+
+PROC init scanning (TEXT CONST f):
+ IF exists (f)
+ THEN namenstabelle holen;
+ erste zeile lesen
+ ELSE errorstop ("Datei existiert nicht")
+ FI.
+
+namenstabelle holen:
+ forget (ds neu);
+ ds neu := ds alt;
+ tabelle := ds neu.
+
+erste zeile lesen:
+ eingabe := sequential file (input, f);
+ IF eof (eingabe)
+ THEN errorstop ("Datei ist leer")
+ ELSE zeile := "";
+ zeilen nr := 0;
+ zeile lesen;
+ naechstes non blank zeichen
+ FI
+END PROC init scanning;
+
+PROC dump name table:
+ dump table (CONCR (tabelle))
+END PROC dump name table;
+
+PROC end scanning (TEXT CONST f):
+ IF anything noted
+ THEN eingabe := sequential file (modify, f);
+ note edit (eingabe)
+ FI
+END PROC end scanning;
+
+PROC get name (INT CONST index, TEXT VAR t):
+ get name (CONCR (tabelle), index, t)
+END PROC get name;
+
+PROC zeile lesen:
+ getline (eingabe, zeile);
+ zeilen nr INCR 1;
+ cout (zeilen nr);
+ zeichen pos := 0
+END PROC zeile lesen;
+
+PROC naechstes non blank zeichen:
+ REP
+ zeichen pos := pos (zeile, ""33"", ""254"", zeichen pos + 1);
+ IF zeichen pos <> 0
+ THEN zeichen := (zeile SUB zeichen pos);
+ LEAVE naechstes non blank zeichen
+ ELIF eof (eingabe)
+ THEN zeichen := end of program;
+ LEAVE naechstes non blank zeichen
+ ELSE zeile lesen
+ FI
+ END REP.
+END PROC naechstes non blank zeichen;
+
+PROC naechstes zeichen:
+ IF zeichen pos > length (zeile)
+ THEN IF eof (eingabe)
+ THEN zeichen := end of program;
+ LEAVE naechstes zeichen
+ ELSE zeile lesen
+ FI
+ FI;
+ zeichenpos INCR 1;
+ zeichen := zeile SUB zeichenpos
+END PROC naechstes zeichen;
+
+INT PROC line number:
+ IF zeichenpos = pos (zeile, ""33"", ""254"", 1)
+ THEN zeilen nr - 1
+ ELSE zeilen nr
+ FI
+END PROC line number;
+
+PROC symbol (INT VAR symb, type):
+ REP
+ suche naechstes checker symbol
+ END REP.
+
+suche naechstes checker symbol:
+ SELECT code (zeichen) OF
+ CASE 30: (* end of programn *)
+ symb := eop;
+ type := eop;
+ LEAVE symbol
+ CASE 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110,
+ 111, 112, 113, 114, 115, 116, 117, 118, 119, 120, 121, 122:
+ (* small letters *)
+ identifier aufsammeln;
+ put name (CONCR (tabelle), dummy, symb);
+ type := identifier;
+ LEAVE symbol
+ CASE 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81,
+ 82, 83, 84, 85, 86, 87, 88, 89, 90: (* large letters *)
+ schluesselwort aufsammeln;
+ put name (CONCR (tabelle), dummy, symb);
+ type := keyword;
+ LEAVE symbol
+ CASE 34: (* " *)
+ skip text denoter
+ CASE 40: (* ( *)
+ IF (zeile SUB zeichen pos + 1) = "*"
+ THEN skip comment
+ ELSE symb := code (zeichen);
+ type := delimiter;
+ naechstes non blank zeichen;
+ LEAVE symbol;
+ FI
+ CASE 58: (* : *)
+ IF (zeile SUB zeichenpos + 1) = "="
+ THEN symb := assign symbol;
+ zeichenpos INCR 1
+ ELIF (zeile SUB zeichenpos + 1) = ":"
+ THEN symb := init symbol;
+ zeichenpos INCR 1
+ ELSE symb := doppelpunkt
+ FI;
+ type := delimiter;
+ naechstes non blank zeichen;
+ LEAVE symbol
+ CASE 48, 49, 50, 51, 52, 53, 54, 55, 56, 57: (* 0 - 9 *)
+ int denoter skippen;
+ IF zeichen = "."
+ THEN naechstes non blank zeichen;
+ IF digit
+ THEN real denoter skippen
+ ELSE symb := punkt;
+ type := delimiter;
+ LEAVE symbol
+ FI
+ FI
+ CASE 41, 44, 46, 59, 61: (* ) , . ; = *)
+ symb := code (zeichen);
+ type := delimiter;
+ naechstes non blank zeichen;
+ LEAVE symbol
+ OTHERWISE naechstes non blank zeichen
+ END SELECT.
+END PROC symbol;
+
+PROC real denoter skippen:
+ int denoter skippen;
+ IF zeichen = "e"
+ THEN naechstes non blank zeichen;
+ int denoter skippen
+ FI
+END PROC real denoter skippen;
+
+PROC int denoter skippen:
+ naechstes non blank zeichen;
+ WHILE zeichen >= "0" AND zeichen <= "9" REP
+ naechstes non blank zeichen
+ ENDREP;
+ zeichenpos DECR 1;
+ naechstes non blank zeichen
+END PROC int denoter skippen;
+
+PROC identifier aufsammeln:
+ dummy := zeichen;
+ REP
+ naechstes non blank zeichen;
+ IF small letter or digit
+ THEN dummy CAT zeichen
+ ELSE LEAVE identifier aufsammeln
+ FI
+ END REP
+END PROC identifier aufsammeln;
+
+PROC schluesselwort aufsammeln:
+ dummy := "";
+ sammle schluesselwort;
+ IF dummy = "END"
+ THEN noch einmal
+ FI.
+
+sammle schluesselwort:
+ WHILE large letter REP
+ dummy CAT zeichen;
+ naechstes zeichen
+ END REP;
+ IF zeichen = " "
+ THEN naechstes non blank zeichen
+ FI.
+
+noch einmal:
+ sammle schluesselwort
+END PROC schluesselwort aufsammeln;
+
+PROC skip text denoter:
+ INT VAR anz zeilen :: 0;
+ zeichen pos := pos (zeile, """", zeichenpos + 1);
+ WHILE zeichen pos = 0 REP
+ naechste zeile einlesen;
+ zeichen pos := pos (zeile, """");
+ END REP;
+ ende text denoter.
+
+ende text denoter:
+ IF anz zeilen > 1
+ THEN report referencer error (1, zeilen nr, text (anz zeilen))
+ FI;
+ naechstes non blank zeichen.
+
+naechste zeile einlesen:
+ IF eof (eingabe)
+ THEN report referencer error (2, zeilen nr, text (anz zeilen));
+ zeichen := end of program;
+ LEAVE skip text denoter
+ ELSE zeile lesen;
+ anz zeilen INCR 1
+ FI.
+END PROC skip text denoter;
+
+PROC skip comment:
+ INT VAR anz zeilen :: 0;
+ zeichen pos := pos (zeile, "*)", zeichenpos + 2);
+ WHILE zeichen pos = 0 REP
+ naechste zeile einlesen;
+ zeichen pos := pos (zeile, "*)");
+ END REP;
+ ende comment.
+
+ende comment:
+ IF anz zeilen > 1
+ THEN report referencer error (3, zeilen nr, text (anz zeilen))
+ FI;
+ zeichen pos INCR 2;
+ naechstes non blank zeichen.
+
+naechste zeile einlesen:
+ IF eof (eingabe)
+ THEN report referencer error (4, zeilen nr, text (anz zeilen));
+ zeichen := end of program;
+ LEAVE skip comment
+ ELSE zeile lesen;
+ anz zeilen INCR 1
+ FI.
+END PROC skip comment;
+
+BOOL PROC small letter or digit:
+ (zeichen >= "0" AND zeichen <= "9") OR (zeichen >= "a" AND zeichen <= "z")
+END PROC small letter or digit;
+
+BOOL PROC small letter:
+ zeichen >= "a" AND zeichen <= "z"
+END PROC small letter;
+
+BOOL PROC large letter:
+ zeichen >= "A" AND zeichen <= "Z"
+END PROC large letter;
+
+BOOL PROC digit:
+ zeichen >= "0" AND zeichen <= "9"
+END PROC digit;
+END PACKET scanner;
+(*************************************************************************)
+PACKET referencer2 DEFINES referencer:
+
+(* Programm fuer den 'referencer'
+ Autor: Rainer Hahn
+ Stand: 19.03.84
+*)
+INT VAR symb,
+ typ,
+ max index;
+
+TEXT VAR dummy,
+ dummy2,
+ name;
+
+DATASPACE VAR ds;
+
+BOUND ROW max TEXT VAR liste;
+
+FILE VAR f;
+
+BOOL VAR initialisiert :: FALSE,
+ symbol bereits geholt,
+ globale deklarationen;
+
+LET max = 1751,
+ global text = "<--G",
+ local text = "<--L",
+ refinement text = "<--R",
+ procedure text = "<--P",
+ eop = 1,
+ identifier = 2,
+ keyword = 3,
+ init symbol = 30,
+ assign symbol = 31,
+ klammer auf = 40,
+ klammer zu = 41,
+ komma = 44,
+ punkt = 46,
+ doppelpunkt = 58,
+ semikolon = 59,
+ proc symbol = 255,
+ end proc symbol = 256,
+ packet symbol = 257,
+ end packet symbol = 258,
+ type symbol = 259,
+ var symbol = 260,
+ const symbol = 261,
+ let symbol = 262,
+ leave symbol = 263,
+ op symbol = 264,
+ endop symbol = 265,
+ endif symbol = 266,
+ fi symbol = 266;
+
+PROC referencer:
+ referencer (last param)
+END PROC referencer;
+
+PROC referencer (TEXT CONST check file):
+ referencer (check file, check file + ".r")
+END PROC referencer;
+
+PROC referencer (TEXT CONST check file, dump file):
+ IF exists (check file)
+ THEN dump file ueberpruefen
+ ELSE errorstop ("Eingabe-Datei nicht vorhanden")
+ FI.
+
+dump file ueberpruefen:
+ IF exists (dump file)
+ THEN errorstop ("Ausgabe-Datei existiert bereits")
+ ELSE disable stop;
+ start referencing (check file, dump file);
+ forget (ds);
+ enable stop;
+ FI
+END PROC referencer;
+
+PROC start referencing (TEXT CONST check file, dump file):
+ enable stop;
+ ueberschrift;
+ initialisierung;
+ verkuerzte syntax analyse;
+ line;
+ in dump file kopieren (dump file);
+ line;
+ end scanning (check file).
+
+ueberschrift:
+ page;
+ put ("REFERENCER:");
+ put (check file);
+ put ("->");
+ put (dump file);
+ line.
+
+initialisierung:
+ IF NOT initialisiert
+ THEN init name table with
+("PROC,ENDPROC,PACKET,ENDPACKET,TYPE,VAR,CONST,LET,LEAVE,OP,ENDOP,ENDIF,FI");
+ initialisiert := TRUE
+ FI;
+ ds := nilspace;
+ liste := ds;
+ maxindex := endop symbol;
+ dummy := checkfile.
+
+verkuerzte syntax analyse:
+ globale deklarationen := TRUE;
+ line;
+ init scanning (dummy);
+ symbol bereits geholt := FALSE;
+ REP
+ IF symbol bereits geholt
+ THEN symbol bereits geholt := FALSE
+ ELSE symbol (symb, typ)
+ FI;
+ IF typ = keyword
+ THEN nach schluesselwort verarbeiten
+ ELIF symb = punkt
+ THEN ggf refinement aufnehmen
+ ELIF typ = identifier
+ THEN identifier aufnehmen und ggf aktuelle parameter liste
+ FI
+ UNTIL typ = eop ENDREP.
+
+identifier aufnehmen und ggf aktuelle parameter liste:
+ in die liste (symb, "");
+ symbol (symb, typ);
+ IF symb = klammer auf
+ THEN aktuelle parameter aufnehmen
+ ELSE symbol bereits geholt := TRUE
+ FI.
+
+nach schluesselwort verarbeiten:
+ SELECT symb OF
+ CASE let symbol:
+ let deklarationen aufsammeln
+ CASE packet symbol:
+ namen des interface aufsammeln
+ CASE end packet symbol:
+ skip naechstes symbol
+ CASE var symbol, const symbol:
+ datenobjekt deklaration aufnehmen
+ CASE proc symbol:
+ globale deklarationen := FALSE;
+ prozedur name und ggf parameter aufsammeln
+ CASE end proc symbol:
+ globale deklarationen := TRUE;
+ skip naechstes symbol
+ CASE op symbol:
+ globale deklarationen := FALSE;
+ operatornamen skippen und ggf parameter aufsammeln
+ CASE end op symbol:
+ globale deklarationen := TRUE;
+ skip until (semikolon)
+ CASE type symbol:
+ namen der typ definition aufsammeln
+ CASE leave symbol:
+ skip naechstes symbol
+ OTHERWISE:
+ ENDSELECT.
+
+skip naechstes symbol:
+ symbol (symb, typ).
+END PROC start referencing;
+
+PROC aktuelle parameter aufnehmen:
+ REP
+ symbol (symb, typ);
+ IF typ = identifier
+ THEN in die liste (symb, "")
+ FI
+ UNTIL symb = klammer zu END REP.
+END PROC aktuelle parameter aufnehmen;
+
+PROC ggf refinement aufnehmen:
+ symbol (symb, typ);
+ symbol bereits geholt := TRUE;
+ WHILE typ = identifier REP
+ doppelpunkt oder selektor
+ END REP.
+
+doppelpunkt oder selektor:
+ INT CONST letzter id :: symb;
+ symbol (symb, typ);
+ IF symb = doppelpunkt
+ THEN in die liste (letzter id, refinement text);
+ LEAVE ggf refinement aufnehmen
+ ELSE in die liste (letzter id, "");
+ IF symb = punkt
+ THEN symbol (symb, typ)
+ ELSE LEAVE ggf refinement aufnehmen
+ FI
+ FI
+END PROC ggf refinement aufnehmen;
+
+PROC namen des interface aufsammeln:
+ packet name ueberspringen;
+ namen der schnittstelle aufsammeln.
+
+packet name ueberspringen:
+ symbol (symb, typ).
+
+namen der schnittstelle aufsammeln:
+ REP
+ symbol (symb, typ);
+ IF typ = identifier
+ THEN in die liste (symb, "")
+ FI
+ UNTIL symb = doppelpunkt END REP.
+END PROC namen des interface aufsammeln;
+
+PROC let deklarationen aufsammeln:
+ REP
+ symbol (symb, typ);
+ IF typ = identifier
+ THEN let name aufnehmen
+ ELIF typ = keyword
+ THEN bis zum komma oder semikolon
+ FI;
+ UNTIL symb = semikolon END REP.
+
+let name aufnehmen:
+ IF globale deklarationen
+ THEN in die liste (symb, global text)
+ ELSE in die liste (symb, "")
+ FI;
+ REP
+ symbol (symb, typ);
+ IF typ = identifier
+ THEN in die liste (symb, "")
+ FI
+ UNTIL symb = komma OR symb = semikolon END REP.
+END PROC let deklarationen aufsammeln;
+
+PROC namen der typ definition aufsammeln:
+ REP
+ symbol (symb, typ);
+ bis zum komma oder semikolon
+ UNTIL symb = semikolon END REP
+END PROC namen der typ definition aufsammeln;
+
+PROC bis zum komma oder semikolon:
+ INT VAR anz klammern :: 0;
+ REP
+ symbol (symb, typ);
+ (* fields aufnehmen weggelassen *)
+ IF symb = klammer auf
+ THEN anz klammern INCR 1
+ ELIF symb = klammer zu
+ THEN anz klammern DECR 1
+ FI
+ UNTIL (symb = komma AND anz klammern = 0) OR symb = semikolon ENDREP.
+END PROC bis zum komma oder semikolon;
+
+PROC datenobjekt deklaration aufnehmen:
+ symbol (symb, typ);
+ REP
+ IF globale deklarationen
+ THEN in die liste (symb, global text)
+ ELSE in die liste (symb, local text)
+ FI;
+ skip ggf initialisierung;
+ IF symb = komma
+ THEN symbol (symb, typ)
+ FI
+ UNTIL symb = semikolon END REP.
+
+skip ggf initialisierung:
+ symbol (symb, typ);
+ IF symb = init symbol OR symb = assign symbol
+ THEN initialisierung skippen
+ FI.
+
+initialisierung skippen:
+ INT VAR anz klammern :: 0;
+ REP
+ INT CONST vorheriges symbol :: symb,
+ vorheriger typ :: typ;
+ symbol (symb, typ);
+ IF symb = klammer auf
+ THEN anz klammern INCR 1;
+ IF vorheriger typ = identifier
+ THEN in die liste (vorheriges symbol, "")
+ FI
+ ELIF symb = klammer zu
+ THEN anz klammern DECR 1;
+ IF vorheriger typ = identifier
+ THEN in die liste (vorheriges symbol, "")
+ FI
+ ELIF vorheriger typ = identifier AND symb = doppelpunkt
+ THEN in die liste (vorheriges symbol, refinement text);
+ LEAVE datenobjekt deklaration aufnehmen
+ ELIF vorheriger typ = identifier
+ THEN in die liste (vorheriges symbol, "")
+ FI
+ UNTIL (symb = komma AND anz klammern = 0)
+ OR symb = semikolon OR symb = end proc symbol OR
+ symb = end op symbol OR symb = endif symbol OR symb = fi symbol
+ END REP.
+END PROC datenobjekt deklaration aufnehmen;
+
+PROC prozedur name und ggf parameter aufsammeln:
+ prozedurname aufsammeln;
+ symbol (symb, typ);
+ IF symb <> doppelpunkt
+ THEN formale parameter aufsammeln
+ FI.
+
+prozedurname aufsammeln:
+ symbol (symb, typ);
+ in die liste (symb, procedure text).
+END PROC prozedurname und ggf parameter aufsammeln;
+
+PROC operatornamen skippen und ggf parameter aufsammeln:
+ symbol (symb, typ);
+ IF symb <> doppelpunkt
+ THEN formale parameter aufsammeln
+ FI
+END PROC operatornamen skippen und ggf parameter aufsammeln;
+
+PROC formale parameter aufsammeln:
+ REP
+ symbol (symb, typ);
+ IF typ = identifier
+ THEN in die liste (symb, local text);
+ FI
+ UNTIL symb = doppelpunkt END REP
+END PROC formale parameter aufsammeln;
+
+PROC skip until (INT CONST zeichencode):
+ skip until (zeichencode, 0)
+END PROC skip until;
+
+PROC skip until (INT CONST z1, z2):
+ REP
+ symbol (symb, typ)
+ UNTIL symb = z1 OR symb = z2 END REP
+END PROC skip until;
+
+PROC in die liste (INT CONST index, TEXT CONST zusatz):
+ IF index > max index
+ THEN listenelemente initialisieren;
+ FI;
+ IF aktueller eintrag = ""
+ THEN namens eintrag
+ FI;
+ aktueller eintrag CAT " ";
+ aktueller eintrag CAT text (line number);
+ aktueller eintrag CAT zusatz.
+
+aktueller eintrag:
+ liste [index].
+
+listenelemente initialisieren:
+ INT VAR i;
+ FOR i FROM max index + 1 UPTO index REP
+ liste [i] := ""
+ END REP;
+ max index := index.
+
+namens eintrag:
+ get name (index, aktueller eintrag);
+ WHILE length (aktueller eintrag) < 15 REP
+ aktueller eintrag CAT " "
+ END REP;
+ aktueller eintrag CAT ":".
+END PROC in die liste;
+
+TEXT VAR zeile;
+
+PROC in dump file kopieren (TEXT CONST dump file):
+ put ("Ausgabedatei erstellen");
+ line;
+ f := sequential file (output, dump file);
+ INT VAR i;
+ kopieren und ggf fehlermeldung;
+ modify (f);
+ ggf sortieren;
+ zeile ggf aufspalten.
+
+kopieren und ggf fehlermeldung:
+ FOR i FROM fi symbol UPTO max index REP
+ cout (i);
+ zeile := liste [i];
+ IF zeile <> ""
+ THEN ausgabe der referenz und ggf fehlermeldung
+ FI
+ ENDREP.
+
+ausgabe der referenz und ggf fehlermeldung:
+ putline (f, zeile);
+ ggf referencer fehlermeldung.
+
+ggf sortieren:
+ IF yes (dump file + " sortieren")
+ THEN sort (dump file);
+ FI.
+
+zeile ggf aufspalten:
+ i := 0;
+ to line (f, 1);
+ WHILE NOT eof (f) REP
+ i INCR 1;
+ cout (i);
+ read record (f, zeile);
+ ggf aufspalten
+ END REP.
+
+ggf aufspalten:
+INT VAR anf :: 1, ende :: pos (zeile, " ", 72);
+ IF ende > 0
+ THEN dummy := subtext (zeile, 1, ende - 1);
+ write record (f, dummy);
+ spalte bis restzeile auf;
+ dummy CAT subtext (zeile, anf);
+ write record (f, dummy);
+ FI;
+ down (f).
+
+spalte bis restzeile auf:
+ REP
+ dummy := " ";
+ anf := ende + 1;
+ ende := pos (zeile, " ", ende + 55);
+ down (f);
+ insert record (f);
+ IF ende <= 0
+ THEN LEAVE spalte bis restzeile auf
+ FI;
+ dummy CAT subtext (zeile, anf, ende - 1);
+ write record (f, dummy);
+ END REP.
+END PROC in dump file kopieren;
+
+PROC ggf referencer fehlermeldung:
+ name := subtext (zeile, 1, min( pos(zeile, " "), pos(zeile, ":")) - 1);
+ dummy := subtext (zeile, pos (zeile, ": ") + 2);
+ ueberdeckungs ueberpruefung;
+ not used ueberpruefung;
+ IF pos (dummy, "R") > 0
+ THEN refinement mehr als zweimal verwendet
+ FI.
+
+ueberdeckungs ueberpruefung:
+ IF pos (dummy, global text) > 0 AND pos (dummy, local text) > 0
+ THEN dummy2 := "und Zeile ";
+ dummy2 CAT text (nr (pos (dummy, local text)));
+ dummy2 CAT ": ";
+ dummy2 CAT name;
+ report referencer error
+ (5, nr (pos (dummy, global text)), dummy2)
+ FI.
+
+not used ueberpruefung:
+ IF pos (dummy, " ") = 0 AND
+ (pos (dummy, global text) > 0 OR pos (dummy, local text) > 0 OR
+ pos (dummy, refinement text) > 0)
+ THEN not used fehlermeldung
+ FI.
+
+not used fehlermeldung:
+ report referencer error
+ (8, nr (length (dummy) - length (local text) + 1), name).
+
+refinement mehr als zweimal verwendet:
+ INT VAR refinement deklarationen :: 0,
+ refinement aufrufe :: 0,
+ anf :: 1;
+ WHILE pos (dummy,"R", anf) > 0 REP
+ refinement deklarationen INCR 1;
+ anf := pos (dummy, "R", anf) + 1
+ END REP;
+ anf := 1;
+ WHILE pos (dummy, " ", anf) > 0 REP
+ refinement aufrufe INCR 1;
+ anf := pos (dummy, " ", anf) + 1
+ END REP;
+ IF refinement deklarationen = 1
+ THEN IF refinement aufrufe > 1
+ THEN report referencer error
+ (6, nr (pos (dummy, refinement text)), name)
+ ELIF refinement aufrufe = 0
+ THEN report referencer error
+ (7, nr (pos (dummy, refinement text)), name)
+ FI
+ ELIF refinement deklarationen > 1
+ THEN IF 2 * refinement deklarationen - 1 > refinement aufrufe
+ THEN report referencer error (9, 0, name)
+ ELIF 2 * refinement deklarationen - 1 < refinement aufrufe
+ THEN report referencer error (10, 0, name)
+ FI
+ FI.
+END PROC ggf referencer fehlermeldung;
+
+INT PROC nr (INT CONST ende):
+ INT VAR von :: ende - 1;
+ WHILE von > 0 AND ((dummy SUB von) >= "0" AND (dummy SUB von) <= "9") REP
+ von DECR 1
+ END REP;
+ int (subtext (dummy, von + 1, ende - 1))
+END PROC nr;
+
+END PACKET referencer2;
diff --git a/system/std.zusatz/1.7.3/src/reporter b/system/std.zusatz/1.7.3/src/reporter new file mode 100644 index 0000000..13e76b5 --- /dev/null +++ b/system/std.zusatz/1.7.3/src/reporter @@ -0,0 +1,479 @@ +PACKET reporter routines DEFINES generate counts,
+ count on,
+ count off,
+ generate reports,
+ eliminate reports,
+ assert,
+ report on,
+ report off,
+ report:
+
+(* Programm zur Ablaufverfolgung von ELAN Programmen. Das Programm
+ verfolgt Prozedur- und Refinementaufrufe ('trace') und erstellt
+ eine Haeufigkeitszaehlung ('frequency count') und beachtet 'assertions'.
+
+ Autor: Rainer Hahn
+ Letzte Aenderung: 11.01.84
+ Ausgabe der Gesamtaufrufe (Jan. 84)
+*)
+
+FILE VAR input file;
+
+INT VAR zeilen nr,
+ type;
+
+TEXT VAR zeile,
+ dummy,
+ dummy1,
+ symbol;
+
+LET quadro fis = "####",
+ triple fis = "###",
+ double fis = "##",
+
+ tag = 1 ;
+
+DATASPACE VAR ds := nilspace;
+BOUND ROW max STRUCT (INT anzahl, BOOL proc) VAR zaehlwerk;
+
+LET max = 2000;
+
+(******************* gen report-Routinen ******************************)
+
+PROC generate reports:
+ generate reports (last param)
+END PROC generate reports;
+
+PROC generate reports (TEXT CONST name):
+ disable stop;
+ gen trace statements (name);
+ IF is error AND error message = "ende"
+ THEN clear error
+ FI;
+ last param (name);
+ enable stop.
+END PROC generate reports;
+
+PROC gen trace statements (TEXT CONST name):
+ enable stop;
+ IF exists (name)
+ THEN input file := sequential file (modify, name)
+ ELSE errorstop ("input file does not exist")
+ FI;
+ input file modifizieren
+END PROC gen trace statements;
+
+(*************************** Test file modifizieren *****************)
+
+PROC input file modifizieren:
+ zeilen nr := 1;
+ to first record (input file);
+ WHILE NOT eof (input file) REP
+ lese zeile;
+ IF triple fis symbol
+ THEN wandele in quadro fis
+ FI;
+ IF proc oder op symbol
+ THEN verarbeite operator oder prozedurkopf
+ ELIF refinement symbol
+ THEN verarbeite ggf refinements
+ FI;
+ down (input file)
+ END REP.
+
+triple fis symbol:
+ pos (zeile, triple fis) > 0 AND
+ (pos (zeile, triple fis) <> pos (zeile, quadro fis)).
+
+wandele in quadro fis:
+ change all (zeile, triple fis, quadro fis);
+ write record (input file, zeile).
+
+proc oder op symbol:
+ pos (zeile, "PROC") > 0 OR pos (zeile, "OP") > 0.
+
+verarbeite operator oder prozedurkopf:
+ IF NOT (pos (zeile, "END") > 0)
+ THEN scanne kopf;
+ insertiere trace anweisung
+ FI.
+
+scanne kopf:
+ scan (zeile);
+ REP
+ next symbol (symbol, type);
+ IF ende der zeile gescannt
+ THEN vorwaerts;
+ lese zeile;
+ continue scan (zeile);
+ next symbol (symbol, type)
+ FI
+ UNTIL symbol = "PROC" OR symbol = "OP" END REP;
+ baue trace statement fuer kopf auf.
+
+baue trace statement fuer kopf auf:
+ dummy := double fis;
+ dummy CAT "report(""";
+ dummy CAT symbol;
+ dummy CAT " ";
+ IF ende der zeile gescannt
+ THEN vorwaerts;
+ lese zeile;
+ continue scan (zeile)
+ FI;
+ next symbol (symbol, type);
+ dummy CAT symbol;
+ dummy CAT " ";
+ next symbol (symbol, type);
+ IF type = tag
+ THEN dummy CAT symbol
+ FI.
+
+ende der zeile gescannt:
+ type >= 7.
+
+insertiere trace anweisung:
+ WHILE pos (zeile, ":") = 0 REP
+ vorwaerts;
+ lese zeile
+ END REP;
+ schreibe zeile mit report statement.
+
+refinement symbol:
+ INT CONST point pos := pos (zeile, ".") ;
+ point pos > 0 AND point pos >= length (zeile) - 1.
+
+verarbeite ggf refinements:
+ ueberlies leere zeilen ;
+ IF ist wirklich refinement
+ THEN insertiere report fuer refinement
+ FI .
+
+ueberlies leere zeilen :
+ REP
+ vorwaerts;
+ lese zeile
+ UNTIL pos (zeile, ""33"", ""254"", 1) > 0 PER .
+
+ist wirklich refinement :
+ scan (zeile) ;
+ next symbol (symbol, type) ;
+ next symbol (symbol) ;
+ symbol = ":" AND type = tag .
+
+insertiere report fuer refinement:
+ dummy := double fis;
+ dummy CAT "report(""";
+ dummy1 := subtext (zeile, 1, pos (zeile, ":") - 1);
+ dummy CAT dummy1;
+ schreibe zeile mit report statement
+END PROC input file modifizieren;
+
+PROC schreibe zeile mit report statement:
+ dummy CAT """);";
+ dummy CAT double fis;
+ IF doppelpunkt steht am ende der zeile
+ THEN (********** bei neuer Compiler-Version aendern:
+ fuelle zeile ggf auf 75 spalten auf;
+ zeile CAT dummy
+ die naechste drei zeilen dann loeschen **************)
+ down (input file);
+ insert record (input file);
+ write record (input file, dummy)
+ ELSE insert char (dummy, ":", 1);
+ change (zeile, ":", dummy);
+ write record (input file, zeile)
+ FI.
+
+doppelpunkt steht am ende der zeile:
+ pos (zeile, ":") >= length (zeile) - 1.
+
+(* Kommentarklammern beineuer Compiler Version hier weg:
+fuelle zeile ggf auf 75 spalten auf:
+ IF length (zeile) < 75
+ THEN dummy1 := (75 - length (zeile)) * " ";
+ zeile CAT dummy1
+ FI.*)
+END PROC schreibe zeile mit report statement;
+
+PROC vorwaerts:
+ down (input file);
+ IF eof (input file)
+ THEN errorstop ("ende")
+ FI
+END PROC vorwaerts;
+
+PROC lese zeile:
+ read record (input file, zeile);
+ cout (zeilen nr);
+ zeilen nr INCR 1
+END PROC lese zeile;
+
+(************************ eliminate reports-Routinen ******************)
+
+PROC eliminate reports:
+ eliminate reports (last param)
+END PROC eliminate reports;
+
+PROC eliminate reports (TEXT CONST name):
+ disable stop;
+ eliminate statements (name);
+ IF is error AND error message = "ende"
+ THEN clear error
+ FI;
+ last param (name);
+ enable stop.
+END PROC eliminate reports;
+
+PROC eliminate statements (TEXT CONST name):
+ enable stop;
+ IF exists (name)
+ THEN input file := sequential file (modify, name)
+ ELSE errorstop ("input file does not exist")
+ FI;
+ statements entfernen.
+
+statements entfernen:
+ to first record (input file);
+ zeilen nr := 1;
+ WHILE NOT eof (input file) REP
+ lese zeile;
+ IF pos (zeile, double fis) > 0
+ THEN eliminiere zeichenketten in dieser zeile
+ ELSE down (input file)
+ FI
+ END REP.
+
+eliminiere zeichenketten in dieser zeile:
+ INT VAR anfang := pos (zeile, double fis);
+ WHILE es ist noch etwas zu eliminieren REP
+ IF es ist ein quadro fis
+ THEN wandele es in ein triple fis
+ ELIF es ist ein triple fis
+ THEN lass diese sequenz stehen
+ ELSE entferne zeichenkette
+ FI
+ END REP;
+ IF zeile ist jetzt leer
+ THEN delete record (input file)
+ ELSE write record (input file, zeile);
+ down (input file)
+ FI.
+
+es ist noch etwas zu eliminieren:
+ anfang > 0.
+
+es ist ein quadro fis:
+ pos (zeile, quadro fis, anfang) = anfang.
+
+wandele es in ein triple fis:
+ delete char (zeile, anfang);
+ anfang := pos (zeile, double fis, anfang + 3).
+
+es ist ein triple fis:
+ pos (zeile, triple fis, anfang) = anfang.
+
+lass diese sequenz stehen:
+ anfang := pos (zeile, triple fis, anfang + 1) + 3.
+
+entferne zeichenkette:
+ INT VAR end := pos (zeile, double fis, anfang+2) ;
+ IF end > 0
+ THEN change (zeile, anfang, end + 1, "");
+ anfang := pos (zeile, double fis, anfang)
+ ELSE anfang := pos (zeile, double fis, anfang+2)
+ FI .
+
+zeile ist jetzt leer:
+ pos (zeile, ""33"", ""254"", 1) = 0.
+END PROC eliminate statements;
+
+(********************** Trace-Routinen *******************************)
+
+FILE VAR trace file;
+
+BOOL VAR trace on, haeufigkeit on;
+
+PROC report (TEXT CONST message):
+ IF NOT exists ("TRACE")
+ THEN trace file := sequential file (output, "TRACE");
+ trace on := TRUE;
+ haeufigkeit on := FALSE;
+ FI;
+ BOOL CONST ist prozedur ::
+ (pos (message, "PROC") > 0 OR pos (message, "OP") > 0);
+ IF trace on
+ THEN ablauf verfolgung
+ FI;
+ IF haeufigkeit on
+ THEN haeufigkeits zaehlung (ist prozedur)
+ FI.
+
+ablauf verfolgung:
+ dummy := text (pcb (1));
+ dummy CAT ": ";
+ IF NOT ist prozedur
+ THEN dummy CAT " "
+ FI;
+ dummy CAT message;
+ putline (trace file, dummy).
+END PROC report;
+
+PROC report (TEXT CONST message, INT CONST value):
+ report (message, text (value))
+END PROC report;
+
+PROC report (TEXT CONST message, REAL CONST value):
+ report (message, text (value))
+END PROC report;
+
+PROC report (TEXT CONST message, TEXT CONST value):
+ dummy1 := message;
+ dummy1 CAT ": ";
+ dummy1 CAT value;
+ report (dummy1)
+END PROC report;
+
+PROC report (TEXT CONST message, BOOL CONST value):
+ dummy1 := message;
+ dummy1 CAT ": ";
+ IF value
+ THEN dummy1 CAT "TRUE"
+ ELSE dummy1 CAT "FALSE"
+ FI;
+ report (dummy1)
+END PROC report;
+
+PROC report on:
+ trace on := TRUE;
+ dummy1 := "REPORT ---> ON";
+ report (dummy1)
+END PROC report on;
+
+PROC report off:
+ dummy1 := "REPORT ---> OFF";
+ report (dummy1);
+ trace on := FALSE;
+END PROC report off;
+
+PROC assert (BOOL CONST value):
+ assert ("", value)
+END PROC assert;
+
+PROC assert (TEXT CONST message, BOOL CONST value):
+ dummy1 := "ASSERTION:";
+ dummy1 CAT message;
+ dummy1 CAT " ---> ";
+ IF value
+ THEN dummy1 CAT "TRUE"
+ ELSE line;
+ put ("ASSERTION:");
+ put (message);
+ put ("---> FALSE");
+ line;
+ IF yes ("weiter")
+ THEN dummy1 CAT "FALSE"
+ ELSE errorstop ("assertion failed")
+ FI
+ FI;
+ report (dummy1)
+END PROC assert;
+
+(************************** haeufigkeits-zaehlung ****************)
+
+PROC count on:
+ report ("COUNT ---> ON");
+ haeufigkeit on := TRUE;
+ initialisiere haeufigkeit.
+
+initialisiere haeufigkeit:
+ INT VAR i;
+ forget (ds);
+ ds := nilspace;
+ zaehlwerk := ds;
+ FOR i FROM 1 UPTO max REP
+ zaehlwerk [i] . anzahl := 0
+ END REP
+END PROC count on;
+
+PROC count off:
+ report ("COUNT ---> OFF");
+ haeufigkeit on := FALSE
+END PROC count off;
+
+PROC haeufigkeits zaehlung (BOOL CONST ist prozedur):
+ IF pcb (1) <= max
+ THEN zaehlwerk [pcb (1)]. anzahl INCR 1;
+ zaehlwerk [pcb (1)] . proc := ist prozedur
+FI
+END PROC haeufigkeits zaehlung;
+
+PROC generate counts:
+ generate counts (last param)
+END PROC generate counts;
+
+PROC generate counts (TEXT CONST name):
+ disable stop;
+ insert counts (name);
+ last param (name);
+ enable stop.
+END PROC generate counts;
+
+PROC insert counts (TEXT CONST name):
+ enable stop;
+ IF exists (name)
+ THEN input file := sequential file (modify, name)
+ ELSE errorstop ("input file does not exist")
+ FI;
+ counts insertieren;
+ dataspace loeschen;
+ statistik ausgeben.
+
+counts insertieren:
+ REAL VAR gesamt aufrufe :: 0.0,
+ proc aufrufe :: 0.0,
+ andere aufrufe :: 0.0;
+ zeilen nr := 1;
+ WHILE zeilennr <= lines (input file) REP
+ cout (zeilen nr);
+ IF zaehlwerk [zeilen nr] . anzahl > 0
+ THEN anzahl aufrufe in die eingabe zeile einfuegen;
+ aufrufe mitzaehlen
+ FI;
+ zeilen nr INCR 1
+ END REP.
+
+anzahl aufrufe in die eingabe zeile einfuegen:
+ to line (input file, zeilen nr);
+ read record (input file, zeile);
+ dummy := double fis;
+ dummy1 := text (zaehlwerk [zeilen nr] . anzahl);
+ dummy CAT dummy1;
+ dummy CAT double fis;
+ change (zeile, 1, 0, dummy);
+ write record (input file, zeile).
+
+aufrufe mitzaehlen:
+ gesamt aufrufe INCR real (zaehlwerk [zeilen nr] . anzahl);
+ IF zaehlwerk [zeilen nr] . proc
+ THEN proc aufrufe INCR real (zaehlwerk [zeilen nr] . anzahl)
+ ELSE andere aufrufe INCR real (zaehlwerk [zeilen nr] . anzahl)
+ FI.
+
+dataspace loeschen:
+ forget (ds).
+
+statistik ausgeben:
+ line (2);
+ put ("Anzahl der Gesamtaufrufe:");
+ put (gesamt aufrufe);
+ line;
+ put ("davon:");
+ line;
+ put (proc aufrufe); put ("Prozeduren oder Operatoren");
+ line;
+ put (andere aufrufe); put ("Refinements und andere");
+ line.
+END PROC insert counts;
+
+END PACKET reporter routines;
diff --git a/system/std.zusatz/1.7.3/src/scheduler b/system/std.zusatz/1.7.3/src/scheduler new file mode 100644 index 0000000..7a76f10 --- /dev/null +++ b/system/std.zusatz/1.7.3/src/scheduler @@ -0,0 +1,419 @@ +
+PACKET std schedule strategy DEFINES (* Autor: J.Liedtke *)
+ (* Stand: 15.10.82 *)
+ strategic decision :
+
+
+PROC strategic decision
+ (INT CONST foreground workers, background workers,
+ REAL CONST fore cpu load, back cpu load, paging load,
+ INT VAR lowest activation prio, max background tasks) :
+
+ IF no background permitted
+ THEN lowest activation prio := 0 ;
+ max background tasks := 0
+ ELSE lowest activation prio := 10 ;
+ select max background tasks
+ FI .
+
+no background permitted :
+ foreground workers > 0 AND fore cpu load > 0.03 .
+
+select max background tasks :
+ IF fore cpu load > 0.01
+ THEN max background tasks := 1
+ ELIF paging load < 0.07
+ THEN max background tasks := 3
+ ELIF paging load < 0.15
+ THEN max background tasks := 2
+ ELSE max background tasks := 1
+ FI .
+
+ENDPROC strategic decision ;
+
+ENDPACKET std schedule strategy ;
+
+
+ (* Autor: J.Liedtke*)
+PACKET eumelmeter DEFINES (* Stand: 11.10.83 *)
+
+ init log ,
+ log :
+
+
+LET snapshot interval = 590.0 ;
+
+REAL VAR next snapshot time ,
+ time , timex ,
+ paging wait , paging wait x ,
+ paging busy , paging busy x ,
+ fore cpu , fore cpu x ,
+ back cpu , back cpu x ,
+ system cpu , system cpu x ,
+ delta t ;
+INT VAR storage max, used ;
+TEXT VAR record ;
+
+PROC init log :
+
+ time := clock (1) ;
+ paging wait := clock (2) ;
+ paging busy := clock (3) ;
+ fore cpu := clock (4) ;
+ back cpu := clock (5) ;
+ system cpu := clock (6) ;
+ next snapshot time := time + snapshot interval
+
+ENDPROC init log ;
+
+PROC log (INT CONST active terminals, active background) :
+
+ new snapshot time if was clock reset ;
+ IF clock (1) >= next snapshot time
+ THEN save values ;
+ get new values ;
+ create stat record ;
+ put log (record) ;
+ define next snapshot time
+ FI .
+
+new snapshot time if was clock reset :
+ IF clock (1) < next snapshot time - snapshot interval
+ THEN next snapshot time := clock (1)
+ FI .
+
+save values :
+ time x := time ;
+ paging wait x := paging wait ;
+ paging busy x := paging busy ;
+ fore cpu x := fore cpu ;
+ back cpu x := back cpu ;
+ system cpu x := system cpu .
+
+get new values :
+ time := clock (1) ;
+ paging wait := clock (2) ;
+ paging busy := clock (3) ;
+ fore cpu := clock (4) ;
+ back cpu := clock (5) ;
+ system cpu := clock (6) ;
+ storage (storage max, used) .
+
+create stat record :
+ record := text (used, 5) ;
+ record CAT text (active terminals,3) ;
+ record CAT text (active background,3) ;
+ delta t := (time - time x) ;
+ percent (paging wait, paging wait x) ;
+ percent (paging busy, paging busy x) ;
+ percent (fore cpu, fore cpu x) ;
+ percent (back cpu, back cpu x) ;
+ percent (system cpu, system cpu x) ;
+ percent (last, 0.0) ;
+ percent (nutz, 0.0) .
+
+last : paging wait + paging busy + fore cpu + back cpu + system cpu
+ - paging waitx - paging busyx - fore cpux - back cpux - system cpux .
+
+nutz : time - paging wait - system cpu
+ - timex + paging waitx + system cpux .
+
+define next snapshot time :
+ next snapshot time := time + snapshot interval .
+
+ENDPROC log ;
+
+PROC percent (REAL CONST neu, alt ) :
+
+ record CAT text ( (neu-alt) / delta t * 100.0, 6,1) + "%"
+
+ENDPROC percent ;
+
+ENDPACKET eumelmeter ;
+
+
+
+PACKET background que manager DEFINES (* Autor: J.Liedtke *)
+ (* Stand: 15.10.82 *)
+ into background que ,
+ delete from background que ,
+ get first from background que ,
+ get next from background que :
+
+LET que size = 100 ,
+ ENTRY = STRUCT (TASK task, INT class) ;
+
+INT VAR end of que := 0 ,
+ actual entry pos ;
+
+ROW que size ENTRY VAR que ;
+
+
+PROC into background que (TASK CONST task) :
+
+ INT VAR class := prio (task) ;
+ IF end of que = que size
+ THEN delete all not existing tasks
+ FI ;
+ check whether already in que ;
+ IF already in que
+ THEN IF in same class
+ THEN LEAVE into background que
+ ELSE delete from background que (task) ;
+ into background que (task)
+ FI
+ ELSE insert new entry
+ FI .
+
+check whether already in que :
+ INT VAR entry pos := 1 ;
+ WHILE entry pos <= end of que REP
+ IF que (entry pos).task = task
+ THEN LEAVE check whether already in que
+ FI ;
+ entry pos INCR 1
+ PER .
+
+already in que : entry pos <= end of que .
+
+in same class : que (entry pos).class = class .
+
+insert new entry :
+ end of que INCR 1 ;
+ que (end of que) := ENTRY:( task, class ) .
+
+delete all not existing tasks :
+ INT VAR j ;
+ FOR j FROM 1 UPTO end of que REP
+ TASK VAR examined := que (j).task ;
+ IF NOT exists (examined)
+ THEN delete from background que (examined)
+ FI
+ PER .
+
+ENDPROC into background que ;
+
+PROC delete from background que (TASK CONST task) :
+
+ search for entry ;
+ IF entry found
+ THEN delete entry ;
+ update actual entry pos
+ FI .
+
+search for entry :
+ INT VAR entry pos := 1 ;
+ WHILE entry pos <= end of que REP
+ IF que (entry pos).task = task
+ THEN LEAVE search for entry
+ FI ;
+ entry pos INCR 1
+ PER .
+
+entry found : entry pos <= end of que .
+
+delete entry :
+ INT VAR i ;
+ FOR i FROM entry pos UPTO end of que - 1 REP
+ que (i) := que (i+1)
+ PER ;
+ end of que DECR 1 .
+
+update actual entry pos :
+ IF actual entry or following one deleted
+ THEN actual entry pos DECR 1
+ FI .
+
+actual entry or following one deleted :
+ entry pos >= actual entry pos .
+
+ENDPROC delete from background que ;
+
+PROC get first from background que (TASK VAR task, INT CONST lowest class) :
+
+ actual entry pos := 0 ;
+ get next from background que (task, lowest class)
+
+ENDPROC get first from background que ;
+
+PROC get next from background que (TASK VAR task, INT CONST lowest class) :
+
+ search next entry of permitted class ;
+ IF actual entry pos <= end of que
+ THEN task := que (actual entry pos).task
+ ELSE task := niltask
+ FI .
+
+search next entry of permitted class :
+ REP
+ actual entry pos INCR 1
+ UNTIL actual entry pos > end of que
+ COR que (actual entry pos).class <= lowest class PER.
+
+ENDPROC get next from background que ;
+
+ENDPACKET background que manager ;
+
+
+
+PACKET scheduler DEFINES (* Autor: J.Liedtke *)
+ (* Stand: 09.12.82 *)
+ scheduler :
+
+
+LET std background prio = 7 ,
+ highest background prio = 5 ,
+ long slice = 6000 ,
+ short slice = 600 ,
+ blocked busy = 4 ;
+
+INT VAR slice ,
+ foreground workers ,
+ background workers ;
+
+BOOL VAR is logging ;
+
+REAL VAR fore cpu load , back cpu load , paging load ;
+
+
+access catalogue ;
+TASK CONST ur task := brother (supervisor) ;
+
+TASK VAR actual task ;
+
+
+PROC scheduler :
+ IF yes ("mit eumelmeter")
+ THEN is logging := TRUE
+ ELSE is logging := FALSE
+ FI ;
+ task password ("-") ;
+ break ;
+ set autonom ;
+ command dialogue (FALSE) ;
+ forget ("scheduler", quiet) ;
+ disable stop;
+ REP scheduler operation;
+ clear error
+ PER;
+
+END PROC scheduler;
+
+PROC scheduler operation:
+ enable stop;
+ IF is logging
+ THEN init log
+ FI;
+ slice := short slice ;
+ init system load moniting ;
+ REP
+ pause (slice) ;
+ monit system load ;
+ look at all active user tasks and block background workers ;
+ activate next background workers if possible ;
+ IF is logging
+ THEN log (foreground workers, background workers)
+ FI
+ PER .
+
+init system load moniting :
+ REAL VAR
+ time x := clock (1) ,
+ fore cpu x := clock (4) ,
+ back cpu x := clock (5) ,
+ paging x := clock (2) + clock (3) .
+
+monit system load :
+ REAL VAR interval := clock (1) - time x ;
+ fore cpu load := (clock (4) - fore cpu x) / interval ;
+ back cpu load := (clock (5) - back cpu x) / interval ;
+ paging load := (clock (2) + clock (3) - paging x) / interval ;
+ time x := clock (1) ;
+ fore cpu x := clock (4) ;
+ back cpu x := clock (5) ;
+ paging x := clock (2) + clock (3) .
+
+ENDPROC scheduler operation;
+
+PROC look at all active user tasks and block background workers :
+
+ foreground workers := 0 ;
+ background workers := 0 ;
+ actual task := myself ;
+ next active (actual task) ;
+ WHILE NOT (actual task = myself) REP
+ IF actual task < ur task
+ THEN look at this task
+ FI ;
+ next active (actual task)
+ END REP .
+
+look at this task :
+ IF channel (actual task) >= 0
+ THEN foreground workers INCR 1
+ ELSE background workers INCR 1 ;
+ block actual task if simple worker
+ FI .
+
+block actual task if simple worker :
+ IF son (actual task) = niltask
+ THEN pause (5) ;
+ block (actual task) ;
+ IF status (actual task) = blocked busy
+ THEN set background prio ;
+ into background que (actual task)
+ ELIF prio (actual task) < highest background prio
+ THEN unblock (actual task)
+ FI
+ FI .
+
+set background prio :
+ IF prio (actual task) < highest background prio
+ THEN prio (actual task, std background prio)
+ FI .
+
+ENDPROC look at all active user tasks and block background workers ;
+
+PROC activate next background workers if possible :
+
+ INT VAR lowest activation prio ,
+ max background workers ,
+ active background workers := 0 ;
+
+ strategic decision (foreground workers, background workers,
+ fore cpu load, back cpu load, paging load,
+ lowest activation prio, max background workers) ;
+
+ IF background permitted
+ THEN try to activate background workers
+ FI ;
+ IF active background workers > 0
+ THEN slice := short slice
+ ELSE slice := long slice
+ FI .
+
+background permitted : max background workers > 0 .
+
+try to activate background workers :
+ get first from background que (actual task, lowest activation prio) ;
+ IF NOT is niltask (actual task)
+ THEN delete from background que (actual task)
+ FI ;
+
+ WHILE active background workers < max background workers REP
+ IF is niltask (actual task)
+ THEN LEAVE try to activate background workers
+ ELIF status (actual task) <> blocked busy
+ THEN delete from background que (actual task)
+ ELSE
+ unblock (actual task) ;
+ active background workers INCR 1
+ FI ;
+ get next from background que (actual task, lowest activation prio)
+ PER .
+
+ENDPROC activate next background workers if possible ;
+
+ENDPACKET scheduler ;
+
+scheduler;
diff --git a/system/std.zusatz/1.7.3/src/spool manager b/system/std.zusatz/1.7.3/src/spool manager new file mode 100644 index 0000000..8f9ab9f --- /dev/null +++ b/system/std.zusatz/1.7.3/src/spool manager @@ -0,0 +1,377 @@ +PACKET spool manager DEFINES (* Autor: J. Liedtke *)
+ spool manager, server channel: (* 21.05.84 *)
+
+
+LET que size = 100 ,
+
+ ack = 0 ,
+ nak = 1 ,
+ error nak = 2 ,
+ second phase ack = 5 ,
+
+ fetch code = 11 ,
+ save code = 12 ,
+ erase code = 14 ,
+ list code = 15 ,
+ all code = 17 ,
+ continue code = 100,
+
+ empty = 0 ,
+ used = 1 ;
+
+TASK VAR order task , waiting server , from task , server ;
+INT VAR order code , reply , first , last , list index ;
+
+DATASPACE VAR ds ;
+
+TEXT VAR from title ;
+
+BOUND STRUCT (TEXT name, write pass, read pass) VAR msg ;
+BOUND TEXT VAR error msg ;
+BOUND STRUCT (TEXT tname, tpass, TASK task) VAR sv msg ;
+
+FILE VAR list file ;
+TEXT VAR entry name, entry task;
+
+INT VAR command index , params ;
+TEXT VAR command line, param 1, param 2 ;
+
+LET spool command list =
+"break:1.0start:2.01stop:4.0first:5.0killer:6.0 " ;
+
+
+LET ENTRY = STRUCT (TEXT title, TASK origin, DATASPACE space, INT status) ;
+
+ROW que size ENTRY VAR que ;
+
+
+INT VAR server chan := 0;
+
+PROC server channel (INT CONST ch):
+ server chan := ch
+
+END PROC server channel;
+
+INT PROC server channel:
+ server chan
+
+END PROC server channel;
+
+PROC spool manager (PROC server start) :
+ INT VAR old heap size := heap size;
+ begin (PROC server start, server) ;
+ set autonom ;
+ break ;
+ disable stop ;
+ first := 1 ;
+ last := 1 ;
+ from task := niltask ;
+ waiting server := niltask ;
+ spool ;
+ clear error ;
+ forget all dataspaces.
+
+forget all dataspaces :
+ INT VAR i ;
+ FOR i FROM 1 UPTO que size REP
+ forget (que (i).space)
+ PER .
+
+spool:
+ REP
+ wait (ds, order code, order task) ;
+ IF order code = fetch code THEN out of que
+ ELIF order code = save code THEN prepare into que
+ ELIF order code = second phase ack THEN into que
+ ELIF order code = erase code THEN delete que entry
+ ELIF order code = list code THEN list spool
+ ELIF order code = all code THEN y all
+ ELIF order code >= continue code
+ AND order task = supervisor THEN spool command (PROC server start)
+ FI;
+ clear error
+ PER;
+ collect heap garbage if necessary.
+
+collect heap garbage if necessary:
+ IF heap size > old heap size + 2
+ THEN collect heap garbage;
+ old heap size := heap size
+ FI.
+
+ENDPROC spool manager ;
+
+PROC out of que :
+
+ forget (ds) ;
+ IF NOT (order task < myself)
+ THEN error ("not parent")
+ ELIF que empty
+ THEN waiting server := order task
+ ELSE send (order task, ack, que (first).space) ;
+ inc first
+ FI .
+
+que empty : first = last .
+
+ENDPROC out of que ;
+
+PROC inc first :
+
+ que (first).status := empty ;
+ REP
+ first := first MOD que size + 1 ;
+ UNTIL first = last OR que (first).status <> empty PER
+
+ENDPROC inc first ;
+
+PROC dec first :
+
+ first DECR 1 ;
+ IF first = 0
+ THEN first := que size
+ FI
+
+ENDPROC dec first ;
+
+PROC prepare into que :
+
+ msg := ds ;
+ from task := order task ;
+ from title := CONCR (msg).name ;
+ send (order task, second phase ack, ds) .
+
+ENDPROC prepare into que ;
+
+PROC into que :
+
+ IF order task = from task
+ THEN try entry into spool
+ ELSE send (order task, nak, ds)
+ FI .
+
+try entry into spool :
+ IF que full
+ THEN error ("spool overflow")
+ ELSE entry (que (last)) ;
+ last := next (last) ;
+ send (order task, ack, ds) ;
+ awake server if necessary
+ FI .
+
+awake server if necessary :
+ IF NOT is niltask (waiting server)
+ THEN send (waiting server, ack, que (first).space , reply) ;
+ IF reply = ack
+ THEN waiting server := niltask ;
+ inc first
+ FI
+ FI .
+
+que full : first = next (last) .
+
+ENDPROC into que ;
+
+PROC entry (ENTRY VAR que entry) :
+
+ que entry.title := from title ;
+ que entry.origin := from task ;
+ que entry.space := ds ;
+ que entry.status := used ;
+
+ENDPROC entry ;
+
+INT PROC next (INT CONST index) :
+
+ index MOD que size + 1
+
+ENDPROC next ;
+
+
+PROC delete que entry :
+
+ msg := ds ;
+ INT VAR index := first ;
+ WHILE index <> last REP
+ IF entry found
+ THEN erase entry (index) ;
+ send (order task, ack, ds) ;
+ LEAVE delete que entry
+ FI ;
+ index := next (index)
+ PER ;
+ error ("your file does not exist") .
+
+entry found :
+ entry.status = used CAND entry.origin = order task
+ CAND entry.title = CONCR (msg).name .
+
+entry : que (index) .
+
+ENDPROC delete que entry ;
+
+PROC erase entry (INT CONST index) :
+
+ entry.status := empty ;
+ forget (entry.space) ;
+ IF index = first
+ THEN inc first
+ FI .
+
+entry : que (index) .
+
+ENDPROC erase entry ;
+
+PROC list spool :
+
+ forget (ds) ;
+ ds := nilspace ;
+ list file := sequential file (output, ds) ;
+ to first que entry ;
+ get next que entry (entry name, entry task) ;
+ WHILE entry name <> "" REP
+ putline (list file, text (entry task, 15) + " : " + entry name);
+ get next que entry (entry name, entry task)
+ PER;
+ send (order task, ack, ds) .
+
+ENDPROC list spool ;
+
+BOUND THESAURUS VAR all thesaurus;
+
+PROC y all:
+ forget (ds);
+ ds := nilspace;
+ all thesaurus := ds;
+ all thesaurus := empty thesaurus;
+ to first que entry;
+ get next que entry (entry name, entry task); (* hier erster Eintrag *)
+ WHILE entryname <> "" REP
+ IF entry task = name (order task)
+ AND NOT (all thesaurus CONTAINS entry name)
+ THEN insert (all thesaurus, entry name)
+ FI;
+ get next que entry (entry name, entry task)
+ PER;
+ send (order task, ack, ds)
+
+END PROC y all;
+
+PROC to first que entry :
+
+ list index := first - 1
+
+ENDPROC to first que entry ;
+
+PROC get next que entry (TEXT VAR entry name, origin task name):
+
+ WHILE list index <> last REP
+ list index := next (list index)
+ UNTIL que (list index).status <> empty PER ;
+ IF que (list index).status = used
+ THEN origin task name := name (que (list index).origin) ;
+ entry name := que (list index).title
+ ELSE entry name := "";
+ origin task name := ""
+ FI .
+
+ENDPROC get next que entry ;
+
+PROC error (TEXT CONST error text) :
+
+ forget (ds) ;
+ ds := nilspace ;
+ error msg := ds ;
+ CONCR (error msg) := error text ;
+ send (order task, error nak, ds)
+
+ENDPROC error ;
+
+PROC spool command (PROC server start) :
+
+ enable stop ;
+ continue (order code - continue code) ;
+ command dialogue (TRUE) ;
+ disable stop ;
+ REP
+ get command ("gib spoolkommando :", command line);
+ analyze command (spool command list, command line, 3,
+ command index, params, param1, param2);
+ execute command
+ PER .
+
+execute command :
+ SELECT command index OF
+ CASE 1 : break cmd
+ CASE 2 : start cmd
+ CASE 3 : start channel cmd
+ CASE 4 : stop cmd
+ CASE 5 : first cmd
+ CASE 6 : killer cmd
+ OTHERWISE do (command line) END SELECT .
+
+start channel cmd:
+ server channel (int (param1));
+ start cmd;
+ break cmd.
+
+break cmd:
+ break; set autonom ; LEAVE spool command.
+
+start cmd :
+ IF is niltask (server)
+ THEN begin (PROC server start, server)
+ FI .
+
+stop cmd :
+ IF NOT is niltask (server)
+ THEN command dialogue (FALSE) ;
+ end (server) ;
+ server := niltask
+ FI .
+
+first cmd :
+ line ;
+ to first que entry ;
+ get next que entry (entry name, entry task);
+ IF entry name = ""
+ THEN LEAVE first cmd
+ FI ;
+ REP
+ get next que entry (entry name, entry task) ;
+ IF entry name = ""
+ THEN LEAVE first cmd
+ FI;
+ say (text (entry task, 15) + " : " + entry name) ;
+ IF yes (" als erstes")
+ THEN make to first entry ;
+ LEAVE first cmd
+ FI
+ PER .
+
+make to first entry :
+ IF first = next (last)
+ THEN errorstop ("spool overflow")
+ ELSE dec first ;
+ que (first) := que (list index) ;
+ erase entry (list index)
+ FI .
+
+
+killer cmd :
+ line ;
+ to first que entry ;
+ REP
+ get next que entry (entry name, entry task) ;
+ IF entry name = ""
+ THEN LEAVE killer cmd
+ FI ;
+ say (text (entry task, 15) + " : " + entry name) ;
+ IF yes (" loeschen")
+ THEN erase entry (list index)
+ FI
+ PER .
+
+ENDPROC spool command ;
+
+ENDPACKET spool manager ;
diff --git a/system/std.zusatz/1.7.3/src/std printer b/system/std.zusatz/1.7.3/src/std printer new file mode 100644 index 0000000..f00fa80 --- /dev/null +++ b/system/std.zusatz/1.7.3/src/std printer @@ -0,0 +1,434 @@ +PACKET std printer DEFINES reset printer, (* F. Klapper *)
+ new page, (* 21.05.84 *)
+ start,
+ printer cmd,
+ on,
+ off,
+ material,
+ papersize,
+ limit,
+ change type,
+ print text,
+ x pos,
+ y pos,
+ line:
+
+LET begin mark cmd = ""15"", (* Kommandos fr 'output buffer' *)
+ end mark cmd = ""14"",
+ bsp cmd = ""8"" ,
+ printercmd cmd = ""16"",
+ begin mark code = 15,
+ end mark code = 14,
+ bsp code = 8,
+ printercmd code = 16,
+
+ cr = ""13"", (* Steuerzeichen fr die Ausgabe *)
+ lf = ""10"",
+ underline char = "_",
+
+ inch = 2.54, (* Konstanten *)
+ max printer cmds per line = 10;
+
+INT CONST std length of paper :: 12 * y factor per inch,
+ std width of paper :: cm to x steps (13.2 * inch),
+ std limit :: cm to x steps (12.0 * inch),
+ std first line :: 5,
+ std first collumn :: cm to x steps (inch),
+
+ no xpos :: - 10; (* beliebige negative ganze Zahl *)
+
+INT VAR first collumn,
+ first line,
+ xlimit,
+ actual line,
+ x pos steps,
+ width of paper,
+ length of paper,
+ x pos mode;
+
+BOOL VAR block mode,
+ underline on, (* gibt durch on / off gesetzten Zustand an *)
+ underline out; (* gibt Zustand an der bis jetzt durch output buffer
+ ausgegebenen Stelle an *)
+TEXT VAR buffer,
+ x pos buffer,
+ left margin;
+
+ROW max printer cmds per line TEXT VAR cmd arry;
+INT VAR cmd pointer;
+
+ length of paper := std length of paper;
+ first line := std first line;
+ actual line := 0;
+ buffer := "";
+ reset printer;
+
+INT PROC cm to x steps (REAL CONST cm):
+ int ((abs (cm) * real (x factor per inch) / inch) + 0.5)
+END PROC cm to x steps;
+
+INT PROC cm to y steps (REAL CONST cm):
+ int ((abs (cm) * real (y factor per inch) / inch) + 0.5)
+END PROC cm to y steps;
+
+PROC start (REAL CONST x, y):
+ first collumn := cm to x steps (x);
+ first line := cm to y steps (y);
+ left margin := first collumn * " "
+END PROC start;
+
+PROC papersize (REAL CONST w, l):
+ width of paper := cm to x steps (w);
+ length of paper := cm to y steps (l);
+END PROC papersize;
+
+PROC limit (REAL CONST x):
+ xlimit := cm to x steps (x);
+END PROC limit;
+
+PROC on (TEXT CONST attribute):
+ IF (attribute SUB 1) = "u"
+ THEN underline on := TRUE;
+ buff CAT begin mark cmd
+ FI.
+
+buff:
+ IF xpos steps >= 0
+ THEN x pos buffer
+ ELSE buffer
+ FI.
+END PROC on;
+
+PROC off (TEXT CONST attribute):
+ IF (attribute SUB 1) = "u"
+ THEN underline on := FALSE;
+ buff CAT end mark cmd
+ FI.
+
+buff:
+ IF xpos steps >= 0
+ THEN x pos buffer
+ ELSE buffer
+ FI.
+END PROC off;
+
+PROC printer cmd (TEXT CONST cmd):
+ IF cmd pointer < max printer cmds per line
+ THEN cmd pointer INCR 1;
+ cmd arry (cmd pointer) := cmd;
+ buff CAT printercmd cmd
+ FI.
+
+buff:
+ IF xpos steps >= 0
+ THEN x pos buffer
+ ELSE buffer
+ FI.
+END PROC printer cmd;
+
+PROC material (TEXT CONST name of material):
+END PROC material;
+
+PROC change type (TEXT CONST name of type):
+ENDPROC change type;
+
+PROC reset printer :
+ new page; (* actual line := 0 *)
+ width of paper := std width of paper;
+ length of paper := std length of paper;
+ first line := std first line;
+ first collumn := std first collumn;
+ xlimit := std limit;
+ xpos mode := 0;
+ cmd pointer := 0;
+ x pos steps := no x pos;
+ buffer := "";
+ xpos buffer := "";
+ left margin := first collumn * " ";
+ block mode := FALSE;
+ underline on := FALSE;
+ underline out := FALSE;
+ENDPROC reset printer;
+
+PROC print text (TEXT CONST content, INT CONST mode):
+ IF x pos steps >= 0
+ THEN x pos buffer CAT content;
+ x pos mode := mode MOD 4;
+ block mode := FALSE
+ ELSE buffer CAT content ;
+ block mode := (mode MOD 4) = 3
+ FI.
+END PROC print text;
+
+PROC tab and print:
+ SELECT x pos mode OF
+ CASE 0: fill (buffer, " ", x pos steps);
+ CASE 1: fill (buffer, " ", x pos steps - outputlength (x pos buffer));
+ CASE 2: fill (buffer, " ",
+ x pos steps - outputlength (xpos buffer) DIV 2);
+ CASE 3: fill (buffer, " ", x pos steps);
+ block (x pos buffer, xlimit - x pos steps);
+ OTHERWISE
+ END SELECT;
+ buffer CAT x pos buffer;
+ x pos buffer := "";
+ x pos steps := no x pos.
+END PROC tab and print;
+
+INT PROC outputlength (TEXT CONST buff):
+ length (buff) - chars (buff, printercmd cmd) - chars (buff, begin mark cmd)
+ - chars (buff, end mark cmd) - chars (buff, bsp cmd) * 2
+END PROC outputlength;
+
+PROC x pos (REAL CONST cm):
+ IF x pos steps >= 0
+ THEN tab and print
+ FI;
+ IF underline on
+ THEN buffer CAT end mark cmd;
+ x pos buffer CAT begin mark cmd
+ FI;
+ x pos steps := cm to x steps (cm)
+END PROC x pos;
+
+PROC y pos (REAL CONST cm):
+ IF actual line = 0
+ THEN output linefeed (first line - actual line);
+ actual line := first line
+ FI;
+ output buffer;
+ INT VAR y lf steps := cm to y steps (cm);
+ output linefeed (y lf steps + first line - actual line);
+ actual line := first line + y lf steps.
+END PROC y pos;
+
+PROC line (REAL CONST proposed lf) :
+ IF actual line = 0
+ THEN output linefeed (first line - actual line);
+ actual line := first line
+ FI;
+ output buffer;
+ INT VAR done lf;
+ convert into min y steps (proposed lf, done lf);
+ output line feed (done lf);
+ actual line INCR done lf;
+END PROC line;
+
+PROC convert into min y steps (REAL CONST in, INT VAR out):
+ IF in < 0.001
+ THEN out := 0
+ ELSE out := int (in);
+ IF out < 1 THEN out := 1 FI
+ FI;
+ENDPROC convert into min y steps;
+
+PROC new page:
+ IF buffer <> ""
+ THEN line (1.0)
+ FI;
+ actual line := actual line MOD length of paper;
+ IF actual line > first line
+ THEN output pagefeed (length of paper - actual line);
+ actual line := 0
+ FI;
+END PROC new page;
+
+PROC output buffer:
+ IF x pos steps >= 0
+ THEN tab and print
+ ELIF block mode
+ THEN block (buffer, xlimit)
+ FI ;
+ TEXT VAR bsp buffer := "",
+ underline buffer := "";
+ INT VAR cmd pos := pos (buffer, ""1"", ""31"", 1),
+ akt cmd pointer := 0,
+ soon out := 0;
+ out (left margin);
+ put leading blanks not underlined;
+ WHILE cmd pos > 0
+ REP analyze cmd;
+ cmd pos := pos (buffer, ""1"", ""31"", cmd pos)
+ PER;
+ IF underline out
+ THEN fill (underline buffer, underline char, LENGTH buffer)
+ FI;
+ out buffer;
+ out bsp buffer;
+ out underline buffer;
+ buffer := "";
+ cmd pointer := 0.
+
+put leading blanks not underlined:
+ IF underline out
+ THEN INT VAR first non blank pos := pos (buffer, ""33"", ""254"", 1);
+ IF cmd pos > 0 CAND first non blank pos > 0
+ THEN fill (underline buffer, " ",
+ min (first non blank pos, cmd pos) - 1)
+ ELIF cmd pos > 0
+ THEN fill (underline buffer, " ", cmd pos - 1)
+ ELSE fill (underline buffer, " ", first non blank pos -1)
+ FI;
+ FI.
+
+analyze cmd:
+ SELECT code (buffer SUB cmd pos) OF
+ CASE bsp code : do bsp cmd
+ CASE begin mark code : do begin mark cmd
+ CASE end mark code : do end mark cmd
+ CASE printercmd code : do printercmd cmd
+ OTHERWISE
+ END SELECT.
+
+do bsp cmd:
+ fill (bsp buffer, " ", cmd pos - 2);
+ cmd pos DECR 1;
+ bsp buffer CAT (buffer SUB cmd pos);
+ delete char (buffer, cmd pos);
+ delete char (buffer, cmd pos).
+
+do begin mark cmd:
+ IF NOT underline out
+ THEN underline out := TRUE;
+ fill (underline buffer, " ", cmd pos -1);
+ delete char (buffer, cmd pos)
+ FI.
+
+do end mark cmd:
+ IF underline out
+ THEN underline out := FALSE;
+ fill (underline buffer, underline char, cmd pos - 1);
+ delete char (buffer, cmd pos)
+ FI.
+
+do printercmd cmd:
+ IF akt cmd pointer < cmd pointer
+ THEN akt cmd pointer INCR 1;
+ out subtext (buffer, soon out + 1, cmd pos - 1);
+ soon out := cmd pos - 1;
+ delete char (buffer, cmd pos);
+ out (cmd arry (akt cmd pointer))
+ FI.
+
+out buffer:
+ (* out (left margin) steht schon weiter oben *)
+ outsubtext (buffer, soon out + 1).
+
+out bsp buffer:
+ IF bsp buffer <> ""
+ THEN out (cr);
+ out (left margin);
+ out (bsp buffer)
+ FI.
+
+out underline buffer:
+ IF underline buffer <> ""
+ THEN out (cr);
+ out (left margin);
+ out (underline buffer)
+ FI.
+END PROC output buffer;
+
+PROC fill (TEXT VAR buff, TEXT CONST char, INT CONST len):
+ buff CAT (len - outputlength (buff)) * char
+END PROC fill;
+
+PROC output linefeed (INT CONST min y steps):
+ IF min y steps > 0
+ THEN out (cr);
+ out (min y steps * lf)
+ FI
+ENDPROC output linefeed ;
+
+PROC output pagefeed (INT CONST rest) :
+ out (cr) ;
+ rest TIMESOUT lf
+ENDPROC output pagefeed ;
+
+(********************* B L O C K **********************************)
+LET blank = " " ,
+ enumeration list = "-).:" ;
+
+INT VAR to insert,
+ nr of blanks ,
+ nr of big spaces ,
+ begin ;
+
+TEXT VAR small space ,
+ big space ;
+
+BOOL VAR right := TRUE ;
+
+PROC block (TEXT VAR blockline, INT CONST len):
+ to insert := len - outputlength (blockline);
+ nr of blanks := 0; begin:=0;
+ IF to insert <= 0 THEN LEAVE block FI;
+ IF to insert > (xlimit DIV 3 ) THEN LEAVE block FI;
+ mark the variable blanks;
+ IF nr of blanks <= 0 THEN LEAVE block FI;
+ right := NOT right;
+ compute spaces;
+ insert spaces.
+
+mark the variable blanks:
+ skip blanks ;
+ begin := pos(blockline,blank,begin+1);
+ IF (pos (enumeration list, (blockline SUB (begin-1))) > 0 )
+ THEN skip blanks ;
+ begin := pos(blockline,blank,begin+1);
+ FI;
+ WHILE begin > 0 REP
+ IF single blank gap
+ THEN change (blockline,begin,begin,""0"");
+ nr of blanks INCR 1;
+ ELSE skip blanks
+ FI;
+ begin := pos(blockline,blank,begin+1);
+ ENDREP.
+
+single blank gap :
+ ((blockline SUB (begin+1)) <> blank).
+
+skip blanks :
+ begin := pos (blockline, ""33"", ""254"", begin+1) .
+
+compute spaces:
+ INT VAR steps := to insert ;
+ INT VAR small := steps DIV nr of blanks;
+ nr of big spaces := steps MOD nr of blanks;
+ small space := (small+1) * blank ;
+ big space := small space ;
+ big space CAT blank .
+
+insert spaces:
+ IF right THEN insert big spaces on right side
+ ELSE insert big spaces on left side
+ FI.
+
+insert big spaces on right side:
+ INT VAR nr of small spaces := nr of blanks - nr of big spaces;
+ INT VAR i;
+ FOR i FROM 1 UPTO nr of small spaces REP
+ change (blockline, ""0"",small space)
+ ENDREP;
+ changeall (blockline,""0"",big space).
+
+insert big spaces on left side:
+ INT VAR j;
+ FOR j FROM 1 UPTO nr of big spaces REP
+ change (blockline,""0"",big space)
+ ENDREP;
+ changeall (blockline,""0"",small space).
+ENDPROC block;
+
+INT PROC chars (TEXT CONST text, char) :
+ INT VAR how many := 0 ,
+ cmd pos := pos (text, char) ;
+ WHILE cmd pos > 0 REP
+ how many INCR 1 ;
+ cmd pos := pos (text, char, cmd pos+1)
+ PER ;
+ how many
+ENDPROC chars ;
+
+ENDPACKET std printer ;
diff --git a/system/std.zusatz/1.7.3/src/std printer generator-M b/system/std.zusatz/1.7.3/src/std printer generator-M new file mode 100644 index 0000000..f07d31c --- /dev/null +++ b/system/std.zusatz/1.7.3/src/std printer generator-M @@ -0,0 +1,22 @@ +forget ("std printer generator/M", quiet) ;
+check off ;
+
+fetch ("minimal fonts routines", archive);
+fetch ("std printer", archive);
+fetch ("eumel printer", archive);
+fetch ("elan lister", archive);
+fetch ("spool manager", archive);
+fetch ("printer/M", archive);
+
+ins ("minimal fonts routines");
+ins ("std printer");
+ins ("eumel printer");
+ins ("elan lister");
+ins ("spool manager");
+run ("printer/M");
+
+PROC ins (TEXT CONST name):
+ insert (name);
+ forget (name, quiet)
+END PROC ins;
+
diff --git a/system/std.zusatz/1.7.3/src/std printer generator-S b/system/std.zusatz/1.7.3/src/std printer generator-S new file mode 100644 index 0000000..067df88 --- /dev/null +++ b/system/std.zusatz/1.7.3/src/std printer generator-S @@ -0,0 +1,15 @@ +forget ("std printer generator/S", quiet) ;
+check off ;
+
+ins ("minimal fonts routines");
+ins ("std printer");
+ins ("eumel printer");
+ins ("elan lister");
+ins ("printer/S");
+
+PROC ins (TEXT CONST name):
+ fetch (name, archive);
+ insert (name);
+ forget (name, quiet)
+END PROC ins;
+
diff --git a/system/std.zusatz/1.7.3/src/vector b/system/std.zusatz/1.7.3/src/vector new file mode 100644 index 0000000..fd1b0ef --- /dev/null +++ b/system/std.zusatz/1.7.3/src/vector @@ -0,0 +1,213 @@ +PACKET vector DEFINES VECTOR, :=, vector, (* Autor : H.Indenbirken *)
+ SUB, LENGTH, length, norm, (* Stand : 21.10.83 *)
+ nilvector, replace, =, <>,
+ +, -, *, /,
+ get, put :
+
+LET n = 4000;
+
+TYPE VECTOR = STRUCT (INT lng, TEXT elem);
+TYPE INITVECTOR = STRUCT (INT lng, REAL value);
+
+INT VAR i;
+TEXT VAR t :: "12345678";
+VECTOR VAR v :: nilvector;
+
+(****************************************************************************
+PROC dump (VECTOR CONST v) :
+ put line (text (v.lng) + " Elemente :");
+ FOR i FROM 1 UPTO v.lng
+ REP put line (text (i) + ": " + text (element i)) PER .
+
+element i :
+ v.elem RSUB i .
+
+END PROC dump;
+****************************************************************************)
+
+OP := (VECTOR VAR l, VECTOR CONST r) :
+ l.lng := r.lng;
+ l.elem := r.elem
+
+END OP :=;
+
+OP := (VECTOR VAR l, INITVECTOR CONST r) :
+ l.lng := r.lng;
+ replace (t, 1, r.value);
+ l.elem := r.lng * t
+
+END OP :=;
+
+INITVECTOR PROC nilvector :
+ vector (1, 0.0)
+
+END PROC nilvector;
+
+INITVECTOR PROC vector (INT CONST lng, REAL CONST value) :
+ IF lng <= 0
+ THEN errorstop ("PROC vector : lng <= 0") FI;
+ INITVECTOR : (lng, value)
+
+END PROC vector;
+
+INITVECTOR PROC vector (INT CONST lng) :
+ vector (lng, 0.0)
+
+END PROC vector;
+
+REAL OP SUB (VECTOR CONST v, INT CONST i) :
+ test ("REAL OP SUB : ", v, i);
+ v.elem RSUB i
+
+END OP SUB;
+
+INT OP LENGTH (VECTOR CONST v) :
+ v.lng
+
+END OP LENGTH;
+
+INT PROC length (VECTOR CONST v) :
+ v.lng
+
+END PROC length;
+
+REAL PROC norm (VECTOR CONST v) :
+ REAL VAR result :: 0.0;
+ FOR i FROM 1 UPTO v.lng
+ REP result INCR ((v.elem RSUB i)**2) PER;
+ sqrt (result) .
+
+END PROC norm;
+
+PROC replace (VECTOR VAR v, INT CONST i, REAL CONST r) :
+ test ("PROC replace : ", v, i);
+ replace (v.elem, i, r)
+
+END PROC replace;
+
+BOOL OP = (VECTOR CONST l, r) :
+ l.elem = r.elem
+END OP =;
+
+BOOL OP <> (VECTOR CONST l, r) :
+ l.elem <> r.elem
+END OP <>;
+
+VECTOR OP + (VECTOR CONST v) :
+ v
+END OP +;
+
+VECTOR OP + (VECTOR CONST l, r) :
+ test ("VECTOR OP + : ", l, r);
+ v := l;
+ FOR i FROM 1 UPTO v.lng
+ REP replace (v.elem, i, (l.elem RSUB i) + (r.elem RSUB i)) PER;
+ v
+
+END OP +;
+
+VECTOR OP - (VECTOR CONST a) :
+ v := a;
+ FOR i FROM 1 UPTO v.lng
+ REP replace (v.elem, i, - (a.elem RSUB i)) PER;
+ v
+
+END OP -;
+
+VECTOR OP - (VECTOR CONST l, r) :
+ test ("VECTOR OP - : ", l, r);
+ v := l;
+ FOR i FROM 1 UPTO v.lng
+ REP replace (v.elem, i, (l.elem RSUB i) - (r.elem RSUB i)) PER;
+ v
+END OP -;
+
+REAL OP * (VECTOR CONST l, r) :
+ test ("REAL OP * : ", l, r);
+ REAL VAR x :: 0.0;
+ FOR i FROM 1 UPTO l.lng
+ REP x INCR ((l.elem RSUB i) * (r.elem RSUB i)) PER;
+ x
+
+END OP *;
+
+VECTOR OP * (VECTOR CONST v, REAL CONST r) :
+ r*v
+
+END OP *;
+
+VECTOR OP * (REAL CONST r, VECTOR CONST a) :
+ v := a;
+ FOR i FROM 1 UPTO v.lng
+ REP replace (v.elem, i, r*(a.elem RSUB i)) PER;
+ v
+
+END OP *;
+
+VECTOR OP / (VECTOR CONST a, REAL CONST r) :
+ v := a;
+ FOR i FROM 1 UPTO v.lng
+ REP replace (v.elem, i, (a.elem RSUB i)/r) PER;
+ v
+
+END OP /;
+
+TEXT VAR error :: "";
+PROC test (TEXT CONST proc, VECTOR CONST v, INT CONST i) :
+ IF i > v.lng
+ THEN error := proc;
+ error CAT "subscript overflow (LENGTH v=";
+ error CAT text (v.lng);
+ error CAT ", i=";
+ error CAT text (i);
+ error CAT ")";
+ errorstop (error)
+ ELIF i < 1
+ THEN error := proc;
+ error CAT "subscript underflow (i = ";
+ error CAT text (i);
+ error CAT ")";
+ errorstop (error)
+ FI .
+
+END PROC test;
+
+PROC test (TEXT CONST proc, VECTOR CONST a, b) :
+ IF a.lng <> b.lng
+ THEN error := proc;
+ error CAT "LENGTH a (";
+ IF a.lng <= 0
+ THEN error CAT "undefined"
+ ELSE error CAT text (a.lng) FI;
+ error CAT ") <> LENGTH b (";
+ error CAT text (b.lng);
+ error CAT ")";
+ errorstop (error)
+ FI
+
+END PROC test;
+
+PROC get (VECTOR VAR v, INT CONST lng) :
+ v.lng := lng;
+ v.elem := lng * "12345678";
+ REAL VAR x;
+ FOR i FROM 1 UPTO lng
+ REP get (x);
+ replace (v.elem, i, x)
+ PER .
+
+END PROC get;
+
+PROC put (VECTOR CONST v, INT CONST length, fracs) :
+ FOR i FROM 1 UPTO v.lng
+ REP put (text (v.elem RSUB i, length, fracs)) PER
+
+END PROC put;
+
+PROC put (VECTOR CONST v) :
+ FOR i FROM 1 UPTO v.lng
+ REP put (text (v.elem RSUB i)) PER
+
+END PROC put;
+
+END PACKET vector;
|