From 98cab31fc3659e33aef260efca55bf9f1753164c Mon Sep 17 00:00:00 2001 From: Lars-Dominik Braun Date: Mon, 11 Feb 2019 11:49:19 +0100 Subject: Add source files from Michael --- system/base/unknown/src/SPOLMAN5.ELA | 1003 ++++++++++++++++++++++++++++++ system/base/unknown/src/STD.ELA | 220 +++++++ system/base/unknown/src/STDPLOT.ELA | 365 +++++++++++ system/base/unknown/src/bildeditor | 722 +++++++++++++++++++++ system/base/unknown/src/command handler | 239 +++++++ system/base/unknown/src/dateieditorpaket | 743 ++++++++++++++++++++++ system/base/unknown/src/editor | 210 +++++++ system/base/unknown/src/elan | 245 ++++++++ system/base/unknown/src/feldeditor | 747 ++++++++++++++++++++++ system/base/unknown/src/file | 810 ++++++++++++++++++++++++ system/base/unknown/src/init | 250 ++++++++ system/base/unknown/src/integer | 134 ++++ system/base/unknown/src/mathlib | 359 +++++++++++ system/base/unknown/src/real | 378 +++++++++++ system/base/unknown/src/scanner | 255 ++++++++ system/base/unknown/src/stdescapeset | 31 + 16 files changed, 6711 insertions(+) create mode 100644 system/base/unknown/src/SPOLMAN5.ELA create mode 100644 system/base/unknown/src/STD.ELA create mode 100644 system/base/unknown/src/STDPLOT.ELA create mode 100644 system/base/unknown/src/bildeditor create mode 100644 system/base/unknown/src/command handler create mode 100644 system/base/unknown/src/dateieditorpaket create mode 100644 system/base/unknown/src/editor create mode 100644 system/base/unknown/src/elan create mode 100644 system/base/unknown/src/feldeditor create mode 100644 system/base/unknown/src/file create mode 100644 system/base/unknown/src/init create mode 100644 system/base/unknown/src/integer create mode 100644 system/base/unknown/src/mathlib create mode 100644 system/base/unknown/src/real create mode 100644 system/base/unknown/src/scanner create mode 100644 system/base/unknown/src/stdescapeset (limited to 'system/base') 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 ; -- cgit v1.2.3