diff options
Diffstat (limited to 'system/base/unknown/src')
| -rw-r--r-- | system/base/unknown/src/SPOLMAN5.ELA | 1003 | ||||
| -rw-r--r-- | system/base/unknown/src/STD.ELA | 220 | ||||
| -rw-r--r-- | system/base/unknown/src/STDPLOT.ELA | 365 | ||||
| -rw-r--r-- | system/base/unknown/src/bildeditor | 722 | ||||
| -rw-r--r-- | system/base/unknown/src/command handler | 239 | ||||
| -rw-r--r-- | system/base/unknown/src/dateieditorpaket | 743 | ||||
| -rw-r--r-- | system/base/unknown/src/editor | 210 | ||||
| -rw-r--r-- | system/base/unknown/src/elan | 245 | ||||
| -rw-r--r-- | system/base/unknown/src/feldeditor | 747 | ||||
| -rw-r--r-- | system/base/unknown/src/file | 810 | ||||
| -rw-r--r-- | system/base/unknown/src/init | 250 | ||||
| -rw-r--r-- | system/base/unknown/src/integer | 134 | ||||
| -rw-r--r-- | system/base/unknown/src/mathlib | 359 | ||||
| -rw-r--r-- | system/base/unknown/src/real | 378 | ||||
| -rw-r--r-- | system/base/unknown/src/scanner | 255 | ||||
| -rw-r--r-- | system/base/unknown/src/stdescapeset | 31 |
16 files changed, 6711 insertions, 0 deletions
diff --git a/system/base/unknown/src/SPOLMAN5.ELA b/system/base/unknown/src/SPOLMAN5.ELA new file mode 100644 index 0000000..99d4ec2 --- /dev/null +++ b/system/base/unknown/src/SPOLMAN5.ELA @@ -0,0 +1,1003 @@ +PACKET queue handler DEFINES enter into que,
+ exists in que,
+ all in que,
+ erase from que,
+ erase last top of que,
+ get top of que,
+ restore ,
+ list que,
+ info, killer,first,
+ que status,
+ que empty,
+ set entry types,
+ change entry types,
+ initialize que:
+
+
+LET que size = 100,
+
+ empty = 0,
+ used = 1,
+ blocked = 2,
+ nil = 0,
+ user error = 99,
+ unused char = ""0"",
+ used char = ""1"",
+ blocked char= ""2"",
+ ENTRY = STRUCT(TEXT title, TASK origin, TEXT origin name,
+ DATASPACE space, INT storage, acc code ) ;
+
+ROW que size ENTRY VAR que ;
+
+TEXT VAR status list;
+BOOL VAR n ok := FALSE;
+INT VAR top of que,
+ first que entry,
+ last que entry,
+ index ;
+
+.entry: que[index]. ;
+
+PROC initialize que :
+ FOR index FROM 1 UPTO que size REP
+ forget( entry.space );
+ entry.acc code := empty
+ END REP ;
+ first que entry := nil;
+ last que entry := nil;
+ top of que := nil;
+ index := nil;
+ status list := que size * unused char;
+END PROC initialize que ;
+
+initialize que ;
+
+(****************** Interne Queue-Zugriffsoperationen **********************)
+
+INT PROC next (INT CONST pre) :
+ pre MOD que size + 1
+END PROC next ;
+
+PROC block (INT CONST entry number) :
+ que [entry number].acc code := blocked;
+ replace (status list,entry number,blocked char);
+ENDPROC block;
+
+PROC unblock (INT CONST entry number) :
+ que [entry number].acc code := used;
+ replace (status list,entry number,used char);
+ENDPROC unblock;
+
+PROC to next que entry:
+ REP
+ IF index = last que entry OR index = nil
+ THEN index := nil ; LEAVE to next que entry
+ FI ;
+ index := next(index)
+ UNTIL entry.acc code <> empty PER
+END PROC to next que entry ;
+
+PROC to first que entry :
+ index := first que entry
+END PROC to first que entry ;
+
+PROC search que entry (TEXT CONST title, TASK CONST origin) :
+
+ check if index identifies entry ;
+ IF last que entry = nil
+ THEN index := nil
+ ELSE index := last que entry ;
+ REPEAT
+ IF is wanted entry
+ THEN LEAVE search que entry
+ FI ;
+ IF index = first que entry
+ THEN index := nil
+ ELSE index DECR 1 ;
+ IF index = 0
+ THEN index := que size
+ FI
+ FI
+ UNTIL index = nil PER
+ FI.
+
+is wanted entry:
+
+ entry.acc code <> empty CAND
+ entry.title = title CAND
+ (entry.origin = origin OR
+ origin = niltask ).
+
+check if index identifies entry:
+
+ IF index <> nil CAND is wanted entry
+ THEN LEAVE search que entry
+ FI
+
+END PROC search que entry ;
+
+PROC exec erase :
+
+ forget (entry.space) ; entry.acc code := empty ;
+ replace (status list,index,unused char);
+ try to cut off queue ends.
+
+try to cut off queue ends:
+
+ WHILE first entry is not valid REP
+ check if que empty ;
+ first que entry := next(first que entry)
+ END REP ;
+ WHILE last entry is not valid REP
+ make index invalid if necessary ;
+ last que entry DECR 1 ;
+ IF last que entry = 0
+ THEN last que entry := que size
+ FI
+ END REP .
+
+first entry is not valid:
+ que [first que entry].acc code = empty.
+
+last entry is not valid:
+ que [last que entry].acc code = empty.
+
+check if que empty:
+ IF first que entry = last que entry
+ THEN first que entry := nil ;
+ last que entry := nil ;
+ index := nil ;
+ LEAVE try to cut off queue ends
+ FI.
+
+make index invalid if necessary:
+ IF index = last que entry
+ THEN index := nil
+ FI.
+
+END PROC exec erase ;
+
+PROC exec first:
+ IF next (last que entry) = first que entry
+ THEN errorstop ("Queue ist voll - vorziehen unmoeglich")
+ ELIF index = top of que
+ THEN errorstop ("Auftrag wird bereits bearbeitet")
+ ELIF entry.acc code = empty
+ THEN errorstop ("undefinierter Queue-Eintrag. /exec first")
+ ELSE first que entry DECR 1 ;
+ IF first que entry = 0
+ THEN first que entry := que size
+ FI ;
+ que[first que entry] := que[index] ;
+ replace (status list,first que entry,code (entry.acc code));
+ exec erase
+ FI
+END PROC exec first ;
+
+PROC erase last top of que:
+ IF top of que <> nil
+ THEN index := top of que; exec erase;
+ top of que := nil
+ FI
+END PROC erase last top of que;
+
+
+(****************** Behandlung von DATASPACE-typen ***********************)
+
+LET semicolon = ";" ,
+ colon = ":" ,
+ quote = """";
+TEXT VAR entry types :: "" ;
+
+BOOL PROC no permitted type (DATASPACE CONST ds) :
+ TEXT CONST type nr :: semicolon + text(type(ds)) + colon;
+ INT CONST t pos :: pos (entry types,type nr) ;
+ entry types <> "" CAND t pos = 0
+END PROC no permitted type ;
+
+TEXT PROC record of que entry:
+ IF entry.acc code = empty
+ THEN errorstop ("undefinierter Queue-Eintrag. /record");""
+ ELSE TEXT VAR record :: "" ;
+ record CAT storage in k ;
+ record CAT type of entry ;
+ record CAT name of entry ;
+ record CAT origin of entry ;
+ IF entry.acc code = blocked THEN record CAT "- blocked -" FI;
+ record
+ FI.
+
+storage in k:
+
+ text (entry.storage,3) + " K ".
+
+type of entry:
+
+ IF entry types = ""
+ THEN 12 * "?"
+ ELSE TEXT CONST type nr :: semicolon + text(type(entry.space)) + colon ;
+ INT CONST semi colon pos :: pos (entry types, type nr),
+ start type :: semi colon pos + LENGTH type nr ,
+ end type :: pos(entrytypes,semicolon,starttype)-1;
+ IF semi colon pos = 0
+ THEN 12 * "?"
+ ELSE text( subtext(entry types, starttype, endtype),12)
+ FI
+ FI.
+
+name of entry:
+
+ text (quote+ entry.title +quote, 20) .
+
+origin of entry:
+
+ IF entry.origin = niltask
+ THEN 20 * " "
+ ELSE text (" TASK: "+entry.origin name,20)
+ FI
+
+END PROC record of que entry ;
+
+PROC set entry types (TEXT CONST t) :
+ check if void ;
+ IF first char is no semicolon
+ THEN entry types := semicolon
+ ELSE entry types := ""
+ FI;
+ entry types CAT t ;
+ IF last char is no semicolon
+ THEN entry types CAT semicolon
+ FI.
+
+check if void:
+ IF t = ""
+ THEN entry types := "";
+ LEAVE set entry types
+ FI.
+
+first char is no semicolon:
+ (t SUB 1) <> semicolon.
+
+last char is no semicolon:
+ (t SUB length(t)) <> semicolon
+
+END PROC set entry types ;
+
+PROC change entry types:
+ TEXT VAR t :: entry types;
+ line;putline("Entrytypes :");
+ editget(t);
+ set entry types (t)
+END PROC change entry types;
+
+
+(************************ Std Zugriffe auf Queue ***************************)
+
+
+PROC erase from que (TEXT CONST title, TASK CONST origin) :
+ search que entry (title, origin) ;
+ IF index = nil
+ THEN errorstop ("Auftrag existiert nicht. /erase")
+ ELIF index = top of que
+ THEN errorstop (user error, "Dieser Auftrag wird bereits bearbeitet")
+ ELSE exec erase
+ FI
+END PROC erase from que ;
+
+BOOL PROC exists in que (TEXT CONST title, TASK CONST origin) :
+ search que entry (title, origin) ;
+ index <> nil
+END PROC exists in que ;
+
+PROC info (BOOL CONST b) : n ok := b ENDPROC info;
+
+THESAURUS PROC all in que (TASK CONST origin) :
+
+ THESAURUS VAR result := empty thesaurus ;
+ to first que entry ;
+ WHILE index <> 0 REP
+ IF entry.origin = origin OR origin = niltask
+ THEN insert (result, entry.title)
+ FI ;
+ to next que entry
+ END REP ;
+ result
+
+END PROC all in que ;
+
+PROC enter into que (TEXT CONST title, TASK CONST origin,
+ DATASPACE CONST space ):
+
+ IF next(last que entry) = first que entry
+ THEN errorstop ("Queue zu voll")
+ ELIF no permitted type (space) OR title = ""
+ THEN errorstop (user error, "Auftrag wird nicht angenommen")
+ ELSE last que entry := next(last que entry);
+ index := last que entry;
+ entry := ENTRY:
+ ( title, origin,task name, space, storage(space), used ) ;
+ IF first que entry = nil
+ THEN first que entry := 1
+ FI ;
+ replace (status list,last que entry,used char);
+ FI.
+
+task name :
+ TEXT VAR name of task :: name (origin);
+ IF name of task = "stemmer" AND n ok THEN "stemmi" ELSE name of task FI.
+
+END PROC enter into que ;
+
+PROC get top of que (DATASPACE VAR top space) :
+ forget (top space) ;
+ IF que empty
+ THEN errorstop ("kein Auftrag vorhanden. /get")
+ ELSE erase last top of que;
+ top of que := first que entry;
+ IF que [top of que].acc code = blocked THEN
+ wrap around if necessary
+ ELSE top space := que [first que entry].space ; FI;
+ FI .
+
+wrap around if necessary :
+
+ IF entry is allowed to be printed THEN
+ give it to spool manager
+ ELSE enter into end of queue FI.
+
+entry is allowed to be printed :
+ pos (status list,used char) = nil.
+
+give it to spool manager :
+ top space := que [first que entry].space;
+ que [first que entry].acc code := used.
+
+enter into end of queue :
+ top space := que [first que entry].space;
+ enter into que (que [first que entry].title,que [first que entry].origin
+ ,top space);
+ index := first que entry;
+ IF entry.acc code = blocked THEN block (index) FI;
+ get top of que (top space).
+
+END PROC get top of que ;
+
+PROC restore:
+ top of que := nil
+END PROC restore ;
+
+BOOL PROC que empty: (* 'top of que' gilt nicht *)
+ first que entry = last que entry AND
+ top of que = last que entry.
+END PROC que empty ;
+
+PROC que status (INT VAR size, TEXT VAR top title,
+ TASK VAR top origin, TEXT VAR top origin name ):
+
+ size := last que entry - first que entry ; (* geloeschte Eintraege *)
+ IF size < 0 (* zaehlen mit !! *)
+ THEN size INCR que size (* (aber nicht 'top' ) *)
+ FI ;
+ IF top of que <> nil
+ THEN top title := que [top of que].title ;
+ top origin := que [top of que].origin ;
+ top origin name := que [top of que].origin name
+ ELSE size INCR 1 ;
+ top title := "" ;
+ top origin := niltask ;
+ top origin name := ""
+ FI
+END PROC que status ;
+
+TEXT VAR sep :: 79 * "_", record :: "",
+ ask :: "editieren (e),kopieren (k),loeschen (l)," +
+ "vorziehen (v),duplizieren (d),"13""10"" +
+ "print --> quickprint (q),blockieren (b),freigeben (f)," +
+ "weiter (w) ? ";
+
+PROC info :
+
+ to first que entry;
+ WHILE index <> nil REP
+ record := record of que entry;
+ WHILE index <> top of que REPEAT
+ ask user what to do;
+ out (input char);
+ exec command
+ UNTIL command index = 1 PER;
+ to next que entry;
+ PER.
+
+ask user what to do :
+
+ out (""13""10"");out (sep);out (""13""10""13""10"");
+ out (record);
+ out (""13""10""10"");out (ask);
+ INT VAR command index; TEXT VAR input char;
+ REPEAT
+ inchar (input char);
+ command index := pos ("w eklvdqbf",input char);
+ UNTIL command index > 0 PER.
+
+exec command :
+
+ SELECT command index OF
+ CASE 3 : INT VAR old dataspace type := type (entry.space);
+ type (entry.space,1003);
+ FILE VAR f :: sequentialfile (modify,entry.space);
+ edit (f); line (2);
+ type (entry.space,old dataspace type)
+ CASE 4 : forget (entry.title,quiet);
+ copy (entry.space,entry.title);
+ type (old (entry.title),1003)
+ CASE 5 : exec erase ;command index := 1
+ CASE 6 : exec first ;command index := 1
+ CASE 7 : INT VAR dummy no := index;
+ enter into que (que [dummy no].title,que [dummy no].origin,
+ que [dummy no].space)
+ CASE 8 : type (entry.space,1103) ;record := record of que entry;
+ CASE 9 : block (index) ;record := record of que entry;
+ CASE 10: unblock (index); record := record of que entry;
+ ENDSELECT.
+
+ENDPROC info;
+
+PROC list que (FILE VAR f, DATASPACE VAR ds) :
+ open listfile ;
+ to first que entry ;
+ WHILE index <> nil REP
+ TEXT VAR record :: record of que entry ;
+ IF index = top of que
+ THEN record := text(record,60) ;
+ record CAT ""15"wird bearbeitet"14""
+ FI ;
+ putline (f,record) ;
+ to next que entry
+ END REP.
+
+open listfile:
+
+ forget (ds) ;
+ ds := nilspace ;
+ f := sequentialfile (output,ds) ;
+ headline (f, name(myself) + " - Queue") ;
+ line (f)
+
+END PROC list que ;
+
+PROC killer : info ENDPROC killer;
+PROC first : info ENDPROC first;
+
+END PACKET queue handler ;
+
+(***************************************************************************)
+(* Programm zur Verwaltung einer Servertask *)
+(* (benutzt 'queue handler') *)
+(* Autor: A.Vox *)
+(* Stand: 3.6.85 *)
+(* *)
+(***************************************************************************)
+PACKET spool manager DEFINES server status,
+ server modus,
+ server task,
+ server channel,
+ server routine,
+ server fail msg,
+
+ log edit,
+ logline,
+ logfilename,
+ check,
+ feed server if hungry,
+ check if server vanished,
+
+ spool manager,
+ get title and origin,
+
+ start,
+ stop,
+ pause,
+ spool info,
+ list,
+ spool maintenance:
+
+
+ LET user error = 99;
+
+ LET { Status: } { Modus: }
+ init = 0, active = 0,
+ work = 1, paused = 1,
+ wait = 2, stopped = 2,
+ dead = 3;
+
+ LET cmd form feed = ""12"";
+
+INT VAR status :: init,
+ modus :: stopped;
+
+TASK VAR server :: niltask;
+TEXT VAR routine :: "",
+ fail msg:: "";
+INT VAR channel :: 0;
+(************ Globale Variablen fuer alle 'que status'-Aufrufe ************)
+
+INT VAR que size;
+TEXT VAR actual title,
+ actual origin name;
+TASK VAR actual origin;
+
+
+(*********** Zugriffsoperationen auf wichtige Paketvariablen **************)
+
+TASK PROC servertask : server END PROC servertask;
+INT PROC serverstatus : status END PROC serverstatus;
+INT PROC servermodus : modus END PROC servermodus;
+TEXT PROC serverroutine : routine END PROC serverroutine;
+TEXT PROC serverfailmsg : fail msg END PROC serverfailmsg;
+INT PROC serverchannel : channel END PROC serverchannel;
+
+PROC serverroutine (TEXT CONST neu):
+ routine := neu
+END PROC serverroutine;
+
+PROC serverfailmsg (TEXT CONST neu):
+ failmsg := neu
+END PROC serverfailmsg;
+
+PROC serverchannel (INT CONST neu):
+ channel := neu
+END PROC serverchannel;
+
+(************************* Basic Spool Routines ***************************)
+
+TEXT CONST logfilename :: "Vorkommnisse";
+FILE VAR logfile;
+
+TEXT VAR fail title :: "" ;
+TASK VAR fail origin :: niltask ;
+REAL VAR fail time :: 0.0 ;
+
+PROC logline (TEXT CONST mess):
+ logfile := sequential file(output, logfilename) ;
+ clear file if too large ;
+ put(logfile, date);
+ put(logfile, time of day);
+ put(logfile, " : ");
+ putline(logfile, mess)
+END PROC logline ;
+
+PROC log edit:
+ enable stop ;
+ IF NOT exists(logfilename)
+ THEN errorstop ("keine Eintragungen vorhanden")
+ ELSE logfile := sequentialfile(modify,logfilename) ;
+ position to actual page;
+ edit(logfile);
+ line (2);
+ forget (logfilename);
+ FI.
+
+position to actual page:
+
+ INT CONST begin of last page :: lines(logfile)-22 ;
+ logfile := sequential file(modify,logfilename);
+ IF begin of last page < 1
+ THEN toline(logfile,1)
+ ELSE toline(logfile,begin of last page)
+ FI
+
+END PROC logedit;
+
+PROC clear file if too large:
+ IF lines(logfile) > 1000
+ THEN modify (logfile) ;
+ toline (logfile, 900) ;
+ remove (logfile, 900) ;
+ clear removed (logfile) ;
+ output (logfile)
+ FI
+END PROC clear file if too large ;
+
+PROC end server (TEXT CONST mess):
+ access catalogue;
+ IF exists (server) CAND son(myself) = server
+ THEN end(server)
+ FI;
+ failtime := clock(1);
+ que status (que size, fail title, fail origin, actual origin name) ;
+ logline (mess) ;
+ IF fail title <> ""
+ THEN logline(""""+fail title+""" von Task: "+actual origin name)
+ ELSE logline("kein Auftrag betroffen")
+ FI ;
+ status := dead ;
+ server := niltask
+END PROC end server;
+
+PROC check (TEXT CONST title, TASK CONST origin):
+ check if server vanished ;
+ IF less than 3 days ago AND
+ was failure AND
+ title matches AND
+ origin matches
+ THEN fail origin := myself ;
+ errorstop (user error, """"+fail title+""" abgebrochen")
+ FI.
+
+less than 3 days ago:
+ clock(1) < fail time + 3.0 * day.
+
+origin matches:
+ (origin = fail origin OR origin = niltask).
+
+title matches:
+ (title = fail title OR title = "").
+
+was failure:
+ fail title <> ""
+
+END PROC check ;
+
+PROC start server:
+ begin (PROC server start,server) ;
+ status := init
+END PROC start server;
+
+PROC server start:
+ disable stop ;
+ IF channel <> 0
+ THEN continue (channel) ;
+ FI ;
+ command dialogue (FALSE) ;
+ out (cmd form feed);
+ do (routine) ;
+ IF is error
+ THEN call(logline code, "Server-Fehler :",father);
+ call(logline code, error message, father) ;
+ call(logline code, "Zeile: " + text(errorline) +
+ " Code: " + text(errorcode) ,father)
+ ELSE call(logline code, "Ende des Server-Programms erreicht",father)
+ FI ;
+ IF online
+ THEN out (fail msg)
+ FI ;
+ call (terminate code,fail msg, father) ;
+ end (myself)
+END PROC server start ;
+
+PROC check if server vanished:
+ IF NOT (server = nil task) CAND NOT exists (server)
+ THEN end server ("Server gestorben :") ;
+ start server
+ FI
+END PROC check if server vanished;
+
+
+(*************************** Manager Routines *****************************)
+
+ LET ack = 0,
+ second phase ack = 5,
+ not existing nak = 6,
+
+ begin code = 4,
+ fetch code = 11,
+ save code = 12,
+ exists code = 13,
+ erase code = 14,
+ list code = 15,
+ all code = 17,
+ clear code = 18,
+ release code = 20,
+ check code = 22,
+
+ terminate code = 25,
+ logline code = 26,
+ get title code = 27,
+
+ continue code = 100;
+
+
+DATASPACE VAR packet space ;
+INT VAR reply ;
+BOUND STRUCT(TEXT f name,a,b) VAR msg ;
+.f name: msg.f name. ;
+
+TEXT VAR save title :: "";
+FILE VAR listfile;
+
+PROC get title and origin (TEXT VAR title, origin):
+ forget (packet space) ;
+ packet space := nilspace ;
+ call (father, get title code, packet space, reply) ;
+ IF reply = ack
+ THEN msg := packet space ;
+ title := msg.f name ;
+ origin := msg.a ;
+ forget (packet space)
+ ELSE forget (packet space) ;
+ errorstop ("'get title' nicht erfolgreich. Antwort="+text(reply))
+ FI
+END PROC get title and origin;
+
+PROC feed server if hungry:
+ check if server vanished ;
+ IF status = wait AND NOT que empty
+ THEN get top of que (packet space) ;
+ send (server, ack, packet space, reply) ;
+ forget (packet space) ;
+ IF reply = ack
+ THEN status := work
+ ELSE restore ;
+ end server ("Server nimmt keinen Auftrag an") ;
+ start server
+ FI
+ FI
+ENDPROC feed server if hungry;
+
+PROC server request (DATASPACE VAR ds, INT CONST order, phase) :
+
+ enable stop ;
+ msg := ds ;
+ SELECT order OF
+ CASE terminate code: terminate
+ CASE logline code: logline (f name) ;send(server, ack, ds)
+ CASE get title code: send title
+ OTHERWISE
+ IF order = fetch code CAND f name = "-"
+ THEN send top of que
+ ELSE freemanager (ds,order,phase,server)
+ FI
+ END SELECT ;
+ forget(ds).
+
+terminate:
+ end server ("Server terminiert :") ;
+ start server.
+
+send title:
+ forget (ds) ;
+ ds := nilspace ;
+ msg := ds ;
+ que status (que size, msg.f name, actual origin, msg.a) ;
+ send (server, ack, ds).
+
+send top of que:
+ status := wait ;
+ erase last top of que ;
+ IF modus = active
+ THEN feed server if hungry
+ FI
+
+END PROC server request;
+
+PROC spool manager(DATASPACE VAR ds, INT CONST order, phase,
+ TASK CONST order task) :
+
+ IF ordertask < myself
+ THEN server request (ds,order,phase)
+ ELIF ordertask = supervisor
+ THEN system request
+ ELSE spool command (ds,order,phase,order task)
+ FI;
+ check storage;
+ error protocol.
+
+check storage:
+ INT VAR size, used;
+ storage(size,used);
+ IF used > size
+ THEN logline("Speicher-Engpass :");
+ initialize que;
+ logline("Queue geloescht !!");
+ stop
+ FI.
+
+error protocol:
+ IF is error AND error code <> user error
+ THEN logline ("Spool-Fehler :") ;
+ logline (errormessage) ;
+ logline (" Zeile: " + text(errorline) +
+ " Code: " + text(errorcode) )
+ FI.
+
+system request:
+ IF order > continue code
+ THEN call (supervisor,order,ds,reply) ;
+ forget(ds) ;
+ IF reply = ack
+ THEN spool maintenance
+ FI
+ FI
+
+END PROC spool manager;
+
+PROC spool command (DATASPACE VAR ds, INT CONST order, phase,
+ TASK CONST order task):
+
+ enable stop ;
+ check if server vanished ;
+ msg := ds ;
+ SELECT order OF
+ CASE begin code : special begin
+ CASE fetch code: y get logfile
+ CASE save code : y save
+ CASE exists code: y exists
+ CASE erase code: y erase
+ CASE list code: y list
+ CASE all code: y all
+ CASE release code,
+ clear code: y restart
+ CASE check code: y check
+ OTHERWISE errorstop (user error, "Kein Kommando fuer SPOOLER")
+ END SELECT.
+
+special begin :
+ INT VAR dummy;
+ call (public,begin code,ds,dummy);
+ send (order task,ack,ds).
+
+y get logfile:
+ forget(ds) ;
+ ds := old(logfilename) ;
+ send (ordertask, ack, ds).
+
+y erase:
+ IF NOT exists in que (f name,ordertask)
+ THEN manager message(""""+f name+""" steht nicht in der Queue")
+ ELIF phase = 1
+ THEN manager question (""""+f name+""" aus der Queue loeschen")
+ ELSE erase from que (f name,ordertask) ;
+ send (ordertask, ack, ds)
+ FI.
+
+y save:
+ IF phase = 1
+ THEN save title := f name ;
+ send (order task,second phase ack,ds);
+ ELSE enter into que (save title, ordertask, ds) ;
+ IF modus = active
+ THEN feed server if hungry
+ FI ;
+ send (order task,ack,ds);
+ FI.
+
+y list:
+ list que (listfile,ds) ;
+ send (ordertask, ack, ds).
+
+y all:
+ forget(ds) ;
+ ds := nilspace ;
+ BOUND THESAURUS VAR all names := ds ;
+ all names := all in que (ordertask) ;
+ send (ordertask, ack, ds).
+
+y exists:
+ IF exists in que (f name,ordertask)
+ THEN send (ordertask, ack, ds)
+ ELSE send (ordertask, not existing nak, ds)
+ FI.
+
+y check:
+ check (f name,ordertask) ;
+ questatus (que size, actual title, actual origin, actual origin name) ;
+ IF there is a title AND
+ is actual origin AND
+ is actual title
+ THEN manager message (""""+f name+""" wird soeben bearbeitet")
+ ELIF exists in que (f name,ordertask)
+ THEN manager message (""""+f name+""" steht noch in der Queue")
+ ELSE errorstop (usererror, """"+f name+""" steht nicht in der Queue")
+ FI.
+
+ there is a title: actual title <> "" .
+ is actual origin: ordertask = actual origin .
+ is actual title : (f name = "" OR f name = actual title) .
+
+y restart:
+ questatus (que size, actual title, actual origin, actual origin name) ;
+ IF actual origin = ordertask
+ THEN IF phase = 1
+ THEN manager question (""""+actual title+""" unterbrechen")
+ ELSE end server ("unterbrochen durch Auftraggeber :") ;
+ start server ;
+ IF order = clear code
+ THEN restore
+ ELSE erase last top of que
+ FI ;
+ manager message ("Auftrag unterbrochen")
+ FI
+ ELSE errorstop (usererror, "kein eigener Auftrag")
+ FI
+
+END PROC spool command ;
+
+PROC start:
+ IF modus = stopped
+ THEN start server ;
+ modus := active;
+ message ("Server aktiviert")
+ ELIF modus = paused
+ THEN modus := active ;
+ message ("'Pause'-Modus zurueckgesetzt") ;
+ feed server if hungry
+ ELSE message ("Server bereits aktiv")
+ FI
+END PROC start;
+
+PROC stop:
+ IF modus <> stopped
+ THEN end server ("Gestoppt :");
+ modus := stopped ;
+ status := init ;
+ message ("Server gestoppt")
+ ELSE message ("Server bereits gestoppt")
+ FI
+END PROC stop;
+
+PROC pause:
+ IF modus = active
+ THEN modus := paused ;
+ message ("'Pause'-Modus gesetzt")
+ ELIF modus = paused
+ THEN message ("'Pause'-Modus bereits gesetzt")
+ ELSE errorstop ("Server ist gestoppt")
+ FI
+END PROC pause;
+
+PROC message (TEXT CONST mess):
+ say(""13""10"") ;
+ say(mess) ;
+ say(""13""10"")
+END PROC message ;
+
+PROC list:
+ list que(listfile,packet space) ;
+ show(listfile)
+END PROC list;
+
+PROC spool maintenance:
+ command dialogue (TRUE);
+ IF exists(logfilename)
+ THEN logedit
+ FI;
+ WHILE online REP
+ get command ("gib spool kommando :") ;
+ do command
+ END REP ;
+ command dialogue (FALSE) ;
+ break ;
+ set autonom
+END PROC spool maintenance ;
+
+PROC spoolinfo:
+ check if server vanished ;
+ que status (que size, actual title, actual origin, actual origin name) ;
+ line(2) ;
+ putline("Queue :") ;
+ put("Auslastung :");put(que size); line;
+ IF actual title <> ""
+ THEN put("Aktueller Auftrag :");putline(actual title);
+ put(" von Task :");putline(actual origin name)
+ FI ;
+ line ;
+ putline("Server :");
+ put("Status :");
+ SELECT status OF
+ CASE init : putline("initialisiert")
+ CASE work : putline("arbeitet")
+ CASE wait : putline("wartet")
+ OTHERWISE putline("gestorben")
+ END SELECT ;
+ put("Modus :");
+ SELECT modus OF
+ CASE active : putline("aktiv")
+ CASE paused : putline("pausierend")
+ OTHERWISE putline("gestoppt")
+ END SELECT ;
+ put("Kanal :");put(pcb(server,4));
+ line(2)
+END PROC spool info
+
+END PACKET spool manager;
+
diff --git a/system/base/unknown/src/STD.ELA b/system/base/unknown/src/STD.ELA new file mode 100644 index 0000000..047db9a --- /dev/null +++ b/system/base/unknown/src/STD.ELA @@ -0,0 +1,220 @@ +PACKET command dialogue DEFINES (* Autor: J.Liedtke *)
+ (* Stand: 26.04.82 *)
+ command dialogue ,
+ say ,
+ yes ,
+ no ,
+ param position ,
+ last param :
+
+
+LET up = ""3"" ,
+ right = ""2"" ,
+ param pre = " (""" ,
+ param post = """)"13""10"" ;
+
+TEXT VAR std param := "" ;
+
+BOOL VAR dialogue flag := TRUE ;
+
+INT VAR param x := 0 ;
+
+
+BOOL PROC command dialogue :
+ dialogue flag
+ENDPROC command dialogue ;
+
+PROC command dialogue (BOOL CONST status) :
+ dialogue flag := status
+ENDPROC command dialogue ;
+
+
+BOOL PROC yes (TEXT CONST question) :
+
+ IF dialogue flag
+ THEN ask question
+ ELSE TRUE
+ FI .
+
+ask question :
+ put (question) ;
+ skip previous input chars ;
+ put ("(j/n) ?") ;
+ get answer ;
+ IF correct answer
+ THEN putline (answer) ;
+ positive answer
+ ELSE out (""7"") ;
+ LENGTH question + 9 TIMESOUT ""8"" ;
+ yes (question)
+ FI .
+
+get answer :
+ TEXT VAR answer ;
+ inchar (answer) .
+
+correct answer :
+ pos ("jnyJNY", answer) > 0 .
+
+positive answer :
+ pos ("jyJY", answer) > 0 .
+
+skip previous input chars :
+ REP UNTIL incharety = "" PER .
+
+ENDPROC yes ;
+
+BOOL PROC no (TEXT CONST question) :
+
+ NOT yes (question)
+
+ENDPROC no ;
+
+PROC say (TEXT CONST message) :
+
+ IF dialogue flag
+ THEN out (message)
+ FI
+
+ENDPROC say ;
+
+PROC param position (INT CONST x) :
+
+ param x := x
+
+ENDPROC param position ;
+
+TEXT PROC last param :
+
+ IF param x > 0
+ THEN out (up) ;
+ param x TIMESOUT right ;
+ out (param pre) ;
+ out (std param) ;
+ out (param post)
+ FI ;
+ std param
+
+ENDPROC last param ;
+
+PROC last param (TEXT CONST new) :
+ std param := new
+ENDPROC last param ;
+
+ENDPACKET command dialogue ;
+
+
+PACKET input DEFINES (* Stand: 01.05.81 *)
+
+ get ,
+ getline ,
+ get secret line :
+
+
+LET cr = ""13"" ,
+ esc = ""27"" ,
+ rubout = ""12"" ,
+ bell = ""7"" ,
+ back blank back = ""8" "8"" ,
+ del line cr lf = ""5""13""10"" ;
+
+PROC get (TEXT VAR word) :
+
+ REP
+ get (word, " ")
+ UNTIL word <> "" AND word <> " " PER ;
+ delete leading blanks .
+
+delete leading blanks :
+ WHILE (word SUB 1) = " " REP
+ word := subtext (word,2)
+ PER .
+
+ENDPROC get ;
+
+PROC get (TEXT VAR word, TEXT CONST separator) :
+
+ word := "" ;
+ feldseparator (separator) ;
+ editget (word) ;
+ feldseparator ("") ;
+ echoe last char
+
+ENDPROC get ;
+
+PROC echoe last char :
+
+ TEXT CONST last char := feldzeichen ;
+ IF last char = ""13""
+ THEN out (""13""10"")
+ ELSE out (last char)
+ FI
+
+ENDPROC echoe last char ;
+
+PROC get (TEXT VAR word, INT CONST length) :
+
+ word := "" ;
+ feldseparator ("") ;
+ editget (word, length, length) ;
+ echoe last char
+
+ENDPROC get ;
+
+PROC getline (TEXT VAR line ) :
+
+ line := "" ;
+ feldseparator ("") ;
+ editget (line) ;
+ echoe last char
+
+ENDPROC getline ;
+
+PROC get secret line (TEXT VAR line) :
+
+ TEXT VAR char ;
+ line := "" ;
+ get start cursor position ;
+ get line very secret ;
+ IF char = esc
+ THEN get line little secret
+ FI ;
+ cursor to start position ;
+ out (del line cr lf) .
+
+get line very secret :
+ REP
+ inchar (char) ;
+ IF char = esc OR char = cr
+ THEN LEAVE get line very secret
+ ELIF char = rubout
+ THEN delete last char
+ ELIF char >= " "
+ THEN line CAT char ;
+ out (".")
+ ELSE out (bell)
+ FI
+ PER .
+
+delete last char :
+ IF LENGTH line = 0
+ THEN out (bell)
+ ELSE out (back blank back) ;
+ delete char (line, LENGTH line)
+ FI .
+
+get line little secret :
+ feldseparator ("") ;
+ cursor to start position ;
+ editget (line) .
+
+get start cursor position :
+ INT VAR x, y;
+ get cursor (x, y) .
+
+cursor to start position :
+ cursor (x, y) .
+
+ENDPROC get secret line ;
+
+ENDPACKET input ;
diff --git a/system/base/unknown/src/STDPLOT.ELA b/system/base/unknown/src/STDPLOT.ELA new file mode 100644 index 0000000..be55e33 --- /dev/null +++ b/system/base/unknown/src/STDPLOT.ELA @@ -0,0 +1,365 @@ +PACKET std plot DEFINES (* J. Liedtke 06.02.81 *)
+ (* H.Indenbirken, 19.08.82 *)
+ transform,
+ set values,
+
+ clear ,
+ begin plot ,
+ end plot ,
+ dir move,
+ dir draw ,
+ pen,
+ pen info :
+
+LET pen down = "*"8"" ,
+ y raster = 43,
+ display hor = 78.0,
+ display vert = 43.0;
+
+INT CONST up := 1 ,
+ right := 1 ,
+ down := -1 ,
+ left := -1 ;
+
+REAL VAR h min limit :: 0.0, h max limit :: display hor,
+ v min limit :: 0.0, v max limit :: display vert,
+ h :: display hor/2.0, v :: display vert/2.0,
+ size hor :: 23.5, size vert :: 15.5;
+
+ROW 5 ROW 5 REAL VAR p :: ROW 5 ROW 5 REAL :
+ (ROW 5 REAL : (1.0, 0.0, 0.0, 0.0, 0.0),
+ ROW 5 REAL : (0.0, 1.0, 0.0, 0.0, 0.0),
+ ROW 5 REAL : (0.0, 0.0, 1.0, 0.0, 0.0),
+ ROW 5 REAL : (0.0, 0.0, 0.0, 1.0, 0.0),
+ ROW 5 REAL : (0.0, 0.0, 0.0, 0.0, 1.0));
+ROW 5 ROW 5 REAL VAR result;
+INT VAR i, j;
+
+ROW 5 ROW 5 REAL OP * (ROW 5 ROW 5 REAL CONST l, r) :
+ ROW 5 ROW 5 REAL VAR erg;
+ FOR i FROM 1 UPTO 5
+ REP FOR j FROM 1 UPTO 5
+ REP erg [i] [j] := zeile i mal spalte j
+ PER
+ PER;
+ erg .
+
+zeile i mal spalte j :
+ INT VAR k;
+ REAL VAR summe :: 0.0;
+ FOR k FROM 1 UPTO 5
+ REP summe INCR zeile i * spalte j PER;
+ summe .
+
+zeile i : l [i] [k] .
+
+spalte j : r [k] [j] .
+
+END OP *;
+
+PROC set values (ROW 3 ROW 2 REAL CONST size,
+ ROW 2 ROW 2 REAL CONST limits,
+ ROW 3 REAL CONST angles,
+ ROW 2 REAL CONST oblique,
+ ROW 3 REAL CONST perspective) :
+ norm p;
+ set views;
+ calc two dim extrema;
+ calc limits;
+ calc result values .
+
+norm p :
+ p := ROW 5 ROW 5 REAL :
+ (ROW 5 REAL : (1.0/dx, 0.0, 0.0, 0.0, 0.0),
+ ROW 5 REAL : ( 0.0, 1.0/dy, 0.0, 0.0, 0.0),
+ ROW 5 REAL : ( 0.0, 0.0, 1.0/dz, 0.0, 0.0),
+ ROW 5 REAL : ( 0.0, 0.0, 0.0, 1.0, 0.0),
+ ROW 5 REAL : (size [1][1]/dx, size [2][1]/dy,
+ size [3][1]/dz, 0.0, 1.0)) .
+
+dx : size [1][2] - size [1][1] .
+dy : size [2][2] - size [2][1] .
+dz : size [3][2] - size [3][1] .
+
+set views :
+ REAL VAR sin a := sind (angles [1]), cos a := cosd (angles [1]),
+ sin p := sind (angles [2]), cos p := cosd (angles [2]),
+ sin t := sind (angles [3]), cos t := cosd (angles [3]),
+ norm a :: oblique [1] * p [1][1],
+ norm b :: oblique [2] * p [2][2],
+ norm cx :: perspective [1] * p [1][1],
+ norm cy :: perspective [2] * p [2][2],
+ norm cz :: perspective [3] * p [3][3];
+
+ result := ROW 5 ROW 5 REAL :
+ (ROW 5 REAL : (cos p*cos t, -sin p, cos p*sin t, 0.0, 0.0),
+ ROW 5 REAL : (sin p*cos t, cos p, sin p*sin t, 0.0, 0.0),
+ ROW 5 REAL : ( -sin t, 0.0, cos t, 0.0, 0.0),
+ ROW 5 REAL : ( 0.0, 0.0, 0.0, 1.0, 0.0),
+ ROW 5 REAL : ( 0.0, 0.0, 0.0, 0.0, 1.0));
+ p := p*result;
+
+
+ result := ROW 5 ROW 5 REAL :
+ (ROW 5 REAL : ( 1.0, 0.0, 0.0, 0.0, 0.0),
+ ROW 5 REAL : ( 0.0, 1.0, 0.0, 0.0, 0.0),
+ ROW 5 REAL : ( norm a, norm b, 0.0, norm cz, 0.0),
+ ROW 5 REAL : (-norm cx, -norm cy, 0.0, 1.0, 0.0),
+ ROW 5 REAL : ( 0.0, 0.0, 0.0, 0.0, 1.0));
+ p := p * result;
+
+ result := ROW 5 ROW 5 REAL :
+ (ROW 5 REAL : (cos a,-sin a, 0.0, 0.0, 0.0),
+ ROW 5 REAL : (sin a, cos a, 0.0, 0.0, 0.0),
+ ROW 5 REAL : ( 0.0, 0.0, 1.0, 0.0, 0.0),
+ ROW 5 REAL : ( 0.0, 0.0, 0.0, 1.0, 0.0),
+ ROW 5 REAL : ( 0.0, 0.0, 0.0, 0.0, 1.0));
+ p := p * result .
+
+calc two dim extrema :
+ REAL VAR max x :: - max real, min x :: max real,
+ max y :: - max real, min y :: max real, x, y;
+
+ transform (size [1][1], size [2][1], size [3][1], x, y);
+ extrema;
+ transform (size [1][2], size [2][1], size [3][1], x, y);
+ extrema;
+ transform (size [1][2], size [2][2], size [3][1], x, y);
+ extrema;
+ transform (size [1][1], size [2][2], size [3][1], x, y);
+ extrema;
+ transform (size [1][1], size [2][1], size [3][2], x, y);
+ extrema;
+ transform (size [1][2], size [2][1], size [3][2], x, y);
+ extrema;
+ transform (size [1][2], size [2][2], size [3][2], x, y);
+ extrema;
+ transform (size [1][1], size [2][2], size [3][2], x, y);
+ extrema .
+
+extrema :
+ min x := min (min x, x);
+ max x := max (max x, x);
+
+ min y := min (min y, y);
+ max y := max (max y, y) .
+
+calc limits :
+ IF all limits smaller than 2
+ THEN prozente
+ ELSE zentimeter FI .
+
+all limits smaller than 2 :
+ limits [1][2] < 2.0 AND limits [2][2] < 2.0 .
+
+prozente :
+ h min limit := limits [1][1] * display hor * (size vert/size hor);
+ h max limit := limits [1][2] * display hor * (size vert/size hor);
+
+ v min limit := limits [2][1] * display vert;
+ v max limit := limits [2][2] * display vert .
+
+zentimeter :
+ h min limit := display hor * (limits [1][1]/size hor);
+ h max limit := display hor * (limits [1][2]/size hor);
+
+ v min limit := display vert * (limits [2][1]/size vert);
+ v max limit := display vert * (limits [2][2]/size vert) .
+
+calc result values :
+ REAL VAR sh := (h max limit - h min limit) / (max x - min x),
+ sv := (v max limit - v min limit) / (max y - min y),
+ dh := h min limit - min x*sh,
+ dv := v min limit - min y*sv;
+
+ result := ROW 5 ROW 5 REAL :
+ (ROW 5 REAL : ( sh, 0.0, 0.0, 0.0, 0.0),
+ ROW 5 REAL : (0.0, sv, 0.0, 0.0, 0.0),
+ ROW 5 REAL : (0.0, 0.0, 1.0, 0.0, 0.0),
+ ROW 5 REAL : (0.0, 0.0, 0.0, 1.0, 0.0),
+ ROW 5 REAL : ( dh, dv, 0.0, 0.0, 1.0));
+ p := p * result .
+
+END PROC set values;
+
+PROC transform (REAL CONST x, y, z, REAL VAR h, v) :
+ REAL CONST w :: 1.0/(x*p [1][4] + y*p [2][4] + z*p [3][4] + p [4][4]);
+
+ h := (x*p [1][1]+y*p [2][1]+z*p [3][1]+p [4][1])*w + p [5][1];
+ v := (x*p [1][2]+y*p [2][2]+z*p [3][2]+p [4][2])*w + p [5][2];
+END PROC transform;
+
+(************************** Eigentliches plot *************************)
+INT VAR x pos := 0 ,
+ y pos := 0 ,
+ new x pos ,
+ new y pos ;
+
+ROW 24 TEXT VAR display;
+clear ;
+
+PROC clear :
+
+ INT VAR i;
+ display (1) := 79 * " " ;
+ FOR i FROM 2 UPTO 24
+ REP display [i] := display [1]
+ PER;
+ out (""6""2""0""4"")
+
+END PROC clear ;
+
+PROC begin plot :
+
+ cursor (x pos + 1, 24 - (y pos) DIV 2 )
+
+ENDPROC begin plot ;
+
+PROC end plot :
+
+ENDPROC end plot ;
+
+PROC dir move (REAL CONST x, y, z) :
+ transform (x, y, z, h, v);
+ move (round (h), round (v))
+
+END PROC dir move;
+
+PROC move (INT CONST x val, y val) :
+
+ x pos := x val;
+ y pos := y val
+
+ENDPROC move ;
+
+PROC dir draw (REAL CONST x, y, z) :
+ transform (x, y, z, h, v);
+ draw (round (h), round (v))
+
+END PROC dir draw;
+
+PROC draw (INT CONST x val, y val) :
+
+ new x pos := x val;
+ new y pos := y val;
+
+ plot vector (new x pos - x pos, new y pos - y pos) ;
+
+END PROC draw ;
+
+PROC dir draw (TEXT CONST text, REAL CONST angle, height) :
+ out (""6"");
+ out (code (23 - (y pos DIV 2)));
+ out (code (x pos));
+
+ out (text)
+
+END PROC dir draw;
+
+INT VAR act no :: 1, act thickness :: 1, act line type :: 1;
+
+PROC pen (INT CONST no, thickness, line type) :
+ act no := no;
+ act thickness := thickness;
+ act line type := line type
+
+ENDPROC pen ;
+
+PROC pen info (INT VAR no, thickness, line type) :
+ no := act no;
+ thickness := act thickness;
+ line type := act line type
+
+END PROC pen info;
+
+PROC plot vector (INT CONST dx , dy) :
+
+ IF dx >= 0
+ THEN IF dy > dx THEN vector (y pos, x pos, dy, dx, up, right)
+ ELIF dy > 0 THEN vector (x pos, y pos, dx, dy, right, up)
+
+ ELIF dy > -dx THEN vector (x pos, y pos, dx, -dy, right, down)
+ ELSE vector (y pos, x pos, -dy, dx, down, right)
+ FI
+ ELSE IF dy > -dx THEN vector (y pos, x pos, dy, -dx, up, left)
+ ELIF dy > 0 THEN vector (x pos, y pos, -dx, dy, left, up)
+
+ ELIF dy > dx THEN vector (x pos, y pos, -dx, -dy, left, down)
+ ELSE vector (y pos, x pos, -dy, -dx, down, left)
+ FI
+ FI .
+
+ENDPROC plot vector ;
+
+PROC vector (INT VAR x pos, y pos; INT CONST dx, dy, right, up) :
+
+ prepare first step ;
+ INT VAR i ;
+ FOR i FROM 1 UPTO dx REP
+ do one step
+ PER .
+
+prepare first step :
+ point;
+ INT VAR old error := 0 ,
+ up right error := dy - dx ,
+ right error := dy .
+
+do one step :
+ IF right is better
+ THEN do right step
+ ELSE do up right step
+ FI .
+
+right is better :
+ abs (old error + right error) < abs (old error + up right error) .
+
+do upright step :
+ x pos INCR right ;
+ y pos INCR up ;
+ point ;
+ old error INCR upright error .
+
+do right step :
+ x pos INCR right ;
+ point ;
+ old error INCR right error .
+
+ENDPROC vector ;
+
+
+PROC point :
+ INT CONST line :: y pos DIV 2;
+ BOOL CONST above :: (y pos MOD 2) = 1;
+ TEXT CONST point :: display [line+1] SUB (x pos+1),
+ new point :: calculated point;
+
+ replace (display [line+1], x pos+1, new point);
+ out (""6"") ;
+ out (code (23-line)) ;
+ out (code (x pos)) ;
+ out (new point) .
+
+calculated point :
+ IF above
+ THEN IF point = "," OR point = "|"
+ THEN "|"
+ ELSE "'" FI
+ ELSE IF point = "'" OR point = "|"
+ THEN "|"
+ ELSE "," FI
+ FI
+
+END PROC point;
+
+REAL CONST real max int := real (max int);
+INT PROC round (REAL CONST x) :
+ IF x > real max int
+ THEN max int
+ ELIF x < 0.0
+ THEN 0
+ ELSE int (x + 0.5) FI
+
+END PROC round;
+
+ENDPACKET std plot ;
diff --git a/system/base/unknown/src/bildeditor b/system/base/unknown/src/bildeditor new file mode 100644 index 0000000..c84a300 --- /dev/null +++ b/system/base/unknown/src/bildeditor @@ -0,0 +1,722 @@ +
+PACKET b i l d e d i t o r DEFINES (* Autor: P.Heyderhoff *)
+ (*****************) (* Stand: 06.02.82 *)
+ (* Vers.: 1.6.0 *)
+ bildeditor, (* test des bildeditors, *)
+ schreiberlaubnis,
+ zeile unveraendert,
+ feldanfangsmarke,
+ bildmarksatz,
+ bildeinfuegen,
+ bildneu,
+ bildzeile,
+ bildmarke,
+ bildstelle,
+ bildlaenge,
+ bildmaxlaenge,
+ bildsatz,
+ bildrand :
+
+
+LET anker = 2, freianker = 1, satzmax = 4075,
+ DATEI = ROW satzmax STRUCT (INT nachfolger, vorgaenger, index,
+ fortsetzung, TEXT inhalt);
+
+INT VAR stelle :: anker, marke :: 0, satz :: 1, zeile :: 1,
+ zeilen :: 0, maxlaenge :: 23, laenge :: maxlaenge, rand :: 0,
+ marksatz :: 0, alte feldstelle :: 1, alte feldmarke :: 0;
+
+TEXT VAR kommando :: "", teil :: "", zeichen :: "";
+
+BOOL VAR neu :: TRUE, zeileneu :: TRUE, ueberschriftneu :: FALSE,
+ einfuegen :: FALSE, schreiben erlaubt :: TRUE;
+
+LET hop mark rubout up down cr = ""1""16""12""3""10""13"",
+ hop cr mark down up right rubin = ""1""13""16""10""3""2""11"",
+ hop rubin rubout down up cr tab esc = ""1""11""12""10""3""13""9""27"",
+ blank = " ", hop = ""1"", clear eop = ""4"", clear eol = ""5"",
+ left = ""8"", right = ""2"", up = ""3"", down = ""10"", bell = ""7"",
+ tab = ""9"", cr = ""13"", escape = ""27"", begin mark = ""15"",
+ end mark = ""14"", hoechstes steuerzeichen = ""31"", escape q = ""27"q",
+ rubin = ""11"", mark = ""16"", down clear eol = ""10""5"";
+
+(****************** z u g r i f f s p r o z e d u r e n ******************)
+
+BOOL PROC schreiberlaubnis :
+ schreiben erlaubt
+END PROC schreiberlaubnis;
+
+PROC schreiberlaubnis (BOOL CONST b) :
+ schreiben erlaubt := b
+END PROC schreiberlaubnis;
+
+BOOL PROC bildneu :
+ neu
+END PROC bildneu;
+
+PROC bildneu (BOOL CONST b) :
+ neu := b
+END PROC bildneu;
+
+PROC bildeinfuegen (BOOL CONST b):
+ einfuegen := b
+END PROC bildeinfuegen;
+
+INT PROC bildmarke :
+ marke
+END PROC bildmarke;
+
+PROC bildmarke (INT CONST i) :
+ marke := i
+END PROC bildmarke;
+
+INT PROC feldanfangsmarke :
+ alte feldmarke
+END PROC feldanfangsmarke;
+
+PROC feldanfangsmarke (INT CONST i) :
+ alte feldmarke := i
+END PROC feldanfangsmarke;
+
+INT PROC bildstelle :
+ stelle
+END PROC bildstelle;
+
+PROC bildstelle (INT CONST i) :
+ stelle := i
+END PROC bildstelle;
+
+INT PROC bildmarksatz :
+ marksatz
+END PROC bildmarksatz;
+
+PROC bildmarksatz (INT CONST i) :
+ marksatz := i
+END PROC bildmarksatz;
+
+INT PROC bildsatz :
+ satz
+END PROC bildsatz;
+
+PROC bildsatz (INT CONST i) :
+ satz := i
+END PROC bildsatz;
+
+INT PROC bildzeile :
+ zeile
+END PROC bildzeile;
+
+PROC bildzeile (INT CONST i) :
+ zeile := min (i, laenge)
+END PROC bildzeile;
+
+INT PROC bildlaenge :
+ laenge
+END PROC bildlaenge;
+
+PROC bildlaenge (INT CONST i) :
+ laenge := i
+END PROC bildlaenge;
+
+PROC bildmaxlaenge (INT CONST i) :
+ maxlaenge := i
+END PROC bildmaxlaenge;
+
+INT PROC bildrand :
+ rand
+END PROC bildrand;
+
+PROC bildrand (INT CONST i) :
+ rand := i
+END PROC bildrand;
+
+INT PROC max (INT CONST a, b) :
+ IF a > b THEN a ELSE b FI
+END PROC max;
+
+PROC zeile unveraendert :
+ zeileneu := FALSE
+END PROC zeile unveraendert;
+
+
+(************************** b i l d e d i t o r **************************)
+
+PROC bildeditor (DATEI VAR datei) :
+
+ INTERNAL 293 ;
+
+ INT VAR j;
+
+ kommando := feldkommando;
+ IF neu
+ THEN bild ausgeben (datei)
+ ELIF zeileneu
+ THEN satz ausgeben (datei); ueberschriftneu := TRUE
+ ELSE feldposition; zeileneu := TRUE
+ FI;
+ REPEAT
+ IF neu THEN bild ausgeben (datei)
+ ELIF ueberschriftneu THEN ueberschrift (datei)
+ FI ;
+ IF stelle = anker
+ THEN IF schreiben erlaubt
+ THEN satz erzeugen (datei, stelle); (* gestrichen z:=z *)
+ satz ausgeben (datei)
+ ELSE feldkommando (escape q); out(bell); LEAVE bildeditor
+ FI
+ FI ;
+ feldbearbeitung;
+ IF zeichen <> escape THEN kommandoausfuehrung FI
+ UNTIL zeichen = escape
+ END REPEAT;
+ feldkommando (kommando) .
+
+feldbearbeitung :
+ feldkommando (kommando);
+ IF schreiben erlaubt
+ THEN feldeditor (inhalt); kommando := feldkommando
+ ELSE teil := inhalt; feldeditor (teil);
+ IF teil <> inhalt
+ THEN kommando := escape q; kommando CAT teil
+ ELSE kommando := feldkommando
+ FI
+ FI;
+ zeichen := kommando SUB 1;
+ feldnachbehandlung .
+
+
+feldnachbehandlung :
+ IF inhalt = ""
+ THEN IF schreiben erlaubt
+ THEN IF zeichen > hoechstes steuerzeichen
+ THEN inhalt := subtext (kommando, 1, feldlimit);
+ kommando := subtext (kommando, feldlimit+1);
+ feldout (inhalt); zeichen := cr
+ FI FI FI .
+
+kommandoausfuehrung :
+ delete char (kommando, 1);
+ IF marke > 0
+ THEN bildmarkeditor (datei)
+ ELSE
+ SELECT pos (hop cr mark down up right rubin, zeichen) OF
+ CASE 1:
+ zeichen := kommando SUB 1; delete char (kommando, 1);
+ SELECT pos (hop rubin rubout down up cr tab esc, zeichen) OF
+ CASE 1: oben links
+ CASE 2: IF schreiben erlaubt
+ THEN zeilen einfuegen ELSE out (bell) FI
+ CASE 3: IF schreiben erlaubt
+ THEN zeile ausfuegen ELSE out (bell) FI
+ CASE 4: weiterblaettern
+ CASE 5: zurueckblaettern
+ CASE 6: neue seite
+ CASE 7: ueberschriftneu := TRUE
+ CASE 8: lernmodus umschalten
+ OTHERWISE zeichen := ""; out (bell)
+ END SELECT
+ CASE 2: neue zeile
+ CASE 3: markieren beginnen
+ CASE 4: naechster satz
+ CASE 5: vorgaenger (datei)
+ CASE 6: feldposition (feldanfang); naechster satz
+ CASE 7: ueberschriftneu := TRUE;
+ OTHERWISE
+ IF zeichen > hoechstes steuerzeichen
+ THEN IF schreiben erlaubt THEN ueberlauf FI
+ ELSE insert char (kommando, zeichen, 1);
+ insert char (kommando, escape, 1)
+ FI
+ END SELECT
+ FI .
+
+oben links :
+ ueberschriftneu := TRUE;
+ WHILE zeile > 1 REP vorgaenger (datei) PER;
+ feldposition (feldanfang) .
+
+zeile ausfuegen :
+ IF feldstelle = 1
+ THEN satz loeschen (datei);
+ IF stelle = anker THEN vorgaenger (datei) FI
+ ELSE zeilen rekombinieren
+ FI .
+
+zeilen einfuegen :
+ ueberschriftneu := TRUE;
+ IF einfuegen
+ THEN einfuegen := FALSE;
+ IF inhalt = "" THEN satz loeschen (datei) FI;
+ IF zeilen < laenge THEN bild ausgeben (datei) FI
+ ELSE einfuegen := TRUE;
+ IF logischer satzanfang
+ THEN satz erzeugen (datei, stelle);
+ IF zeilen >= zeile THEN bildrest loeschen FI;
+ zeilen := zeile; satz ausgeben (datei)
+ ELSE IF feldstelle <= LENGTH inhalt
+ THEN zeile auftrennen
+ FI;
+ IF zeile < zeilen
+ THEN nachfolger (datei); bildrest loeschen;
+ vorgaenger (datei); zeilen := zeile
+ FI ; feldposition
+ FI
+ FI .
+
+logischer satzanfang :
+ FOR j FROM feldanfang UPTO feldstelle - 1
+ REP IF (inhalt SUB j) = ""
+ THEN LEAVE logischer satzanfang WITH TRUE
+ ELIF (inhalt SUB j) <> " "
+ THEN LEAVE logischer satzanfang WITH FALSE
+ FI
+ END REP; TRUE .
+
+zeilen rekombinieren :
+ IF eof (datei) THEN
+ ELSE inhalt CAT (feldstelle-1-LENGTH inhalt) * " ";
+ inhalt CAT datei (datei (stelle).nachfolger).inhalt;
+ stelle := datei (stelle).nachfolger;
+ satz loeschen (datei, stelle);
+ stelle := datei (stelle).vorgaenger;
+ bildausgeben (datei)
+ FI .
+
+zeile auftrennen :
+ marke := stelle; (feldende-feldstelle+1) TIMESOUT " ";
+ stelle := datei (stelle).nachfolger;
+ satz erzeugen (datei, stelle);
+ inhalt := subtext (datei (datei (stelle).vorgaenger).inhalt, feldstelle);
+ stelle := marke; marke := 0;
+ inhalt := subtext (inhalt, 1, feldstelle-1) .
+
+weiterblaettern :
+ ueberschriftneu := TRUE;
+ IF eof (datei)
+ THEN out (bell)
+ ELSE IF zeile = laenge
+ THEN nachfolger (datei); zeile := 1; bild ausgeben (datei)
+ ELIF einfuegen
+ THEN IF zeile = zeilen THEN bild ausgeben (datei) FI
+ FI;
+ WHILE zeile < zeilen AND stelle <> anker
+ REP nachfolger (datei) END REP;
+ IF stelle = anker
+ THEN vorgaenger (datei)
+ FI FI .
+
+zurueckblaettern :
+ ueberschriftneu := TRUE;
+ IF satz > 1
+ THEN IF zeile = 1
+ THEN vorgaenger (datei); zeile := laenge
+ FI;
+ WHILE zeile > 1 AND satz > 1
+ REP vorgaenger (datei) PER;
+ zeile := 1
+ FI .
+
+ueberlauf :
+ insert char (kommando, zeichen, 1);
+ feldposition (feldanfang); feld einruecken (inhalt); nachfolger (datei);
+ satz erzeugen (datei, stelle);
+ inhalt := ""0"" ; (* 12.01.81 *)
+ IF zeile <= zeilen OR neu
+ THEN bild ausgeben (datei) ELSE satz ausgeben (datei)
+ FI ;
+ inhalt := "" .
+
+lernmodus umschalten :
+ feldlernmodus (NOT feldlernmodus);
+ ueberschriftneu := TRUE;
+ IF feldlernmodus
+ THEN feldaudit (""); zeichen := ""
+ ELSE insert char (kommando, escape, 1);
+ insert char (kommando, hop, 1)
+ FI.
+
+neue seite :
+ feldstelle (feldanfang); zeile := 1; neu := TRUE .
+
+neue zeile :
+ BOOL VAR wirklich einfuegen := einfuegen;
+ IF feldstelle > LENGTH inhalt OR feldstelle >= feldende
+ THEN feldposition (feldanfang); feld einruecken (inhalt); nachfolger(datei)
+ ELIF einfuegen AND logischer satzanfang
+ THEN feldposition (feldanfang); feldeinruecken (inhalt)
+ ELSE feldposition (feldanfang); nachfolger (datei);
+ wirklich einfuegen := FALSE
+ FI;
+ IF stelle = anker THEN
+ ELIF wirklich einfuegen
+ THEN satz erzeugen (datei, stelle);
+ IF zeile <= zeilen OR neu
+ THEN bild ausgeben (datei)
+ ELSE satz ausgeben (datei)
+ FI
+ ELIF neu THEN
+ ELSE IF zeile > zeilen
+ THEN satz ausgeben (datei)
+ FI;
+ FOR j FROM feldanfang UPTO min (feldstelle, LENGTH inhalt)
+ REP IF (inhalt SUB j) <> blank
+ THEN feldposition (j); LEAVE neue zeile FI
+ PER
+ FI .
+
+naechster satz :
+ nachfolger (datei);
+ IF neu
+ THEN IF stelle = anker
+ THEN IF datei (datei (stelle).vorgaenger).inhalt = ""
+ THEN stelle := datei (stelle).vorgaenger; satz DECR 1;
+ neu := FALSE
+ FI FI
+ ELIF zeile <= zeilen THEN
+ ELIF stelle = anker THEN
+ ELSE satz ausgeben (datei)
+ FI .
+
+markieren beginnen :
+ IF feldstelle <= min (LENGTH inhalt, feldende)
+ THEN feldmarke (feldstelle); marke := stelle;
+ marksatz := satz; satz ausgeben (datei);
+ alte feldmarke := feldmarke
+ ELSE out (bell)
+ FI .
+
+inhalt :
+ datei (stelle).inhalt .
+
+END PROC bildeditor;
+
+
+(******************** b i l d - m a r k e d i t o r **********************)
+
+PROC bildmarkeditor (DATEI VAR datei) :
+ INT VAR j, k;
+
+ IF zeichen = right OR zeichen = tab
+ THEN zeichen := down;
+ feldposition (feldanfang)
+ FI;
+ SELECT pos (hop mark rubout up down cr, zeichen) OF
+ CASE 1: zeichen := kommando SUB 1; delete char (kommando, 1);
+ IF zeichen = up
+ THEN rueckblaetternd demarkieren
+ ELIF zeichen = down
+ THEN weiterblaetternd markieren
+ ELSE out (bell)
+ FI;
+ zeichen := ""
+ CASE 2: markieren beenden
+ CASE 3: IF schreiben erlaubt
+ THEN markiertes loeschen
+ ELSE out (bell)
+ FI
+ CASE 4: zeile demarkieren
+ CASE 5,6: zeile markieren
+ OTHERWISE insert char (kommando, zeichen, 1);
+ insert char (kommando, escape, 1)
+ END SELECT;
+ IF marke > 0
+ THEN IF stelle = marke
+ THEN feldmarke (alte feldmarke)
+ ELSE feldmarke (feldanfang)
+ FI
+ FI .
+
+markieren beenden :
+ feldmarke (0); alte feldmarke := 0;
+ IF marke = stelle
+ THEN satz ausgeben (datei); ueberschriftneu := TRUE;
+ marke := 0;
+ ELSE marke := 0; neu := TRUE
+ FI .
+
+markiertes loeschen :
+ IF stelle = marke
+ THEN satzausschnitt loeschen
+ ELSE letzten satz bis stelle loeschen;
+ ersten satz ab marke loeschen;
+ alle zwischensaetze loeschen;
+ IF zeile <= 1
+ THEN zeile := 1
+ FI;
+ feldstelle (feldanfang); feldmarke (0);
+ alte feldmarke := 0; marke := 0; neu := TRUE
+ FI .
+
+satzausschnitt loeschen :
+ inhalt := subtext (inhalt, 1, feldmarke-1) + subtext (inhalt, feldstelle);
+ feldstelle (feldmarke); feldmarke (0); marke := 0;
+ IF inhalt = ""
+ THEN satz loeschen (datei)
+ ELSE satz ausgeben (datei)
+ FI .
+
+letzten satz bis stelle loeschen :
+ IF feldstelle > LENGTH inhalt
+ THEN satz loeschen (datei, stelle)
+ ELIF feldstelle > feldanfang
+ THEN inhalt := subtext (inhalt, feldstelle)
+ FI .
+
+ersten satz ab marke loeschen :
+ INT CONST altstelle := stelle;
+ stelle := marke;
+ IF alte feldmarke = 1
+ THEN satz loeschen (datei, stelle);
+ satz DECR 1; zeile DECR 1
+ ELSE IF alte feldmarke <= LENGTH inhalt
+ THEN inhalt := text (inhalt, alte feldmarke-1)
+ FI;
+ stelle := datei (stelle).nachfolger
+ FI .
+
+alle zwischensaetze loeschen :
+ WHILE stelle <> altstelle
+ REP satzloeschen (datei, stelle);
+ satz DECR 1; zeile DECR 1
+ PER .
+
+zeile markieren :
+ IF zeichen = cr
+ THEN feldstelle (feldanfang)
+ FI;
+ IF eof (datei)
+ THEN feldstelle (feldende)
+ ELSE nachfolger (datei)
+ FI;
+ markierung justieren (datei);
+ satz ausgeben (datei) .
+
+zeile demarkieren :
+ IF stelle = marke
+ THEN out (bell); LEAVE zeile demarkieren
+ FI;
+ feldmarke (0); satz ausgeben (datei);
+ vorgaenger (datei);
+ markierung justieren (datei);
+ satz ausgeben (datei) .
+
+weiterblaetternd markieren :
+ IF zeile >= laenge THEN zeile := 0 FI; out (hop);
+ WHILE NOT eof (datei)
+ REP nachfolger (datei) UNTIL zeile = laenge PER;
+ IF eof (datei)
+ THEN feldstelle (feldende);
+ FI;
+ neu := TRUE .
+
+rueckblaetternd demarkieren :
+ IF stelle = marke
+ THEN out (bell); LEAVE rueckblaetternd demarkieren
+ FI;
+ FOR j FROM 1 UPTO laenge
+ WHILE stelle <> marke
+ REP vorgaenger (datei) PER;
+ neu := TRUE .
+
+inhalt :
+ datei (stelle).inhalt .
+
+END PROC bildmarkeditor;
+
+PROC markierung justieren (DATEI CONST datei) :
+ IF feldstelle > LENGTH inhalt
+ THEN feldstelle (min (feldende, LENGTH inhalt) + 1)
+ FI;
+ IF stelle = marke
+ THEN feldmarke (alte feldmarke);
+ IF feldstelle < feldmarke
+ THEN feldstelle (feldmarke)
+ FI
+ ELSE feldmarke (feldanfang)
+ FI .
+
+inhalt :
+ datei (stelle).inhalt .
+
+END PROC markierung justieren;
+
+PROC vorgaenger (DATEI VAR datei) :
+ IF eof (datei)
+ THEN IF inhalt = "" THEN satz loeschen (datei)
+ FI FI ;
+ stelle := datei (stelle).vorgaenger; satz DECR 1;
+ IF stelle = anker
+ THEN out (bell); stelle := datei (anker).nachfolger;
+ satz := 1; zeile := 1
+ ELIF zeile > 1
+ THEN out (up); zeile DECR 1
+ ELSE neu := TRUE
+ FI .
+
+inhalt :
+ datei (stelle).inhalt .
+
+END PROC vorgaenger;
+
+PROC nachfolger (DATEI CONST datei) :
+ stelle := datei (stelle).nachfolger; satz INCR 1; zeile INCR 1;
+ IF zeile <= laenge
+ THEN out (down)
+ ELIF laenge <> maxlaenge
+ THEN neu := TRUE ; zeile := laenge
+ FI
+END PROC nachfolger;
+
+PROC bild ausgeben (DATEI VAR datei) :
+
+ IF marke > 0 THEN markierung justieren (datei) FI;
+ alte feldstelle := feldstelle; feldstelle (feldende+1);
+ INT VAR altstelle :: stelle, altsatz :: satz,
+ altzeile :: zeile, altmarke :: feldmarke;
+ ueberschrift (datei);
+ IF marke > 0 OR neu
+ THEN zurueck zur ersten zeile;
+ cursor (1, rand+2) FI;
+ IF (rand+laenge) = maxlaenge THEN out (clear eop) FI;
+ WHILE zeile <= laenge AND stelle <> anker
+ REP zeile schreiben PER;
+ feldstelle (alte feldstelle);
+ feldmarke (altmarke);
+ zeilen := zeile - 1;
+ IF zeile > laenge
+ THEN zeile := laenge; feldposition
+ ELSE bildrest loeschen
+ FI;
+ (zeile - altzeile) TIMESOUT up;
+ zeile := altzeile; satz := altsatz; stelle := altstelle;
+ neu := FALSE .
+
+zurueck zur ersten zeile :
+ IF eof (datei)
+ THEN WHILE inhalt = "" AND datei(stelle).vorgaenger <> anker
+ REP vorgaenger (datei) END REP;
+ altstelle := stelle; altsatz := satz; altzeile := zeile;
+ FI;
+ WHILE zeile > 1 AND datei (stelle).vorgaenger <> anker
+ REP IF stelle = marke
+ THEN feldmarke (0)
+ FI;
+ vorgaenger (datei)
+ PER;
+ altzeile DECR (zeile-1); zeile := 1 .
+
+inhalt :
+ datei (stelle).inhalt .
+
+zeile schreiben :
+ IF stelle = marke THEN feldmarke (alte feldmarke) FI;
+ IF stelle = altstelle THEN feldstelle (alte feldstelle) FI;
+ feldout (inhalt);
+ IF stelle = altstelle
+ THEN feldmarke (0)
+ ELIF feldmarke > feldanfang
+ THEN feldmarke (feldanfang)
+ FI;
+ zeile INCR 1;
+ IF zeile <= laenge
+ THEN stelle := datei (stelle).nachfolger;
+ satz INCR 1; out (down)
+ FI .
+
+END PROC bild ausgeben;
+
+PROC ueberschrift (DATEI CONST datei) :
+ cursor (feldrand+1, rand+1); out(begin mark);
+ INT CONST punkte ::
+ (feldende-feldanfang-13-length(datei(anker).inhalt)) DIV 2;
+ punkte TIMESOUT "."; out (" ", datei(anker).inhalt, " .");
+ cursor (feldrand+3, rand+1);
+ IF feldeinfuegen
+ THEN out ("RUBIN"2""2"")
+ ELSE out (""2""2""2""2""2""2""2"") FI;
+ IF einfuegen
+ THEN out ("INS")
+ ELSE out (""2""2""2"") FI;
+ IF feldlernmodus THEN out ("..LEARN.") FI;
+ cursor (feldrand+feldende-feldanfang-9-punkte, rand+1);
+ punkte TIMESOUT ".";
+ out (" zeile ", end mark, " ");
+ cursor (feldrand+feldende-feldanfang-2, rand+1) ;
+ IF satz <= zeile THEN out("1")
+ ELSE out (text (satz-zeile+1)) FI;
+ cursor (feldrand+2, rand+1);
+ feldtab (tabulator);
+ outsubtext (tabulator, feldanfang+1, min (feldende, LENGTH tabulator));
+ cursor (1, rand+zeile+1); feldposition;
+ ueberschriftneu := FALSE
+
+END PROC ueberschrift;
+
+TEXT VAR tabulator;
+
+PROC satz ausgeben (DATEI VAR datei) :
+ IF zeile > laenge
+ THEN roll up
+ ELIF zeile > zeilen
+ THEN zeilen INCR 1
+ FI;
+ feldout (datei (stelle).inhalt); feldposition .
+roll up :
+ out (down); cursor (1, rand + zeile); zeile DECR 1 .
+END PROC satz ausgeben;
+
+PROC satz loeschen (DATEI VAR datei) :
+ satz loeschen (datei, stelle); zeilen DECR 1;
+ IF zeile > zeilen
+ THEN bildrest loeschen;
+ IF stelle <> anker THEN satz ausgeben (datei) FI
+ ELSE bild ausgeben (datei)
+ FI
+END PROC satz loeschen;
+
+PROC bildrest loeschen :
+ out (cr); feldrand TIMESOUT right;
+ IF (rand+laenge) = maxlaenge
+ THEN out (clear eop)
+ ELSE out (up);
+ (laenge-zeile+1) TIMESOUT (down clear eol);
+ (laenge-zeile) TIMESOUT up
+ FI;
+ feldposition
+END PROC bildrest loeschen;
+
+BOOL PROC eof (DATEI CONST datei) :
+ datei (stelle).nachfolger = anker
+END PROC eof;
+
+(*************************** schrott *************************************)
+
+PROC satz erzeugen (DATEI VAR datei, INT VAR satz):
+ EXTERNAL 291 ;
+END PROC satz erzeugen;
+
+PROC satz loeschen (DATEI VAR datei, INT VAR satz):
+ EXTERNAL 292 ;
+END PROC satz loeschen;
+
+(************************** testprogramm ***********************************)
+(*
+PROC test des bildeditors :
+
+ IF NOT exists ("test")
+ THEN FILE VAR file 1 := sequential file (modify, "test"); close (file 1)
+ FI ;
+ DATASPACE VAR ds := old ("test");
+ BOUND DATEI VAR datei := ds ;
+ feldwortweise (NOT feldwortweise);
+ bildneu (TRUE); bildmarke (0);
+ bildstelle (CONCR(datei) (anker).nachfolger); bildsatz (1);
+ feldmarke (0); feldseparator (""); feldstelle (1) ;
+ REP b i l d e d i t o r (CONCR (datei));
+ out (""7""); feldkommando ("")
+ UNTIL (feldkommando SUB 1) = ""27""
+ PER;
+
+END PROC test des bildeditors;
+*)
+END PACKET bildeditor;
diff --git a/system/base/unknown/src/command handler b/system/base/unknown/src/command handler new file mode 100644 index 0000000..3e06280 --- /dev/null +++ b/system/base/unknown/src/command handler @@ -0,0 +1,239 @@ +
+PACKET command handler DEFINES (* Autor: J.Liedtke *)
+ (* Stand: 29.02.82 *)
+ command handler ,
+ do command ,
+ command error ,
+ set command :
+
+
+LET esc = ""27"" ,
+ esc k = ""27"k" ,
+ cr lf = ""4""13""10"" ,
+ command pre = ""4""13" " ,
+ command post = ""13""10" " ,
+
+ tag type = 1 ,
+ texttype = 4 ,
+ eof type = 7 ;
+
+
+TEXT VAR command line := "" ,
+ previous command line := "" ,
+ symbol ,
+ procedure ,
+ pattern ,
+ error note := "" ;
+
+INT VAR symbol type ,
+ allowed type := 0 ;
+
+
+PROC set command (TEXT CONST command, INT CONST type) :
+
+ param position (0) ;
+ command line := command ;
+ allowed type := type
+
+ENDPROC set command ;
+
+PROC do command :
+
+ do (command line)
+
+ENDPROC do command ;
+
+
+PROC command handler ( TEXT CONST command list,
+ INT VAR command index, number of params,
+ TEXT VAR param 1, param 2,
+ TEXT CONST command text ) :
+
+prepare and get command ;
+command handler (command list,command index,number of params,param1,param2).
+
+prepare and get command :
+ set line nr (0) ;
+ error protocoll ;
+ get command from console .
+
+error protocoll :
+ IF is error
+ THEN put error ;
+ clear error
+ ELSE command line := "" ;
+ FI .
+
+get command from console :
+ INT VAR x, y;
+ out (crlf) ;
+ get cursor (x, y) ;
+ cursor (x, y) ;
+ REP
+ out (command pre) ;
+ out (command text) ;
+ out (command post) ;
+ editget command
+ UNTIL command line <> "" PER ;
+ param position (LENGTH command line) ;
+ out (command post) .
+
+editget command :
+ feldaudit ("") ;
+ feldlernmodus (FALSE) ;
+ REP
+ feldtabulator ("") ;
+ feldseparator (esc) ;
+ editget (command line) ;
+ ignore halt errors during editget ;
+ IF feldzeichen = esc k
+ THEN command line := previous command line
+ ELSE previous command line := command line ;
+ LEAVE editget command
+ FI
+ PER .
+
+ignore halt errors during editget :
+ IF is error
+ THEN clear error
+ FI .
+
+ENDPROC command handler ;
+
+PROC command handler ( TEXT CONST command list,
+ INT VAR command index, number of params,
+ TEXT VAR param 1, param 2) :
+
+ scan (command line) ;
+ next symbol ;
+ IF pos (command list, symbol) > 0
+ THEN procedure name ;
+ parameter list pack option ;
+ nothing else in command line ;
+ decode command
+ ELSE impossible command
+ FI .
+
+procedure name :
+ IF symbol type = tag type OR symbol = "?"
+ THEN procedure := symbol ;
+ next symbol
+ ELSE error ("incorrect procedure name")
+ FI .
+
+parameter list pack option :
+ number of params := 0 ;
+ param 1 := "" ;
+ param 2 := "" ;
+ IF symbol = "("
+ THEN next symbol ;
+ parameter list ;
+ IF symbol <> ")"
+ THEN error (") expected")
+ FI
+ ELIF symbol type <> eof type
+ THEN error ("( expected")
+ FI .
+
+parameter list :
+ parameter (param 1, number of params) ;
+ IF symbol = ","
+ THEN next symbol ;
+ parameter (param 2, number of params) ;
+ FI ;
+ IF symbol <> ")"
+ THEN error (") expected")
+ FI .
+
+nothing else in command line :
+ next symbol ;
+ IF symbol <> ""
+ THEN error ("command too complex")
+ FI .
+
+decode command :
+ command index := index (command list, procedure, number of params) .
+
+impossible command :
+ command index := 0 .
+
+ENDPROC command handler ;
+
+PROC parameter (TEXT VAR param, INT VAR number of params) :
+
+ IF symbol type = text type OR symbol type = allowed type
+ THEN param := symbol ;
+ number of params INCR 1 ;
+ next symbol
+ ELSE error ("parameter is no text denoter ("" missing!)")
+ FI
+
+ENDPROC parameter ;
+
+INT PROC index (TEXT CONST list, procedure, INT CONST params) :
+
+ pattern := procedure ;
+ pattern CAT ":" ;
+ INT CONST index pos := pos (list, pattern) ;
+ IF procedure name found
+ THEN get colon pos ;
+ get dot pos ;
+ get end pos ;
+ get command index ;
+ get param index ;
+ IF param index >= 0
+ THEN command index + param index
+ ELSE - command index
+ FI
+ ELSE 0
+ FI .
+
+procedure name found :
+ index pos > 0 AND (list SUB index pos - 1) <= "9" .
+
+get param index :
+ INT CONST param index :=
+ pos (list, text (params), dot pos, end pos) - dot pos - 1 .
+
+get command index :
+ INT CONST command index :=
+ int ( subtext (list, colon pos + 1, dot pos - 1) ) .
+
+get colon pos :
+ INT CONST colon pos := pos (list, ":", index pos) .
+
+get dot pos :
+ INT CONST dot pos := pos (list, ".", index pos) .
+
+get end pos :
+ INT CONST end pos := dot pos + 4 .
+
+ENDPROC index ;
+
+PROC error (TEXT CONST message) :
+
+ error note := message ;
+ scan ("") ;
+ procedure := "-"
+
+ENDPROC error ;
+
+PROC command error :
+
+ disable stop ;
+ IF error note <> ""
+ THEN errorstop (error note) ;
+ error note := ""
+ FI ;
+ enable stop
+
+ENDPROC command error ;
+
+
+PROC next symbol :
+
+ next symbol (symbol, symbol type)
+
+ENDPROC next symbol ;
+
+iNDPACKET command handler ;
diff --git a/system/base/unknown/src/dateieditorpaket b/system/base/unknown/src/dateieditorpaket new file mode 100644 index 0000000..8aedb2d --- /dev/null +++ b/system/base/unknown/src/dateieditorpaket @@ -0,0 +1,743 @@ +
+PACKET d a t e i e d i t o r paket DEFINES (* Autor: P.Heyderhoff *)
+ (*******************) (* Stand: 19.02.82 *)
+ (* Vers.: 1.6.0 *)
+ define escape ,
+ dateieditor :
+
+LET satzmax = 4075, dateianker = 2, left = ""8"", escape = ""27"",
+ hop = ""1"", right = ""2"", hoechstes steuerzeichen = ""31"",
+ clear = ""1""4"", hop and mark = ""1""15"", code f = "f",
+ clear line mark = ""5""14"", bell = ""7"", freianker = 1, down = ""10"",
+ begin mark = ""15"", end mark = ""14"", escape escape = ""27""27"",
+ clear eol and mark = ""5""15"";
+
+LET DATEI = ROW satzmax STRUCT (INT nachfolger, vorgaenger, index,
+ fortsetzung, TEXT inhalt);
+FOR j FROM 1 UPTO 127 REP escapefkt (j) := "" PER;
+INT VAR j, haltzeile :: satzmax, symboltyp, typ,
+ zahlwert, stelle, satz, marke, maxbildlaenge :: 23;
+FILE VAR sekundaerfile ;
+TEXT VAR zeichen :: "", ersatz :: "", kommando :: "",
+ symbol :: "", textwert :: "", lernsequenz::"";
+BOOL VAR war fehler, boolwert;
+LET op1namen =
+";+;-;BEGIN;COL;GET;HALT;LIMIT;MARK;PUT;IF;NOT;REPEAT;WRITE;SIZE";
+LET b = 5, c = 11, g = 15, h = 19, l = 24, m = 30,
+ p = 35, i = 39, n = 42, r = 46, w = 53, s=59;
+LET op2namen = "&+&-&*&/&;&CHANGETO;&OR";
+LET plus = 1, minus = 3, mal = 5, durch = 7, semicolon = 9,
+ changecode = 11, or = 21;
+LET proznamen = ";col;row;halt;limit;mark;len;eof;";
+LET pcol = 1, prow = 5, phalt = 9, plimit = 14, pmark = 20,
+ plen = 25, peof = 29;
+LET void = 0, (* keine angabe des typs *)
+ tag = 1, (* typ: lower case letter *)
+ bold = 2, (* typ: upper case letter *)
+ integer = 3, (* typ: digit *)
+ texttyp = 4, (* typ: quote *)
+ operator = 5, (* typ: operator +-*=<> ** := *)
+ delimiter = 6, (* typ: delimiter ( ) , ; . *)
+ eol = 7, (* typ: niltext, Zeilenende *)
+ bool = 8; (* typ: boolean *)
+LET varimax = 10;
+INT VAR freivar :: 1;
+ROW varimax INT VAR varzahlwert, vartyp;
+ROW varimax TEXT VAR vartextwert, varname;
+FOR j FROM 1 UPTO varimax
+REP vartextwert (j) := ""; varname (j) := "" PER;
+
+ROW 127 TEXT VAR escapefkt;
+
+
+(************************* d a t e i e d i t o r *************************)
+
+PROC dateieditor (DATEI VAR datei) :
+
+ INTERNAL 295 ;
+
+ REP datei editieren
+ UNTIL (feldkommando SUB 1) <> escape
+ PER .
+
+datei editieren :
+ war fehler := FALSE ;
+ zeichen := feldkommando SUB 2;
+ IF zeichen = "q" OR zeichen = "w"
+ THEN LEAVE dateieditor
+ ELIF zeichen = escape
+ THEN kommando ermitteln
+ ELSE tastenkommando ermitteln ; (* Li 19.1.82 *)
+ abbruchtest;
+ feldkommando (subtext (feldkommando, 3))
+ FI;
+ a u s f u e h r e n .
+
+tastenkommando ermitteln :
+ IF zeichen > ""0"" AND zeichen < ""128""
+ THEN kommando := escapefkt (code (zeichen)) (* Li 06.01.82 *)
+ ELSE kommando := ""
+ FI .
+
+abbruchtest :
+ IF is incharety (escape)
+ THEN fehler bearbeiten
+ FI .
+
+kommando ermitteln :
+ IF (feldkommando SUB 1) = hop
+ THEN lernsequenz auf taste legen;
+ feldkommando (subtext (feldkommando, 4));
+ LEAVE datei editieren
+ FI;
+ feldkommando (subtext (feldkommando, 3));
+ kommando := ""; dialog; analysieren .
+
+dialog:
+ REP kommandodialog;
+ IF (feldzeichen SUB 1) <> escape OR kommando <> "?"
+ THEN LEAVE dialog
+ ELIF (feldzeichen SUB 2) > ""0"" THEN (* Li 19.02.82 *)
+ kommando := escapefkt (code (feldzeichen SUB 2) MOD 128 )
+ ELSE kommando := ""
+ FI
+ PER .
+
+lernsequenz auf taste legen :
+ lernsequenz := feldaudit;
+ lernsequenz := subtext (lernsequenz, 1, LENGTH lernsequenz - 3);
+ INT CONST lerncode := code (feldkommando SUB 3) MOD 128 ;
+ escapefkt (lerncode) := "W""" ;
+ escapefkt (lerncode) CAT lernsequenz ; (* Li 5.1.81 *)
+ escapefkt (lerncode) CAT """" .
+
+kommandodialog :
+ INT CONST feldlaenge :: max (feldende-feldanfang-21, 6) ;
+ cursor (feldrand+1, bildrand+bildzeile+1);
+ out (begin mark, "gib editor kommando: ");
+ feldlaenge TIMESOUT "."; out(end mark);
+ bildneu (TRUE);
+ cursor (feldrand+23, bildrand+bildzeile+1); feldseparator (escape);
+ editget (kommando, 255, feldlaenge); feldseparator ("") .
+
+analysieren :
+ IF (feldzeichen SUB 1) = escape AND (feldzeichen SUB 2) > ""0"" (*02.82*)
+ THEN escapefkt (code (feldzeichen SUB 2) MOD 128) := kommando; (* Li 5.1.*)
+ LEAVE datei editieren
+ ELIF kommando = ""
+ THEN LEAVE datei editieren
+ ELIF (kommando SUB 1) = "?"
+ THEN kommandos erklaeren;
+ LEAVE datei editieren
+ ELIF pos ("quit", kommando) = 1
+ THEN feldkommando (escape escape);
+ LEAVE dateieditor
+ ELSE escapefkt (code (code f)) := kommando
+ FI .
+
+ausfuehren :
+ haltzeile := satzmax;
+ IF kommando = ""
+ THEN zeile unveraendert
+ ELSE scan (kommando); nextsymbol;
+ IF a u s d r u c k (datei)
+ THEN IF symboltyp <> eol THEN fehler bearbeiten FI
+ FI;
+ IF war fehler THEN inchar (zeichen) (* warten *) FI
+ FI .
+
+kommandos erklaeren :
+ out (clear);
+ putline ("kommandos fuer den benutzer :"); line;
+ putline ("quit : beendet das editieren");
+ putline (" n : positioniert auf zeile n");
+ putline ("+ n : blaettert n zeilen vorwaerts");
+ putline ("- n : blaettert n zeilen rueckwaerts");
+ putline (" ""z"" : sucht angegebene zeichenkette ");
+ putline ("""muster"" CHANGETO ""ersatz"" :");
+ putline (" muster wird durch ersatz ersetzt");
+ putline ("HALT n : sieht anhalten des suchens in zeile n vor");
+ putline ("GET ""d"" : kopiert datei d und markiert");
+ putline ("PUT ""d"" : schreibt markierten abschnitt in datei d");
+ putline ("LIMIT n : setzt schreibende auf spalte n");
+ putline ("BEGIN n : setzt feldanfang auf spalte n");
+ putline ("SIZE n : setzt bildlaenge auf n"); line;
+ putline ("?ESCx : zeigt kommando auf escapetaste x");
+ inchar (zeichen) .
+
+END PROC dateieditor;
+
+PROC define escape (TEXT CONST cmd char, kommando) :
+ escapefkt (code (cmd char) MOD 128) := kommando
+END PROC define escape ;
+
+
+(******************** h i l f s - p r o z e d u r e n ********************)
+
+PROC fehler bearbeiten :
+ IF NOT war fehler
+ THEN war fehler := TRUE; bildneu (TRUE);
+ out (""2""2""2" kommandofehler bei ",symbol," erkannt.");
+ out (clear line mark)
+ FI
+END PROC fehler bearbeiten;
+
+BOOL PROC fehler : fehler bearbeiten; FALSE END PROC fehler;
+
+BOOL PROC klammerzu :
+ IF symbol = ")"
+ THEN nextsymbol; TRUE
+ ELSE fehler
+ FI
+END PROC klammerzu;
+
+PROC nextsymbol :
+ nextsymbol (symbol, symboltyp);
+ IF symboltyp = eol THEN symbol := "kommandoende" FI
+END PROC nextsymbol;
+
+PROC eof (DATEI VAR datei) :
+ boolwert := (bildstelle = dateianker); typ := void
+END PROC eof;
+
+PROC nachsatz (DATEI CONST datei) :
+ stelle := datei (stelle).nachfolger;
+ satz INCR 1; protokoll
+END PROC nachsatz;
+
+PROC vorsatz (DATEI CONST datei) :
+ stelle := datei (stelle).vorgaenger;
+ satz DECR 1; protokoll
+END PROC vorsatz;
+
+
+PROC protokoll :
+ cout (satz) ;
+ IF is incharety (escape)
+ THEN fehler bearbeiten
+ FI .
+END PROC protokoll;
+
+
+(******************* s p r i n g e n und s u c h e n *******************)
+
+PROC row (DATEI VAR datei) :
+ IF ziel voraus THEN vorwaerts springen ELSE rueckwaerts springen FI;
+ bildsatz (satz); bildstelle (stelle); typ := void; bildneu (TRUE) .
+
+ziel voraus :
+ satz := bildsatz; stelle := bildstelle;
+ IF zahlwert > satz
+ THEN TRUE
+ ELIF zahlwert <= satz DIV 2 AND bildmarke = 0
+ THEN stelle := datei (dateianker).nachfolger; satz := 1; TRUE
+ ELSE FALSE
+ FI .
+
+vorwaerts springen :
+ IF zahlwert <= 0
+ THEN fehler bearbeiten
+ FI ;
+ WHILE stelle <> dateianker AND satz < zahlwert
+ REP nachsatz (datei) UNTIL war fehler PER;
+ IF stelle = dateianker AND satz > 1
+ THEN vorsatz (datei);
+ feldstelle (LENGTH (datei (stelle).inhalt)+1)
+ FI .
+
+rueckwaerts springen :
+ WHILE stelle <> bildmarke AND satz > zahlwert
+ REP vorsatz (datei) UNTIL war fehler PER .
+
+END PROC row;
+
+PROC search (DATEI VAR datei) :
+ stelle := bildstelle;
+ IF textwert <> "" THEN contextadressierung FI;
+ typ := void .
+
+contextadressierung :
+ j := feldstelle - 1; satz := bildsatz;
+ WHILE noch nicht gefunden REP nachsatz (datei) UNTIL war fehler PER;
+ IF stelle = dateianker
+ THEN vorsatz (datei);
+ feldstelle (LENGTH (datei (stelle).inhalt)+1)
+ ELIF j > 0
+ THEN feldstelle ((LENGTH textwert)+j)
+ FI;
+ IF bildstelle <> stelle
+ THEN bildstelle (stelle); bildsatz (satz); bildneu (TRUE)
+ FI .
+
+noch nicht gefunden :
+ j := pos (datei (stelle).inhalt, textwert, j+1);
+ j = 0 AND stelle <> dateianker AND satz < haltzeile .
+
+END PROC search;
+
+
+(******************** vom file holen, in file bringen ********************)
+
+PROC vom file holen (DATEI VAR datei, TEXT VAR textwert) :
+ stelle := bildstelle; satz := bildsatz;
+ IF datei eroeffnung korrekt
+ THEN IF stelle = dateianker THEN satz erzeugen (datei, stelle) FI;
+ zeile auftrennen; file kopieren; kopiertes markieren;
+ bildstelle (stelle); bildsatz (satz); bildmarke (marke)
+ FI ; textwert := "" .
+
+datei eroeffnung korrekt :
+ IF textwert = ""
+ THEN sekundaerfile := sequential file (input); NOT eof (sekundaerfile)
+ ELIF exists (textwert)
+ THEN sekundaerfile := sequential file (input, textwert);
+ NOT eof (sekundaerfile)
+ ELSE FALSE
+ FI .
+
+file kopieren :
+ INT VAR altstelle;
+ FOR j FROM 0 UPTO satzmax WHILE NOT eof (sekundaerfile)
+ REP nachsatz (datei); altstelle := stelle;
+ satz erzeugen (datei, stelle);
+ IF stelle = altstelle THEN LEAVE file kopieren FI;
+ getline (sekundaerfile, inhalt)
+ UNTIL war fehler
+ PER .
+
+zeile auftrennen :
+ marke := stelle; bildmarksatz (satz);
+ nachsatz (datei); satz erzeugen (datei, stelle);
+ inhalt := subtext (datei (marke).inhalt, feldstelle);
+ vorsatz (datei); inhalt := text (inhalt, feldstelle-1) .
+
+kopiertes markieren :
+ nachsatz (datei);
+ IF inhalt = "" THEN satz loeschen (datei, stelle) FI;
+ vorsatz (datei);
+ IF datei (marke).inhalt = ""
+ THEN satz loeschen (datei, marke); satz DECR 1;
+ ELSE marke := datei (marke).nachfolger; bildmarksatz (bildmarksatz+1)
+ FI;
+ feldmarke (feldanfang); feldanfangsmarke (feldanfang);
+ feldstelle (1+LENGTH inhalt); bildneu (TRUE) .
+
+inhalt :
+ datei (stelle).inhalt .
+
+END PROC vom file holen;
+
+PROC in file bringen ( DATEI VAR datei, TEXT VAR textwert) :
+ neuen sekundaerfile erzeugen;
+ marke := bildstelle; stelle := bildmarke; satz := bildmarksatz;
+ IF stelle = marke
+ THEN IF feldmarke <> feldstelle
+ THEN putline (sekundaerfile,
+ subtext (inhalt, feldmarke, feldstelle-1))
+ FI
+ ELSE IF feldanfangsmarke <= LENGTH inhalt
+ THEN putline (sekundaerfile, subtext (inhalt, feldanfangsmarke))
+ FI; schreiben;
+ IF feldstelle > feldanfang
+ THEN putline (sekundaerfile, subtext (inhalt, 1, feldstelle-1))
+ FI
+ FI .
+
+schreiben:
+ REP nachsatz (datei);
+ IF stelle = marke OR war fehler THEN LEAVE schreiben FI;
+ putline (sekundaerfile, inhalt)
+ PER .
+
+neuen sekundaerfile erzeugen :
+ IF textwert = ""
+ THEN sekundaerfile := sequential file (output) ;
+ ELSE IF exists (textwert)
+ THEN forget (textwert)
+ FI;
+ IF exists (textwert)
+ THEN LEAVE in file bringen
+ FI;
+ sekundaerfile := sequential file (output, textwert)
+ FI .
+
+inhalt :
+ datei (stelle).inhalt .
+
+END PROC in file bringen;
+
+
+(************************* i n t e r p r e t e r *************************)
+
+BOOL PROC primary (DATEI VAR datei) :
+
+ SELECT symboltyp OF
+ CASE integer :
+ IF LENGTH symbol <= 4 (* Li 20.01.82 *)
+ THEN zahlwert := int (symbol);
+ typ := symboltyp;
+ nextsymbol; TRUE
+ ELSE fehler
+ FI
+ CASE texttyp :
+ textwert := symbol; typ := symboltyp; nextsymbol; TRUE
+ CASE delimiter :
+ IF symbol = "("
+ THEN nextsymbol;
+ IF ausdruck (datei) THEN klammerzu ELSE fehler FI
+ ELSE fehler
+ FI
+ CASE tag :
+ INT CONST pcode :: pos (proznamen, ";" + symbol + ";");
+ IF pcode = 0
+ THEN is variable
+ ELSE nextsymbol; prozedurieren
+ FI
+ CASE bold, operator :
+ INT CONST op1code :: pos (op1namen, ";" + symbol);
+ IF op1code = 0
+ THEN fehler
+ ELIF op1code = r (* Li 12.01.81 *)
+ THEN wiederholung (datei)
+ ELSE nextsymbol ;
+ IF primary (datei)
+ THEN operieren
+ ELSE fehler
+ FI
+ FI
+ OTHERWISE : fehler
+ END SELECT .
+
+is variable :
+ INT VAR var :: 1;
+ WHILE varname (var) <> symbol AND var <> freivar REP var INCR 1 PER;
+ IF var = freivar
+ THEN varname (var) := symbol; nextsymbol;
+ IF symbol = ":="
+ THEN deklarieren
+ ELSE LEAVE is variable WITH fehler
+ FI
+ ELSE nextsymbol
+ FI;
+ IF symbol = ":=" THEN nextsymbol; assignieren ELSE dereferenzieren FI .
+
+dereferenzieren :
+ typ := vartyp (var); zahlwert := varzahlwert (var);
+ textwert := vartextwert (var); TRUE .
+
+assignieren :
+ IF primary (datei)
+ THEN IF typ = integer
+ THEN varzahlwert (var) := zahlwert
+ ELIF typ = texttyp
+ THEN vartextwert (var) := textwert
+ ELSE fehler bearbeiten
+ FI;
+ vartyp (var) := typ; typ := void
+ ELSE fehler bearbeiten
+ FI;
+ NOT war fehler .
+
+deklarieren :
+ IF freivar = varimax
+ THEN fehler bearbeiten
+ ELSE freivar INCR 1
+ FI .
+
+prozedurieren :
+ typ := integer;
+ SELECT pcode OF
+ CASE pcol : zahlwert := feldstelle
+ CASE plen : zahlwert := LENGTH (datei (bildstelle).inhalt)
+ CASE prow : zahlwert := bildsatz
+ CASE phalt : zahlwert := haltzeile
+ CASE plimit : zahlwert := feldlimit
+ CASE pmark : zahlwert := bildmarke
+ CASE peof : eof (datei)
+ OTHERWISE fehler bearbeiten
+ END SELECT;
+ NOT war fehler .
+
+operieren :
+ SELECT op1code OF
+ CASE plus : zahlwert INCR bildsatz; row (datei)
+ CASE minus : zahlwert := bildsatz - zahlwert; row (datei)
+ CASE b : begin
+ CASE c : col
+ CASE g : get
+ CASE h : halt
+ CASE l : limit
+ CASE m : mark
+ CASE p : put
+ CASE i : if
+ CASE w : write
+ CASE s : size
+ OTHERWISE fehler bearbeiten
+ END SELECT;
+ typ := void; TRUE .
+
+begin :
+ zahlwert := zahlwert MOD 180;
+ feldende (feldende+zahlwert-feldanfang); feldanfang (zahlwert) .
+
+col :
+ zahlwert := zahlwert MOD 256; feldstelle (zahlwert) .
+
+get :
+ IF bildmarke <= 0 AND schreiberlaubnis
+ THEN vom file holen (datei, textwert)
+ FI .
+
+halt :
+ haltzeile := zahlwert .
+
+limit :
+ zahlwert := zahlwert MOD 256; feldlimit (zahlwert) .
+
+mark :
+ IF zahlwert = 0
+ THEN bildmarke (0); feldmarke (0); bildneu (TRUE)
+ ELSE bildmarke (bildstelle); feldmarke (feldstelle);
+ bildmarksatz (bildsatz)
+ FI .
+
+put :
+ IF bildmarke > 0 THEN in file bringen (datei, textwert) FI .
+
+if :
+ IF bedingung (datei)
+ THEN IF boolwert
+ THEN IF pos ("THEN", symbol) = 1
+ THEN nextsymbol;
+ IF ausdruck (datei)
+ THEN skip elseteil
+ ELSE fehler bearbeiten
+ FI
+ ELSE fehler bearbeiten
+ FI
+ ELSE skip thenteil;
+ IF j = 1
+ THEN elseteil
+ ELIF j <> 5
+ THEN fehler bearbeiten
+ FI
+ FI
+ ELSE fehler bearbeiten
+ FI .
+
+elseteil :
+ IF ausdruck (datei)
+ THEN IF symbol = "FI" THEN nextsymbol ELSE fehler bearbeiten FI
+ FI .
+
+skip elseteil :
+ WHILE symboltyp <> eol AND pos ("FI", symbol) <> 1 REP nextsymbol PER;
+ nextsymbol .
+
+skip thenteil :
+ WHILE (symboltyp <> eol) AND nicht elsefi REP nextsymbol PER;
+ nextsymbol .
+
+nicht elsefi :
+ j := pos ("ELSEFI", symbol); j = 0 .
+
+write :
+ feldkommando (textwert); zeile unveraendert .
+
+size :
+ IF bildlaenge > maxbildlaenge
+ THEN maxbildlaenge := bildlaenge
+ FI;
+ bildlaenge (max (1, min (zahlwert, maxbildlaenge)));
+ bildzeile (min (bildzeile, bildlaenge));
+ bildrand (0); bildneu (TRUE); page .
+
+END PROC primary;
+
+
+(*********** w i e d e r h o l u n g , b e d i n g u n g ***************)
+
+BOOL PROC wiederholung (DATEI VAR datei) :
+
+ fix scanner ; (* Li 12.01.81 *)
+ wiederholt interpretieren;
+ skip endrep; typ := void;
+ NOT war fehler .
+
+wiederholt interpretieren :
+ REP reset scanner; nextsymbol; (* 12.01.81 *)
+ WHILE ausdruck (datei) REP UNTIL until PER; abbruchtest
+ UNTIL ende der wiederholung
+ PER .
+
+until :
+ IF pos ("UNTIL", symbol) = 1
+ THEN nextsymbol;
+ IF primary (datei) THEN FI;
+ IF bedingung (datei)
+ THEN IF boolwert
+ THEN LEAVE wiederholt interpretieren;TRUE
+ ELSE TRUE
+ FI
+ ELSE fehler
+ FI
+ ELSE TRUE
+ FI .
+
+ende der wiederholung :
+ IF war fehler
+ THEN TRUE
+ ELIF datei (stelle).nachfolger = dateianker
+ THEN feldstelle > LENGTH (datei (stelle).inhalt)
+ ELSE FALSE
+ FI .
+
+skip endrep :
+ WHILE pos ("ENDREPEAT", symbol) <> 1 AND symboltyp <> eol
+ REP nextsymbol PER;
+ nextsymbol .
+
+abbruchtest :
+ IF is incharety (escape)
+ THEN fehler bearbeiten
+ FI .
+
+END PROC wiederholung;
+
+BOOL PROC bedingung (DATEI VAR datei) :
+ INT VAR relator;
+ relator := pos ("=><<=>=<>", symbol);
+ IF relator = 0
+ THEN fehler
+ ELSE IF typ = texttyp THEN relator INCR 8 FI;
+ nextsymbol;
+ INT VAR operandtyp :: typ, operandzahlwert :: zahlwert;
+ TEXT VAR operandtextwert :: textwert;
+ IF primary (datei) THEN FI;
+ IF operandtyp <> typ
+ THEN fehler
+ ELSE boolwert := vergleich; typ := bool; TRUE
+ FI
+ FI .
+
+vergleich :
+ SELECT relator OF
+ CASE 1 : operandzahlwert = zahlwert
+ CASE 2 : operandzahlwert > zahlwert
+ CASE 3 : operandzahlwert < zahlwert
+ CASE 4 : operandzahlwert <= zahlwert
+ CASE 6 : operandzahlwert >= zahlwert
+ CASE 8 : operandzahlwert <> zahlwert
+ CASE 9 : operandtextwert = textwert
+ CASE 10 : operandtextwert > textwert
+ CASE 11 : operandtextwert < textwert
+ CASE 12 : operandtextwert <= textwert
+ CASE 14 : operandtextwert >= textwert
+ CASE 16 : operandtextwert <> textwert
+ OTHERWISE fehler
+ END SELECT .
+
+END PROC bedingung;
+
+(**************************** a u s d r u c k ****************************)
+
+BOOL PROC ausdruck (DATEI VAR datei) :
+ INT VAR opcode, operandtyp, operandzahlwert;
+ TEXT VAR operandtextwert;
+ IF primary (datei)
+ THEN BOOL VAR war operation :: TRUE;
+ WHILE operator AND war operation
+ REP IF primary (datei)
+ THEN war operation := operator verarbeiten
+ ELSE war operation := FALSE
+ FI
+ PER;
+ war operation
+ ELSE fehler
+ FI .
+
+operator :
+ IF kommandoende
+ THEN IF typ = integer
+ THEN row (datei)
+ ELIF typ = texttyp
+ THEN search (datei)
+ FI
+ FI;
+ opcode := pos (op2namen, "&" + symbol);
+ IF opcode = 0
+ THEN FALSE
+ ELSE nextsymbol; operandtyp := typ;
+ operandzahlwert := zahlwert;
+ operandtextwert := textwert;
+ NOT war fehler
+ FI .
+
+operator verarbeiten :
+ SELECT opcode OF
+ CASE plus :
+ IF typ = integer
+ THEN zahlwert := operandzahlwert + zahlwert
+ ELSE textwert := operandtextwert + textwert
+ FI
+ CASE minus :
+ zahlwert := operandzahlwert - zahlwert
+ CASE mal :
+ IF typ = integer
+ THEN zahlwert := operandzahlwert * zahlwert
+ ELSE textwert := operandzahlwert * textwert
+ FI
+ CASE durch :
+ zahlwert := operandzahlwert DIV zahlwert
+ CASE changecode :
+ change
+ CASE semicolon :
+ OTHERWISE fehler bearbeiten
+ END SELECT;
+ NOT war fehler .
+
+change :
+ IF bildmarke <= 0 AND schreiberlaubnis AND bildstelle <> dateianker
+ THEN ersatz := textwert; textwert := operandtextwert; search (datei);
+ INT VAR fstelle :: feldstelle;
+ IF textwert = "" AND ersatz <> "" AND fstelle > LENGTH inhalt
+ THEN inhalt := text (inhalt, fstelle-1)
+ FI;
+ IF subtext (inhalt, fstelle-LENGTH textwert, fstelle-1) = textwert
+ THEN fstelle := fstelle - LENGTH textwert;
+ FOR j FROM 1 UPTO LENGTH ersatz
+ REP IF j <= LENGTH textwert
+ THEN replace (inhalt, fstelle, ersatz SUB j)
+ ELSE insert char (inhalt, ersatz SUB j, fstelle)
+ FI;
+ fstelle INCR 1
+ PER;
+ FOR j FROM 1+LENGTH ersatz UPTO LENGTH textwert
+ REP delete char (inhalt, fstelle) PER;
+ FI;
+ feldstelle (fstelle); typ := void
+ ELSE fehler bearbeiten
+ FI .
+
+inhalt :
+ datei (stelle).inhalt .
+
+kommandoende :
+ SELECT pos (";FIELSEENDREPEATUNTIL", symbol) OF
+ CASE 1,2,4,8,17 : TRUE
+ OTHERWISE symboltyp = eol
+ END SELECT .
+
+END PROC ausdruck;
+
+(************************** schrott ****************************************)
+
+PROC satz erzeugen (DATEI VAR datei, INT VAR satz):
+ EXTERNAL 291 ;
+END PROC satz erzeugen;
+
+PROC satz loeschen (DATEI VAR datei, INT VAR satz):
+ EXTERNAL 292 ;
+END PROC satz loeschen;
+
+END PACKET dateieditorpaket;
diff --git a/system/base/unknown/src/editor b/system/base/unknown/src/editor new file mode 100644 index 0000000..55fbfb1 --- /dev/null +++ b/system/base/unknown/src/editor @@ -0,0 +1,210 @@ +
+PACKET editor DEFINES (* Autor: P.Heyderhoff *)
+ (* Stand: 26.04.82 *)
+ edit , (* Vers.: 1.6.3 *)
+ show ,
+ editmode :
+
+FILE VAR file 1, file 2 ;
+
+PROC edit (FILE VAR file) :
+ x edit (file) ;
+ENDPROC edit ;
+
+PROC edit (FILE VAR file 1, file 2) :
+ x edit (file 1, file 2 )
+ENDPROC edit ;
+
+PROC edit (TEXT CONST file name) :
+ last param (file name) ;
+ IF exists (file name)
+ THEN edit 1 (file name)
+ ELIF yes ("neue datei einrichten")
+ THEN edit 1 (file name)
+ ELSE errorstop ("")
+ FI
+ENDPROC edit ;
+
+PROC edit :
+ edit (last param)
+ENDPROC edit ;
+
+PROC edit 1 (TEXT CONST name) :
+ file 1 := sequential file (modify, name) ;
+ IF NOT is error
+ THEN edit (file 1)
+ FI
+ENDPROC edit 1 ;
+
+PROC edit (TEXT CONST file name 1, file name 2) :
+ IF exists (file name 1)
+ THEN edit 2 (file name 1, file name 2)
+ ELIF yes ("erste datei neu einrichten")
+ THEN edit 2 (file name 1, file name 2)
+ ELSE errorstop ("")
+ FI
+ENDPROC edit ;
+
+PROC edit 2 (TEXT CONST file name 1, file name 2) :
+ file 1 := sequential file (modify, file name 1) ;
+ IF exists (file name 2)
+ THEN file 2 := sequential file (modify, file name 2) ;
+ edit (file 1, file 2)
+ ELIF yes ("zweite datei neu einrichten")
+ THEN file 2 := sequential file (modify, file name 2) ;
+ edit (file 1, file 2)
+ ELSE errorstop ("")
+ FI
+ENDPROC edit 2 ;
+
+PROC show (FILE VAR file) :
+ schreiberlaubnis (FALSE) ;
+ edit (file) ;
+ schreiberlaubnis (TRUE)
+ENDPROC show ;
+
+PROC show (TEXT CONST file name) :
+ IF exists (file name)
+ THEN file 1 := sequential file (modify, file name) ;
+ show (file 1) ;
+ ELSE errorstop ("file does not exist")
+ FI
+ENDPROC show ;
+
+PROC editmode :
+ feldwortweise (NOT feldwortweise) ;
+ say (" ") ;
+ IF feldwortweise
+ THEN say ("Flieátext"13""10"")
+ ELSE say ("kein Umbruch"13""10"")
+ FI .
+
+ENDPROC editmode ;
+
+
+(****************************** e d i t o r ******************************)
+
+LET DATEI = ROW 4075 STRUCT (INT nachfolger, vorgaenger, index,
+ fortsetzung, TEXT inhalt),
+ freianker = 1, dateianker = 2, satzmax = 4075,
+ bottom = ""6""23""0"" , escape = ""27"", escape w = ""27"w";
+
+BOOL VAR war kein wechsel ;
+TEXT VAR tabulator :: 77*" ";
+
+
+PROC editor (DATEI VAR datei) :
+ enable stop ;
+ grundzustand;
+ zustand aus datei holen ;
+
+ REP b i l d e d i t o r (datei);
+ d a t e i e d i t o r (datei)
+ UNTIL (feldkommando SUB 1) = escape
+ PER;
+ war kein wechsel := (feldkommando SUB 2) <> "w";
+ feldkommando (subtext (feldkommando, 3));
+
+ IF schreiberlaubnis THEN zustand in datei retten FI;
+ schreiberlaubnis (TRUE);
+ out (bottom) .
+
+grundzustand :
+ bildneu (TRUE); bildeinfuegen (FALSE); bildmarke (0);
+ feldmarke (0); feldseparator (""); feldstelle(1);
+ feldeinfuegen (FALSE).
+
+zustand in datei retten :
+ inhalt := text (bildstelle, 5);
+ inhalt CAT text (bildsatz, 5);
+ inhalt CAT text (bildzeile, 5);
+ inhalt CAT text (feldlimit, 5);
+ feldtab (tabulator);
+ inhalt CAT tabulator .
+
+zustand aus datei holen :
+ INT CONST satz nr := int (subtext (inhalt, 1, 5)) ;
+ IF satz nr > 0
+ THEN bildstelle (satz nr)
+ ELSE bildstelle (datei (dateianker).nachfolger)
+ FI ;
+ bildsatz (int (subtext (inhalt, 6, 10)));
+ bildzeile (int (subtext (inhalt, 11, 15)));
+ feldlimit (int (subtext (inhalt, 16, 20)));
+ tabulator := subtext (inhalt, 21) ;
+ feldtabulator (tabulator) .
+
+inhalt :
+ datei (freianker).inhalt .
+
+END PROC editor;
+
+PROC y edit (DATEI VAR datei) :
+ editor (datei);
+ close
+END PROC y edit;
+
+LET begin mark = ""15"", endmark blank = ""14" ";
+
+PROC y edit (DATEI VAR erste datei, zweite datei) :
+ INT CONST alte laenge := bildlaenge - 1;
+ INT VAR laenge := alte laenge DIV 2, flen := feldende - feldanfang + 2;
+ bildlaenge (laenge); feldkommando (escape w);
+ zweimal editieren;
+ bildlaenge (alte laenge + 1); bildrand (0);
+ close .
+
+zweimal editieren:
+ page;
+ REP cursor ( 1, laenge + 2); out (begin mark);
+ cursor(flen, laenge + 2); out (endmark blank);
+ bildrand (0); editor (erste datei); laenge anpassen;
+ IF war kein wechsel THEN LEAVE zweimal editieren FI;
+ bildrand (alte laenge + 1 - laenge);
+ editor (zweite datei); laenge anpassen
+ UNTIL war kein wechsel
+ PER .
+
+laenge anpassen :
+ laenge := bildlaenge;
+ IF laenge = 1 THEN laenge := 2 FI;
+ IF laenge <= alte laenge - 2
+ THEN laenge := alte laenge - laenge
+ ELSE laenge := 2
+ FI ; bildlaenge (laenge) .
+END PROC y edit;
+
+(**************** schrott ***********************)
+
+PROC x edit (FILE VAR f) :
+ EXTERNAL 296
+ENDPROC x edit ;
+
+PROC x edit (FILE VAR f1, f2) :
+ EXTERNAL 297
+ENDPROC x edit ;
+
+LET FDATEI= STRUCT ( BOUND DATEI f ,
+ INT index, pointer, line counter,
+ mode, max line length, max page length,
+ BOOL edit status unchanged) ;
+
+PROC x edit (FDATEI VAR f1) :
+ INTERNAL 296 ;
+ y edit (CONCR (f1.f))
+ENDPROC x edit ;
+
+PROC x edit (FDATEI VAR f1, f2) :
+ INTERNAL 297 ;
+ y edit (CONCR (f1.f), CONCR (f2.f))
+ENDPROC x edit ;
+
+PROC dateieditor (DATEI VAR d) :
+ EXTERNAL 295
+ENDPROC dateieditor ;
+
+PROC bildeditor (DATEI VAR d) :
+ EXTERNAL 293
+ENDPROC bildeditor ;
+
+ENDPACKET editor ;
diff --git a/system/base/unknown/src/elan b/system/base/unknown/src/elan new file mode 100644 index 0000000..744003d --- /dev/null +++ b/system/base/unknown/src/elan @@ -0,0 +1,245 @@ +
+PACKET local manager part 2 DEFINES (* Autor: J.Liedtke *)
+ (* Stand: 29.04.80 *)
+ list ,
+ file names :
+
+
+FILE VAR list file ;
+TEXT VAR file name, status text;
+
+PROC list :
+
+ list file := sequential file (output) ;
+ headline (list file, "list") ;
+ list (list file) ;
+ show (list file) ;
+ close
+
+ENDPROC list ;
+
+PROC list (FILE VAR f) :
+
+ begin list ;
+ putline (f, "") ;
+ REP
+ get list entry (file name, status text) ;
+ IF file name = ""
+ THEN LEAVE list
+ FI ;
+ out (f, status text + " """ ) ;
+ out (f, file name) ;
+ out (f, """") ;
+ line (f)
+ PER
+
+ENDPROC list ;
+
+PROC file names (FILE VAR f) :
+
+ begin list ;
+ REP
+ get list entry (file name, status text) ;
+ IF file name = ""
+ THEN LEAVE file names
+ FI ;
+ putline (f, file name)
+ PER
+
+ENDPROC file names ;
+
+ENDPACKET local manager part 2 ;
+
+
+PACKET elan DEFINES (*Autor: J.Liedtke *)
+ (*Stand: 01.05.82 *)
+ do ,
+ run ,
+ run again ,
+ insert ,
+ prot ,
+ prot off ,
+ check on ,
+ check off :
+
+
+LET newinit option = FALSE ,
+ ins = TRUE ,
+ no ins = FALSE ,
+ lst = TRUE ,
+ no lst = FALSE ,
+ compiler dump option = FALSE ,
+ sys option = TRUE ,
+ stop at first error = TRUE ,
+ multiple error analysis = FALSE ,
+ sermon = TRUE ,
+ no sermon = FALSE ,
+
+ run again mode = 0 ,
+ compile file mode = 1 ,
+ compile line mode = 2 ,
+
+ error message = 4 ;
+
+BOOL VAR list option := FALSE ,
+ check option := TRUE ,
+ errors occurred ;
+
+INT VAR run again mod nr := 0 ;
+DATASPACE VAR ds ;
+
+FILE VAR error file, source file ;
+
+
+PROC do (TEXT CONST command) :
+
+ INT VAR dummy mod ;
+ run again mod nr := 0 ;
+ errors occurred := FALSE ;
+ elan (compile line mode, ds, command, dummy mod,
+ newinit option, no ins, compiler dump option, no lst, sys option,
+ check option, stop at first error, no sermon) ;
+ IF errors occurred
+ THEN forget (ds) ;
+ errorstop ("")
+ FI
+
+ENDPROC do ;
+
+
+PROC run (TEXT CONST file name) :
+
+ last param (file name) ;
+ run elan (file name, no ins)
+
+END PROC run;
+
+PROC run :
+
+ run (last param)
+
+ENDPROC run ;
+
+PROC run again :
+
+ IF run again mod nr > 0
+ THEN INT VAR mod := run again mod nr ;
+ elan (run again mode, ds, "", run again mod nr,
+ newinit option, no ins, compiler dump option, no lst,
+ sys option, check option, stop at first error, no sermon)
+ ELSE errorstop ("run again impossible")
+ FI
+
+ENDPROC run again ;
+
+PROC insert (TEXT CONST file name) :
+
+ last param (file name) ;
+ run elan (file name, ins)
+
+ENDPROC insert ;
+
+PROC insert :
+
+ insert (last param)
+
+ENDPROC insert ;
+
+PROC run elan (TEXT CONST file name, BOOL CONST insert option) :
+
+ IF exists (file name)
+ THEN compile and execute
+ ELSE errorstop ("file does not exist")
+ FI .
+
+compile and execute :
+ disable stop ;
+ errors occurred := FALSE ;
+ elan (compile file mode, old (file name, 1002), "" , run again mod nr,
+ newinit option, insert option, compiler dump option, list option,
+ sys option, check option, multiple error analysis, sermon) ;
+
+ IF errors occurred
+ THEN ignore halt during compiling ;
+ errors occurred := FALSE ;
+ enable stop ;
+ source file := sequential file (modify, file name) ;
+ modify (error file) ;
+ edit (error file, source file) ;
+ forget (ds)
+ FI .
+
+ignore halt during compiling :
+ IF is error
+ THEN put error ;
+ clear error ;
+ pause (5)
+ FI .
+
+ENDPROC run elan ;
+
+PROC elan (INT CONST mode, DATASPACE CONST source, TEXT CONST line,
+ INT VAR start module number,
+ BOOL CONST newinit, ins, dump, lst, sys, rt check, error1, ser) :
+ EXTERNAL 256
+ENDPROC elan ;
+
+PROC out text (TEXT CONST text, INT CONST out type) :
+
+ INTERNAL 257 ;
+ out (text) ;
+ IF out type = error message
+ THEN access error file ;
+ out (error file, text)
+ FI .
+
+access error file :
+ IF NOT errors occurred
+ THEN open error file
+ FI .
+
+ENDPROC out text ;
+
+PROC out line (INT CONST out type) :
+
+ INTERNAL 258 ;
+ out (""13""10"") ;
+ IF out type = error message
+ THEN access error file ;
+ line (error file)
+ FI .
+
+access error file :
+ IF NOT errors occurred
+ THEN open error file
+ FI .
+
+ENDPROC out line ;
+
+PROC open error file :
+
+ errors occurred := TRUE ;
+ forget (ds) ;
+ ds := nilspace ;
+ error file := sequential file (output, ds) ;
+ headline (error file, "errors")
+
+ENDPROC open error file ;
+
+PROC prot :
+ list option := TRUE
+ENDPROC prot ;
+
+PROC prot off :
+ list option := FALSE
+ENDPROC prot off ;
+
+PROC check on :
+ check option := TRUE
+ENDPROC check on ;
+
+PROC check off :
+ check option := FALSE
+ENDPROC check off ;
+
+ENDPACKET elan ;
diff --git a/system/base/unknown/src/feldeditor b/system/base/unknown/src/feldeditor new file mode 100644 index 0000000..4156111 --- /dev/null +++ b/system/base/unknown/src/feldeditor @@ -0,0 +1,747 @@ +
+PACKET f e l d e d i t o r DEFINES (* Autor: P.Heyderhoff *)
+ (*****************) (* Stand: 12.04.82 *)
+ (* Vers.: 1.6.0 *)
+ editget,
+ feldeditor,
+ feldout,
+ feldposition,
+ feldeinruecken,
+ feldtab,
+ feldtabulator,
+ feldseparator,
+ feldmarke,
+ feldstelle,
+ feldwortweise,
+ feldanfang,
+ feldende,
+ feldrand,
+ feldlimit,
+ feldaudit,
+ feldzeichen,
+ feldkommando,
+ feldeinfuegen,
+ feldlernmodus,
+ is incharety,
+ getchar,
+ min :
+
+
+TEXT VAR tabulator :: "", separator :: "", fzeichen ::"",
+ kommando :: "", audit :: "";
+
+INT VAR fmarke :: 0, fstelle :: 1, frand :: 0, limit :: 77,
+ fanfang :: 1, dyn fanfang :: fanfang, flaenge, fj,
+ fende :: 77, dyn fende :: fende, dezimalen :: 0;
+
+BOOL VAR wortweise :: FALSE, feinfuegen :: FALSE,
+ blankseparator :: FALSE, lernmodus :: FALSE,
+ war absatz;
+
+LET blank = " ", hop=""1"", right=""2"", up=""3"", clear eop=""4"",
+ clear eol=""5"", bell=""7"", left=""8"", tab=""9"", down=""10"",
+ rubin=""11"", rubout=""12"", cr=""13"", mark=""16"", escape=""27"",
+ hoechstes steuerzeichen=""31"", dach=""94"", end mark=""14"", begin
+ mark=""15"", clear=""1""4"", hop tab=""1""9"", hop rubin=""1""11"",
+ hop rubout=""1""12"", hop cr=""1""13"", cr down=""13""10"",
+ right left tab rubout escape = ""2""8""9""12""27"", hop escape=""1""27"",
+ left left=""8""8"", left endmark=""8""14"", endmark left=""14""8"",
+ left right=""8""2"", blank left=" "8"",
+ blank left rubout=" "8""12"", absatzmarke=""15""14"",
+ hop esc right left tab rubin rubout cr = ""1""27""2""8""9""11""12""13"",
+ hop esc right left tab down cr = ""1""27""2""8""9""10""13"";
+
+(*************************** p r o z e d u r e n *************************)
+
+PROC editget (TEXT VAR editsatz, INT CONST editlimit, editfende):
+
+ disable stop ; (* J.Liedtke 10.02.82 *)
+
+ INT CONST altflaenge :: LENGTH editsatz, altfrand :: frand,
+ altfmarke :: fmarke, altfstelle :: fstelle,
+ altfanfang :: fanfang, altfende :: fende, altlimit :: limit;
+ BOOL CONST altwortweise :: wortweise, altfeinfuegen :: feinfuegen;
+ fmarke := 0; fstelle := 1; fanfang := 1; dyn fanfang := 1;
+ fende := editfende MOD 256; dyn fende := fende;
+ limit := editlimit MOD 256; wortweise := FALSE;
+ feinfuegen := FALSE;
+ INT VAR x, y; get cursor (x,y); frand := x-1;
+ out (editsatz); cursor (x,y);
+ REP
+ feldeditor (editsatz);
+ IF (kommando SUB 1) = escape OR (kommando SUB 1) = hop
+ THEN delete char (kommando, 1)
+ FI;
+ delete char (kommando, 1)
+ UNTIL fzeichen = cr OR (fzeichen SUB 1) = separator OR is error
+ PER;
+ cursor (x + 1 + editflaenge - dyn fanfang, y);
+ fmarke := altfmarke; fstelle := altfstelle; fanfang := altfanfang;
+ dyn fanfang := fanfang; fende := altfende; dyn fende := fende;
+ limit := altlimit; wortweise := altwortweise; frand := altfrand;
+ feinfuegen := altfeinfuegen .
+
+editflaenge :
+ min (dyn fende, flaenge) .
+
+END PROC editget;
+
+PROC editget (TEXT VAR editsatz) :
+ INT VAR x, y; get cursor (x,y);
+ editget (editsatz, 255, fende-fanfang+2+frand-x)
+END PROC editget;
+
+PROC feldout (TEXT CONST satz) :
+ INT VAR x, y;
+ flaenge := min (fende, LENGTH satz);
+ out (cr);
+ frand TIMESOUT right; feldrest loeschen (fanfang);
+ IF fmarke > 0
+ THEN outsubtext (satz, fanfang, fmarke-1); out (begin mark);
+ outsubtext (satz, fmarke, min (fstelle-1,flaenge));
+ out (end mark); outsubtext (satz, fstelle, flaenge);
+ ELIF absatzmarke noetig (satz)
+ THEN get cursor (x,y); outsubtext (satz, fanfang, flaenge);
+ cursor (x + fende + 1 - fanfang, y); out (absatzmarke)
+ ELSE outsubtext (satz, fanfang, flaenge)
+ FI
+END PROC feldout;
+
+
+PROC feld einruecken (TEXT CONST satz) :
+
+ IF fstelle = fanfang
+ THEN fstelle := neue einrueckposition;
+ (fstelle-fanfang) TIMESOUT right
+ FI .
+
+neue einrueckposition :
+ INT VAR suchindex;
+ FOR suchindex FROM fanfang UPTO min (LENGTH satz, fende)
+ REP IF (satz SUB suchindex) <> blank
+ THEN LEAVE neue einrueckposition WITH suchindex
+ FI
+ PER;
+ fanfang .
+
+END PROC feld einruecken;
+
+TEXT PROC feldzeichen :
+ fzeichen
+END PROC feldzeichen;
+
+TEXT PROC feldkommando :
+ kommando
+END PROC feldkommando;
+
+PROC feldkommando (TEXT CONST t) :
+ kommando := t
+END PROC feldkommando;
+
+PROC feldtab (TEXT VAR t) :
+ t := tabulator
+END PROC feldtab;
+
+PROC feldtabulator (TEXT CONST t) :
+ tabulator := t
+END PROC feldtabulator;
+
+TEXT PROC feldseparator :
+ separator
+END PROC feldseparator;
+
+PROC feldseparator (TEXT CONST t) :
+ separator := t; blankseparator := t = blank
+END PROC feldseparator;
+
+TEXT PROC feldaudit :
+ audit
+END PROC feldaudit;
+
+PROC feldaudit (TEXT CONST a) :
+ audit := a
+END PROC feldaudit;
+
+BOOL PROC feldlernmodus :
+ lernmodus
+END PROC feldlernmodus;
+
+PROC feldlernmodus (BOOL CONST b) :
+ lernmodus := b
+END PROC feldlernmodus;
+
+BOOL PROC feldeinfuegen :
+ feinfuegen
+END PROC feldeinfuegen;
+
+PROC feldeinfuegen (BOOL CONST b):
+ feinfuegen := b
+END PROC feldeinfuegen;
+
+BOOL PROC feldwortweise :
+ wortweise
+END PROC feldwortweise;
+
+PROC feldwortweise (BOOL CONST b) :
+ wortweise := b
+END PROC feldwortweise;
+
+INT PROC feldmarke :
+ fmarke
+END PROC feldmarke;
+
+PROC feldmarke (INT CONST i) :
+ fmarke := i MOD 256
+END PROC feldmarke;
+
+INT PROC feldstelle :
+ fstelle
+END PROC feldstelle;
+
+PROC feldstelle (INT CONST i) :
+ fstelle := i MOD 256
+END PROC feldstelle;
+
+INT PROC feldanfang :
+ fanfang
+END PROC feldanfang;
+
+PROC feldanfang (INT CONST i) :
+ fanfang := i MOD 256; dyn fanfang := fanfang
+END PROC feldanfang;
+
+INT PROC feldende :
+ fende
+END PROC feldende;
+
+PROC feldende (INT CONST i) :
+ fende := i MOD 256; dyn fende := fende
+END PROC feldende;
+
+INT PROC feldrand :
+ frand
+END PROC feldrand;
+
+PROC feldrand (INT CONST i) :
+ frand := i MOD 256
+END PROC feldrand;
+
+INT PROC feldlimit :
+ limit
+END PROC feldlimit;
+
+PROC feldlimit (INT CONST i) :
+ limit := i MOD 256
+END PROC feldlimit;
+
+PROC feldposition :
+ INT VAR x, y;
+ IF fstelle <= fende
+ THEN IF fstelle < fanfang
+ THEN fstelle := fanfang;
+ IF fanfang > fende
+ THEN fende := fanfang; dyn fende := fanfang
+ FI
+ FI
+ ELSE fstelle := fende;
+ IF fanfang > fende
+ THEN fanfang := fende; dyn fanfang := fende
+ FI
+ FI;
+ get cursor(x,y); cursor(1+frand+fstelle-fanfang+fmarke oder fstelle, y).
+
+fmarke oder fstelle :
+ IF fmarke > 0 THEN 1 ELSE 0 FI .
+
+END PROC feldposition;
+
+PROC feldposition (INT CONST i) :
+ fstelle := i; feldposition
+END PROC feldposition;
+
+BOOL PROC absatzmarke noetig (TEXT CONST satz) :
+
+ IF wortweise
+ THEN (satz SUB LENGTH satz) = blank
+ ELSE FALSE
+ FI
+END PROC absatzmarke noetig;
+
+PROC zeile neu schreiben (TEXT CONST satz) :
+ INT VAR x,y; get cursor (x,y);
+ flaenge := min (dyn fende, LENGTH satz);
+ cursor (1+frand, y);
+ feldrest loeschen (dyn fanfang);
+ outsubtext (satz, dyn fanfang, flaenge);
+ cursor (x,y)
+END PROC zeile neu schreiben;
+
+PROC feldrest loeschen (INT CONST fstelle):
+ INT VAR x,y;
+ IF frand + fende <= 76
+ THEN get cursor (x,y); (1 + dyn fende - fstelle) TIMESOUT blank;
+ cursor (x,y)
+ ELSE out (clear eol); war absatz := FALSE
+ FI
+END PROC feldrest loeschen;
+
+TEXT OP SUBB (TEXT CONST t, INT CONST i) :
+ IF i <= LENGTH t THEN t SUB i ELSE blank FI
+END OP SUBB;
+
+INT PROC min (INT CONST a, b):
+ IF a < b THEN a ELSE b FI
+END PROC min;
+
+BOOL PROC is incharety (TEXT CONST muster) :
+
+ fzeichen := incharety;
+ IF fzeichen = ""
+ THEN FALSE
+ ELSE IF lernmodus
+ THEN audit CAT fzeichen;
+ IF fzeichen = """" THEN audit CAT fzeichen
+ FI FI ;
+ IF fzeichen = muster
+ THEN kommando := ""; TRUE
+ ELSE kommando CAT fzeichen; FALSE
+ FI FI
+END PROC is incharety;
+
+PROC getchar (TEXT VAR fzeichen) :
+
+ IF kommando = ""
+ THEN inchar (fzeichen)
+ ELSE fzeichen := kommando SUB 1;
+ delete char (kommando, 1);
+ kommando CAT incharety
+ FI;
+ IF lernmodus
+ THEN audit CAT fzeichen;
+ IF fzeichen = """"
+ THEN audit CAT fzeichen
+ FI
+ FI .
+END PROC getchar;
+
+
+(************************** f e l d e d i t o r **************************)
+
+PROC feldeditor (TEXT VAR satz) :
+
+ enable stop ; (* J. Liedtke 10.02.82 *)
+
+ INT VAR x, y;
+ BOOL VAR inkompetent :: FALSE; war absatz := absatzmarke noetig (satz);
+ IF fstelle <= fende
+ THEN IF fstelle < fanfang THEN feldposition FI
+ ELSE feldposition
+ FI;
+ flaenge := min (fende, LENGTH satz);
+
+ REP e i n g a b e UNTIL inkompetent PER;
+
+ blanks abschneiden;
+ IF dyn fanfang <> fanfang THEN zurechtruecken FI;
+ IF NOT war absatz AND absatzmarke noetig (satz)
+ THEN absatzmarke schreiben
+ ELIF war absatz AND NOT absatzmarke noetig (satz)
+ THEN absatzmarke loeschen
+ FI .
+
+absatzmarke schreiben :
+ get cursor (x,y); cursor (frand+fende-fanfang+2, y); out (absatzmarke);
+ cursor (x,y) .
+
+absatzmarke loeschen :
+ get cursor (x,y); cursor (frand+fende-fanfang+2, y); out (" ");
+ cursor (x,y) .
+
+zurechtruecken :
+ fstelle DECR (dyn fanfang - fanfang);
+ dyn fanfang := fanfang; dyn fende := fende;
+ zeile neu schreiben (satz) .
+
+blanks abschneiden :
+ flaenge := LENGTH satz;
+ FOR fj FROM flaenge DOWNTO 0 WHILE (satz SUB fj) = blank
+ REP delete char (satz, fj) PER;
+ IF fj < flaenge THEN satz CAT blank FI .
+
+eingabe :
+ IF fmarke <= 0
+ THEN s c h r e i b e d i t o r;
+ IF ueberlaufbedingung
+ THEN ueberlauf
+ ELSE a u s f u e h r e n
+ FI
+ ELSE m a r k e d i t o r
+ FI .
+
+ueberlaufbedingung :
+ IF fstelle <= dyn fende
+ THEN IF fstelle <= limit
+ THEN FALSE
+ ELSE fzeichen > hoechstes steuerzeichen
+ FI
+ ELSE TRUE
+ FI .
+
+ueberlauf :
+ IF fstelle > limit
+ THEN IF wortweise OR fstelle > LENGTH satz
+ THEN ueberlauf in naechste zeile; LEAVE ueberlauf
+ FI
+ FI;
+ IF fstelle > dyn fende
+ THEN fstelle := dyn fende; out (left);
+ zeile um eins nach links verschieben
+ FI .
+
+ueberlauf in naechste zeile :
+ IF wortweise
+ THEN umbrechen
+ ELSE out (bell); kommando := cr
+ FI;
+ inkompetent := TRUE .
+
+umbrechen :
+ IF LENGTH satz > limit
+ THEN kommando CAT subtext (satz, limit+1);
+ FOR fj FROM LENGTH satz DOWNTO fstelle
+ REP kommando CAT left PER;
+ satz := subtext (satz, 1, limit)
+ FI;
+ fj := limit;
+ zeichen zuruecknehmen;
+ (fstelle-fj) TIMESOUT left; fstelle := fj; feldrest loeschen (fstelle);
+ IF kommando = "" THEN kommando := blank left rubout FI;
+ blanks loeschen.
+
+blanks loeschen:
+ REP fj DECR 1;
+ IF (satz SUB fj) <> blank THEN LEAVE blanks loeschen FI;
+ delete char (satz, fj)
+ PER .
+
+zeichen zuruecknehmen:
+ REP fzeichen := satz SUB fj; delete char (satz, fj);
+ IF fzeichen = blank THEN LEAVE zeichen zuruecknehmen FI;
+ insert char (kommando, fzeichen, 1);
+ IF fj = fanfang THEN LEAVE zeichen zuruecknehmen FI;
+ fj DECR1
+ PER.
+
+ausfuehren :
+ dezimalen := 0;
+ SELECT pos (hop esc right left tab rubin rubout cr, fzeichen) OF
+ CASE 1 : getchar (fzeichen);
+ SELECT pos (right left tab rubout escape, fzeichen) OF
+ CASE 1 : zum rechten frand
+ CASE 2 : zum linken frand
+ CASE 3 : tabulator setzen
+ CASE 4 : zeile loeschen
+ CASE 5 : bei lernmodus ein zeichen lesen
+ OTHERWISE hop return
+ END SELECT
+ CASE 2 : escape aktion
+ CASE 3 : nach rechts
+ CASE 4 : nach links
+ CASE 5 : nach tabulator
+ CASE 6 : feinfuegen umschalten
+ CASE 7 : ausfuegen
+ CASE 8 : ggf absatz erzeugen; return
+ OTHERWISE return
+ END SELECT .
+
+ggf absatz erzeugen :
+ IF wortweise
+ THEN IF fstelle > LENGTH satz
+ THEN IF (satz SUB LENGTH satz) <> blank
+ THEN satz CAT blank; fstelle INCR 1
+ FI
+ FI
+ FI .
+
+nach rechts :
+ IF fstelle < dyn fende AND (fstelle < limit OR fstelle < flaenge)
+ THEN out (right); fstelle INCR1
+ ELIF LENGTH satz > dyn fende
+ THEN zeile um eins nach links verschieben
+ ELSE return
+ FI .
+
+nach links :
+ IF fstelle > dyn fanfang
+ THEN out (left); fstelle DECR1
+ ELIF dyn fanfang = fanfang
+ THEN out (bell)
+ ELSE zeile um eins nach rechts verschieben
+ FI .
+
+bei lernmodus ein zeichen lesen :
+ IF lernmodus
+ THEN getchar (fzeichen); return;
+ fzeichen := escape
+ FI;
+ hop return; fzeichen := hop escape .
+
+zeile um eins nach links verschieben :
+ dyn fanfang INCR 1; dyn fende INCR 1;
+ fstelle := dyn fende; zeile neu schreiben (satz) .
+
+zeile um eins nach rechts verschieben :
+ dyn fanfang DECR 1; dyn fende DECR 1;
+ fstelle := dyn fanfang; zeile neu schreiben (satz) .
+
+feinfuegen umschalten :
+ IF feinfuegen
+ THEN feinfuegen := FALSE
+ ELSE feinfuegen := TRUE; get cursor (x,y); out (dach);
+ outsubtext (satz, fstelle, flaenge);
+ cursor (x,y); pause (1);
+ feldrest loeschen (fstelle);
+ outsubtext (satz, fstelle, flaenge);
+ cursor (x,y)
+ FI;
+ return .
+
+ausfuegen :
+ IF flaenge < dyn fanfang OR fstelle > flaenge
+ THEN IF fstelle = flaenge + 1 AND fstelle > dyn fanfang
+ THEN fstelle := flaenge; out (left)
+ ELSE out (bell);
+ LEAVE ausfuegen
+ FI
+ FI;
+ ausfuegeoperation; delete char (satz, fstelle);
+ flaenge := min (dyn fende, LENGTH satz) .
+
+ausfuegeoperation :
+ get cursor (x,y); outsubtext (satz, fstelle+1, flaenge+1);
+ out (blank); cursor (x,y) .
+
+zum linken frand :
+ IF fstelle > fanfang
+ THEN get cursor (x,y); cursor (1+frand, y);
+ IF dyn fanfang = fanfang
+ THEN fstelle := fanfang
+ ELSE verschieben an linken frand
+ FI
+ FI .
+
+zum rechten frand :
+ fj := min (dyn fende, limit); get cursor (x,y);
+ IF LENGTH satz > fj
+ THEN IF fstelle >= LENGTH satz
+ THEN out (bell)
+ ELIF LENGTH satz > dyn fende
+ THEN verschieben an rechten frand
+ ELSE cursor (x + LENGTH satz - fstelle, y);
+ fstelle := LENGTH satz
+ FI
+ ELIF fstelle < fj
+ THEN cursor (x + fj-fstelle, y); fstelle := fj
+ FI .
+
+verschieben an linken frand :
+ dyn fanfang := fanfang; dyn fende := fende;
+ fstelle := fanfang; zeile neu schreiben (satz).
+
+verschieben an rechten frand :
+ (dyn fende - fstelle) TIMESOUT right;
+ dyn fanfang INCR (LENGTH satz - dyn fende); dyn fende := LENGTH satz;
+ fstelle := dyn fende; zeile neu schreiben (satz).
+
+nach tabulator :
+ fj := pos (tabulator, "^", fstelle+1);
+ IF fj = 0
+ THEN IF (satz SUB fstelle) = blank AND fstelle = fanfang
+ THEN IF satz = blank
+ THEN fstelle INCR 1; out (right)
+ ELSE out (blank left); feld einruecken (satz);
+ FI;
+ LEAVE nach tabulator
+ ELIF flaenge < dyn fende AND fstelle <= flaenge
+ THEN fj := flaenge + 1
+ FI
+ ELSE dezimalen := 1
+ FI;
+ IF fj > 0 AND fj <= dyn fende
+ THEN outsubtext (satz, fstelle, fj-1); fstelle := fj
+ ELSE (fstelle-dyn fanfang) TIMESOUT left;
+ fstelle := dyn fanfang; insert char (kommando, down, 1)
+ FI .
+
+tabulator setzen :
+ IF (tabulator SUB fstelle) = "^"
+ THEN fzeichen := right
+ ELSE fzeichen := "^"
+ FI;
+ WHILE fstelle > LENGTH tabulator
+ REP tabulator CAT right PER;
+ replace (tabulator, fstelle, fzeichen);
+ insert char (kommando, tab, 1);
+ insert char (kommando, hop, 1);
+ inkompetent := TRUE .
+
+zeile loeschen :
+ IF fstelle = 1
+ THEN satz := ""; feldrest loeschen (fstelle); hop return
+ ELIF fstelle <= flaenge
+ THEN REP delete char (satz, LENGTH satz)
+ UNTIL fstelle > LENGTH satz
+ PER;
+ flaenge := fstelle - 1; feldrest loeschen (fstelle)
+ ELSE hop return
+ FI .
+
+(*********************** s c h r e i b e d i t o r ***********************)
+
+schreibeditor :
+ REP getchar (fzeichen);
+ IF fzeichen <= hoechstes steuerzeichen THEN LEAVE schreibeditor
+ ELIF separator bedingung THEN LEAVE schreibeditor
+ ELSE f o r t s c h r e i b e n FI
+ PER .
+
+separatorbedingung :
+ IF blankseparator
+ THEN IF flaenge + 2 <= fstelle
+ THEN insert char (kommando, fzeichen, 1);
+ fzeichen := blank
+ FI
+ FI;
+ fzeichen = separator .
+
+fortschreiben :
+ IF dezimalen > 0 THEN dezimaltabulator FI;
+ out (fzeichen);
+ IF fstelle > flaenge
+ THEN anhaengen
+ ELIF dezimalen = 0 AND feinfuegen
+ THEN insert char (satz, fzeichen, fstelle)
+ ELSE replace (satz, fstelle, fzeichen)
+ FI;
+ flaenge := min (dyn fende, LENGTH satz);
+ fstelle INCR 1;
+ IF feinfuegen AND dezimalen = 0 AND fstelle <= flaenge
+ THEN zeilenrest neu schreiben
+ FI;
+ IF fstelle > dyn fende
+ OR fstelle > limit AND (wortweise OR fstelle > flaenge)
+ THEN LEAVE schreibeditor
+ FI .
+
+zeilenrest neu schreiben :
+ get cursor (x,y); outsubtext (satz, fstelle, flaenge); cursor (x,y) .
+
+dezimaltabulator :
+ IF fzeichen < "0" OR fzeichen > "9"
+ THEN dezimalen := 0
+ ELIF dezimalen = 1
+ THEN IF (satz SUB fstelle) = blank OR fstelle > flaenge
+ THEN dezimalen := 2
+ ELSE dezimalen := 0
+ FI
+ ELIF (satz SUB fstelle-dezimalen) = blank
+ THEN replace (satz, fstelle-dezimalen,
+ subtext (satz, fstelle-dezimalen+1, fstelle-1)) ;
+ dezimalen TIMESOUT left;
+ outsubtext (satz, fstelle-dezimalen, fstelle-2);
+ dezimalen INCR 1; fstelle DECR 1
+ ELSE dezimalen := 0
+ FI .
+
+anhaengen :
+ FOR fj FROM flaenge+2 UPTO fstelle
+ REP satz CAT blank PER;
+ satz CAT fzeichen .
+
+
+(************************** m a r k e d i t o r **************************)
+
+markeditor :
+ getchar (fzeichen);
+ SELECT pos (hop esc right left tab down cr, fzeichen) OF
+ CASE 1 : getchar (fzeichen);
+ IF fzeichen = right THEN markierung maximal
+ ELIF fzeichen = left THEN markierung minimal
+ ELSE hop return
+ FI
+ CASE 2 : escape aktion
+ CASE 3 : markierung verlaengern
+ CASE 4 : markierung verkuerzen
+ CASE 5 : markierung bis tab verlaengern
+ CASE 6,7 : zeilenrest markieren
+ OTHERWISE IF fzeichen <= hoechstes steuerzeichen
+ THEN return
+ ELSE out (bell)
+ FI
+ END SELECT .
+
+markierung verlaengern :
+ IF fstelle <= flaenge
+ THEN out (satz SUB fstelle, end mark left); fstelle INCR 1
+ ELSE return
+ FI .
+
+markierung maximal :
+ IF fstelle <= flaenge
+ THEN outsubtext (satz, fstelle, flaenge); out (end mark left);
+ fstelle := flaenge + 1
+ FI .
+
+zeilenrest markieren :
+ IF fstelle <= flaenge
+ THEN outsubtext (satz, fstelle, flaenge);
+ out (end mark left);
+ (flaenge-fstelle+2) TIMESOUT left
+ FI;
+ return .
+
+markierung verkuerzen :
+ IF fstelle > fmarke
+ THEN fstelle DECR 1;
+ out (left end mark, satz SUBB fstelle, left left)
+ ELSE out (bell)
+ FI .
+
+markierung minimal :
+ IF fstelle > fmarke
+ THEN (fstelle-fmarke) TIMESOUT left; out (end mark);
+ outsubtext (satz, fmarke, fstelle-1);
+ (fstelle-fmarke+1) TIMESOUT left; fstelle := fmarke
+ FI .
+
+markierung bis tab verlaengern :
+ fj := pos (tabulator, "^", fstelle + 1);
+ IF fj = 0
+ THEN fj := flaenge - fstelle + 1; IF fj <= 0 THEN return FI
+ ELSE fj DECR fstelle
+ FI;
+ IF fj > 0
+ THEN outsubtext (satz, fstelle, min (fstelle+fj-1, flaenge));
+ out (end mark left)
+ FI;
+ fstelle INCR fj;
+ IF fstelle > (dyn fende+1) THEN return FI .
+
+
+(******************* allgemein verwendete refinements *********************)
+
+return :
+ insert char (kommando, fzeichen, 1);
+ inkompetent := TRUE .
+
+hop return :
+ return; insert char (kommando, hop, 1) .
+
+escape aktion :
+ getchar (fzeichen); return;
+ insert char (kommando, escape, 1);
+ insert char (fzeichen, escape, 1) .
+
+END PROC feldeditor;
+
+END PACKET feldeditor;
diff --git a/system/base/unknown/src/file b/system/base/unknown/src/file new file mode 100644 index 0000000..e556bec --- /dev/null +++ b/system/base/unknown/src/file @@ -0,0 +1,810 @@ +
+PACKET file DEFINES (* Autor: J.Liedtke *)
+ (* Stand: 30.04.82 *)
+ FILE ,
+ := ,
+ input ,
+ output ,
+ modify ,
+ sequential file ,
+ getline ,
+ putline ,
+ line ,
+ reset ,
+ eof ,
+ put ,
+ get ,
+ page ,
+ out ,
+ eop ,
+ close ,
+ max line length ,
+ max page length ,
+ read record ,
+ write record ,
+ forward ,
+ backward ,
+ delete record ,
+ insert record ,
+ to first record ,
+ to eof ,
+ is first record ,
+ headline ,
+ copy attributes ,
+ reorganize ,
+ feldeditor ,
+ feldout ,
+ feldeinruecken ,
+ pos ,
+ change ,
+ subtext ,
+ sort :
+
+
+
+TYPE FILE = STRUCT ( BOUND DATEI f ,
+ INT index, pointer, line counter,
+ mode, max line length, max page length,
+ BOOL edit status unchanged) ;
+
+TYPE TRANSPUTDIRECTION = INT ;
+
+LET closed = 1 ,
+ in = 2 ,
+ outp = 3 ,
+ mod = 4 ,
+ end = 5 ,
+ escape = ""27"" ,
+
+ nullzustand = " 0 1 1" ,
+
+ max length = 15 000 ; (* < maxint/2 because 2 * maxlength possible*)
+
+
+TRANSPUTDIRECTION PROC input :
+ TRANSPUTDIRECTION : ( in )
+ENDPROC input ;
+
+TRANSPUTDIRECTION PROC output :
+ TRANSPUTDIRECTION : ( outp )
+ENDPROC output ;
+
+TRANSPUTDIRECTION PROC modify :
+ TRANSPUTDIRECTION : ( mod )
+ENDPROC modify ;
+
+LET DATEI = ROW 4075 STRUCT (
+ INT nachfolger, vorgaenger, index, fortsetzung,
+ TEXT inhalt ) ;
+
+LET anker = 2 ,
+ freianker = 1 ;
+
+TEXT VAR number word ;
+
+FILE VAR result file ;
+
+DATASPACE VAR scratch space ;
+close ;
+
+
+FILE PROC sequential file (TRANSPUTDIRECTION CONST mode) :
+
+ IF CONCR (mode) = outp
+ THEN close
+ FI ;
+ sequential file (mode, scratch space)
+
+ENDPROC sequential file ;
+
+FILE PROC sequential file (TRANSPUTDIRECTION CONST mode,
+ DATASPACE VAR ds) :
+
+ IF type (ds) = 1002
+ THEN result file.f := ds
+ ELIF type (ds) < 0
+ THEN result file.f := ds ;
+ type (ds, 1002) ;
+ datei initialisieren (CONCR (result file.f))
+ ELSE errorstop ("dataspace has wrong type") ;
+ result file.f := scratch space
+ FI ;
+ result file.mode := CONCR (mode) ;
+ reset (result file) ;
+ result file.max line length := max line length (result file) ;
+ result file.max page length := 0 ;
+
+ result file .
+
+ENDPROC sequential file ;
+
+
+FILE PROC sequential file (TRANSPUTDIRECTION CONST mode,
+ TEXT CONST name ) :
+
+ IF exists (name)
+ THEN get dataspace if file
+ ELIF CONCR (mode) <> in
+ THEN get new file space
+ ELSE errorstop ("input file not existing") ;
+ result file.f := scratch space
+ FI ;
+ IF CONCR (mode) <> in
+ THEN status (name, "") ;
+ headline (result file, name)
+ FI ;
+ result file.mode := CONCR (mode) ;
+ reset (result file) ;
+ result file.max line length := max line length (result file) ;
+ result file.max page length := 0 ;
+
+ result file .
+
+get new file space :
+ result file.f := new (name) ;
+ IF NOT is error
+ THEN type (old (name), 1002) ;
+ datei initialisieren ( CONCR (result file.f) )
+ FI .
+
+get dataspace if file :
+ result file.f := old (name, 1002) .
+
+ENDPROC sequential file ;
+
+INT PROC max line length (FILE CONST file) :
+
+ int (subtext (zustand, 16, 20)) .
+
+zustand :
+ CONCR (file.f) (freianker).inhalt .
+
+ENDPROC max line length ;
+
+PROC max line length (FILE VAR file, INT CONST length) :
+
+ replace (zustand, 16, text (length,5)) .
+
+zustand :
+ CONCR (file.f) (freianker).inhalt .
+
+ENDPROC max line length ;
+
+PROC headline (FILE VAR file, TEXT CONST head) :
+
+ CONCR (file.f)(anker).inhalt := head
+
+ENDPROC headline ;
+
+TEXT PROC headline (FILE VAR file) :
+
+ CONCR (file.f)(anker).inhalt
+
+ENDPROC headline ;
+
+PROC copy attributes (FILE CONST source, FILE VAR dest) :
+
+ dest attributes := source attributes ;
+ reset edit status (dest) ;
+ dest headline := source headline .
+
+dest attributes : CONCR (dest.f) (freianker).inhalt .
+source attributes : CONCR (source.f) (freianker).inhalt .
+
+dest headline : CONCR (dest.f) (anker).inhalt .
+source headline : CONCR (source.f) (anker).inhalt .
+
+ENDPROC copy attributes ;
+
+
+PROC input (FILE VAR file) :
+
+ file.mode := in ;
+ reset (file)
+
+ENDPROC input ;
+
+PROC output (FILE VAR file) :
+
+ file.mode := outp ;
+ reset (file)
+
+ENDPROC output ;
+
+PROC modify (FILE VAR file) :
+
+ file.mode := mod ;
+ reset (file)
+
+ENDPROC modify ;
+
+
+PROC putline (FILE VAR file, TEXT CONST record) :
+
+ check mode (file, outp) ;
+ line (file) ;
+ CONCR (file.f)(file.index).inhalt := record ;
+ file.pointer := max length
+
+ENDPROC putline ;
+
+
+PROC getline (FILE VAR file, TEXT VAR record) :
+
+ check mode (file, in) ;
+ line (file) ;
+ record := CONCR (file.f)(file.index).inhalt ;
+ file.pointer := max length
+
+ENDPROC getline ;
+
+
+PROC line (FILE VAR file) :
+
+ file.index := CONCR (file.f) (file.index).nachfolger ;
+ file.pointer := 0 ;
+ IF file.mode = in
+ THEN check eof
+ ELIF file.mode = outp
+ THEN satz erzeugen (CONCR (file.f), file.index) ;
+ CONCR (file.f)(file.index).inhalt := "" ;
+ perhaps implicit page feed
+ FI .
+
+check eof :
+ IF eof
+ THEN file.mode := end
+ FI .
+
+eof : CONCR (file.f)(file.index).nachfolger = anker .
+
+perhaps implicit page feed :
+ file.line counter INCR 1 ;
+ IF file.line counter = file.max page length
+ THEN page (file)
+ FI .
+
+ENDPROC line ;
+
+PROC check mode (FILE CONST file, INT CONST mode) :
+
+ IF file.mode = mode
+ THEN LEAVE check mode
+ ELIF file.mode = closed
+ THEN errorstop ("file not open")
+ ELIF file.mode = mod
+ THEN errorstop ("operation not in transputdirection 'modify'")
+ ELIF mode = mod
+ THEN errorstop ("operation only in transputdirection 'modify'")
+ ELIF file.mode = end
+ THEN IF eof (file) THEN errorstop ("input after end of file") FI
+ ELIF mode = in
+ THEN errorstop ("input access to output file")
+ ELIF mode = outp
+ THEN errorstop ("output access to input file")
+ FI
+
+ENDPROC check mode ;
+
+PROC reset (FILE VAR file) :
+
+ file.pointer := max length ;
+ file.line counter := 0 ;
+ file.edit status unchanged := TRUE ;
+ initialize file index ;
+ set correct file mode .
+
+initialize file index :
+ IF file.mode = outp
+ THEN file.index := last record
+ ELSE file.index := anker
+ FI .
+
+set correct file mode :
+ IF file.mode = end
+ THEN file.mode := in
+ FI ;
+ IF file.mode = in AND empty file
+ THEN file.mode := end
+ FI .
+
+last record : CONCR (file.f) (anker).vorgaenger .
+
+empty file : CONCR (file.f) (anker).nachfolger = anker .
+
+ENDPROC reset ;
+
+BOOL PROC eof (FILE CONST file) :
+
+ IF file.mode = end
+ THEN end of record
+ ELIF file.mode = mod
+ THEN file.index = anker
+ ELSE FALSE
+ FI .
+
+end of record :
+ file.pointer >= length (CONCR (file.f)(file.index).inhalt) .
+
+ENDPROC eof ;
+
+PROC line (FILE VAR file, INT CONST lines) :
+
+ check mode (file, outp) ;
+ INT VAR i ;
+ FOR i FROM 1 UPTO lines REP
+ line (file)
+ PER
+
+ENDPROC line ;
+
+PROC page (FILE VAR file) :
+
+ file.line counter := 0 ;
+ putline (file, "#page")
+
+ENDPROC page ;
+
+BOOL PROC eop (FILE CONST file) :
+
+ CONCR (file.f)(file.index).inhalt = "#page"
+
+ENDPROC eop ;
+
+PROC put (FILE VAR file, TEXT CONST word) :
+
+ check mode (file, outp) ;
+ IF file.pointer + LENGTH word >= file.max line length
+ THEN line (file)
+ FI ;
+ put word (CONCR (file.f)(file.index).inhalt, word, file.pointer)
+
+ENDPROC put ;
+
+PROC put word (TEXT VAR record, TEXT CONST word, INT VAR pointer) :
+
+ IF pointer > 0
+ THEN record CAT " " ;
+ FI ;
+ record CAT word ;
+ pointer := LENGTH record
+
+ENDPROC put word ;
+
+PROC put (FILE VAR f, INT CONST value) :
+
+ put (f, text (value) )
+
+ENDPROC put ;
+
+PROC put (FILE VAR f, REAL CONST real) :
+
+ put (f, text (real) )
+
+ENDPROC put ;
+
+PROC out (FILE VAR file, TEXT CONST word) :
+
+ check mode (file, outp) ;
+ IF file.pointer + LENGTH word >= file.max line length
+ THEN line (file)
+ FI ;
+ record CAT word ;
+ file.pointer INCR LENGTH word .
+
+record : CONCR (file.f)(file.index).inhalt .
+
+ENDPROC out ;
+
+PROC get (FILE VAR file, TEXT VAR word, TEXT CONST separator) :
+
+ check mode (file, in) ;
+ get word (CONCR (file.f)(file.index).inhalt, word,
+ file.pointer, max length, separator)
+
+ENDPROC get ;
+
+PROC get (FILE VAR file, TEXT VAR word, INT CONST max length) :
+
+ check mode (file, in) ;
+ get word (CONCR (file.f)(file.index).inhalt, word,
+ file.pointer, max length, "")
+
+ENDPROC get ;
+
+PROC get (FILE VAR file, TEXT VAR word) :
+
+ check mode (file, in) ;
+ next word (file, CONCR (file.f)(file.index).inhalt, word)
+
+ENDPROC get ;
+
+PROC next word (FILE VAR file, TEXT CONST record, TEXT VAR word) :
+
+ get next non blank char ;
+ IF char found
+ THEN get word (record, word, file.pointer, max length, " ")
+ ELIF last line of file
+ THEN word := "" ;
+ file.pointer := max length
+ ELSE line (file) ;
+ get (file, word)
+ FI .
+
+get next non blank char :
+ TEXT VAR char ;
+ REP
+ file.pointer INCR 1 ;
+ char := record SUB file.pointer
+ UNTIL char <> " " PER ;
+ file.pointer DECR 1 .
+
+char found : char <> "" .
+
+last line of file :
+ CONCR (file.f) (anker).nachfolger = anker .
+
+ENDPROC next word ;
+
+PROC get (FILE VAR f, INT VAR number) :
+
+ get (f, number word) ;
+ number := int (number word)
+
+ENDPROC get ;
+
+PROC get (FILE VAR f, REAL VAR number) :
+
+ get (f, number word) ;
+ number := real (number word)
+
+ENDPROC get ;
+
+PROC get word (TEXT CONST record, TEXT VAR word, INT VAR pointer,
+ INT CONST max length, TEXT CONST separator) :
+
+ INT VAR end of word := pos (record, separator, pointer+1) - 1 ;
+ IF end of word < 0
+ THEN end of word := pointer + max length
+ FI ;
+ word := subtext (record, pointer+1, end of word) ;
+ pointer := end of word + 1
+
+ENDPROC get word ;
+
+PROC close (FILE VAR file) :
+
+ file.mode := closed
+
+ENDPROC close ;
+
+PROC close :
+
+ disable stop ;
+ forget (scratch space) ;
+ scratch space := nilspace
+
+ENDPROC close ;
+
+INT PROC max page length (FILE CONST file) :
+ file.max page length
+ENDPROC max page length ;
+
+PROC max page length (FILE VAR file, INT CONST length) :
+ file.max page length := length
+ENDPROC max page length
+
+
+PROC read record (FILE CONST file, TEXT VAR record) :
+
+ check mode (file, mod) ;
+ record := CONCR (file.f) (file.index).inhalt
+
+ENDPROC read record ;
+
+PROC write record (FILE VAR file, TEXT CONST record) :
+
+ check mode (file, mod) ;
+ CONCR (file.f) (file.index).inhalt := record
+
+ENDPROC write record ;
+
+PROC forward (FILE VAR file) :
+
+ check mode (file, mod) ;
+ IF file.index <> anker
+ THEN file.index := CONCR (file.f) (file.index).nachfolger
+ ELSE errorstop ("forward at eof")
+ FI
+
+ENDPROC forward ;
+
+PROC backward (FILE VAR file) :
+
+ check mode (file, mod) ;
+ file.index := CONCR (file.f) (file.index).vorgaenger ;
+ IF file.index = anker
+ THEN to first record (file) ;
+ errorstop ("backward at first record")
+ FI
+
+ENDPROC backward ;
+
+PROC delete record (FILE VAR file) :
+
+ check mode (file, mod) ;
+ IF file.edit status unchanged
+ THEN reset edit status (file)
+ FI ;
+ satz loeschen (CONCR (file.f), file.index)
+
+ENDPROC delete record ;
+
+PROC insert record (FILE VAR file) :
+
+ check mode (file, mod) ;
+ IF file.edit status unchanged
+ THEN reset edit status (file)
+ FI ;
+ satz erzeugen (CONCR (file.f), file.index)
+
+ENDPROC insert record ;
+
+PROC to first record (FILE VAR file) :
+
+ check mode (file, mod) ;
+ file.index := CONCR (file.f) (anker).nachfolger
+
+ENDPROC to first record ;
+
+PROC to eof (FILE VAR file) :
+
+ check mode (file, mod) ;
+ file.index := anker
+
+ENDPROC to eof ;
+
+BOOL PROC is first record (FILE CONST file) :
+
+ file.index = CONCR (file.f) (anker).nachfolger
+
+ENDPROC is first record ;
+
+PROC reset edit status (FILE VAR file) :
+
+ replace (zustand, 1, nullzustand) ;
+ file.edit status unchanged := FALSE .
+
+zustand : CONCR (file.f)(freianker).inhalt .
+
+ENDPROC reset edit status ;
+
+
+FILE VAR scratch , file ;
+TEXT VAR record ;
+
+LET esc = ""27"" ;
+
+PROC reorganize (TEXT CONST file name) :
+
+ IF exists (file name)
+ THEN last param (file name) ;
+ reorganize file
+ ELSE errorstop ("file does not exist")
+ FI .
+
+reorganize file :
+ scratch := sequential file (output) ;
+ headline (scratch, file name) ;
+ IF format 15
+ THEN set to 16 file type ;
+ file := sequential file (input, file name)
+ ELSE file := sequential file (input, file name) ;
+ copy attributes (file, scratch)
+ FI ;
+
+ disable stop ;
+
+ INT VAR counter := 0 ;
+ WHILE NOT eof (file) REP
+ getline (file, record) ;
+ putline (scratch, record) ;
+ counter INCR 1 ;
+ cout (counter) ;
+ IF is incharety (escape) OR is error
+ THEN close ;
+ LEAVE reorganize
+ FI
+ PER ;
+ forget file ;
+ copy (scratch space, file name) ;
+ close .
+
+forget file :
+ BOOL CONST old status := command dialogue ;
+ command dialogue (FALSE) ;
+ forget (file name) ;
+ command dialogue (old status) .
+
+format 15 : type (old (file name)) = 1001 .
+
+set to 16 file type :
+ type (old (file name), 1002) .
+
+ENDPROC reorganize ;
+
+PROC reorganize :
+
+ reorganize (last param)
+
+ENDPROC reorganize ;
+
+PROC feldout (FILE CONST file, TEXT CONST satz) :
+
+ feldout ( CONCR (file.f) (file.index).inhalt )
+
+ENDPROC feldout ;
+
+PROC feldeinruecken (FILE CONST file, TEXT CONST satz) :
+
+ feldeinruecken ( CONCR (file.f) (file.index).inhalt )
+
+ENDPROC feldeinruecken ;
+
+PROC feldeditor (FILE VAR file, TEXT CONST satz) :
+
+ feldeditor ( CONCR (file.f) (file.index).inhalt )
+
+ENDPROC feldeditor ;
+
+INT PROC pos (FILE CONST file, TEXT CONST pattern, INT CONST from) :
+
+ pos ( CONCR (file.f) (file.index).inhalt, pattern, from )
+
+ENDPROC pos ;
+
+PROC change (FILE VAR file, INT CONST from, to, TEXT CONST new) :
+
+ change ( CONCR (file.f) (file.index).inhalt, from, to, new )
+
+ENDPROC change ;
+
+TEXT PROC subtext (FILE CONST file, INT CONST from) :
+
+ record := subtext ( CONCR (file.f) (file.index).inhalt, from ) ;
+ record
+
+ENDPROC subtext ;
+
+TEXT PROC subtext (FILE CONST file, INT CONST from, to) :
+
+ record := subtext ( CONCR (file.f) (file.index).inhalt, from, to ) ;
+ record
+
+ENDPROC subtext ;
+
+(* sortieren sequentieller Dateien Autor: P.Heyderhoff *)
+ (* Stand: 14.11.80 *)
+
+BOUND DATEI VAR datei;
+INT VAR sortierstelle, sortanker, byte;
+TEXT VAR median, tausch ;
+
+PROC sort (TEXT CONST dateiname) :
+ sortierstelle := feldanfang; sort (dateiname, "")
+ END PROC sort;
+
+PROC sort (TEXT CONST dateiname, INT CONST sortieranfang) :
+ sortierstelle := sortieranfang; sort (dateiname, "")
+ END PROC sort;
+
+PROC sort (TEXT CONST dateiname, feldname) :
+ IF exists (dateiname)
+ THEN datei := old (dateiname);
+ IF CONCR(datei) (freianker).nachfolger <> freianker
+ THEN reorganize (dateiname)
+ FI ;
+ sortanker := 3;
+ IF feldname = ""
+ THEN byte := 0
+ ELSE feldname in feldnummer uebersetzen
+ FI;
+ quicksort(sortanker, CONCR(datei)(freianker).fortsetzung-1)
+ FI .
+feldname in feldnummer uebersetzen :
+ byte := pos (CONCR(datei) (sortanker).inhalt, feldname);
+ IF byte > 0
+ THEN byte := pos (CONCR(datei) (sortanker).inhalt, code(255-byte))
+ FI;
+ IF byte = 0
+ THEN errorstop ("sort: feldname"); LEAVE sort
+ FI ; sortanker INCR 1 .
+ END PROC sort;
+
+PROC quicksort ( INT CONST anfang, ende ) :
+ IF anfang < ende
+ THEN INT VAR p,q;
+ spalte (anfang, ende, p, q);
+ quicksort (anfang, q);
+ quicksort (p, ende) FI
+ END PROC quicksort;
+
+PROC spalte (INT CONST anfang, ende, INT VAR p, q):
+ fange an der seite an und waehle den median;
+ ruecke p und q so dicht wie moeglich zusammen;
+ hole ggf median in die mitte .
+
+ fange an der seite an und waehle den median :
+ p := anfang; q := ende ;
+ INT CONST m :: (p + q) DIV 2 ;
+ median := subtext(datei m, merkmal m) .
+
+ ruecke p und q so dicht wie moeglich zusammen :
+ REP schiebe p und q so weit wie moeglich auf bzw ab;
+ IF p < q THEN vertausche die beiden FI
+ UNTIL p > q END REP .
+
+ vertausche die beiden :
+ tausch := datei p; datei p := datei q; datei q := tausch;
+ p INCR 1; q DECR 1 .
+
+ schiebe p und q so weit wie moeglich auf bzw ab :
+ WHILE p kann groesser werden REP p INCR 1 END REP;
+ WHILE q kann kleiner werden REP q DECR 1 END REP .
+
+ p kann groesser werden :
+ IF p <= ende THEN subtext (datei p, merkmal p) <= median ELSE FALSE FI .
+
+ q kann kleiner werden :
+ IF q >= anfang THEN subtext(datei q,merkmal q) >= median ELSE FALSE FI .
+
+ hole ggf median in die mitte :
+ IF m < q THEN vertausche m und q
+ ELIF m > p THEN vertausche m und p FI .
+
+ vertausche m und q :
+ tausch := datei m; datei m := datei q; datei q := tausch; q DECR 1 .
+
+ vertausche m und p :
+ tausch := datei m; datei m := datei p; datei p := tausch; p INCR 1 .
+
+ merkmal m :
+ IF byte = 0 THEN sortierstelle ELSE 255 - code (datei m SUB byte) FI .
+
+ merkmal p :
+ IF byte = 0 THEN sortierstelle ELSE 255 - code (datei p SUB byte) FI .
+
+ merkmal q :
+ IF byte = 0 THEN sortierstelle ELSE 255 - code (datei q SUB byte) FI .
+
+ datei m : CONCR(datei)(m).inhalt .
+ datei p : CONCR(datei)(p).inhalt .
+ datei q : CONCR(datei)(q).inhalt .
+
+END PROC spalte;
+
+
+(*********** schrott ************)
+
+OP := (FILE VAR a, FILE CONST b) :
+ EXTERNAL 294
+ENDOP := ;
+
+PROC becomes (ROW 8 INT VAR a, b) :
+ INTERNAL 294 ;
+ a := b
+ENDPROC becomes ;
+
+PROC datei initialisieren (DATEI VAR datei) :
+ EXTERNAL 290 ;
+END PROC datei initialisieren;
+
+PROC satz erzeugen (DATEI VAR datei, INT VAR satz):
+ EXTERNAL 291;
+END PROC satz erzeugen;
+
+PROC satz loeschen (DATEI VAR datei, INT VAR satz):
+ EXTERNAL 292 ;
+END PROC satz loeschen;
+
+ENDPACKET file ;
diff --git a/system/base/unknown/src/init b/system/base/unknown/src/init new file mode 100644 index 0000000..02b8e74 --- /dev/null +++ b/system/base/unknown/src/init @@ -0,0 +1,250 @@ + " Compiler Error : "
+" "
+" |"
+" Fehler entdeckt "
+"Keine Fehler gefunden, "
+" Sekunden CPU-Zeit verbraucht"
+" ******* ENDE DER UEBERSETZUNG *******"
+"FEHLER bei >> "
+" << "
+"weiter bei "
+" (" ") "
+"EOF im Programm"
+"EOF beim Skippen"
+"EOF im TEXT Denoter"
+"EOF im Kommentar"
+"' nach Bold fehlt"
+"das MAIN PACKET muss das letzte sein"
+"ungueltiger Name fuer ein Interface Objekt"
+"':' fehlt"
+"nach ENDPACKET folgt nicht der Paketname"
+"ENDPACKET fehlt"
+"CONST oder VAR fehlt"
+"ungueltiger Name"
+" ',' in Deklarationsliste fehlt"
+"ist nicht der PROC Name"
+"fehlerhaftes Endes des MAIN PACKET"
+"ENDPROC fehlt"
+"PROC/OP Schachtelung unzulaessig"
+"OP darf kein Parameter sein"
+"steht mehrfach im PACKET Interface"
+"Mehrfachdeklaration"
+"ist schon als Datenobjekt deklariert"
+"ist schon als PROC/OP deklariert"
+"')' nach Parameterliste erwartet"
+"Standard-Schluesselwort kann nicht redefiniert werden"
+"ungueltig als BOLD"
+"'(' fehlt"
+"CONST bzw VAR nicht bei Strukturfeldern"
+"'=' fehlt"
+"Schluesselwort wird im Paket schon andersartig verwandt"
+"Dieser Typ ist schon definiert"
+"ungueltiger Deklarierer"
+"ungueltiger OP Name"
+"OP muss monadisch oder dyadisch sein"
+"ist nicht der OP Name"
+"ENDOP fehlt"
+"Name nach ENDPROC fehlt"
+"Name nach ENDOP fehlt"
+"END END ist Unsinn"
+"Diese END... kenne ich nicht"
+"ROW Groesse ist kein INT"
+"ROW Groesse ist kein Denoter"
+"Ein ROW muss mindestens ein Element haben"
+"ROW Groesse fehlt"
+"Parameter kann man nicht initialisieren"
+"Konstanten muessen initialisert werden"
+"'::' verwenden"
+"')' fehlt"
+"Nachkommastellen fehlen"
+"Exponent fehlt"
+"Undefinierter Typ"
+"Rekursiv definierter Typ"
+"Mehrfach definierter Selektor"
+"VARs koennen aus dem Paket nicht herausgereicht werden"
+"NO SHORTHAND DECLARATION IN THIS SCOPE FOR ROW SIZE DENOTER."
+"Typ Deklarationen nur im Paketrumpf"
+"CONST bzw. VAR ohne Zusammenhang"
+"ist nicht deklariert, steht aber in der Paket-Schnittstelle"
+"ist nicht deklariert"
+"Typ ist schon deklariert"
+"THIS IS NO CORRECT EXTERNAL NUMBER."
+" EXTERNAL und INTERNAL unzulaessig"
+"Name erwartet"
+"Denoter erwartet"
+"ENDPROC ohne Zusammenhang"
+"ENDOP ohne Zusammenhang"
+"Refinement ohne Zusammenhang"
+"Delimiter zwischen Paket-Refinement und Deklaration fehlt"
+"unzulaessiges Selektor-Symbol (kein Name)"
+"BOUND Schachtelungen unzulaessig"
+"Textende fehlt"
+
+"Denoter-Wert wird fuer diese Maschine zu gross"
+"NOBODY SHOULD EVER WRITE THAT, Uli ! "
+"ist ein zusammenhangloses Schluesselwort"
+"'::' nur fuer Initialisierungen, sonst ':='"
+"welches Objekt soll verlassen werden?"
+"du bist gar nicht innerhalb dieses Refinements"
+"nur die eigene PROC / OP kann verlassen werden"
+"THEN fehlt"
+"FI fehlt"
+"BOOL - Ausdruck erwartet"
+"ELSE - Teil ist notwendig, da ein Wert geliefert wird"
+"Mit ELIF kann kein IF-Statement beginnen"
+"INT - Ausdruck erwartet"
+"OF fehlt"
+"Keine Typanpassung moeglich"
+"CASE - Label fehlt"
+"CASE - Label ist zu gross (skipped)"
+"mehrfach definiertes CASE-Label"
+"ungueltiges Zeichen nach CASE-Label"
+" OTHERWISE PART fehlt"
+"END SELECT fehlt"
+"DEAR USER, PLEASE BE REMINDED OF NOT CALLING REFINEMENTS RECURSIVLY !"
+"Dieses Refinement wird nicht benutzt"
+"Zwischen diesen Symbolen fehlt ein Operator oder ein ';'"
+"undefinierter monadischer Operator"
+"undefinierter dyadischer Operator"
+"Operator vor '(' fehlt"
+"kann nicht redefiniert werden"
+"Auf die Feinstruktur des Typs kann man nicht mehr zugreifen"
+"fuer diesen Typ nicht definierter Selektor"
+"Primitive Typen koennen nicht selektiert werden"
+"bei ROWs nur Subscription"
+"ungueltiger Selectand"
+"unzulaessiger Index fuer Subscription"
+"'[' ohne Zusammenhang"
+"']' ohne Zusammenhang"
+"']' nach Subscription fehlt"
+"',' ungueltig zwischen UNITs"
+"':' ungueltig zwischen UNITs"
+"';' fehlt"
+"nur die letzte UNIT einer SECTION darf einen Wert liefern"
+"Der Paketrumpf kann keinen Wert liefern"
+"anstelle des letzten Symbols wurde ein Operand erwartet"
+"Der Schleifenrumpf darf keinen Wert liefern"
+"INT VAR erwartet"
+"wird schon in einer aeusseren Schleife als Laufvariable benutzt"
+"FROM erwartet"
+"UPTO bzw DOWNTO fehlt"
+"REPEAT fehlt"
+"END REP fehlt"
+"UNTIL ohne Zusammenhang"
+"Die Konstante darf nicht mit ':=' veraendert werden"
+"In einer FOR-Schleife darf die Laufvariable nicht veraendert werden"
+"falscher Typ des Resultats"
+"ist CONST, es wird aber ein VAR Parameter verlangt"
+"unbekannte Prozedur"
+"Parameter-Prozedur liefert falsches Resultat"
+"Es gibt keine Prozedur mit diesen Parametern"
+"unbekannte Parameter-Prozedur"
+"VIRTUAL PARAM MODE INCONSISTENCE"
+"INCONSISTENCE BETWEEN THE PARAMETERS OF THE ACTUAL AND THE FORMAL PARAM PROC
+EDURE "
+"nicht deklariertes Objekt"
+"THIS OBJECT IS USED OUTSIDE IT'S RANGE"
+"Kein TYPE DISPLAY moeglich, da die Feinstruktur hier unbekannt ist"
+"zu wenig Felder angegeben"
+"zu viele Felder angegeben"
+"unzulaessiger Trenner zwischen Feldern"
+"Dies Feld hat einen falschen Typ"
+"THIS ROW DISPLAY DOES NOT HAVE THE CORRECT NUMBER OF ELEMENTS."
+"Dieser Typ kann nicht noch mehr konkretisiert werden"
+
+"Warnung in Zeile"
+" Zeile "
+"in Zeile "
+"<----+--->"
+" TYPE undefiniert "
+" MODE undefiniert "
+"Parameter spezifiziert "
+"Parameter Typ(en) sind "
+" B Code, "
+" B Paketdaten generiert"
+"Operandentyp"
+"Typ des linken Operanden "
+"Typ des rechten Operanden "
+"erwartet "
+"gefunden "
+ "NULL 1TEST 1NOT 2INCR 1DECR
+ 1MOV2 2MOV8 2MOVS 2EQI 2LSEQI
+ 2EQR 2LSEQR 2COMPLI 2COMPLR 2ADDI
+ 3SUBI 3MULTI 3DIVI 3ADDR 3SUBR
+ 3MULTR 3DIVR 3AND 2OR 2BRANCH
+8BTRUE 8BFALSE 8ACCDS 2ALIAS 5RETURN
+0MOVE 3CASE 3SUBS 5SUBS2 4SUBS8
+ 4SUBS16 4SEL 3BSTL 6ESTL 7HEAD
+ 1PACKET 1BOOL 1NBOOL 1"
+
+(*000 *) END INTERNAL BOUND
+(*001 *) PACKET
+(*002 *) ENDPACKET
+(*003 *) DEFINES
+(*003 A*) LET
+(*004 *) PROCEDURE
+(*005 *) PROC
+(*006 *) ENDPROC
+(*006A *) ENDPROCEDURE
+(*007 *) OPERATOR
+(*008 *) OP
+(*009 *) ENDOP
+(*009A *) ENDOPERATOR
+(*010 *) TYPE
+(*011 *) INT
+(*012 *) REAL
+(*013 *) DATASPACE
+(*015 *) TEXT
+(*016 *) BOOL
+(*017 *) CONST
+(*018 *) VAR
+(* INIT CONTROL *) INTERNAL
+(*019 *) ROW
+(*0191 *) STRUCT CONCR
+(*0193*) ACTUAL
+(*020 *) REP
+(*020A *) REPEAT
+(*021 *) ENDREP
+(*021A *) ENDREPEAT PER
+(*022 *) SELECT
+(*023 *) ENDSELECT
+(*0235 *) EXTERNAL
+(*024 *) IF (*024A *) ENDIF
+(*021 *) THEN
+(*022 *) ELIF
+(*023 *) ELSE
+(*024 *) FI
+(*026 *) OF
+(*026A *) CASE
+(*027 *) OTHERWISE
+(*029 *) FOR
+(*030 *) FROM
+(*031 *) UPTO
+(*032 *) DOWNTO
+(*034 *) UNTIL
+(*035 *) WHILE
+(*036 *) LEAVE WITH
+(*0361 *) TRUE
+(*362 *) FALSE
+(*038 *) :: SBL = := INCR DECR
+(*039 *) + - * / DIV MOD ** AND CAND OR COR NOT <> > >= < <=
+(*040 *) MAIN
+(*043*) ENDOFFILE
+
+PACKET a :
+
+PROC out (TEXT CONST t) :
+ EXTERNAL 60
+ENDPROC out ;
+
+PROC out text (TEXT CONST t, INT CONST typ) :
+ INTERNAL 257 ;
+ out (t)
+ENDPROC out text ;
+
+PROC out line (INT CONST typ) :
+ INTERNAL 258 ;
+ out (""13""10"")
+ENDPROC out line ;
+
+ENDPACKET a ;
diff --git a/system/base/unknown/src/integer b/system/base/unknown/src/integer new file mode 100644 index 0000000..0e1d19d --- /dev/null +++ b/system/base/unknown/src/integer @@ -0,0 +1,134 @@ +
+PACKET integer DEFINES
+ sign, SIGN, abs, ABS, **, min, max, maxint,
+ get, random, initialize random :
+
+INT PROC maxint : 32767 ENDPROC maxint ;
+
+INT PROC sign (INT CONST argument) :
+
+ IF argument < 0 THEN -1
+ ELIF argument > 0 THEN 1
+ ELSE 0
+ FI
+
+ENDPROC sign ;
+
+INT OP SIGN (INT CONST argument) :
+ sign (argument)
+ENDOP SIGN ;
+
+INT PROC abs (INT CONST argument) :
+
+ IF argument > 0 THEN argument
+ ELSE - argument
+ FI
+
+ENDPROC abs ;
+
+INT OP ABS (INT CONST argument) :
+ abs (argument)
+ENDOP ABS ;
+
+INT OP ** (INT CONST arg, exp) :
+
+ INT VAR x := arg , z := 1 ,
+ counter := exp ;
+
+ IF exp < 0 THEN errorstop ("INT OP ** : negative exponent") FI ;
+ IF arg = 0 AND exp = 0
+ THEN errorstop (" 0 ** 0 is not defined")
+ FI ;
+ IF exp = 0 THEN x := 1 FI ;
+
+ WHILE counter >= 2 REP
+ calculate new x and z ;
+ counter := counter DIV 2 ;
+ ENDREP ;
+ z * x .
+
+calculate new x and z :
+ IF counter is not even
+ THEN z := z * x
+ FI ;
+ x := x * x .
+
+counter is not even :
+ counter MOD 2 = 1 .
+
+ENDOP ** ;
+
+INT PROC min (INT CONST first, second) :
+
+ IF first < second THEN first ELSE second FI
+
+ENDPROC min ;
+
+INT PROC max (INT CONST first, second) :
+
+ IF first > second THEN first ELSE second FI
+
+ENDPROC max ;
+
+
+PROC get (INT VAR number) :
+
+ get (word) ;
+ number := int (word)
+
+ENDPROC get ;
+
+TEXT VAR word := "" ;
+
+
+
+(************************************************)
+(*** ***)
+(*** generator 32 650 ***)
+(*** ***)
+(************************************************)
+
+(* INT-Zufallsgenerator mit Periode 32650 *) (*Autor: Bake *)
+ (*Gymnasium Aspe *)
+
+INT VAR z1 :: 14, (* fuer den generator mit periode 25 *)
+ z2 :: 345; (* fuer den generator mit periode 1306 *)
+
+
+ INT PROCEDURE random (INT CONST ugrenze, ogrenze) :
+ (*******************************************************)
+
+generator 25;
+generator 1306;
+(zufallszahl MOD intervallgroesse) + ugrenze.
+
+(* Durch MOD wird bei grosser 'intervallgroesse' der vordere
+ Bereich doppelt ueberdeckt, also keine Gleichverteilung. heinrichs
+ 24.04.81 *)
+
+
+ generator 25 :
+z1 := (11 * z1 + 18) MOD 25
+(* erster generator. liefert alle zahlen zwischen 0 und 24. *).
+
+ generator 1306 :
+z2 := (24 * z2 + 23) MOD 1307
+(* zweiter generator. liefert alle zahlen zwischen 0 und 1305. *).
+
+ zufallszahl :
+z1 + z2 * 25 (* diese zahl liegt zwischen 0 und 32 649 *).
+
+ intervallgroesse : ogrenze - ugrenze + 1
+
+END PROC random ;
+
+
+ PROCEDURE initialize random (INT CONST wert) :
+(**************************************************)
+
+z1 := wert MOD 25;
+z2 := wert MOD 1306
+
+END PROC initialize random ;
+
+ENDPACKET integer ;
diff --git a/system/base/unknown/src/mathlib b/system/base/unknown/src/mathlib new file mode 100644 index 0000000..be44ff6 --- /dev/null +++ b/system/base/unknown/src/mathlib @@ -0,0 +1,359 @@ +
+PACKET mathlib DEFINES sqrt,**,exp,ln,log2,log10,sin,cos,
+ tan,arctan,sind,cosd,tand,arctand,e,pi,
+ random,initializerandom :
+
+
+REAL VAR rdg::0.4711;
+
+REAL PROC pi:
+ 3.141592653589793.
+END PROC pi;
+
+REAL PROC e:
+ 2.718281828459045.
+END PROC e;
+
+REAL PROC ln(REAL CONST x):
+LET ln2= 0.6931471805599453;
+log2(x)*ln2.
+END PROC ln;
+
+REAL PROC log2(REAL CONST z):
+INT VAR k::0,p::0;
+REAL VAR m::0.0,x::z,t::0.0,summe::0.0;
+IF x>0.0
+THEN normal
+ELSE errorstop("log2 mit negativer zahl");4711.4711
+FI.
+normal:
+ IF x>=0.5
+ THEN normalise downwards
+ ELSE normalise upwards
+ FI;
+ IF x>=0.1 AND x< 0.7071067811865475 THEN
+ t:=(x-0.5946035575013605)/(x+0.5946035575013605);
+ summe:=reihenentwicklung (t) - 0.75
+ FI;
+ IF x>=0.7071067811865475 AND x < 1.0 THEN
+ t:=(x - 0.8408964152537145)/(x+0.8408964152537145);
+ summe:= reihenentwicklung(t)-0.25
+ FI;
+ summe-real(p - 4*k).
+
+ normalise downwards:
+ WHILE x>= 16.0 REP
+ x:=x/16.0;k:=k+1;
+ END REP;
+ WHILE x>=0.5 REP
+ x:=x/2.0;p:=p-1;
+ END REP.
+
+ normalise upwards:
+ WHILE x<=0.0625 REP
+ x:=x*16.0;k:=k-1;
+ END REP;
+ WHILE x<= 0.5 REP
+ x:=x*2.0;p:=p+1;
+ END REP.
+
+END PROC log2;
+
+REAL PROC reihenentwicklung(REAL CONST x):
+ REAL VAR i::39.0,s::1.0/39.0;
+ LET ln2=0.6931471805599453;
+ WHILE i>1.0 REP
+ i:=i-2.0;s:=s*x*x + 1.0/i;
+ END REP;
+ s*2.0*x/ln2.
+END PROC reihenentwicklung;
+
+REAL PROC log10(REAL CONST x):
+ LET lg2=0.301029995664;
+ log2(x)*lg2.
+END PROC log10;
+
+REAL PROC sqrt(REAL CONST z):
+ REAL VAR y0,y1,x::z;
+ INT VAR p::0;
+ BOOL VAR q::FALSE;
+ IF x<0.0
+ THEN errorstop("sqrt von negativer zahl");0.0
+ ELSE correct
+ FI.
+
+ correct:
+ IF x=0.0
+ THEN 0.0
+ ELSE nontrivial
+ FI.
+
+ nontrivial:
+ IF x<0.01
+ THEN small
+ ELSE notsmall
+ FI.
+
+
+ notsmall:
+ IF x>1.0
+ THEN big
+ ELSE normal
+ FI.
+
+ small:
+ WHILE x<0.01 REP
+ p:=p-1;x:=x*100.0;
+ END REP;
+ normal.
+
+ big:
+ WHILE x>=1.0 REP
+ p:=p+1;x:=x/100.0;
+ END REP;
+ normal.
+
+ normal:
+ IF x<0.1
+ THEN x:=x*10.0;q:=TRUE
+ FI;
+ y0:=10.0**p*(1.681595-1.288973/(0.8408065+x));
+ IF q
+ THEN y0:=y0/3.162278
+ FI;
+ y1:=(y0+z/y0)/2.0;
+ y0:=(y1+z/y1)/2.0;
+ y1:=(y0+z/y0)/2.0;
+ (y1-z/y1)/2.0+z/y1.
+
+END PROC sqrt;
+
+REAL PROC exp(REAL CONST z):
+ REAL VAR c,d,x::z, a, b ;
+ IF x<-180.2187
+ THEN 0.0
+ ELIF x<0.0
+ THEN 1.0/exp(-x)
+ ELIF x=0.0
+ THEN 1.0
+ ELSE x:=x/0.6931471805599453;approx
+ FI.
+
+ approx:
+ a:=floor(x/4.0)+1.0;
+ b:=floor(4.0*a-x);
+ c:=(4.0*a-b-x)*16.0;
+ d:=(c -floor(c))/16.0;
+ d:=d*0.6931471805599453;
+ ( (16.0 POWER a) / (2.0 POWER b) / (1.044273782427419 POWER c ))*
+ ((((((0.135910788320380e-2*d-0.8331563191293753e-2)*d
+ +0.4166661437490328e-1)*d-0.1666666658727157)*d+0.4999999999942539)*d
+ - 0.9999999999999844)*d+1.0).
+
+ENDPROC exp ;
+
+REAL OP POWER (REAL CONST basis, exponent) :
+
+ IF floor (exponent) = 0.0
+ THEN 1.0
+ ELSE power
+ FI .
+
+power :
+ REAL VAR counter := floor (abs (exponent)) - 1.0 ,
+ result := basis ;
+ WHILE counter > 0.0 REP
+ result := result * basis ;
+ counter := counter - 1.0
+ PER ;
+ IF exponent > 0.0
+ THEN result
+ ELSE 1.0 / result
+ FI .
+
+ENDOP POWER ;
+
+REAL PROC tan (REAL CONST x):
+ REAL VAR p;
+ p:=1.273239544735168*ABSx;
+ tg(p)*sign(x).
+END PROC tan;
+
+REAL PROC tand(REAL CONST x):
+ REAL VAR p;
+ p:=0.02222222222222222*ABSx;
+ tg(p)*sign(x).
+END PROC tand;
+
+REAL PROC tg(REAL CONST x):
+ REAL VAR r,s,u,q;
+ q:=floor(x);r:=x-q;
+ IF q = floor(q/2.0) * 2.0
+ THEN s:=r
+ ELSE s:=(1.0-r)
+ FI;
+ q:= q - floor(q/4.0) * 4.0 ;
+ u:=s*s;
+ s:=s*0.785398163397448;
+ s:=s/(((((((((-0.4018243865271481e-10*u-0.4404768172667185e-9)*u-
+ 0.748183650813680e-8)*u-0.119216115119129e-6)*u-0.1909255769212821e-5)*u-
+0.3064200638849133e-4)*u-0.4967495424202482e-3)*u-0.8455650263333471e-2)*u-
+ 0.2056167583560294)*u+1.0);
+ IF q=0.0
+ THEN s
+ ELIF q=3.0
+ THEN -s
+ ELIF q=1.0
+ THEN 1.0/s
+ ELSE -1.0/s
+ FI .
+
+END PROC tg;
+
+REAL PROC sin(REAL CONST x):
+ REAL VAR y,r;
+ INT VAR q;
+ y:=ABS x*1.273239544735168;
+ q:=int(y);
+ r:=y-real(q);
+ IF x<0.0
+ THEN q:=q+4
+ FI;
+ sincos(q,r).
+END PROC sin;
+
+REAL PROC sind(REAL CONST x):
+ REAL VAR y,r;
+ INT VAR q;
+ y:=ABSx/45.0;
+ q:=int(y);
+ r:=y-real(q);
+ IF x<0.0
+ THEN q:=q+4
+ FI;
+ sincos(q,r).
+END PROC sind;
+
+
+REAL PROC cos(REAL CONST x):
+ REAL VAR y,r;
+ INT VAR q;
+ y:=ABS x*1.273239544735168;
+ q:=int(y);
+ r:=y-real(q);
+ q:=q+2;
+ sincos(q,r).
+END PROC cos;
+
+REAL PROC cosd(REAL CONST x):
+ REAL VAR y,r;
+ INT VAR q;
+ y:=ABS x/45.0;
+ q:=int(y);
+ r:=y-real(q);
+ q:=q+2;
+ sincos(q,r).
+END PROC cosd;
+
+
+REAL PROC sincos(INT VAR q,REAL VAR r):
+ SELECT q MOD 8 + 1 OF
+ CASE 1 : sin approx(r)
+ CASE 2 : cos approx (1.0-r)
+ CASE 3 : cos approx(r)
+ CASE 4 : sin approx(1.0-r)
+ CASE 5 : - sin approx(r)
+ CASE 6 : - cos approx(1.0-r)
+ CASE 7 : - cos approx(r)
+ CASE 8 : - sin approx(1.0-r)
+ OTHERWISE 0.0
+ END SELECT
+END PROC sincos;
+
+REAL PROC sin approx(REAL CONST x):
+ REAL VAR z::x*x;
+ x*((((((0.6877101540593035e-11*z-0.1757149296873372e-8)*z+0.313361621667256
+8
+e-6)*z-0.3657620415845891e-4)*z+0.2490394570188737e-2)*z-0.807455121882e-1
+)*z+0.7853981633974483).
+END PROC sin approx;
+
+REAL PROC cos approx(REAL CONST x):
+ REAL VAR z::x*x;
+ (((((( -0.3857761864560276e-12*z+0.115004970178141e-9)*z-0.246113638267419e
+-7)*z+0.3590860445885748e-5)*z-0.3259918869266875e-3)*z+0.1585434424381541e-1
+)*z-0.3084251375340425)*z+1.0.
+END PROC cos approx;
+
+REAL PROC arctan(REAL CONST x):
+REAL VAR z::x*x;
+IF x<0.0 THEN -arctan(-x)
+ELIF x>1.0 THEN 3.141592653589792/2.0-arctan(1.0/x)
+ELIF x*1.0e16>2.67949192431e15 THEN pi/6.0+arctan(1.732050807568877-4.0
+/(x+1.732050807568877))
+ELSE x/(((((((0.0107090276046822*z-0.01647757182108040)*z
+ +0.02177846332482151)*z-0.03019339673273880)*z+0.04656083561183398)*z
+ -0.0888888888888888)*z+0.3333333333333333)*z+1.0)FI.
+END PROC arctan;
+
+REAL PROC arctand(REAL CONST x):
+ arctan(x)/3.1415926589793*180.0.
+END PROC arctand;
+
+
+BOOL PROC even(INT CONST number):
+ (number DIV 2)*2=number.
+END PROC even;
+
+REAL OP **(REAL CONST base,exponent):
+ IF base<0.0
+ THEN errorstop("hoch mit negativer basis")
+ FI;
+ IF base=0.0
+ THEN test exponent
+ ELSE
+ exp(exponent*ln(base))
+ FI.
+
+ test exponent:
+ IF exponent=0.0
+ THEN errorstop("0**0 geht nicht");4711.4711
+ ELSE 0.0
+ FI.
+
+END OP **;
+
+
+REAL PROC sign(REAL CONST number):
+ IF number >0.0 THEN 1.0
+ ELIF number <0.0 THEN -1.0
+ ELSE 0.0
+ FI.
+END PROC sign ;
+
+REAL OP **(REAL CONST a,INT CONST b):
+REAL VAR p::1.0,r::a;INT VAR n::ABS b;
+WHILE n>0 REP
+ IF n MOD 2=0
+ THEN n:=n DIV 2;r:=r*r
+ ELSE n DECR 1;p:=p*r
+ FI;
+END REP;
+IF b>0
+THEN p
+ELSE 1.0/p
+FI.
+END OP **;
+
+
+
+REAL PROC random:
+rdg:=rdg+pi;rdg:=rdg*rdg;rdg:=rdg*rdg;rdg:=rdg*rdg;rdg:=frac(rdg);rdg.
+END PROC random;
+
+
+PROC initializerandom(REAL CONST z):
+ rdg:=z;
+END PROC initializerandom;
+
+END PACKET mathlib;
diff --git a/system/base/unknown/src/real b/system/base/unknown/src/real new file mode 100644 index 0000000..a2ab9c3 --- /dev/null +++ b/system/base/unknown/src/real @@ -0,0 +1,378 @@ +
+PACKET real DEFINES (* Autor: J.Liedtke *)
+ (* Stand: 30.04.80 *)
+ text ,
+ int ,
+ real ,
+ round ,
+ floor ,
+ frac ,
+ INCR ,
+ DECR ,
+ abs ,
+ ABS ,
+ sign ,
+ SIGN ,
+ MOD ,
+ min ,
+ max ,
+ put ,
+ get ,
+ max real ,
+ small real :
+
+LET mantissa length = 13 ;
+
+TEXT VAR mantissa ;
+
+ROW 10 REAL VAR real digit ;
+
+INT VAR i ; REAL VAR d := 0.0 ;
+FOR i FROM 1 UPTO 10 REP
+ real digit (i) := d ;
+ d := d + 1.0
+PER ;
+
+REAL PROC max real : 9.999999999999e126 ENDPROC max real ;
+
+REAL PROC small real : 1.0e-12 ENDPROC small real ;
+
+PROC sld (INT CONST in, REAL VAR real, INT VAR out) :
+ EXTERNAL 96
+ENDPROC sld ;
+
+INT PROC decimal exponent (REAL CONST mantissa) :
+ EXTERNAL 97
+ENDPROC decimal exponent ;
+
+PROC set exp (INT CONST exponent, REAL VAR number) :
+ EXTERNAL 98
+ENDPROC set exp ;
+
+REAL PROC tenpower (INT CONST exponent) :
+ REAL VAR result := 1.0 ;
+ set exp (exponent, result) ;
+ result
+ENDPROC tenpower ;
+
+REAL PROC floor (REAL CONST real) :
+ EXTERNAL 99
+ENDPROC floor ;
+
+REAL PROC round (REAL CONST real, INT CONST digits) :
+
+ REAL VAR result := real ;
+ IF (real <> 0.0) CAND (decimal exponent (real) + digits < mantissa length)
+ THEN round result ;
+ FI ;
+ result .
+
+round result :
+ set exp (decimal exponent (result) + digits, result) ;
+ IF result >= 0.0
+ THEN result := floor (result + 0.5)
+ ELSE result := floor (result - 0.5)
+ FI ;
+ set exp (decimal exponent (result) - digits, result) .
+
+ENDPROC round ;
+
+TEXT VAR result ;
+
+TEXT PROC text (REAL CONST real) :
+
+ REAL VAR value := rounded to seven digits ;
+ IF value = 0.0
+ THEN "0.0"
+ ELSE
+ process sign ;
+ get mantissa (value) ;
+ INT CONST exponent := decimal exponent (value) ;
+ get short mantissa ;
+ IF exponent > 7 OR exponent < LENGTH short mantissa - 7
+ THEN scientific notation
+ ELSE short notation
+ FI
+ FI .
+
+rounded to seven digits :
+ round ( real * tenpower( -decimal exponent(real) ) , 6 )
+ * tenpower ( decimal exponent(real) ) .
+
+process sign :
+ IF value < 0.0
+ THEN result := "-" ;
+ value := - value
+ ELSE result := ""
+ FI .
+
+get short mantissa :
+ INT VAR i := 7 ;
+ WHILE (mantissa SUB i) = "0" REP
+ i DECR 1
+ UNTIL i=1 END REP ;
+ TEXT CONST short mantissa := subtext (mantissa, 1, i) .
+
+scientific notation :
+ result CAT (mantissa SUB 1) ;
+ result CAT "." ;
+ result CAT subtext (mantissa, 2, 7) ;
+ result + "e" + text (exponent) .
+
+short notation :
+ result CAT subtext (short mantissa, 1, exponent+1) ;
+ result CAT (exponent+1 - LENGTH short mantissa) * "0" ;
+ result CAT "." ;
+ IF exponent < 0
+ THEN result + (-exponent-1) * "0" + short mantissa
+ ELSE result + subtext (short mantissa, exponent+2)
+ FI .
+
+ENDPROC text ;
+
+PROC get mantissa (REAL CONST number) :
+
+ REAL VAR real mantissa := number ;
+ mantissa := "" ;
+ INT VAR i , digit ;
+ FOR i FROM 1 UPTO mantissa length REP
+ sld (0, real mantissa, digit) ;
+ mantissa CAT code (digit + 48)
+ PER ;
+
+ENDPROC get mantissa ;
+
+PROC put (REAL CONST real) :
+
+ put (text (real) )
+
+ENDPROC put ;
+
+TEXT PROC text (REAL CONST real, INT CONST length, fracs) :
+
+ REAL VAR value := round (real, fracs) ;
+ INT VAR exponent := decimal exponent (value) ;
+ IF value = 0.0 THEN exponent := 0 FI ;
+ INT VAR floors := exponent + 1 ,
+ floor length := length - fracs - 1 ;
+ IF value < 0.0 THEN floor length DECR 1 FI ;
+
+ IF value too big
+ THEN length * "*"
+ ELSE transformed value
+ FI .
+
+transformed value :
+ process leading blanks and sign ;
+ get mantissa (value) ;
+ result CAT subtext (mantissa, 1, floors) ;
+ IF LENGTH mantissa < floors
+ THEN result CAT (floors - LENGTH mantissa) * "0"
+ FI ;
+ result CAT "." ;
+ IF exponent < 0
+ THEN result CAT (-floors) * "0" ;
+ result CAT subtext (mantissa, 1, length - LENGTH result)
+ ELSE result CAT subtext (mantissa, floors+1, floors + fracs)
+ FI ;
+ IF LENGTH result < length
+ THEN result CAT (length - LENGTH result) * "0"
+ FI ;
+ result .
+
+process leading blanks and sign :
+ result := (floor length - max(floors,0)) * " " ;
+ IF value < 0.0
+ THEN result CAT "-" ;
+ value := - value
+ FI .
+
+value too big :
+ floors > floor length .
+
+ENDPROC text ;
+
+REAL PROC real (TEXT CONST text) :
+
+ skip leading blanks ;
+ sign ;
+ mantissa part ;
+ exponent ;
+ check correct conversion ;
+ result .
+
+skip leading blanks :
+ INT VAR pos := 1 ;
+ skip blanks .
+
+skip blanks :
+ WHILE (text SUB pos) = " " REP
+ pos INCR 1
+ PER .
+
+sign :
+ BOOL VAR negative ;
+ IF (text SUB pos) = "-"
+ THEN negative := TRUE ;
+ pos INCR 1
+ ELIF (text SUB pos) = "+"
+ THEN negative := FALSE ;
+ pos INCR 1
+ ELSE negative := FALSE
+ FI .
+
+mantissa part:
+ REAL VAR value := 0.0 ;
+ INT VAR exponent pos := 0 ;
+ WHILE pos <= LENGTH text REP
+ TEXT VAR digit := text SUB pos ;
+ IF digit <= "9" AND digit >= "0"
+ THEN value := value * 10.0 + real digit (code (digit) - 47) ;
+ pos INCR 1
+ ELIF digit = "."
+ THEN pos INCR 1 ;
+ exponent pos := pos
+ ELSE LEAVE mantissa part
+ FI
+ END REP .
+
+exponent :
+ INT VAR exp ;
+ IF exponent pos > 0
+ THEN exp := exponent pos - pos
+ ELSE exp := 0
+ FI ;
+ IF (text SUB pos) = "e"
+ THEN exp INCR int (subtext(text,pos+1))
+ FI .
+
+check correct conversion :
+ skip blanks ;
+ IF pos > LENGTH text
+ THEN set conversion (TRUE)
+ ELSE set conversion (FALSE)
+ FI .
+
+result :
+ value := value * tenpower (exp) ;
+ IF negative
+ THEN - value
+ ELSE value
+ FI .
+
+ENDPROC real ;
+
+TEXT VAR word ;
+
+PROC get (REAL VAR value) :
+
+ get (word) ;
+ value := real (word)
+
+ENDPROC get ;
+
+REAL PROC abs (REAL CONST value) :
+
+ IF value >= 0.0
+ THEN value
+ ELSE -value
+ FI
+
+ENDPROC abs ;
+
+REAL OP ABS (REAL CONST value) :
+
+ abs (value)
+
+ENDOP ABS ;
+
+INT PROC sign (REAL CONST value) :
+
+ IF value < 0.0 THEN -1
+ ELIF value = 0.0 THEN 0
+ ELSE 1
+ FI
+
+ENDPROC sign ;
+
+INT OP SIGN (REAL CONST value) :
+
+ sign (value)
+
+ENDOP SIGN ;
+
+REAL OP MOD (REAL CONST left, right) :
+
+ REAL VAR result := left - floor (left/right) * right ;
+ IF left < 0.0
+ THEN result + abs (right)
+ ELSE result
+ FI
+
+ENDOP MOD ;
+
+REAL PROC frac (REAL CONST value) :
+
+ value - floor (value)
+
+ENDPROC frac ;
+
+REAL PROC max (REAL CONST a, b) :
+
+ IF a > b THEN a ELSE b FI
+
+ENDPROC max ;
+
+REAL PROC min (REAL CONST a, b) :
+
+ IF a < b THEN a ELSE b FI
+
+ENDPROC min ;
+
+OP INCR (REAL VAR dest, REAL CONST increment) :
+
+ dest := dest + increment
+
+ENDOP INCR ;
+
+OP DECR (REAL VAR dest, REAL CONST decrement) :
+
+ dest := dest - decrement
+
+ENDOP DECR ;
+
+INT PROC int (REAL CONST value) :
+
+ INT VAR result := 0, digit ,i ;
+ REAL VAR mantissa := value ;
+
+ FOR i FROM 0 UPTO decimal exponent (value) REP
+ sld (0, mantissa, digit) ;
+ result := result * 10 + digit
+ PER ;
+
+ IF value < 0.0
+ THEN - result
+ ELSE result
+ FI
+
+ENDPROC int ;
+
+REAL PROC real (INT CONST value) :
+
+ IF value < 0
+ THEN - real (-value)
+ ELIF value < 10
+ THEN real digit (value+1)
+ ELSE split value into head and last digit ;
+ real (head) * 10.0 + real digit (last digit+1)
+ FI .
+
+split value into head and last digit :
+ INT CONST
+ head := value DIV 10 ,
+ last digit := value - head * 10 .
+
+ENDPROC real ;
+
+ENDPACKET real ;
diff --git a/system/base/unknown/src/scanner b/system/base/unknown/src/scanner new file mode 100644 index 0000000..ed04699 --- /dev/null +++ b/system/base/unknown/src/scanner @@ -0,0 +1,255 @@ +
+PACKET scanner DEFINES (* Autor: J.Liedtke *)
+ (* Stand: 30.12.81 *)
+ scan ,
+ continue scan ,
+ next symbol ,
+ fix scanner ,
+ reset scanner :
+
+
+LET tag = 1 ,
+ bold = 2 ,
+ integer = 3 ,
+ text = 4 ,
+ operator= 5 ,
+ delimiter = 6 ,
+ end of file = 7 ,
+ within comment = 8 ,
+ within text = 9 ;
+
+
+TEXT VAR line := "" ,
+ char := "" ;
+
+INT VAR position := 0 ,
+ reset position ,
+ comment depth ;
+BOOL VAR continue text ;
+
+
+PROC scan (TEXT CONST scan text) :
+
+ comment depth := 0 ;
+ continue text := FALSE ;
+ continue scan (scan text)
+
+ENDPROC scan ;
+
+PROC continue scan (TEXT CONST scan text) :
+
+ line := scan text ;
+ position := 0 ;
+ next non blank char ;
+ reset position := position
+
+ENDPROC continue scan ;
+
+PROC fix scanner :
+
+ reset position := position
+
+ENDPROC fix scanner ;
+
+PROC reset scanner :
+
+ position := reset position ;
+ char := line SUB position
+
+ENDPROC reset scanner ;
+
+PROC next symbol (TEXT VAR symbol) :
+
+ INT VAR type ;
+ next symbol (symbol, type)
+
+ENDPROC next symbol ;
+
+PROC next symbol (TEXT VAR symbol, INT VAR type) :
+
+ skip blanks ;
+ symbol := "" ;
+ IF is niltext THEN eof
+ ELIF is comment THEN process comment
+ ELIF is text THEN process text
+ ELIF is lower case letter THEN process tag
+ ELIF is upper case letter THEN process bold
+ ELIF is digit THEN process integer
+ ELIF is delimiter THEN process delimiter
+ ELSE process operator
+ FI .
+
+skip blanks :
+ IF char = " "
+ THEN next non blank char
+ FI .
+
+
+process comment :
+ read comment ;
+ IF comment depth = 0
+ THEN next symbol (symbol, type)
+ ELSE type := within comment
+ FI .
+
+process tag :
+ type := tag ;
+ REP
+ symbol CAT char ;
+ next non blank char
+ UNTIL NOT (is lower case letter OR is digit) ENDREP .
+
+process bold :
+ type := bold ;
+ REP
+ symbol CAT char ;
+ next char
+ UNTIL NOT is upper case letter ENDREP .
+
+process integer :
+ type := integer ;
+ REP
+ symbol CAT char ;
+ next non blank char
+ UNTIL NOT (is digit OR char = ".") ENDREP .
+
+process text :
+ type := text ;
+ IF continue text
+ THEN continue text := FALSE
+ ELSE next char
+ FI ;
+ WHILE not end of text REP
+ symbol CAT char ;
+ next char
+ ENDREP .
+
+not end of text :
+ IF is niltext
+ THEN continue text := TRUE ; type := within text ; FALSE
+ ELIF is quote
+ THEN end of text or exception
+ ELSE TRUE
+ FI .
+
+end of text or exception :
+ next char ;
+ IF is quote
+ THEN TRUE
+ ELIF is digit
+ THEN get special char ; TRUE
+ ELSE FALSE
+ FI .
+
+get special char :
+ TEXT VAR special symbol ;
+ next symbol (special symbol) ;
+ char := code ( int (special symbol ) ) .
+
+process delimiter :
+ type := delimiter ;
+ symbol := char ;
+ next non blank char .
+
+process operator :
+ type := operator ;
+ symbol := char ;
+ nextchar ;
+ IF symbol = ":"
+ THEN IF char = "=" OR char = ":"
+ THEN symbol := ":=" ;
+ nextchar
+ ELSE type := delimiter
+ FI
+ ELIF is relational double char
+ THEN symbol CAT char ;
+ nextchar
+ ELIF symbol = "*" AND char = "*"
+ THEN symbol := "**" ;
+ next char
+ FI .
+
+eof :
+ type := end of file ;
+ symbol := "" .
+
+is lower case letter : char lies in (97, 122) .
+
+is upper case letter : char lies in (65, 90) .
+
+is digit : char lies in (48, 57) .
+
+is delimiter : pos ( "()[].,;" , char ) > 0 AND char <> "" .
+
+is relational double char :
+ TEXT VAR double := symbol + char ;
+ double = "<>" OR double = "<=" OR double = ">=" .
+
+is text : is quote OR continue text .
+
+is quote : char = """" .
+
+is niltext : char = "" .
+
+is comment :
+ IF comment depth = 0
+ THEN char = "{" OR char = "(" AND ahead char = "*"
+ ELSE comment depth DECR 1 ; TRUE
+ FI .
+
+ENDPROC next symbol ;
+
+PROC next char :
+
+ position INCR 1 ;
+ char := line SUB position
+
+ENDPROC next char ;
+
+PROC next non blank char :
+
+ REP
+ position INCR 1
+ UNTIL (line SUB position) <> " " ENDREP ;
+ char := line SUB position
+
+ENDPROC next non blank char ;
+
+TEXT PROC ahead char :
+
+ line SUB position+1
+
+ENDPROC ahead char ;
+
+BOOL PROC char lies in (INT CONST lower bound, upper bound) :
+
+ lower bound <= code(char) AND code(char) <= upper bound
+
+ENDPROC char lies in ;
+
+PROC read comment :
+
+ TEXT VAR last char ;
+ comment depth INCR 1 ;
+ REP
+ last char := char ;
+ nextchar ;
+ IF is begin comment
+ THEN read comment
+ FI ;
+ IF char = ""
+ THEN LEAVE read comment
+ FI
+ UNTIL is end comment PER ;
+ comment depth DECR 1 ;
+ next nonblank char .
+
+is end comment :
+ char = "}" OR char = ")" AND last char = "*" .
+
+is begin comment :
+ char = "{" OR char = "(" AND ahead char = "*" .
+
+ENDPROC read comment ;
+
+ENDPACKET scanner ;
diff --git a/system/base/unknown/src/stdescapeset b/system/base/unknown/src/stdescapeset new file mode 100644 index 0000000..0c69ea7 --- /dev/null +++ b/system/base/unknown/src/stdescapeset @@ -0,0 +1,31 @@ +PACKET std escape set (* Autor: P.Heyderhoff *)
+ (************) (* Stand: 20.01.1981 *)
+ (* Vers.: 1.5.5 *)
+DEFINES std escape set :
+
+PROC std escape set :
+
+ define escape ("p", "IFmark>0THEN PUT"""";W""""12""""FI") ;
+ define escape ("g", "GET"""";M0") ;
+ define escape ("d", "IFmark>0THEN PUT"""";M0ELSE GET"""";M0FI");
+ define escape ("B", "W""""194""""") ;
+ define escape ("A", "W""""193""""") ;
+ define escape ("O", "W""""207""""") ;
+ define escape ("U", "W""""213""""") ;
+ define escape ("a", "W""""225""""") ;
+ define escape ("o", "W""""239""""") ;
+ define escape ("u", "W""""245""""") ;
+ define escape ("z", "C1;""""C(((limit-len)/2)*"" "")") ;
+ define escape ("l", "i:=col;C1;M1;Ci;W""""12""""") ;
+ define escape ("h", "S11") ;
+ define escape ("v", "S23") ;
+ define escape ("1", "1;C1");
+ define escape ("9", "9999;C(len+1)");
+ define escape (""2"", """ """);
+ define escape (""10"","+1;R Clen;"" ""Ucol>lenE");
+ define escape (""3"", "R-1;Hrow;Clen;"" ""Ucol>lenE");
+ define escape (""8"", "COL(col-10)");
+
+ENDPROC std escape set ;
+
+ENDPACKET std escape set ;
|