diff options
| author | Lars-Dominik Braun <lars@6xq.net> | 2019-02-04 13:09:03 +0100 |
|---|---|---|
| committer | Lars-Dominik Braun <lars@6xq.net> | 2019-02-04 13:09:03 +0100 |
| commit | 04e68443040c7abad84d66477e98f93bed701760 (patch) | |
| tree | 2b6202afae659e773bf6916157d23e83edfa44e3 /system/multiuser | |
| download | eumel-src-04e68443040c7abad84d66477e98f93bed701760.tar.gz eumel-src-04e68443040c7abad84d66477e98f93bed701760.tar.bz2 eumel-src-04e68443040c7abad84d66477e98f93bed701760.zip | |
Initial import
Diffstat (limited to 'system/multiuser')
26 files changed, 18671 insertions, 0 deletions
diff --git a/system/multiuser/1.7.5/source-disk b/system/multiuser/1.7.5/source-disk new file mode 100644 index 0000000..e24344a --- /dev/null +++ b/system/multiuser/1.7.5/source-disk @@ -0,0 +1,2 @@ +175_src/source-code-1.7.5m_0.img +175_src/source-code-1.7.5m_1.img diff --git a/system/multiuser/1.7.5/src/archive b/system/multiuser/1.7.5/src/archive new file mode 100644 index 0000000..8027b29 --- /dev/null +++ b/system/multiuser/1.7.5/src/archive @@ -0,0 +1,92 @@ +(* ------------------- VERSION 14 06.03.86 ------------------- *) +PACKET archive DEFINES + + archive , + clear , + release , + format , + check , + reserve : + + +LET clear code = 18 , + reserve code = 19 , + free code = 20 , + check read code = 22 , + format code = 23 ; + + +TASK PROC archive : + + task ("ARCHIVE") + +ENDPROC archive ; + +PROC archive (TEXT CONST archive name, TASK CONST task) : + + call (reserve code, archive name, task) + +ENDPROC archive ; + +PROC reserve (TEXT CONST message, TASK CONST task) : + + call (reserve code, message, task) + +END PROC reserve; + +PROC reserve (TASK CONST task) : + + call(reserve code, "", task) + +END PROC reserve; + +PROC archive (TEXT CONST archive name, INT CONST station) : + + call (reserve code, archive name, station/ "ARCHIVE") + +ENDPROC archive ; + +PROC archive (TEXT CONST archive name): + + call (reserve code, archive name, archive) + +ENDPROC archive ; + +PROC release (TASK CONST task) : + + call (free code, "", task) + +ENDPROC release ; + +PROC clear (TASK CONST task) : + + call (clear code, "", task) + +ENDPROC clear ; + +PROC format (TASK CONST task) : + + format (0, task) + +ENDPROC format ; + +PROC format (INT CONST code, TASK CONST task) : + + call (format code , text (code), task) + +ENDPROC format ; + +PROC check (TEXT CONST file name, TASK CONST task) : + + call (check read code, file name, task) + +ENDPROC check ; + +PROC check (THESAURUS CONST nameset, TASK CONST task) : + + do (PROC (TEXT CONST, TASK CONST) check, nameset, task) + +ENDPROC check ; + +ENDPACKET archive ; + diff --git a/system/multiuser/1.7.5/src/archive manager b/system/multiuser/1.7.5/src/archive manager new file mode 100644 index 0000000..c37d2e2 --- /dev/null +++ b/system/multiuser/1.7.5/src/archive manager @@ -0,0 +1,670 @@ +(* ------------------- VERSION 10 vom 17.04.86 ------------------- *) +PACKET archive manager DEFINES (* Autor: J.Liedtke*) + + archive manager , + provide channel : + + + +LET std archive channel = 31 , + + ack = 0 , + nak = 1 , + error nak = 2 , + second phase ack = 5 , + false code = 6 , + + fetch code = 11 , + save code = 12 , + exists code = 13 , + erase code = 14 , + list code = 15 , + all code = 17 , + clear code = 18 , + reserve code = 19 , + free code = 20 , + check read code = 22 , + format code = 23 , + + read error = 92 , + + max files = 200 , + + start of volume = 1000 , + end of volume = 1 , + file header = 3 , + + number of header blocks = 2 , + + quote = """" , + dummy name = "-" , + dummy date = " " , + + + HEADER = STRUCT (TEXT name, date, INT type, TEXT password) ; + + +BOUND STRUCT (TEXT name, pass) VAR msg ; + +INT VAR archive channel := std archive channel ; + +TASK VAR archive owner := niltask , + order task ; +TEXT VAR archive name := "" , write stamp ; + +REAL VAR last access time := 0.0 ; + +BOOL VAR was already write access ; + + +DATASPACE VAR header space := nilspace ; +BOUND HEADER VAR header ; + +TEXT VAR file name := "" ; + +LET invalid = 0 , + read only = 1 , + valid = 2 ; + +LET accept read errors = TRUE , + ignore read errors = FALSE ; + + +INT VAR directory state := invalid ; + +THESAURUS VAR directory ; +INT VAR dir index ; + +INT VAR archive size ; + +INT VAR end of volume block ; +ROW max files INT VAR header block ; +ROW max files TEXT VAR header date ; + + + +PROC provide channel (INT CONST channel) : + + archive channel := channel + +ENDPROC provide channel ; + +PROC archive manager : + + archive manager (archive channel) + +ENDPROC archive manager ; + +PROC archive manager (INT CONST channel) : + + archive channel := channel ; + task password ("-") ; + global manager + (PROC (DATASPACE VAR, INT CONST, INT CONST, TASK CONST) archive manager) + +ENDPROC archive manager ; + +PROC archive manager (DATASPACE VAR ds, INT CONST order, phase, + TASK CONST task) : + + + enable stop ; + order task := task ; + msg := ds ; + SELECT order OF + CASE fetch code : fetch file + CASE save code : save file + CASE exists code : exists file + CASE erase code : erase file + CASE list code : list (ds); manager ok (ds) + CASE all code : deliver directory + CASE clear code, + format code : clear or format + CASE reserve code : reserve + CASE free code : free + CASE check read code : check + OTHERWISE errorstop (name (myself) + ": unbekannter Auftrag") + ENDSELECT . + +deliver directory : + access archive ; + BOUND THESAURUS VAR all names := ds ; + all names := directory ; + WHILE all names CONTAINS dummy name REP + delete (all names, dummy name, dir index) + PER ; + manager ok (ds) . + +clear or format : + IF NOT (order task = archive owner) + THEN errorstop ("Archiv nicht angemeldet") + ELIF phase = 1 + THEN ask for erase all + ELSE directory state := invalid ; + IF order <> clear code + THEN format archive (specification) ; + archive size := archive blocks + FI ; + rewind ; + write header (archive name, text (clock(1),13,1), start of volume); + write end of volume ; + manager ok (ds) + FI . + +ask for erase all : + IF order = format code AND specification > 3 + THEN errorstop ("ungueltiger Format-Code") + FI ; + look at volume header ; + IF header.name <> "" + THEN IF order = clear code + THEN manager question ("Archiv """+header.name+""" loeschen", order task) + ELSE manager question ("Archiv """+header.name+""" formatieren", order task) + FI + ELSE IF order = clear code + THEN manager question ("Archiv initialisieren", order task) + ELSE manager question ("Archiv formatieren", order task) + FI + FI . + +specification : + int (msg.name) . + +reserve : + IF reserve or free permitted + THEN continue archive channel; + disable stop ; + directory state := invalid ; + archive owner := order task ; + archive name := msg.name ; + manager ok (ds) + ELSE errorstop ("Archiv wird von Task """+name(archive owner)+""" benutzt") + FI . + +continue archive channel : + continue channel (archive channel) . + +free : + IF reserve or free permitted + THEN archive owner := niltask ; + break (quiet) ; + manager ok (ds) + ELSE manager message ("Archiv nicht angemeldet", order task) + FI. + +reserve or free permitted : + order task = archive owner OR last access more than five minutes ago + OR archive owner = niltask OR NOT + (exists (archive owner) OR station (archive owner) <> station (myself)) . + +last access more than five minutes ago : + abs (last access time - clock (1)) > 300.0 . + +fetch file : + access archive ; + access file (msg.name) ; + IF no read error remarked + THEN disable stop ; + fetch (ds, accept read errors) ; + IF read error occurred + THEN remark read error + FI ; + enable stop + ELSE fetch (ds, ignore read errors) + FI ; + manager ok (ds) . + +no read error remarked : + pos (file name, " mit Lesefehler") = 0 . + +read error occurred : + is error AND error code = read error . + +remark read error : + dir index := link (directory, file name) ; + REP + file name CAT " mit Lesefehler" ; + UNTIL NOT (directory CONTAINS file name) PER ; + IF LENGTH file name < 100 + THEN rename (directory, dir index, file name) + FI . + +save file : + IF phase = 1 + THEN access archive ; + access file (msg.name) ; + IF file in directory + THEN manager question (""""+file name +""" ueberschreiben", order task) + ELSE send (order task, second phase ack, ds) + FI + ELSE access archive ; + access file (file name) ; + erase ; + save (ds) ; + forget (ds) ; + ds := nilspace ; + manager ok (ds) + FI . + +exists file : + access archive ; + access file (msg.name) ; + IF file in directory + THEN manager ok (ds) + ELSE send (order task, false code, ds) + FI . + +erase file : + access archive ; + access file (msg.name) ; + IF file in directory + THEN IF phase = 1 + THEN manager question (""""+file name+""" loeschen", order task) + ELSE erase ; manager ok (ds) + FI + ELSE manager message ("gibt es nicht", order task) + FI . + +check : + access archive ; + access file (msg.name) ; + IF file in directory + THEN position to file ; + disable stop ; + check read ; + IF is error + THEN clear error; error ("fehlerhaft") + ELSE last access time := clock (1) ; + manager message ("""" + file name + """ ohne Fehler gelesen", order task) + FI + ELSE error ("gibt es nicht") + FI . + +file in directory : dir index > 0 . + +position to file : + seek (header block (dir index) + number of header blocks) . + +ENDPROC archive manager ; + +PROC manager ok (DATASPACE VAR ds) : + + send (order task, ack, ds) ; + last access time := clock (1) . + +ENDPROC manager ok ; + +PROC access archive : + + IF NOT (order task = archive owner) + THEN errorstop ("Archiv nicht angemeldet") + ELIF directory state = invalid + THEN open archive + ELIF last access more than two seconds ago + THEN check volume name ; + new open if somebody changed medium + FI . + +last access more than two seconds ago : + abs (clock (1) - last access time) > 2.0 . + +new open if somebody changed medium : + IF header.date <> write stamp + THEN directory state := invalid ; + access archive + FI . + +open archive : + directory state := invalid ; + check volume name ; + write stamp := header.date ; + was already write access := FALSE ; + read directory ; + make directory valid if no read errors occurred . + +read directory : + directory := empty thesaurus ; + rewind ; + get next header ; + WHILE header.type = file header REP + IF directory CONTAINS header.name + THEN rename (directory, header.name, dummy name) + FI ; + insert (directory, header.name, dir index) ; + header block (dir index) := end of volume block ; + header date (dir index) := header.date ; + get next header ; + PER . + +make directory valid if no read errors occurred : + IF directory state = invalid + THEN directory state := valid + FI . + +ENDPROC access archive ; + +PROC access file (TEXT CONST name) : + + file name := name ; + dir index := link (directory, file name) . + +ENDPROC access file ; + + +PROC check volume name : + + disable stop ; + archive size := archive blocks ; + read volume header ; + IF header.type <> start of volume + THEN simulate header (start of volume, "?????") + ELIF header.name <> archive name + THEN errorstop ("Archiv heisst """ + header.name + """") + FI . + +read volume header : + rewind ; + read header ; + IF is error AND error code = read error + THEN clear error ; + simulate header (start of volume, "?????") + FI . + +ENDPROC check volume name ; + +PROC get next header : + + disable stop ; + skip dataspace ; + IF NOT is error + THEN read header + FI ; + IF is error + THEN clear error ; + directory state := read only ; + search header + FI ; + end of volume block := block number - number of header blocks . + +search header : + INT VAR ds pages ; + search dataspace (ds pages) ; + IF ds pages < 0 + THEN simulate header (end of volume, "") + ELIF NOT is header space + THEN simulate header (file header, "????? " + text (block number)) + FI . + +is header space : + IF ds pages <> 1 + THEN FALSE + ELSE remember position ; + read header ; + IF read error occurred + THEN clear error; back to old position; FALSE + ELIF header format looks ok + THEN TRUE + ELSE back to old position ; FALSE + FI + FI . + +read error occurred : + is error CAND error code = read error . + +header format looks ok : + header.type = file header OR header.type = end of volume . + +remember position : + INT CONST old block nr := block number . + +back to old position : + seek (old block nr) . + +ENDPROC get next header ; + +PROC fetch (DATASPACE VAR ds, BOOL CONST error accept): + + enable stop ; + IF file name <> dummy name + THEN fetch from archive + ELSE error ("Name unzulaessig") + FI . + +fetch from archive : + IF file in directory + THEN position to file ; + read (ds, 30000, error accept) + ELIF directory state = read only + THEN error ("gibt es nicht (oder Lesefehler)") + ELSE error ("gibt es nicht") + FI . + +position to file : + seek (header block (dir index) + number of header blocks) . + +file in directory : dir index > 0 . + +ENDPROC fetch ; + +PROC erase : + + IF directory state = read only + THEN errorstop ("'save'/'erase' wegen Lesefehler verboten") + ELSE update write stamp if first write access ; + erase archive + FI . + +update write stamp if first write access : + IF NOT was already write access + THEN rewind ; + write stamp := text (clock (1), 13, 1) ; + write header (archive name, write stamp, start of volume) ; + was already write access := TRUE + FI . + +erase archive : + IF file in directory + THEN IF is last file of archive + THEN cut off all erased files + ELSE rename to dummy + FI + FI . + +file in directory : dir index > 0 . + +is last file of archive : dir index = highest entry (directory) . + +cut off all erased files : + directory state := invalid ; + REP + delete (directory, dir index) ; + dir index DECR 1 + UNTIL dir index = 0 COR name (directory, dir index) <> dummy name PER ; + behind last valid file ; + write end of volume ; + directory state := valid . + +behind last valid file : + seek (header block (dir index + 1)) ; + end of volume block := block number . + +rename to dummy : + directory state := invalid ; + to file header ; + read header ; + to file header ; + header.name := dummy name ; + header.date := dummy date ; + write (header space) ; + rename (directory, file name, dummy name) ; + header date (dir index) := dummy date ; + directory state := valid . + +to file header : + seek (header block (dir index)) . + +ENDPROC erase ; + +PROC save (DATASPACE VAR ds) : + + IF file name <> dummy name + THEN save to archive + ELSE error ("Name unzulaessig") + FI . + +save to archive : + IF file too large OR highest entry (directory) >= max files + THEN error ( "kann nicht geschrieben werden (Archiv voll)") + ELSE write new file + FI . + +file too large : + end of volume block + ds pages (ds) + 5 > archive size . + +write new file : + seek (end of volume block) ; + disable stop ; + write file (ds) ; + IF is error + THEN seek (end of volume block) + ELSE insert (directory, file name, dir index) ; + remember begin of header block ; + remember date + FI ; + write end of volume . + +remember begin of header block : + header block (dir index) := end of volume block . + +remember date : + header date (dir index) := date . + +ENDPROC save ; + +PROC write file (DATASPACE CONST ds) : + + enable stop ; + write header (file name, date, file header) ; + write (ds) + +ENDPROC write file ; + +PROC write end of volume : + + disable stop ; + end of volume block := block number ; + write header ("", "", end of volume) + +ENDPROC write end of volume ; + +PROC write header (TEXT CONST name, date, INT CONST header type) : + + forget (header space) ; + header space := nilspace ; + header := header space ; + + header.name := subtext (name,1,100) ; + header.date := date ; + header.type := header type ; + + write (header space) + +ENDPROC write header ; + +PROC read header : + + IF archive size > 0 + THEN forget (header space) ; + header space := nilspace ; + read (header space, 1, accept read errors) ; + header := header space + ELSE errorstop ("Lesen unmoeglich (Archiv)") + FI . + +ENDPROC read header ; + +PROC simulate header (INT CONST type, TEXT CONST name) : + + forget (header space) ; + header space := nilspace ; + header := header space ; + header.name := name ; + header.date := "??.??.??" ; + header.type := type ; + header.password := "" + +ENDPROC simulate header ; + +PROC look at volume header : + + rewind ; + archive size := archive blocks ; + forget (header space) ; + header space := nilspace ; + INT VAR return code ; + read block (header space, 1, 1, return code) ; + header := header space ; + disable stop ; + IF return code <> 0 OR + LENGTH header.name < 0 OR LENGTH header.name > 100 OR is error + THEN header.name := "" ; + clear error + FI + +ENDPROC look at volume header ; + +PROC list (DATASPACE VAR ds) : + + access archive ; + open list file ; + INT VAR file number := 0 ; + get (directory, file name, file number) ; + WHILE file number > 0 REP + generate list line ; + get (directory, file name, file number) + PER ; + IF directory state = read only + THEN putline (list file, "Lesefehler: Evtl. fehlen Eintraege") + FI ; + write list head . + +open list file : + forget (ds) ; + ds := nilspace ; + FILE VAR list file := sequential file (output, ds) ; + putline (list file, "") . + +generate list line : + write (list file, header date (file number)) ; + write (list file, text (file blocks DIV 2, 5)) ; + write (list file, " K ") ; + IF file name = dummy name + THEN write (list file, dummy name) + ELSE write (list file, quote) ; + write (list file, file name) ; + write (list file, quote) + FI ; + line (list file) . + +file blocks : + IF file number < highest entry (directory) + THEN header block (file number+1) - header block (file number) + ELSE end of volume block - header block (file number) + FI . + +write list head : (* wk 22.08.85 *) + headline (list file, archive name + + " (" + used + " K belegt von " + text (archive size DIV 2) + " K)") . + +used : text ((end of volume block + 3) DIV 2) . + +ENDPROC list ; + +PROC error (TEXT CONST error msg) : + + errorstop ("""" + file name + """ " + error msg) + +ENDPROC error ; + +ENDPACKET archive manager ; + diff --git a/system/multiuser/1.7.5/src/basic archive b/system/multiuser/1.7.5/src/basic archive new file mode 100644 index 0000000..8235607 --- /dev/null +++ b/system/multiuser/1.7.5/src/basic archive @@ -0,0 +1,401 @@ +(* ------------------- VERSION 11 06.03.86 ------------------- *) +PACKET basic archive DEFINES + + archive blocks , + block number , + check read , + format archive , + read block , + read , + rewind , + search dataspace , + seek , + size , + skip dataspace , + write block , + write : + +INT VAR blocknr := 0 , + rerun := 0 , + page := -1 , + bit word := 1 , + unreadable sequence length := 0 ; +INT CONST all ones :=-1 ; + + +DATASPACE VAR label ds ; + +LET write normal = 0 , + archive version = 1 , + first page stored = 2 , + dr size = 3 , + first bit word = 4 , +(* write deleted data mark = 64 , *) + inconsistent = 90 , + read error = 92 , + label size = 131 ; + +BOUND STRUCT (ALIGN dummy for page1, + (* Page 2 begins: *) + ROW label size INT lab) VAR label; + + +INT PROC block number : + block nr +ENDPROC block number ; + +PROC seek (INT CONST block) : + block nr := block +ENDPROC seek ; + +PROC rewind : + forget (label ds); + label ds := nilspace; + label := label ds; + block nr := 0; + rerun := session +END PROC rewind; + +PROC skip dataspace: + check rerun; + get label; + IF is error + THEN + ELIF olivetti + THEN block nr INCR label.lab (dr size+1) + ELSE block nr INCR label.lab (dr size) + FI +END PROC skip dataspace; + +PROC read (DATASPACE VAR ds): + read (ds, 30000, FALSE) +ENDPROC read ; + +PROC read (DATASPACE VAR ds, INT CONST max pages, BOOL CONST error accept) : + enable stop ; + check rerun; + get label; + init next page; + INT VAR i ; + FOR i FROM 1 UPTO max pages REP + next page; + IF no further page THEN LEAVE read FI; + check storage ; + check rerun ; + read block ; + block nr INCR 1; + PER . + +read block : + disable stop ; + get external block (ds, page, block nr) ; + ignore read error if no errors accepted ; + enable stop . + +ignore read error if no errors accepted : + IF is error CAND error code = read error CAND NOT error accept + THEN clear error + FI . + +check storage : + INT VAR size, used ; + storage (size, used) ; + IF used > size + THEN forget (ds) ; + ds := nilspace ; + errorstop ("Speicherengpass") ; + LEAVE read + FI . + +check rerun : + IF rerun <> session + THEN errorstop ("RERUN beim Archiv-Zugriff") ; + LEAVE read + FI . + +END PROC read; + +PROC check read : + + enable stop ; + get label ; + INT VAR pages, i; + IF olivetti + THEN pages := label.lab (dr size+1) + ELSE pages := label.lab (dr size) + FI ; + FOR i FROM 1 UPTO pages REP + get external block (label ds, 2, block nr) ; + block nr INCR 1 + PER . + +ENDPROC check read ; + +PROC write (DATASPACE CONST ds): + enable stop ; + check rerun; + INT VAR label block nr := block nr; + block nr INCR 1;init label; + INT VAR page := -1,i; + FOR i FROM 1 UPTO ds pages (ds) REP + check rerun ; + page := next ds page(ds,page); + put external block (ds, page, block nr) ; + reset archive bit; + label.lab(dr size) INCR 1; + block nr INCR 1 + PER; + put label. + + + init label: + label.lab(archive version) := 0 ; + label.lab(first page stored) := 0 ; + label.lab(dr size) := 0; + INT VAR j; + FOR j FROM first bit word UPTO label size REP + label.lab (j) := all ones + PER. + + put label: + put external block (label ds, 2, label block nr). + + reset archive bit: + reset bit (label.lab (page DIV 16+first bit word), page MOD 16). + +END PROC write; + +PROC get label: + + enable stop ; + get external block (label ds, 2, block nr) ; + block nr INCR 1; + check label. + +check label: + IF may be z80 format label OR may be old olivetti format label + THEN + ELSE errorstop (inconsistent, "Archiv inkonsistent") + FI. + +may be z80 format label : + z80 archive AND label.lab(dr size) > 0 . + +may be old olivetti format label : + olivetti AND label.lab(first page stored)=0 AND label.lab(dr size+1) > 0 . + +END PROC get label; + +PROC next page: + IF z80 archive + THEN + WHILE labelbits = all ones REP + bitword INCR 1; + IF bitword >= label size THEN + no further page := true; LEAVE next page FI + PER; + INT VAR p := lowest reset (labelbits); + set bit (labelbits, p); + page := 16*(bitword-first bit word)+p + ELSE + WHILE oli bits = 0 REP + bitword INCR 1; + IF bitword >= labelsize-64 THEN + no further page := true; LEAVE next page FI + PER; + p := lowest set (oli bits); + reset bit (olibits, p); + page := 16*(bitword-firstbitword)+p; + FI. + + label bits : label.lab (bitword). + oli bits : label.lab (bitword+1). + +END PROC next page; +. +olivetti : label.lab (archive version) = -1. + +z80 archive : label.lab (archive version) = 0. + +init next page: + BOOL VAR no further page := false; + bitword := first bit word. + +check rerun : + IF rerun <> session + THEN errorstop ("RERUN beim Archiv-Zugriff") + FI . + +PROC get external block (DATASPACE VAR ds, INT CONST page, + INT CONST block nr): + + INT VAR error ; + read block (ds, page, block nr, error) ; + SELECT error OF + CASE 0: read succeeded + CASE 1: error stop ("Lesen unmoeglich (Archiv)") + CASE 2: read failed + CASE 3: error stop ("Archiv-Ueberlauf") + OTHERWISE error stop ("??? (Archiv)") + END SELECT . + +read succeeded : + unreadable sequence length := 0 . + +read failed : + unreadable sequence length INCR 1 ; + IF unreadable sequence length >= 30 + THEN errorstop ("30 unlesbare Bloecke hintereinander") + ELSE error stop (read error, "Lesefehler (Archiv)") + FI . + +END PROC get external block; + +PROC put external block (DATASPACE CONST ds, INT CONST page, + INT CONST block nr): + INT VAR error; + write block (ds, page, write normal, block nr, error) ; + SELECT error OF + CASE 0: + CASE 1: error stop ("Schreiben unmoeglich (Archiv)") + CASE 2: error stop ("Schreibfehler (Archiv)") + CASE 3: error stop ("Archiv-Ueberlauf") + OTHERWISE error stop ("??? (Archiv)") + END SELECT . + +END PROC put external block; + +PROC read block (DATASPACE VAR ds, + INT CONST ds page no, + INT CONST block no, + INT VAR return code) : + read block; + retry if read error. + +read block: + block in (ds, ds page no, 0, block no, return code). + +retry if read error: + INT VAR retry; + FOR retry FROM 1 UPTO 10 WHILE return code = 2 REP + reset to block 0 if fifth try; + read block + PER. + +reset to block 0 if fifth try: + IF retry = 5 + THEN block in (ds, ds page no, 0, 0, return code) + FI. + +END PROC read block; + +PROC write block (DATASPACE CONST ds, + INT CONST ds page no, + INT CONST mode, + INT CONST block no, + INT VAR return code): + write block; + retry if write error. + +write block: + block out (ds, ds page no, mode * 256, block no, return code) . + +retry if write error: + INT VAR retry; + FOR retry FROM 1 UPTO 10 WHILE return code = 2 REP + reset to block 0 if fifth try; + write block + PER. + +reset to block 0 if fifth try: + IF retry = 5 + THEN disable stop; + DATASPACE VAR dummy ds := nilspace; + block in (dummy ds, 2, 0, 0, return code); + forget (dummy ds); + enable stop + FI. + +END PROC write block; + +INT PROC size (INT CONST key) : + + INT VAR return code ; + control (5, key, 0, return code) ; + return code . + +ENDPROC size ; + +INT PROC archive blocks : + size (0) +ENDPROC archive blocks ; + +PROC search dataspace (INT VAR ds pages) : + + disable stop ; + ds pages := -1 ; + INT CONST last block := archive blocks ; + + WHILE block nr < last block REP + IF block is dataspace label + THEN ds pages := pages counted ; + LEAVE search dataspace + FI ; + block nr INCR 1 + UNTIL is error PER . + +block is dataspace label : + look at label block ; + IF is error + THEN IF error code = read error OR error code = inconsistent + THEN clear error + FI ; + FALSE + ELSE count pages ; + pages counted = number of pages as label says + FI . + +look at label block : + INT CONST + old block nr := block nr ; + get label ; + block nr := old block nr. + +count pages : + INT VAR + pages counted := 0 ; + init next page ; + next page ; + WHILE NOT no further page REP + pages counted INCR 1 ; + next page + PER . + +number of pages as label says : label.lab (dr size) . + +ENDPROC search dataspace ; + +PROC format archive (INT CONST format code) : + + IF format is possible + THEN format + ELSE errorstop ("'format' ist hier nicht implementiert") + FI . + +format is possible : + INT VAR return code ; + control (1,0,0, return code) ; + bit (return code, 4) . + +format : + control (7, format code, 0, return code) ; + IF return code = 1 + THEN errorstop ("Formatieren unmoeglich") + ELIF return code > 1 + THEN errorstop ("Schreibfehler (Archiv)") + FI . + +ENDPROC format archive ; + +END PACKET basic archive; + diff --git a/system/multiuser/1.7.5/src/canal b/system/multiuser/1.7.5/src/canal new file mode 100644 index 0000000..ad0baa8 --- /dev/null +++ b/system/multiuser/1.7.5/src/canal @@ -0,0 +1,227 @@ +(* ------------------- VERSION 6 20.05.86 ------------------- *) +PACKET canal DEFINES (* Autor: J.Liedtke *) + + analyze supervisor command : + + + +LET command list = + +"begin:1.12end:3.0break:4.0continue:5.01halt:7.0 +taskinfo:8.0storageinfo:9.0help:10.0 ", + + supervisor command text = + +""6""20""1"ESC ? --> help +"6""21""1"ESC b --> begin ("""") +"6""22""1"ESC c --> continue ("""") +"6""23""1"ESC q --> break +"6""21""50"ESC h --> halt +"6""22""50"ESC s --> storage info +"6""23""50"ESC t --> task info +"6""8""6"gib supervisor kommando :" , + + text type = 4 , + ack = 0 , + error nak = 2 , + begin code = 4 , + end code = 5 , + break code = 6 , + halt code = 8 , + password code = 9 , + continue code = 100 , + + home = ""1"" ; + + +TASK VAR sv ; + +DATASPACE VAR ds ; + +BOUND STRUCT (TEXT tname, tpass, TASK task, PROCA start proc) VAR sv msg ; +BOUND TEXT VAR error msg ; + +INT VAR command index , number of params , reply ; +TEXT VAR param 1, param 2 , task password ; + + + lernsequenz auf taste legen ("b", ""1""8""1""12"begin ("""")"8""8""11"") ; + lernsequenz auf taste legen ("c", ""1""8""1""12"continue ("""")"8""8""11"") ; + lernsequenz auf taste legen ("q", ""1""8""1""12"break"13"") ; + lernsequenz auf taste legen ("h", ""1""8""1""12"halt"13"") ; + lernsequenz auf taste legen ("s", ""1""8""1""12"storage info"13"") ; + lernsequenz auf taste legen ("t", ""1""8""1""12"task info"13"") ; + lernsequenz auf taste legen ("?", ""1""8""1""12"help"13"") ; + +PROC analyze supervisor command : + + disable stop ; + sv := supervisor ; + ds := nilspace ; + REP + command dialogue (TRUE) ; + command pre ; + cry if not enough storage ; + get command (supervisor command text) ; + analyze command (command list, text type, + command index, number of params, + param1, param2) ; + execute command ; + PER . + +command pre : + IF NOT is error + THEN wait for terminal; eumel must advertise + ELSE forget (ds) ; ds := nilspace + FI . + +wait for terminal : + out (home) . + +cry if not enough storage : + INT VAR size, used ; + storage (size, used) ; + IF used > size + THEN out (""7"Speicher Engpass!"13""10"") ; + FI . + +ENDPROC analyze supervisor command ; + +PROC execute command : + + enable stop ; + SELECT command index OF + CASE 1 : begin ("PUBLIC") + CASE 2 : begin (param2) + CASE 3 : end via canal + CASE 4 : break + CASE 5 : quiet + CASE 6 : continue (param1) + CASE 7 : halt + CASE 8 : task info (0); eumel must advertise; quiet + CASE 9 : storage info; quiet + CASE 10 : help; eumel must advertise; quiet + OTHERWISE analyze command error + ENDSELECT ; + IF reply = error nak + THEN error msg := ds ; + errorstop (CONCR (error msg)) + FI . + +end via canal : + IF yes ("Task """ + name (task (channel (myself))) + """ loeschen") + THEN eumel must advertise ; + call (sv, end code, ds, reply) + FI . + +break : + eumel must advertise ; + call (sv, break code, ds, reply) . + +halt : + call (sv, halt code, ds, reply) . + +quiet : + call (sv, ack, ds, reply) . + +analyze command error : + command error ; + IF command index = 0 + THEN errorstop ("kein supervisor kommando") + ELIF number of params = 0 + THEN errorstop ("Taskname fehlt") + ELSE errorstop ("Parameter ueberfluessig") + FI . + +ENDPROC execute command ; + +PROC begin (TEXT CONST father name) : + + IF param1 = "-" + THEN errorstop ("Name ungueltig") + FI ; + sv msg := ds ; + CONCR (sv msg).tname := param1 ; + CONCR (sv msg).tpass := "" ; + call (task (father name), begin code, ds, reply) ; + IF reply = password code + THEN get password ; + sv msg := ds ; + CONCR (sv msg).tpass := task password ; + call (task (father name), begin code, ds, reply) + FI ; + IF reply = ack + THEN continue (param1) + FI . + +get password : + put (" Passwort:") ; + get secret line (task password) . + +ENDPROC begin ; + +PROC continue (TEXT CONST task name) : + + sv msg := ds ; + CONCR (sv msg).tname := task name ; + CONCR (sv msg).tpass := "" ; + call (sv, continue code + channel, ds, reply) ; + IF reply = password code + THEN get password ; + sv msg := ds ; + CONCR (sv msg).tpass := task password ; + call (sv, continue code + channel, ds, reply) + FI . + +get password : + put (" Passwort:") ; + get secret line (task password) . + +ENDPROC continue ; + +PROC help: + + LET page = ""1""4"" + ,bell = ""7"" + ,cr = ""13"" + ,end mark = ""14"" + ,begin mark = ""15"" + ,esc = ""27"" + ; + + REP + out (page) ; + show page ; + UNTIL is quit command PER . + + show page : + putline(begin mark + (31 * ".") + " supervisor help " + (31 * ".") + end mark) ; + putline("Hier finden Sie einige Kommandos, die Ihnen den Einstieg ins System er -") ; + putline("leichtern sollen:") ; + out(""6""05""07"1. Informations-Kommandos") ; + out(""6""07""11"storage info physisch belegten Hintergrundplatz melden") ; + out(""6""08""11"task info Taskbaum zeigen") ; + out(""6""14""07"2. Verbindung zum Supervisor") ; + out(""6""16""11"break Task vom Terminal abkoppeln") ; + out(""6""17""11"begin(""task"") neue Task `task` einrichten") ; + out(""6""18""11"continue(""task"") Task `task` an ein Terminal ankoppeln") ; + out(""6""21""01"Näheres: Benutzerhandbuch, Teil 2, Kap. 2") ; + out(""6""23""05"Wenn Sie den Hilfe-Modus beenden wollen, tippen Sie die Taste `q`. ") ; + out(cr) . + + is quit command : + TEXT VAR char ; + get char (char) ; + IF char = esc + THEN get char (char) + FI; + IF char = "q" COR char = "Q" + THEN true + ELSE out (bell); + FALSE + FI. + +END PROC help ; + +ENDPACKET canal ; + diff --git a/system/multiuser/1.7.5/src/configuration manager b/system/multiuser/1.7.5/src/configuration manager new file mode 100644 index 0000000..5eaea52 --- /dev/null +++ b/system/multiuser/1.7.5/src/configuration manager @@ -0,0 +1,553 @@ +(* ------------------- VERSION 11 02.06.86 ------------------- *) +PACKET configuration manager DEFINES + + configurate , + exec configuration , + setup , + define collector , + configuration manager : + + +LET baudrates = ""1"50"2"75"3"110"4"134.5"5"150"6"300"7"600 +"8"1200"9"1800"10"2400"11"3600"12"4800"13"7200 +"14"9600"15"19200"16"38400"17"", + parities = ""0"no"1"odd"2"even"3"" , + bits per char = ""0"1"1"2"2"3"3"4"4"5"5"6"6"7"7"8"8"" , + stopbits = ""0"1"1"1.5"2"2"3"" , + flow modes = ""0"ohne Protokoll"1"XON/XOFF"2"RTS/CTS +"3""4""5"XON/XOFF - ausgabeseitig"6"RTS/CTS - ausgabeseitig"7""8" +"9"XON/XOFF - eingabeseitig"10"RTS/CTS - eingabeseitig"11"" , + + ok = "j" , + esc = ""27"" , + cr = ""13"" , + right = ""2"" , + + psi = "psi" , + transparent = "transparent" , + + std rate = 14 , + std bits = 22 , + std flow = 0 , + std inbuffer size = 16 , + + device table = 32000 , + + max edit terminal = 15 , + configuration channel = 32 , + + fetch code = 11 , + save code = 12 , + erase code = 14 , + system start interrupt = 100 , + + CONF = STRUCT (TEXT dev type, + INT baud, bits par stop, flow control, inbuffer size) ; + + +BOUND STRUCT (TEXT name, write pass, read pass) VAR msg ; + +BOUND ROW max edit terminal CONF VAR conf ; + +INT VAR channel no ; + +TEXT VAR prelude , last feature , answer , collector := "" ; + + + +BOOL PROC shard permits (INT CONST code, key) : + + INT VAR reply ; + IF key > -128 + THEN control (code, channel no, key, reply) + ELSE control (code, channel no, -maxint-1, reply) + FI ; + reply = 0 . + +ENDPROC shard permits ; + +PROC ask user (TEXT CONST feature, question) : + + last feature := feature ; + put question ; + skip pretyped chars ; + get valid answer . + +put question : + clear line ; + out (prelude) ; + out (feature) ; + out (question) ; + out (" (j/n) ") . + +clear line : + out (cr) ; + 79 TIMESOUT " " ; + out (cr) . + +skip pretyped chars : + REP UNTIL incharety = "" PER . + +get valid answer : + REP + inchar (answer) + UNTIL pos ("jJyYnN"27"", answer) > 0 PER ; + IF answer > ""31"" + THEN out (answer) + FI ; + out (cr) ; + normalize answer . + +normalize answer : + IF pos ("jJyY", answer) > 0 + THEN answer := ok + FI . + +ENDPROC ask user ; + +BOOL PROC yes (TEXT CONST question) : + + ask user ("", question) ; + answer = ok + +ENDPROC yes ; + +PROC chose key (INT VAR old key, INT CONST max key, TEXT CONST key string, + key entity, BOOL PROC (INT CONST) shard permits): + + IF shard permits at least one standard key + THEN try all keys + FI . + +shard permits at least one standard key : + INT VAR key ; + FOR key FROM 0 UPTO max key REP + IF shard permits (key) + THEN LEAVE shard permits at least one standard key WITH TRUE + FI + PER ; + FALSE . + +try all keys : + key := old key ; + REP + examine this key ; + next key + PER . + +examine this key : + IF shard permits (key) CAND key value <> "" + THEN ask user (key value, key entity) ; + IF answer = ok + THEN chose this key + ELIF answer = esc + THEN key := -129 + FI + FI . + +key value : + IF key >= 0 + THEN subtext (key string, key pos + 1, next key pos - 1) + ELSE text (key) + FI . + +key pos : pos (key string, code (key)) . +next key pos : pos (key string, code (key+1)) . + +chose this key : + remember calibration ; + old key := key ; + LEAVE chose key . + +next key : + IF key < max key + THEN key INCR 1 + ELSE key := 0 + FI . + +remember calibration : + prelude CAT last feature ; + prelude CAT ", " . + +ENDPROC chose key ; + +BOOL PROC rate ok (INT CONST key) : + + shard permits (8, key) + +ENDPROC rate ok ; + +BOOL PROC bits ok (INT CONST key) : + + IF key < 0 + THEN shard permits (9, key) + ELSE some standard combination ok + FI . + +some standard combination ok : + INT VAR combined := key ; + REP + IF shard permits (9, combined) + THEN LEAVE bits ok WITH TRUE + FI ; + combined INCR 8 + UNTIL combined > 127 PER ; + FALSE + +ENDPROC bits ok ; + +BOOL PROC parity ok (INT CONST key) : + + INT VAR combined := 8 * key + data bits ; + key >= 0 AND (shard permits (9, combined) OR + shard permits (9, combined + 32) OR + shard permits (9, combined + 64) ) + +ENDPROC parity ok ; + +BOOL PROC stopbits ok (INT CONST key) : + + key >= 0 AND shard permits (9, 32 * key + 8 * parity + data bits) + +ENDPROC stopbits ok ; + +BOOL PROC flow mode ok (INT CONST key) : + + shard permits (6, key) + +ENDPROC flow mode ok ; + + + +INT VAR data bits , + parity , + stop ; + +INT VAR old session := 0 ; + + +TEXT VAR table name, dummy ; + + +PROC configurate : + + new configuration ; + access configuration table ; + show all device types ; + channel no := 1 ; + REP + IF channel hardware exists + THEN try this channel ; + setup this channel + FI ; + channel no INCR 1 + UNTIL channel no > 15 PER ; + prelude := "" ; + IF yes ("Koennen unbenutzte Geraetetypen geloescht werden") + THEN forget unused device tables + FI . + +access configuration table : + IF exists ("configuration") + THEN conf := old ("configuration") + ELSE conf := new ("configuration") ; + initialize configuration + FI . + +initialize configuration : + FOR channel no FROM 1 UPTO max edit terminal REP + conf (channel no) := + CONF:(transparent, std rate, std bits, std flow, std inbuffer size) + PER ; + conf (1).dev type := psi . + +show all device types : + show prelude ; + begin list ; + get list entry (table name, dummy) ; + WHILE table name <> "" REP + IF dataspace is device table + THEN show table name + FI ; + get list entry (table name, dummy) + PER ; + line (2) . + +show prelude : + line (30) ; + outtext (psi, 1, 20) ; + outtext (transparent, 1, 20) . + +dataspace is device table : + type (old (table name)) = device table . + +show table name : + outtext (table name, 1, 20) . + +try this channel : + prelude := "Kanal " ; + ask user ("", text (channel no)) ; + IF answer = ok + THEN prelude CAT text (channel no) + ": " ; + get configuration from user (conf (channel no)) ; + line + FI . + +channel hardware exists : + INT VAR + operators channel := channel ; + INT VAR channel type ; + disable stop ; + continue (channel no) ; + IF is error + THEN IF error message = "kein Kanal" + THEN channel type := 0 + ELSE channel type := inout mask + FI + ELSE get channel type from shard + FI ; + clear error ; + disable stop ; + continue operators channel ; + (channel type AND inout mask) <> 0 . + +get channel type from shard : + control (1, 0, 0, channel type) . + +inout mask : 3 . + +forget unused device tables : + begin list ; + get list entry (table name, dummy) ; + WHILE table name <> "" REP + IF type (old (table name)) = device table + THEN forget if unused + FI ; + get list entry (table name, dummy) + PER . + +forget if unused : + FOR channel no FROM 1 UPTO max edit terminal REP + IF conf (channel no).dev type = table name + THEN LEAVE forget if unused + FI + PER ; + forget (table name, quiet) . + +setup this channel : + operators channel := channel ; + disable stop ; + continue (configuration channel) ; + set up channel (channel no, conf (channel no)) ; + continue operators channel . + +continue operators channel : + continue (operators channel) ; + IF is error + THEN clear error ; + break (quiet) ; + LEAVE configurate + FI ; + enable stop . + +ENDPROC configurate ; + +PROC get configuration from user (CONF VAR conf) : + + get device type ; + get baud rate ; + get bits and parity and stopbits ; + get protocol ; + get buffer size . + + +get device type : + begin list ; + table name := conf.dev type ; + IF NOT is valid device type + THEN next device type + FI ; + REP + IF NOT (table name = transparent AND channel no = 1) + THEN ask user ("", table name) ; + IF answer = ok COR was esc followed by type table name + THEN IF is valid device type + THEN remember device type ; + LEAVE get device type + ELSE out (""7" unbekannter Typ"); pause (20) + FI + FI + FI ; + next device type + PER . + +was esc followed by type table name : + IF answer = esc + THEN 9 TIMESOUT right ; + put ("Typ:") ; + editget (table name) ; + TRUE + ELSE FALSE + FI . + +is valid device type : + table name = psi OR table name = transparent OR + (exists (table name) CAND type (old (table name)) = device table) . + +remember device type : + prelude CAT table name ; + conf.dev type := table name ; + prelude CAT ", " . + +next device type : + IF table name = psi + THEN table name := transparent + ELSE IF table name = transparent + THEN begin list + FI ; + search next device type space + FI . + +search next device type space : + REP + get list entry (table name, dummy) + UNTIL table name = "" COR type (old (table name)) = device table PER; + IF table name = "" + THEN table name := psi + FI . + +get baud rate : + chose key (conf.baud, 16, baudrates, " Baud", PROC rate ok) . + +get bits and parity and stopbits : + data bits := conf.bits par stop MOD 8 ; + parity := (conf.bits par stop DIV 8) MOD 4 ; + stop := (conf.bits par stop DIV 32) MOD 4 ; + chose key (data bits, 7, bits per char, " Bits", PROC bits ok) ; + IF data bits >= 0 + THEN chose key (parity, 2, parities, " parity", PROC parity ok) ; + chose key (stop, 2, stopbits, " Stopbits", PROC stopbits ok); + conf.bits par stop := data bits + 8 * parity + 32 * stop + ELSE conf.bits par stop := data bits + FI . + +get protocol : + chose key (conf.flow control, 10, flow modes, + "", PROC flow mode ok) . + +get buffer size : + IF dev type is transparent + THEN chose buffer size + ELSE conf.inbuffer size := std inbuffer size + FI . + +dev type is transparent : + conf.dev type = "transparent" . + +chose buffer size : + REP + IF conf.inbuffer size = 16 CAND yes ("normaler Puffer") + THEN LEAVE chose buffer size + FI ; + conf.inbuffer size := 512 ; + IF yes ("grosser Puffer") + THEN LEAVE chose buffer size + FI ; + conf.inbuffer size := 16 + PER . + +ENDPROC get configuration from user ; + +PROC exec configuration : + + setup + +ENDPROC exec configuration ; + +PROC setup : + + conf := old ("configuration") ; + continue (configuration channel) ; + FOR channel no FROM 1 UPTO max edit terminal REP + set up channel (channel no, conf (channel no)) + PER ; + set up collector task ; + break but do not forget error message if any . + +set up collector task : + IF collector <> "" CAND collector <> "-" CAND exists task (collector) + THEN define collector (task (collector)) + FI . + +break but do not forget error message if any : + IF is error + THEN dummy := error message ; + clear error ; + break (quiet) ; + errorstop (dummy) + ELSE break (quiet) + FI . + +ENDPROC set up ; + +PROC set up channel (INT CONST channel no, CONF CONST conf) : + + link (channel no, conf.dev type) ; + baudrate (channel no, conf.baud) ; + bits (channel no, conf.bits par stop) ; + flow (channel no, conf.flow control) ; + input buffer size (channel no, conf.inbuffer size) . + +ENDPROC setup channel ; + +PROC configuration manager (DATASPACE VAR ds, INT CONST order, phase, + TASK CONST order task) : + + enable stop ; + IF order <> system start interrupt + THEN font manager + FI ; + IF session <> old session + THEN disable stop ; + set up ; + clear error ; + old session := session ; + set autonom + FI . + + font manager : + IF (order <> save code AND order <> erase code ) OR order task < supervisor + THEN delete password if there is one; + free manager (ds, order, phase, order task) + ELSE errorstop ("kein Zugriffsrecht auf Task """ + name (myself) + """") + FI . + + delete password if there is one : + IF order >= fetch code AND order <= erase code AND phase = 1 + THEN msg := ds; + msg. write pass := ""; + msg. read pass := ""; + FI . + +ENDPROC configuration manager ; + +PROC configuration manager : + + configurate ; + break ; + global manager + (PROC (DATASPACE VAR,INT CONST,INT CONST,TASK CONST) configuration manager) + +ENDPROC configuration manager ; + +PROC define collector (TEXT CONST task table name) : + + collector := task table name ; + IF exists task (collector) + THEN define collector (task (collector)) + FI + +ENDPROC define collector ; + +ENDPACKET configuration manager ; + diff --git a/system/multiuser/1.7.5/src/eumel printer b/system/multiuser/1.7.5/src/eumel printer new file mode 100644 index 0000000..94858b5 --- /dev/null +++ b/system/multiuser/1.7.5/src/eumel printer @@ -0,0 +1,3066 @@ +PACKET eumel printer (* Autor : Rudolf Ruland *) + (* Version : 4 *) + (* Stand : 05.05.86 *) + DEFINES print, + with elan listings, + is elan source, + bottom label for elan listings, + x pos, + y pos, + y offset index, + line type, + material, + pages printed : + + +LET std x wanted = 2.54, + std y wanted = 2.35, + std limit = 16.0, + std pagelength = 25.0, + std linefeed faktor = 1.0, + std material = ""; + +LET blank = " ", + blank code 1 = 33, + geschuetztes blank = ""223"", + keine blankanalyse = 0, + einfach blank = 1, + doppel blank = 2, + + anweisungszeichen = "#", + anweisungszeichen code 1 = 36, + geschuetztes anweisungszeichen = ""222"", + druckerkommando zeichen = "/", + quote = """", + + erweiterungs ausgang = 32767, + blank ausgang = 32766, + anweisungs ausgang = 32765, + d code ausgang = 32764, + max breite = 32763, + + punkt = ".", + + leer = 0, + + kommando token = 0, + text token = 1, + + underline linetype = 1, + underline bit = 0, + bold bit = 1, + italics bit = 2, + modifikations liste = "ubir", + anzahl modifikationen = 4, + + document = 1, + page = 2, + + write text = 1, + write cmd = 2, + carriage return = 3, + move = 4, + draw = 5, + on = 6, + off = 7, + type = 8, + + tag type = 1, + bold type = 2, + number type = 3, + text type = 4, + delimiter type = 6, + eof type = 7; + + +INT CONST null ausgang := -32767-1; + +ROW anzahl modifikationen INT CONST modifikations werte := + ROW anzahl modifikationen INT : (1, 2, 4, 8); + +TEXT CONST anweisungsliste := + "type:1.1on:2.1off:3.1center:4.0right:5.0u:6.0d:7.0e:8.0b:9.0" + + "fillchar:10.1mark:11.2markend:12.0" + + "ub:13.0ue:14.0fb:15.0fe:16.0" + + "block:20.0columns:21.2columnsend:22.0free:23.1limit:24.1linefeed:25.1" + + "material:26.1page:27.01pagelength:29.1start:30.2" + + "table:31.0tableend:32.0clearpos:33.01" + + "lpos:35.1rpos:36.1cpos:37.1dpos:38.2bpos:39.2" + + "textbegin:40.02textend:42.0" + + "indentation:43.1ytab:44.1"; + +LET a type = 1, a block = 20, + a on = 2, a columns = 21, + a off = 3, a columnsend = 22, + a center = 4, a free = 23, + a right = 5, a limit = 24, + a up = 6, a linefeed = 25, + a down = 7, a material = 26, + a end up or down = 8, a page0 = 27, + a bsp = 9, a page1 = 28, + a fill char = 10, a pagelength = 29, + a mark = 11, a start = 30, + a markend = 12, a table = 31, + a ub = 13, a tableend = 32, + a ue = 14, a clearpos0 = 33, + a fb = 15, a clearpos1 = 34, + a fe = 16, a lpos = 35, + a rpos = 36, + a cpos = 37, + a dpos = 38, + a bpos = 39, + a textbegin0 = 40, + a textbegin2 = 41, + a textend = 42, + a indentation = 43, + a y tab = 44; + +INT VAR a xpos, a breite, a font, a modifikationen, + a modifikationen fuer x move, a ypos, aktuelle ypos, + letzter font, letzte modifikationen, + d ypos, d xpos, d font, d modifikationen, + + zeilenpos, alte zeilenpos, zeilen laenge, anzahl zeichen, ausgang, + anzahl einrueck blanks, blankbreite, + einrueckbreite, aktuelle einrueckbreite, alte einrueckbreite, + font durchschuss, fonthoehe, font tiefe, + groesste fonthoehe, aktuelle zeilenhoehe, letzte zeilenhoehe, + blankmodus, alter blankmodus, + token zeiger, erstes token der zeile, + + erstes tab token, tab anfang, anzahl blanks, + d code 1, d pitch, fuell zeichen breite, erstes fuell token, + letztes fuell token, + + x size, y size, x wanted, y wanted, x start, y start, + pagelength, limit, indentation, + left margin, top margin, seitenlaenge, + papierlaenge, papierbreite, + luecke, anzahl spalten, aktuelle spalte, + + verschiebung, rest, neue modifikationen, modifikations modus, pass, + + int param, anweisungs index, anzahl params, index, + + gedruckte seiten; + +BOOL VAR zeile ist absatzzeile, letzte zeile war absatzzeile, + zeile muss geblockt werden, rechts, a block token, offsets, + tabellen modus, block modus, center modus, right modus, + seite ist offen, vor erster seite; + +REAL VAR linefeed faktor, real param; + +TEXT VAR zeile, anweisung, par1, par2, material wert, replacements, + fuell zeichen, d string, font offsets; + +ROW 256 INT VAR zeichenbreiten, replacement tabelle, zeichen zaehler; + +INITFLAG VAR in dieser task := FALSE; + +. zeile ist zu ende : zeilenpos > zeilen laenge + +. zeilen breite : a xpos - left margin + +. neue zeilenhoehe : int (linefeed faktor * real (fonthoehe) + 0.5) + +. naechstes zeichen ist blank : pos (zeile, blank, zeilenpos + 1, zeilenpos + 1) <> 0 + +. naechstes nicht blankes zeichen : pos (zeile, ""33"", ""255"", zeilenpos) + +. in letzter spalte : aktuelle spalte >= anzahl spalten + +. anfangs blankmodus : + INT VAR dummy; + IF center modus OR right modus + THEN dummy + ELIF index zaehler = 0 + THEN blankmodus + ELSE alter blankmodus + FI + +. initialisiere tab variablen : + erstes tab token := token index f + 1; + tab anfang := zeilen breite; + anzahl blanks := 0; +.; + +(******************************************************************) + +LET zeilen nr laenge = 4, + teil einrueckung = 5, + + headline pre = "Zeile **** E L A N EUMEL 1.7.5 **** ", + headline post = " **** "; + +INT VAR zeilen nr, rest auf seite, + max zeichen zeile, max zeichen fuss, layout laenge, layout laenge name, + symbol type, naechster symbol type; + +BOOL VAR vor erstem packet, innerhalb der define liste; + +TEXT VAR bottom label, dateiname, layout blanks, refinement layout zeile; + + +. symbol : fuell zeichen +. naechstes symbol : d string +. elan text : d token. text +.; + +(******************************************************************) +(*** tokenspeicher ***) + +LET max token = 3000, + max ypos = 1000, + + TOKEN = STRUCT (TEXT text, + INT xpos, breite, font, modifikationen, + modifikationen fuer x move, + offset index, naechster token index, + BOOL block token ), + + YPOS = STRUCT (INT ypos, vorheriger ypos index, naechster ypos index, + erster token index, letzter token index ), + + TOKENLISTE = STRUCT (ROW max token TOKEN token liste, + ROW max ypos YPOS ypos liste ); + +DATASPACE VAR ds; + +BOUND TOKENLISTE VAR tokenspeicher; + +TOKEN VAR d token, offset token; + +INT VAR erster ypos index a, letzter ypos index a, + erster ypos index d, letzter ypos index d, + ypos index, ypos index f, ypos index a, ypos index d, + token index, token index f; + +. t : tokenspeicher. token liste (token index) +. tf : tokenspeicher. token liste (token index f) + +. y : tokenspeicher. ypos liste (ypos index) +. yf : tokenspeicher. ypos liste (ypos index f) +. ya : tokenspeicher. ypos liste (ypos index a) +. yd : tokenspeicher. ypos liste (ypos index d) + +. loesche druckspeicher : + erster ypos index d := 0; + ypos index f := 0; + token index f := 0; + +. druckspeicher ist nicht leer : + erster ypos index d <> 0 + +. loesche analysespeicher : + erster ypos index a := 0; + +. analysespeicher ist nicht leer : + erster ypos index a <> 0 +.; + +(******************************************************************) +(*** anweisungsspeicher ***) + +INT VAR anweisungszaehler; +TEXT VAR anweisungs indizes, params1 zeiger, params2 zeiger; +THESAURUS VAR params1, params2; + +PROC loesche anweisungsspeicher : + + anweisungs zaehler := 0; + anweisungs indizes := ""; + params1 zeiger := ""; + params2 zeiger := ""; + params1 := empty thesaurus; + params2 := empty thesaurus; + +END PROC loesche anweisungsspeicher; + +(******************************************************************) +(*** indexspeicher ***) + +INT VAR index zaehler; +TEXT VAR grosse fonts, verschiebungen; + +PROC loesche indexspeicher : + + index zaehler := 0; + grosse fonts := ""; + verschiebungen := ""; + +END PROC loesche indexspeicher; + + +(******************************************************************) +(*** tabellenspeicher ***) + +LET max tabs = 30, + TABELLENEINTRAG = STRUCT (INT tab typ, tab position, tab param); + +TEXT VAR tab liste, fill char; +THESAURUS VAR d strings; +ROW max tabs TABELLENEINTRAG VAR tabspeicher; + +INT VAR tab index; + +. tab typ : tab speicher (tab liste ISUB tab index). tab typ +. tab position : tab speicher (tab liste ISUB tab index). tab position +. tab param : tab speicher (tab liste ISUB tab index). tab param +. anzahl tabs : LENGTH tab liste DIV 2 +.; + +PROC loesche tabellenspeicher : + + fill char := " "; + tabliste := ""; + d strings := empty thesaurus; + FOR tab index FROM 1 UPTO max tabs + REP tab speicher (tab index). tab typ := leer PER; + +END PROC loesche tabellenspeicher; + +(******************************************************************) +(*** markierungsspeicher ***) + +INT VAR mark index l, mark index r, alter mark index l, alter mark index r; + +ROW 4 TOKEN VAR mark token; + +. markierung links : mark index l > 0 +. markierung rechts : mark index r > 0 +.; + +PROC loesche markierung : + + mark index l := 0; + mark index r := 0; + +END PROC loesche markierung; + + +PROC loesche alte markierung : + + alter mark index l := 0; + alter mark index r := 0; + +END PROC loesche alte markierung; + + +PROC initialisiere markierung : + + FOR mark index l FROM 1 UPTO 4 + REP mark token (mark index l). modifikationen fuer x move := 0; + mark token (mark index l). offset index := text token; + mark token (mark index l). block token := FALSE; + mark token (mark index l). naechster token index := 0; + PER; + +END PROC initialisiere markierung; + +(******************************************************************) +(*** durchschuss ***) + +INT VAR durchschuss 1, durchschuss 2, anzahl durchschuss 1, + anzahl durchschuss, zeilen zaehler; + +BOOL VAR wechsel := TRUE; + +INT PROC durchschuss : + + zeilen zaehler INCR 1; + IF zeilen zaehler <= anzahl durchschuss 1 + THEN durchschuss 1 + ELIF zeilen zaehler <= anzahl durchschuss + THEN durchschuss 2 + ELSE 0 + FI + +END PROC durchschuss; + + +PROC neuer durchschuss (INT CONST anzahl, rest) : + + zeilen zaehler := 0; + anzahl durchschuss := anzahl; + IF anzahl > 0 + THEN IF wechsel + THEN durchschuss 1 := rest DIV anzahl durchschuss; + durchschuss 2 := durchschuss 1 + sign (rest); + anzahl durchschuss 1 := anzahl durchschuss - + abs (rest) MOD anzahl durchschuss; + wechsel := FALSE; + ELSE durchschuss 2 := rest DIV anzahl durchschuss; + durchschuss 1 := durchschuss 2 + sign (rest); + anzahl durchschuss 1 := abs (rest) MOD anzahl durchschuss; + wechsel := TRUE; + FI; + ELSE loesche durchschuss + FI; + +END PROC neuer durchschuss; + + +PROC loesche durchschuss : + + durchschuss 1 := 0; + durchschuss 2 := 0; + anzahl durchschuss 1 := 0; + anzahl durchschuss := 0; + zeilen zaehler := 0; + +END PROC loesche durchschuss; + +(****************************************************************) + +PROC initialisierung : + + forget (ds); + ds := nilspace; tokenspeicher := ds; + loesche druckspeicher; + loesche anweisungsspeicher; + loesche indexspeicher; + initialisiere markierung; + right modus := FALSE; + center modus := FALSE; + seite ist offen := FALSE; + pass := 0; + a breite := 0; + a block token := FALSE; + a modifikationen fuer x move := 0; + d code 1 := leer; + erstes fuell token := leer; + IF two bytes + THEN FOR index FROM 1 UPTO 129 REP zeichen zaehler (index) := 1 PER; + FOR index FROM 130 UPTO 160 REP zeichen zaehler (index) := - maxint PER; + FOR index FROM 161 UPTO 224 REP zeichen zaehler (index) := 1 PER; + FOR index FROM 225 UPTO 240 REP zeichen zaehler (index) := - maxint PER; + FOR index FROM 241 UPTO 256 REP zeichen zaehler (index) := 1 PER; + ELSE FOR index FROM 1 UPTO 256 REP zeichen zaehler (index) := 1 PER; + FI; + +END PROC initialisierung; + +(****************************************************************) +(*** print - Kommando ***) + +BOOL VAR elan listings erlaubt; +FILE VAR eingabe; + +with elan listings (TRUE); + +PROC with elan listings (BOOL CONST flag) : + elan listings erlaubt := flag; +END PROC with elan listings; + +BOOL PROC with elan listings : elan listings erlaubt END PROC with elan listings; + + +PROC print (PROC (TEXT VAR) next line, BOOL PROC eof, + PROC (INT CONST, INT VAR, INT VAR) open, + PROC (INT CONST, INT CONST) close, + PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute ): + + print (PROC (TEXT VAR) lese zeile, BOOL PROC eof, + PROC (INT CONST, INT VAR, INT VAR) open, + PROC (INT CONST, INT CONST) close, + PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute, + FALSE, ""); + +END PROC print; + + +PROC print (FILE VAR file, + PROC (INT CONST, INT VAR, INT VAR) open, + PROC (INT CONST, INT CONST) close, + PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) : + + eingabe := file; + input (eingabe); + print (PROC (TEXT VAR) lese zeile, BOOL PROC eof, + PROC (INT CONST, INT VAR, INT VAR) open, + PROC (INT CONST, INT CONST) close, + PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute, + elan listings erlaubt CAND is elan source (eingabe), + headline (eingabe) ); + +END PROC print; + +PROC lese zeile (TEXT VAR zeile) : getline (eingabe, zeile) END PROC lese zeile; + +BOOL PROC eof : eof (eingabe) END PROC eof; + +BOOL PROC is elan source (FILE VAR eingabe) : + +hole erstes symbol; +elan programm tag COR elan programm bold COR kommentar + +. elan programm tag : + symbol type = tag type CAND pos (zeile, ";") > 0 + +. elan programm bold : + symbol type = bold type CAND is elan bold + + . is elan bold : + symbol = "PACKET" COR symbol = "LET" + COR proc oder op (symbol) COR deklaration + + . deklaration : + next symbol (symbol); + symbol = "VAR" OR symbol = "CONST" + +. kommentar : + pos (zeile, "(*") > 0 OR pos (zeile, "{") > 0 + +. + hole erstes symbol : + hole erstes nicht blankes symbol; + scan (zeile); + next symbol (symbol, symbol type); + + . hole erstes nicht blankes symbol : + IF eof (eingabe) THEN LEAVE is elan source WITH FALSE FI; + REP getline (eingabe, zeile); + UNTIL pos (zeile, ""33"",""254"", 1) > 0 OR eof (eingabe) PER; + reset (eingabe); + +END PROC is elan source; + +(****************************************************************) + +bottom label for elan listings (""); + +PROC bottom label for elan listings (TEXT CONST label) : + bottom label := label; +END PROC bottom label for elan listings; + +TEXT PROC bottom label for elan listings : bottom label END PROC bottom label for elan listings; + + +PROC print (PROC (TEXT VAR) next line, BOOL PROC eof, + PROC (INT CONST, INT VAR, INT VAR) open, + PROC (INT CONST, INT CONST) close, + PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute, + BOOL CONST elan listing, TEXT CONST file name) : + +disable stop; +gedruckte seiten := 0; +drucke datei (PROC (TEXT VAR) next line, BOOL PROC eof, + PROC (INT CONST, INT VAR, INT VAR) open, + PROC (INT CONST, INT CONST) close, + PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute, + elan listing, file name ); +IF is error THEN behandle fehlermeldung FI; + +. behandle fehlermeldung : + par1 := error message; + int param := error line; + clear error; + IF NOT vor erster seite + THEN IF seite ist offen + THEN schliesse seite ab (PROC (INT CONST, INT CONST) close, + PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute ) + FI; + clear error; + close (document, 0); + clear error; + FI; + initialisierung; + errorstop (par1 (* + " -> " + text (int param) *) ); + +END PROC print; + +INT PROC x pos : d xpos END PROC x pos; +INT PROC y pos : d ypos END PROC y pos; +INT PROC y offset index : d token. offset index END PROC y offset index; +INT PROC linetype : underline linetype END PROC linetype; +TEXT PROC material : material wert END PROC material; +INT PROC pages printed : gedruckte seiten END PROC pages printed; + +(****************************************************************) + +PROC drucke datei (PROC (TEXT VAR) next line, BOOL PROC eof, + PROC (INT CONST, INT VAR, INT VAR) open, + PROC (INT CONST, INT CONST) close, + PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute, + BOOL CONST elan listing, TEXT CONST file name ) : + + +enable stop; +IF elan listing + THEN dateiname := file name; + drucke elan listing; + ELSE drucke text datei; +FI; + +. + drucke text datei : + initialisiere druck; + WHILE NOT eof + REP next line (zeile); + analysiere zeile; + drucke token soweit wie moeglich; + werte anweisungsspeicher aus; + PER; + schliesse druck ab; + +. + initialisiere druck : + IF NOT initialized (in dieser task) + THEN ds := nilspace; + initialisierung + FI; + vor erster seite := TRUE; + tabellen modus := FALSE; + block modus := FALSE; + zeile ist absatzzeile := TRUE; + x wanted := x step conversion (std x wanted); + y wanted := y step conversion (std y wanted); + limit := x step conversion (std limit); + pagelength := y step conversion (std pagelength); + linefeed faktor := std linefeed faktor; + material wert := std material; + indentation := 0; + modifikations modus := maxint; + seitenlaenge := maxint; + papierlaenge := maxint; + left margin := 0; + top margin := 0; + a ypos := top margin; + a font := -1; + a modifikationen := 0; + aktuelle spalte := 1; + anzahl spalten := 1; + stelle neuen font ein (1); + loesche tabellenspeicher; + loesche markierung; + loesche alte markierung; + loesche durchschuss; + +. + schliesse druck ab : + IF NOT vor erster seite + THEN IF seite ist offen + THEN schliesse seite ab (PROC (INT CONST, INT CONST) close, + PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute ) + FI; + close (document, 0); + FI; + +. + drucke token soweit wie moeglich : + IF analysespeicher ist nicht leer + THEN letztes token bei gleicher ypos; + IF NOT seite ist offen + THEN eroeffne seite (x wanted, y wanted, + PROC (INT CONST, INT VAR, INT VAR) open); + FI; + gehe zur letzten neuen ypos; + IF seitenlaenge ueberschritten OR papierlaenge ueberschritten + THEN neue seite oder spalte; + analysiere zeile nochmal; + ELSE sortiere neue token ein; + IF in letzter spalte + THEN drucke tokenspeicher (a ypos, + PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute); + FI; + FI; + FI; + + . gehe zur letzten neuen ypos : + ypos index a := letzter ypos index a + + . seitenlaenge ueberschritten : + ya. ypos > seitenlaenge + + . papierlaenge ueberschritten : + ya. ypos > papierlaenge + + . neue seite oder spalte : + IF in letzter spalte + THEN schliesse seite ab (PROC (INT CONST, INT CONST) close, + PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute); + eroeffne seite (x wanted, aktuelles y wanted, + PROC (INT CONST, INT VAR, INT VAR) open); + ELSE neue spalte; + FI; + + . aktuelles y wanted : + IF seitenlaenge ueberschritten + THEN y wanted + ELSE 0 + FI + + . analysiere zeile nochmal : + setze auf alte werte zurueck; + loesche anweisungsspeicher; + analysiere zeile; + letztes token bei gleicher ypos; + sortiere neue token ein; + + . setze auf alte werte zurueck : + zeile ist absatzzeile := letzte zeile war absatzzeile; + a modifikationen := letzte modifikationen; + stelle neuen font ein (letzter font); + +. + werte anweisungsspeicher aus : + INT VAR index; + FOR index FROM 1 UPTO anweisungszaehler + REP + SELECT anweisungs indizes ISUB index OF + CASE a block : block anweisung + CASE a columns : columns anweisung + CASE a columnsend : columnsend anweisung + CASE a free : free anweisung + CASE a limit : limit anweisung + CASE a linefeed : linefeed anweisung + CASE a material : material anweisung + CASE a page0, a page1 : page anweisung + CASE a pagelength : pagelength anweisung + CASE a start : start anweisung + CASE a table : table anweisung + CASE a tableend : tableend anweisung + CASE a clearpos0 : clearpos0 anweisung + CASE a clearpos1 : clearpos1 anweisung + CASE a lpos, a rpos, a cpos, a dpos + : lpos rpos cpos dpos anweisung + CASE a bpos : bpos anweisung + CASE a fillchar : fillchar anweisung + CASE a textbegin0 : textbegin0 anweisung + CASE a textbegin2 : textbegin2 anweisung + CASE a textend : textend anweisung + CASE a indentation : indentation anweisung + CASE a y tab : y tab anweisung + END SELECT + PER; + loesche anweisungsspeicher; + + . block anweisung : + blockmodus := TRUE; + + . columns anweisung : + IF anzahl spalten = 1 AND int conversion ok (param1) + AND real conversion ok (param2) + THEN anzahl spalten := max (1, int param); + luecke := x step conversion (real param); + FI; + + . columnsend anweisung : + anzahl spalten := 1; + aktuelle spalte := 1; + left margin := x wanted - x start + indentation; + + . free anweisung : + IF real conversion ok (param1) THEN a ypos INCR y step conversion (real param) FI; + + . limit anweisung : + IF real conversion ok (param1) THEN limit := x step conversion (real param) FI; + + . linefeed anweisung : + IF real conversion ok (param1) + THEN linefeed faktor := real param; + letzte zeilenhoehe := neue zeilenhoehe; + FI; + + . material anweisung : + material wert := param1; + + . page anweisung : + IF seite ist offen + THEN IF NOT in letzter spalte + THEN neue spalte + ELSE schliesse seite ab (PROC (INT CONST, INT CONST) close, + PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute); + papier laenge := maxint; + FI; + ELSE a ypos := top margin; + papier laenge := maxint; + FI; + + . pagelength anweisung : + IF real conversion ok (param1) + THEN pagelength := y step conversion (real param); + FI; + + . start anweisung : + IF real conversion ok (param1) THEN x wanted := x step conversion (real param) FI; + IF real conversion ok (param2) THEN y wanted := y step conversion (real param) FI; + + . table anweisung : + tabellenmodus := TRUE; + + . tableend anweisung : + tabellenmodus := FALSE; + + . clearpos0 anweisung : + loesche tabellenspeicher; + + . clearpos1 anweisung : + IF real conversion ok (param1) + THEN int param := x step conversion (real param); + FOR tab index FROM 1 UPTO anzahl tabs + REP IF tab position = int param + THEN tab typ := leer; + delete int (tab liste, tab index); + LEAVE clearpos1 anweisung; + FI; + PER; + FI; + + . lpos rpos cpos dpos anweisung : + IF real conversion ok (param1) + THEN neuer tab eintrag (anweisungs indizes ISUB index, param2) FI; + + . bpos anweisung : + IF real conversion ok (param2) CAND real conversion ok (param1) + CAND real (param2) > real param + THEN neuer tab eintrag (a bpos, param2) FI; + + . fillchar anweisung : + fill char := param1; + + . textbegin0 anweisung : + aktuelle einrueckbreite := alte einrueckbreite; + mark index l := alter mark index l; + mark index r := alter mark index r; + loesche alte markierung; + + . textbegin2 anweisung : + aktuelle einrueckbreite := alte einrueckbreite; + mark index l := alter mark index l; + mark index r := alter mark index r; + loesche alte markierung; + neuer durchschuss (int (param1), y step conversion (real (param 2))); + + . textend anweisung : + alte einrueckbreite := aktuelle einrueckbreite; + alter mark index l := mark index l; + alter mark index r := mark index r; + loesche markierung; + loesche durchschuss; + + . indentation anweisung : +(* IF real conversion ok (param1) + THEN int param := x step conversion (real param); + left margin INCR (int param - indentation); + indentation := int param; + FI; + *) + . y tab anweisung : +(* IF real conversion ok (param1) + THEN int param := y step conversion (real param); + IF int param <= seitenlaenge THEN a ypos := int param FI; + FI; + *) + . param1 : + IF (params1 zeiger ISUB index) <> 0 + THEN name (params1, params1 zeiger ISUB index) + ELSE "" + FI + + . param2 : + IF (params2 zeiger ISUB index) <> 0 + THEN name (params2, params2 zeiger ISUB index) + ELSE "" + FI + + +. + drucke elan listing : + initialisiere elan listing; + WHILE NOT eof + REP next line (zeile); + zeilen nr INCR 1; + drucke elan zeile; + PER; + schliesse elan listing ab; + +. + initialisiere elan listing : + open document cmd; + hole elan list font; + initialisiere variablen; + elan fuss und kopf (1, + PROC (INT CONST, INT CONST) close, + PROC (INT CONST, INT VAR, INT VAR) open, + PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute); + + . open document cmd : + material wert := ""; + d token. offset index := 1; + erster ypos index d := 0; + vor erster seite := FALSE; + seite ist offen := FALSE; + open (document, x size, y size); + vor erster seite := TRUE; + + . hole elan list font : + d font := max (1, font ("elanlist")); + get replacements (d font, replacements, replacement tabelle); + einrueckbreite := indentation pitch (d font) ; + font hoehe := font lead (d font) + font height (d font) + font depth (d font); + + . initialisiere variablen : + innerhalb der define liste := FALSE; + vor erstem packet := TRUE; + zeilen nr := 0; + y wanted := y size DIV 23; + pagelength := y size - y wanted - y wanted; + x wanted := (min (x size DIV 10, x step conversion (2.54)) + DIV einrueckbreite) * einrueckbreite; + max zeichen zeile := (x size - x wanted - (x wanted DIV 3)) DIV einrueckbreite; + max zeichen fuss := fusszeilenbreite; + layout laenge := min (38, max zeichen zeile DIV 3); + layout laenge name := layout laenge - zeilen nr laenge - 8; + layout blanks := (layout laenge - zeilen nr laenge - 1) * " "; + refinement layout zeile := (layout laenge - 1) * " " ; + refinement layout zeile CAT "|" ; + IF pagelength DIV fonthoehe - 6 < 35 OR max zeichen zeile < 65 + THEN errorstop ("Schreibfeld fuer 'elan listing' zu klein") FI; + + . fusszeilenbreite : + INT CONST dina 4 breite := x step conversion (21.0); + IF x size <= dina 4 breite + THEN (x size - 2 * x wanted) DIV einrueckbreite + ELIF 120 * einrueckbreite <= dina 4 breite - 2 * x wanted + THEN (dina 4 breite - 2 * x wanted) DIV einrueckbreite + ELSE min (120, (x size - 2 * x wanted) DIV einrueckbreite) + FI + +. + schliesse elan listing ab : + elan fuss und kopf (-1, + PROC (INT CONST, INT CONST) close, + PROC (INT CONST, INT VAR, INT VAR) open, + PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute); + close (document, 0); + +. + drucke elan zeile : + IF pos (zeile, "#page#") = 1 + THEN IF nicht am seiten anfang THEN seiten wechsel FI; + ELSE bestimme elan layout; + bestimme elan zeile; + gib elan text aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute); + seitenwechsel wenn noetig; + FI; + + . nicht am seitenanfang : + rest auf seite < pagelength - 3 * font hoehe + + . seiten wechsel : + elan fuss und kopf (0, + PROC (INT CONST, INT CONST) close, + PROC (INT CONST, INT VAR, INT VAR) open, + PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute); + +. + bestimme elan layout : + IF pos (zeile, "P") = 0 AND pos (zeile, ":") = 0 + THEN leeres layout + ELSE analysiere elan zeile + FI; + elan text CAT "|"; + + . leeres layout : + elan text := text (zeilen nr, zeilen nr laenge); + elan text CAT layout blanks; + + . analysiere elan zeile : + scan (zeile); + next symbol (symbol, symbol type); + next symbol (naechstes symbol, naechster symbol type) ; + IF packet anfang THEN packet layout + ELIF innerhalb der define liste THEN leeres layout; pruefe ende der define liste + ELIF proc op anfang THEN proc op layout + ELIF refinement anfang THEN refinement layout + ELSE leeres layout + FI; + + . packet anfang : + symbol = "PACKET" + + . proc op anfang : + IF proc oder op (symbol) + THEN naechster symbol type <> delimiter type + ELIF (symbol <> "END") AND proc oder op (naechstes symbol) + THEN symbol := naechstes symbol; + next symbol (naechstes symbol, naechster symbol type) ; + naechster symbol type <> delimiter type + ELSE FALSE + FI + + . refinement anfang : + symbol type = tag type AND naechstes symbol = ":" + AND NOT innerhalb der define liste + + . packet layout : + IF nicht am seiten anfang AND + (NOT vor erstem packet OR gedruckte seiten > 0) + THEN seiten wechsel FI; + layout (" ", naechstes symbol, "*") ; + vor erstem packet := FALSE ; + innerhalb der define liste := TRUE; + pruefe ende der define liste; + + . pruefe ende der define liste : + IF pos (zeile, ":") <> 0 + THEN scan (zeile); + WHILE innerhalb der define liste + REP next symbol (symbol); + IF symbol = ":" THEN innerhalb der define liste := FALSE FI; + UNTIL symbol = "" PER; + FI; + + . proc op layout : + IF keine vier zeilen mehr + THEN seiten wechsel + ELIF nicht am seitenanfang + THEN cr plus lf (2, PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute); + FI ; + layout (" ", naechstes symbol, "."); + + . keine vier zeilen mehr : + rest auf seite <= 8 * font hoehe + + . refinement layout : + IF keine drei zeilen mehr + THEN seiten wechsel + ELIF nicht am seitenanfang + THEN elan text := refinement layout zeile; + gib elan text aus + (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute); + FI ; + layout (" ", symbol, " "); + + . keine drei zeilen mehr : + rest auf seite <= 7 * font hoehe + +. + bestimme elan zeile : + IF zeile ist nicht zu lang + THEN elan text CAT zeile; + ELSE drucke zeile in teilen + FI; + + . zeile ist nicht zu lang : + zeilen laenge := LENGTH zeile; + zeilen laenge <= rest auf zeile + + . rest auf zeile : + max zeichen zeile - LENGTH elan text + + . drucke zeile in teilen : + zeilen pos := 1; + bestimme einrueckung; + WHILE zeile noch nicht ganz gedruckt REP teil layout PER; + + . bestimme einrueckung : + anzahl einrueck blanks := naechstes nicht blankes zeichen - 1; + IF anzahl einrueck blanks > rest auf zeile - 20 + THEN anzahl einrueck blanks := 0 FI; + + . zeile noch nicht ganz gedruckt : + bestimme zeilenteil; + NOT zeile ist zu ende + + . bestimme zeilenteil : + bestimme laenge; + zeilen teil := subtext (zeile, zeilen pos, zeilen pos + laenge - 1); + elan text CAT zeilen teil; + zeilen pos INCR laenge; + + . zeilen teil : par1 + + . bestimme laenge : + INT VAR laenge := zeilen laenge - zeilen pos + 1; + IF laenge > rest auf zeile + THEN laenge := rest auf zeile; + WHILE (zeile SUB (zeilen pos + laenge - 1)) <> " " + REP laenge DECR 1 UNTIL laenge = 0 PER; + IF laenge = 0 THEN laenge := rest auf zeile FI; + FI; + + . teil layout : + gib elan text aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute); + elan text := (zeilen nr laenge - 1) * " "; + elan text CAT "+"; + elan text CAT layout blanks; + elan text CAT "|"; + elan text cat blanks (anzahl einrueck blanks + teil einrueckung); + +. + seiten wechsel wenn noetig : + IF keine zeilen mehr AND NOT eof THEN seiten wechsel FI; + + . keine zeilen mehr : + rest auf seite <= 4 * font hoehe + +END PROC drucke datei; + + +BOOL PROC real conversion ok (TEXT CONST param) : + real param := real (param); + last conversion ok AND real param >= 0.0 +END PROC real conversion ok; + + +BOOL PROC int conversion ok (TEXT CONST param) : + int param := int (param); + last conversion ok AND int param >= 0 +END PROC int conversion ok; + + +PROC neuer tab eintrag (INT CONST typ, TEXT CONST param) : + + suche neuen eintrag; + sortiere neue tab position ein; + tab typ := typ; + tab position := neue tab position; + tab param := eventueller parameter; + + . suche neuen eintrag : + INT VAR index := 0; + REP index INCR 1; + IF tab speicher (index). tab typ = leer + THEN LEAVE suche neuen eintrag FI; + UNTIL index = max tabs PER; + LEAVE neuer tab eintrag; + + . sortiere neue tab position ein : + INT VAR neue tab position := x step conversion (real param); + FOR tab index FROM 1 UPTO anzahl tabs + REP IF tab position = neue tab position + THEN LEAVE neuer tab eintrag + ELIF tab position > neue tab position + THEN insert int (tab liste, tab index, index); + LEAVE sortiere neue tab position ein; + FI; + PER; + tab liste CAT index; + tab index := anzahl tabs; + + . eventueller parameter : + INT VAR link; + SELECT typ OF + CASE a dpos : insert (d strings, param, link); link + CASE a bpos : x step conversion (real(param)) + OTHERWISE : 0 + END SELECT + +END PROC neuer tab eintrag; + + +PROC neue spalte : + a ypos := top margin; + left margin INCR (limit + luecke); + aktuelle spalte INCR 1; +END PROC neue spalte ; + + +BOOL PROC proc oder op (TEXT CONST symbol) : + + symbol = "PROC" OR symbol = "PROCEDURE" + OR symbol = "OP" OR symbol = "OPERATOR" + +ENDPROC proc oder op ; + + +PROC layout (TEXT CONST pre, TEXT VAR name, TEXT CONST post) : + +name := subtext (name, 1, layout laenge name) ; +elan text := text (zeilen nr, zeilen nr laenge); +elan text CAT pre; +elan text CAT name; +elan text CAT " "; +generiere strukturiertes layout; + +. generiere strukturiertes layout : + INT VAR index; + FOR index FROM 1 UPTO layout laenge - LENGTH elan text - 1 + REP elan text CAT post PER; + +ENDPROC layout ; + + +PROC elan text cat blanks (INT CONST anzahl) : + + par2 := anzahl * " "; + elan text CAT par2; + +END PROC elan text cat blanks; + + +(***********************************************************************) + +PROC analysiere zeile : + +loesche analysespeicher; +behandle fuehrende blanks; +pruefe ob anweisungszeile; +pruefe ob markierung links; + +IF tabellen modus + THEN analysiere tabellenzeile +ELIF letzte zeile war absatzzeile + THEN analysiere zeile nach absatzzeile + ELSE analysiere zeile nach blockzeile +FI; + +pruefe center und right modus; +pruefe ob tabulation vorliegt; +werte indexspeicher aus; +berechne zeilenhoehe; +pruefe ob markierung rechts; + +. + analysiere zeile nach absatzzeile : + test auf aufzaehlung; + IF zeile muss geblockt werden + THEN analysiere blockzeile nach absatzzeile + ELSE analysiere absatzzeile nach absatzzeile + FI; +. + analysiere zeile nach blockzeile : + IF zeile muss geblockt werden + THEN analysiere blockzeile nach blockzeile + ELSE analysiere absatzzeile nach blockzeile + FI; + + +. + behandle fuehrende blanks : + zeilenpos := 1; + zeilenpos := naechstes nicht blankes zeichen; + IF zeilenpos = 0 + THEN behandle leerzeile; + LEAVE analysiere zeile; + ELSE letzte zeile war absatzzeile := zeile ist absatzzeile; + IF letzte zeile war absatzzeile THEN neue einrueckung FI; + initialisiere analyse; + FI; + + . behandle leerzeile : + a ypos INCR (letzte zeilenhoehe + durchschuss); + zeile ist absatzzeile := LENGTH zeile > 0; + pruefe ob markierung links; + pruefe ob markierung rechts; + + . neue einrueckung : + aktuelle einrueckbreite := einrueckbreite; + + . initialisiere analyse : + zeile ist absatzzeile := (zeile SUB LENGTH zeile) = blank; + zeile muss geblockt werden := block modus AND NOT zeile ist absatzzeile; + erstes token der zeile := token index f + 1; + groesste fonthoehe := fonthoehe; + aktuelle zeilenhoehe := letzte zeilenhoehe; + zeilen laenge := laenge der zeile; + anzahl einrueck blanks := zeilen pos - 1; + anzahl zeichen := anzahl einrueck blanks; + a xpos := left margin + anzahl zeichen * aktuelle einrueckbreite; + a modifikationen fuer x move := 0; + letzter font := a font; + letzte modifikationen := a modifikationen; + IF zeile muss geblockt werden THEN initialisiere tab variablen FI; + + . laenge der zeile : + IF zeile ist absatzzeile + THEN LENGTH zeile - 1 + ELSE LENGTH zeile + FI +. + pruefe ob anweisungszeile : + IF erstes zeichen ist anweisungszeichen + THEN REP analysiere anweisung; + IF zeile ist zu ende THEN LEAVE analysiere zeile FI; + UNTIL zeichen ist kein anweisungs zeichen PER; + FI; + + . erstes zeichen ist anweisungszeichen : + pos (zeile, anweisungszeichen, 1, 1) <> 0 + + . zeichen ist kein anweisungszeichen : + pos (zeile, anweisungszeichen, zeilen pos, zeilen pos) = 0 + +. + pruefe ob markierung links : + IF markierung links + THEN mark token (mark index l). xpos := + left margin - mark token (mark index l). breite; + lege markierungs token an (mark index l); + erstes token der zeile := token index f + 1; + initialisiere tab variablen; + FI; + +. + analysiere tabellenzeile : + anfangs blankmodus := doppel blank; + alte zeilenpos := zeilen pos; + FOR tab index FROM 1 UPTO anzahl tabs + REP lege fuell token an wenn noetig; + initialisiere tab variablen; + SELECT tab typ OF + CASE a lpos : linksbuendige spalte + CASE a rpos : rechtsbuendige spalte + CASE a cpos : zentrierte spalte + CASE a dpos : dezimale spalte + CASE a bpos : geblockte spalte + END SELECT; + berechne fuell token wenn noetig; + tabulation; + PER; + analysiere rest der zeile; + + . lege fuell token an wenn noetig : + IF fill char <> blank + THEN fuellzeichen := fill char; + fuellzeichen breite := string breite (fuellzeichen); + token zeiger := zeilen pos; + erstes fuell token := token index f + 1; + lege text token an; + letztes fuell token := token index f; + a modifikationen fuer x move := a modifikationen + FI; + + . berechne fuell token wenn noetig : + IF erstes fuell token <> leer + THEN IF letztes fuell token <> token index f + THEN berechne fuell token; + ELSE loesche letzte token; + FI; + erstes fuell token := leer + FI; + + . berechne fuell token : + INT VAR anzahl fuellzeichen, fuell breite; + token index := erstes fuell token; + anzahl fuellzeichen := (tab anfang - t. xpos + left margin) + DIV fuellzeichen breite; + rest := (tab anfang - t. xpos + left margin) + MOD fuellzeichen breite; + IF anzahl fuell zeichen > 0 + THEN fuell text := anzahl fuellzeichen * fuellzeichen; + fuell breite := anzahl fuellzeichen * fuellzeichen breite; + FOR token index FROM erstes fuell token UPTO letztes fuell token + REP t. text := fuell text; + t. breite := fuell breite; + IF erstes fuell token <> erstes token der zeile + THEN t. xpos INCR rest DIV 2; + t. modifikationen fuer x move := t. modifikationen; + FI; + PER; + FI; + + . fuell text : par1 + + . loesche letzte token : + FOR token index FROM letztes fuell token DOWNTO erstes fuell token + REP loesche letztes token PER; + + . tabulation : + alte zeilenpos := zeilenpos; + zeilenpos := naechstes nicht blankes zeichen; + IF zeilenpos = 0 + THEN zeilenpos := zeilenlaenge + 1; + LEAVE analysiere tabellenzeile; + FI; + anzahl zeichen INCR zeilenpos - alte zeilenpos; + + . linksbuendige spalte : + a xpos := left margin + tab position; + tab anfang := tab position; + bestimme token bis terminator oder zeilenende; + + . rechtsbuendige spalte : + bestimme token bis terminator oder zeilenende; + schreibe zeile rechtsbuendig (tab position); + + . zentrierte spalte : + bestimme token bis terminator oder zeilenende; + zentriere zeile (tab position); + + . dezimale spalte : + d string := name (d strings, tab param); + d code 1 := code (d string SUB 1) + 1; + d pitch := zeichenbreiten (d code 1); + zeichenbreiten (d code 1) := d code ausgang; + bestimme token bis terminator oder zeilenende; + zeichenbreiten (d code 1) := d pitch; + d code 1 := leer; + schreibe zeile rechtsbuendig (tab position); + IF zeichen ist dezimal zeichen + THEN IF tab position <> zeilen breite + THEN a xpos := left margin + tab position; + tab anfang := tab position; + FI; + bestimme token bis terminator oder zeilenende + FI; + + . zeichen ist dezimal zeichen : + pos (zeile, d string, zeilen pos) = zeilen pos + + . geblockte spalte : + blankmodus := einfach blank; + a xpos := left margin + tab position; + tab anfang := tab position; + REP bestimme token bis terminator oder zeilenende; + IF zeile ist zu ende OR naechstes zeichen ist blank + THEN blocke spalte wenn noetig; + LEAVE geblockte spalte; + ELSE dehnbares blank gefunden; + FI; + PER; + + . blocke spalte wenn noetig : + IF letztes zeichen ist kein geschuetztes blank + THEN blocke zeile (tab param) FI; + blank modus := doppel blank; + + . letztes zeichen ist kein geschuetztes blank : + pos (zeile, geschuetztes blank, zeilen pos - 1, zeilen pos - 1) = 0 + AND NOT within kanji (zeile, zeilen pos - 2) + + . analysiere rest der zeile : + blankmodus := keine blankanalyse; + zeilen pos := alte zeilenpos; + bestimme token bis terminator oder zeilenende; + +. + test auf aufzaehlung : + anfangs blankmodus := einfach blank; + bestimme token bis terminator oder zeilenende; + IF zeile ist zu ende + THEN LEAVE analysiere zeile nach absatzzeile + ELSE aufzaehlung moeglich + FI; + + . aufzaehlung moeglich : + bestimme letztes zeichen; + IF (anzahl zeichen bei aufzaehlung < 2 AND letztes zeichen = "-") + OR (anzahl zeichen bei aufzaehlung < 20 AND letztes zeichen = ":") + OR (anzahl zeichen bei aufzaehlung < 7 + AND pos (".)", letztes zeichen) <> 0) + OR naechstes zeichen ist blank + THEN tabulator position gefunden; + ELIF zeile muss geblockt werden + THEN dehnbares blank gefunden; + FI; + + . bestimme letztes zeichen : + token index := token index f; + WHILE token index >= erstes token der zeile + REP IF token ist text token + THEN letztes zeichen := t. text SUB LENGTH t. text; + LEAVE bestimme letztes zeichen; + FI; + token index DECR 1; + PER; + letztes zeichen := ""; + + . letztes zeichen : par1 + + . anzahl zeichen bei aufzaehlung : + anzahl zeichen - anzahl einrueck blanks + + . token ist text token : + t. offset index >= text token +. + analysiere blockzeile nach absatzzeile : + REP bestimme token bis terminator oder zeilenende; + IF zeile ist zu ende + THEN blocke zeile (limit); + LEAVE analysiere blockzeile nach absatzzeile + ELSE analysiere blank in blockzeile nach absatzzeile + FI; + PER; + + . analysiere blank in blockzeile nach absatzzeile : + IF naechstes zeichen ist blank + THEN tabulator position gefunden; + ELSE dehnbares blank gefunden; + FI; + +. + analysiere absatzzeile nach absatzzeile : + blankmodus := doppel blank; + REP bestimme token bis terminator oder zeilenende; + IF zeile ist zu ende + THEN LEAVE analysiere absatzzeile nach absatzzeile + ELSE tabulator position gefunden + FI; + PER; + +. + analysiere blockzeile nach blockzeile : + anfangs blankmodus := einfach blank; + REP bestimme token bis terminator oder zeilenende; + IF zeile ist zu ende + THEN blocke zeile (limit); + LEAVE analysiere blockzeile nach blockzeile + ELSE dehnbares blank gefunden + FI; + PER; + +. + analysiere absatzzeile nach blockzeile : + anfangs blankmodus := keine blankanalyse; + bestimme token bis terminator oder zeilenende; + +. + dehnbares blank gefunden : + anzahl zeichen INCR 1; + zeilenpos INCR 1; + a xpos INCR blankbreite; + a modifikationen fuer x move := a modifikationen; + IF NOT a block token + THEN anzahl blanks INCR 1; + a block token := TRUE; + FI; +. + tabulator position gefunden : + alte zeilenpos := zeilenpos; + zeilenpos := naechstes nicht blankes zeichen; + IF zeilenpos = 0 + THEN zeilenpos := zeilen laenge + 1; + ELSE IF erstes token der zeile > token index f + THEN token zeiger := zeilen pos; + lege text token an; + FI; + anzahl zeichen INCR (zeilenpos - alte zeilenpos); + a xpos := left margin + anzahl zeichen * aktuelle einrueckbreite; + a modifikationen fuer x move := a modifikationen; + IF zeile muss geblockt werden THEN initialisiere tab variablen FI; + FI; + +. + pruefe center und right modus : + IF center modus THEN zentriere zeile (limit DIV 2) FI; + IF right modus THEN schreibe zeile rechtsbuendig (limit) FI; +. + pruefe ob tabulation vorliegt: + IF analyse speicher ist nicht leer CAND a xpos > tf. xpos + tf. breite + THEN a modifikationen fuer x move := a modifikationen; + token zeiger := zeilen pos; + lege text token an; + FI; +. + werte indexspeicher aus : + INT VAR index; + IF index zaehler > 0 + THEN FOR index FROM index zaehler DOWNTO 1 + REP a ypos DECR (verschiebungen ISUB index) PER; + stelle neuen font ein (grosse fonts ISUB 1); + loesche index speicher; + FI; +. + berechne zeilenhoehe : + verschiebung := aktuelle zeilenhoehe + durchschuss; + a ypos INCR verschiebung; + verschiebe token ypos (verschiebung); + +. + pruefe ob markierung rechts : + IF markierung rechts + THEN mark token (mark index r). xpos := left margin + limit; + lege markierungs token an (mark index r); + FI; + +END PROC analysiere zeile; + + +PROC blocke zeile (INT CONST rechter rand) : + +rest := rechter rand - zeilen breite; +IF rest > 0 AND anzahl blanks > 0 + THEN INT CONST schmaler schritt := rest DIV anzahl blanks, + breiter schritt := schmaler schritt + 1, + anzahl breite schritte := rest MOD anzahl blanks; + IF rechts + THEN blocke token xpos (breiter schritt, schmaler schritt, + anzahl breite schritte); + rechts := FALSE; + ELSE blocke token xpos (schmaler schritt, breiter schritt, + anzahl blanks - anzahl breite schritte); + rechts := TRUE; + FI; + a xpos INCR ( breiter schritt * anzahl breite schritte + + schmaler schritt * (anzahl blanks - anzahl breite schritte) ); +FI; + +END PROC blocke zeile; + + +PROC zentriere zeile (INT CONST zentrier pos) : + +IF erstes tab token <= token index f + THEN verschiebung := zentrier pos - tab anfang - + (zeilen breite - tab anfang) DIV 2; + verschiebe token xpos (verschiebung); + a xpos INCR verschiebung; + tab anfang INCR verschiebung; +FI; +center modus := FALSE; + +END PROC zentriere zeile; + + +PROC schreibe zeile rechtsbuendig (INT CONST rechte pos) : + +IF erstes tab token <= token index f + THEN verschiebung := rechte pos - zeilen breite; + verschiebe token xpos (verschiebung); + a xpos INCR verschiebung; + tab anfang INCR verschiebung; +FI; +right modus := FALSE; + + +END PROC schreibe zeile rechtsbuendig; + + +PROC bestimme token bis terminator oder zeilenende : + +token zeiger := zeilen pos; +REP stranalyze (zeichenbreiten, a breite, max breite, + zeile, zeilen pos, zeilen laenge, + ausgang); + zeilen pos INCR 1; + IF ausgang = blank ausgang + THEN analysiere blank + ELIF ausgang = anweisungs ausgang + THEN anweisung gefunden + ELIF ausgang = d code ausgang + THEN analysiere d string + ELIF ausgang = erweiterungs ausgang + THEN erweiterung gefunden + ELSE terminator oder zeilenende gefunden + FI; +PER; + +. analysiere blank : + IF blankmodus = einfach blank OR + (blankmodus = doppel blank AND naechstes zeichen ist blank) + THEN terminator oder zeilenende gefunden + ELSE a breite INCR blankbreite; + zeilenpos INCR 1; + FI; + +. analysiere d string : + IF pos (zeile, d string, zeilen pos) = zeilen pos + THEN terminator oder zeilenende gefunden + ELSE IF d pitch = maxint + THEN erweiterung gefunden + ELIF d pitch < 0 + THEN a breite INCR (d pitch XOR - maxint - 1); + zeilen pos INCR 2; + ELSE a breite INCR d pitch; + zeilenpos INCR 1; + FI; + FI; + +. erweiterung gefunden : + a breite INCR extended char pitch (a font, zeile SUB zeilen pos, + zeile SUB zeilen pos + 1); + zeilen pos INCR 2; + +. anweisung gefunden : + gegebenfalls neues token gefunden; + analysiere anweisung; + IF zeile ist zu ende + THEN LEAVE bestimme token bis terminator oder zeilenende FI; + token zeiger := zeilenpos; + +. terminator oder zeilenende gefunden : + IF ausgang = null ausgang THEN zeilen laenge DECR 1 FI; + gegebenfalls neues token gefunden; + LEAVE bestimme token bis terminator oder zeilenende; + + . gegebenfalls neues token gefunden : + IF token zeiger < zeilenpos THEN lege text token an FI; + +END PROC bestimme token bis terminator oder zeilen ende; + + +PROC analysiere anweisung : + + bestimme anweisung; + IF anweisung ist kommando + THEN lege kommando token an; + ELSE werte anweisung aus; + FI; + + . anweisungsanfang : token zeiger + + . anweisungsende : zeilen pos - 2 + + . erstes zeichen : par1 + +. bestimme anweisung : + anweisungsanfang := zeilenpos + 1; + zeilen pos := pos (zeile, anweisungszeichen, anweisungsanfang, zeilenlaenge); + IF zeilenpos = 0 + THEN zeilenpos := anweisungsanfang - 1; + replace (zeile, zeilenpos, geschuetztes anweisungszeichen); + LEAVE analysiere anweisung; + FI; + zeilen pos INCR 1; + anweisung := subtext (zeile, anweisungsanfang, anweisungsende); + erstes zeichen := anweisung SUB 1; + +. anweisung ist kommando : + IF erstes zeichen = quote + THEN scan (anweisung); + next symbol (anweisung, symbol type); + next symbol (par2, naechster symbol type); + IF symbol type <> text type OR naechster symbol type <> eof type + THEN LEAVE analysiere anweisung FI; + TRUE + ELIF erstes zeichen = druckerkommando zeichen + THEN delete char (anweisung, 1); + TRUE + ELSE FALSE + FI + +. + werte anweisung aus : + analyze command (anweisungs liste, anweisung, number type, + anweisungs index, anzahl params, par1, par2); + SELECT anweisungs index OF + CASE a type : type anweisung + CASE a on : on anweisung + CASE a off : off anweisung + CASE a ub, a fb : ub fb anweisung + CASE a ue, a fe : ue fe anweisung + CASE a center : center anweisung + CASE a right : right anweisung + CASE a up, a down : index anweisung + CASE a end up or down : end index anweisung + CASE a bsp : bsp anweisung + CASE a fillchar : fillchar anweisung + CASE a mark : mark anweisung + CASE a markend : markend anweisung + OTHERWISE : IF anweisungs index > 0 THEN speichere anweisung FI; + END SELECT; + + . type anweisung : + change all (par1, " ", ""); + stelle neuen font ein (font (par1)); + groesste fonthoehe := max (groesste fonthoehe, fonthoehe); + a modifikationen := 0; + IF nicht innerhalb eines indexes THEN berechne aktuelle zeilenhoehe FI; + + . nicht innerhalb eines indexes : + index zaehler = 0 + + . berechne aktuelle zeilenhoehe : + IF linefeed faktor >= 1.0 + THEN aktuelle zeilenhoehe := max (groesste fonthoehe, + letzte zeilenhoehe); + ELSE aktuelle zeilenhoehe := max (aktuelle zeilenhoehe, + letzte zeilenhoehe); + FI; + + . on anweisung : + par1 := par1 SUB 1; + IF pos (modifikations liste, par1) > 0 + THEN set bit (a modifikationen, pos (modifikations liste, par1) - 1 ); + FI; + + . off anweisung : + par1 := par1 SUB 1; + IF pos (modifikations liste, par1) > 0 + THEN reset bit (a modifikationen, pos (modifikations liste, par1) - 1 ); + FI; + + . ub fb anweisung : + IF anweisungs index = a ub + THEN par1 := "u" + ELSE par1 := "b" + FI; + on anweisung; + + . ue fe anweisung : + IF anweisungs index = a ue + THEN par1 := "u" + ELSE par1 := "b" + FI; + off anweisung; + + . center anweisung : + IF NOT zeile muss geblockt werden AND NOT tabellen modus + AND NOT right modus + THEN center modus := TRUE; + blankmodus := keine blankanalyse; + initialisiere tab variablen; + FI; + + . right anweisung : + IF NOT zeile muss geblockt werden AND NOT tabellen modus + THEN IF center modus THEN zentriere zeile (limit DIV 2) FI; + right modus := TRUE; + blankmodus := keine blankanalyse; + initialisiere tab variablen; + FI; + + . index anweisung : + INT CONST grosser font := a font, grosse fonthoehe := fonthoehe; + INT VAR kleiner font; + IF next smaller font exists (grosser font, kleiner font) + THEN stelle neuen font ein (kleiner font) FI; + IF font hoehe < grosse fonthoehe + THEN berechne verschiebung fuer kleinen font + ELSE berechne verschiebung fuer grossen font + FI; + a ypos INCR verschiebung; + merke grossen font und verschiebung; + + . berechne verschiebung fuer kleinen font : + IF anweisungs index = a down + THEN verschiebung := 15 PROZENT grosse fonthoehe; + ELSE verschiebung := - ( 9 PROZENT grosse fonthoehe ) + - (grosse fonthoehe - fonthoehe); + FI; + + . berechne verschiebung fuer grossen font : + IF anweisungs index = a down + THEN verschiebung := 25 PROZENT fonthoehe; + ELSE verschiebung := - (50 PROZENT fonthoehe); + FI; + + . merke grossen font und verschiebung : + index zaehler INCR 1; + grosse fonts CAT grosser font; + verschiebungen CAT verschiebung; + IF index zaehler = 1 + THEN alter blankmodus := blankmodus; + blankmodus := keine blankanalyse; + FI; + + . end index anweisung : + IF index zaehler > 0 + THEN schalte auf groesseren font zurueck; + FI; + + . schalte auf groesseren font zurueck : + a ypos DECR (verschiebungen ISUB index zaehler); + stelle neuen font ein (grosse fonts ISUB index zaehler); + IF index zaehler = 1 + THEN blankmodus := alter blankmodus; + FI; + index zaehler DECR 1; + verschiebungen := subtext (verschiebungen, 1, 2 * index zaehler); + grosse fonts := subtext (grosse fonts, 1, 2 * index zaehler); + + . bsp anweisung : + INT VAR breite davor, breite dahinter; + IF anweisungs anfang - 2 >= 1 AND anweisungs ende + 2 <= zeilen laenge + THEN IF is kanji esc (zeile SUB anweisungs anfang - 3) + THEN zeichen davor := subtext (zeile, anweisungs anfang - 3, + anweisungs anfang - 2); + ELSE zeichen davor := zeile SUB anweisungs anfang - 2; + FI; + IF is kanji esc (zeile SUB anweisungs ende + 2) + THEN zeichen dahinter := subtext (zeile, anweisungs ende + 2, + anweisungs ende + 3 ); + ELSE zeichen dahinter := zeile SUB anweisungs ende + 2; + FI; + IF pos (" #", zeichen davor) = 0 AND pos (" #", zeichen dahinter) = 0 + THEN breite davor := char pitch (a font, zeichen davor); + breite dahinter := char pitch (a font, zeichen dahinter); + IF breite davor < breite dahinter THEN vertausche zeichen FI; + lege token fuer zeichen dahinter an; + a xpos INCR (breite davor - breite dahinter) DIV 2; + FI; + FI; + + . zeichen davor : par1 + . zeichen dahinter : par2 + + . vertausche zeichen : + change (zeile, anweisungs anfang - 2 - LENGTH zeichen davor + 1, + anweisungs anfang - 2, zeichen dahinter); + change (zeile, anweisungs ende + 2, + anweisungs ende + 2 + LENGTH zeichen dahinter - 1, zeichen davor); + change (tf. text, LENGTH tf. text - LENGTH zeichen davor + 1, + LENGTH tf. text, zeichen dahinter); + tf. breite INCR (breite dahinter - breite davor); + a xpos INCR (breite dahinter - breite davor); + int param := breite davor; + breite davor := breite dahinter; + breite dahinter := int param; + + . lege token fuer zeichen dahinter an : + token zeiger := zeilen pos; + a breite := breite dahinter; + zeilen pos INCR LENGTH zeichen dahinter; + a xpos DECR (breite davor + breite dahinter) DIV 2; + lege text token an; + anzahl zeichen DECR 1; + + . fillchar anweisung : + IF par1 = "" THEN par1 := " " FI; + fill char := par1; + speichere anweisung; + + . mark anweisung : + IF par1 <> "" + THEN mark index l := (alter mark index l MOD 2) + 1; + neue markierung (par1, mark index l); + ELSE mark index l := 0; + FI; + IF par2 <> "" + THEN mark index r := (alter mark index r MOD 2) + 3; + neue markierung (par2, mark index r); + ELSE mark index r := 0; + FI; + + . markend anweisung : + loesche markierung; + + . speichere anweisung : + anweisungs zaehler INCR 1; + anweisungs indizes CAT anweisungs index; + IF par1 <> "" + THEN insert (params1, par1); + params1 zeiger CAT highest entry (params1); + ELSE params1 zeiger CAT 0; + FI; + IF par2 <> "" + THEN insert (params2, par2); + params2 zeiger CAT highest entry (params2); + ELSE params2 zeiger CAT 0; + FI; + +END PROC analysiere anweisung; + + +PROC stelle neuen font ein (INT CONST font nr ) : + + IF font nr <> a font THEN neuer font FI; + + . neuer font : + a font := max (1, font nr); + get font (a font, einrueckbreite, font durchschuss, font hoehe, font tiefe, + zeichenbreiten); + font hoehe INCR (font durchschuss + font tiefe); + letzte zeilenhoehe := neue zeilenhoehe; + blankbreite := zeichenbreiten (blank code 1); + zeichenbreiten (blank code 1) := blank ausgang; + zeichenbreiten (anweisungs zeichen code 1) := anweisungs ausgang; + font offsets := y offsets (a font); + offsets := LENGTH font offsets > 2; + IF d code 1 <> leer + THEN d pitch := zeichenbreiten (d code 1); + zeichenbreiten (d code 1) := d code ausgang; + FI; + +END PROC stelle neuen font ein; + + +INT OP PROZENT (INT CONST prozent, wert) : + + (wert * prozent + 99) DIV 100 + +END OP PROZENT; + + +PROC neue markierung (TEXT CONST text, INT CONST mark index) : + + mark token (mark index). text := text; + mark token (mark index). breite := string breite (text); + mark token (mark index). font := a font; + mark token (mark index). modifikationen := a modifikationen; + +END PROC neue markierung; + + +INT PROC string breite (TEXT CONST string) : + + INT VAR summe := 0, pos := 1; + REP stranalyze (zeichenbreiten, summe, max breite, string, pos, maxint, ausgang); + IF ausgang = erweiterungs ausgang + THEN summe INCR extended char pitch (a font, + string SUB pos+1, string SUB pos+2); + pos INCR 3; + ELIF ausgang = blank ausgang + THEN summe INCR blankbreite; + pos INCR 2; + ELIF ausgang = anweisungs ausgang + THEN summe INCR char pitch (a font, anweisungszeichen); + pos INCR 2; + ELSE LEAVE string breite WITH summe + FI; + PER; + 0 + +END PROC string breite; + +(*******************************************************************) + +PROC lege text token an : + + aktuelle ypos := a ypos + (font offsets ISUB 1); + neuer token index; + uebertrage text token (tf); + IF offsets THEN lege offsets an (font offsets) FI; + stranalyze (zeichen zaehler, anzahl zeichen, max int, + zeile, token zeiger, zeilen pos - 1, ausgang); + a xpos INCR a breite; + a breite := 0; + a modifikationen fuer x move := 0; + a block token := FALSE; + +END PROC lege text token an; + + +PROC uebertrage text token (TOKEN VAR tf) : + + tf. text := subtext (zeile, token zeiger, zeilenpos - 1); + tf. xpos := a xpos; + tf. breite := a breite; + tf. font := a font; + tf. modifikationen := a modifikationen; + tf. modifikationen fuer x move := a modifikationen fuer x move; + tf. offset index := text token; + tf. block token := a block token; + +END PROC uebertrage text token; + + +PROC lege kommando token an : + + aktuelle ypos := a ypos + (font offsets ISUB 1); + neuer token index; + uebertrage kommando token (tf); + a modifikationen fuer x move := 0; + a block token := FALSE; + +END PROC lege kommando token an; + + +PROC uebertrage kommando token (TOKEN VAR tf) : + + tf. text := anweisung; + tf. breite := 0; + tf. xpos := a xpos; + tf. font := a font; + tf. modifikationen := a modifikationen; + tf. modifikationen fuer x move := a modifikationen fuer x move; + tf. offset index := kommando token; + tf. block token := a block token; + +END PROC uebertrage kommando token; + + +PROC lege markierungs token an (INT CONST mark index) : + + aktuelle ypos := a ypos + (mark font offsets ISUB 1); + neuer token index; + tf := mark token (mark index); + IF mark offsets THEN lege offsets an (mark font offsets) FI; + + . mark font offsets : y offsets (mark token (mark index). font) + + . mark offsets : LENGTH mark font offsets > 2 + +END PROC lege markierungs token an; + + +PROC lege offsets an (TEXT CONST offsets) : + + INT CONST anzahl offsets := LENGTH offsets DIV 2; + offset token := tf; + offset token. block token := FALSE; + reset bit (offset token. modifikationen, underline bit); + FOR index FROM 2 UPTO anzahl offsets + REP aktuelle ypos := a ypos + (offsets ISUB index); + neuer token index; + tf := offset token; + tf. offset index := index; + PER; + +END PROC lege offsets an; + + +PROC neuer token index : + +IF erster ypos index a = 0 + THEN erste ypos +ELIF ya. ypos = aktuelle ypos + THEN neues token bei gleicher ypos + ELSE fuege neue ypos ein +FI; + + . erste ypos : + ypos index f INCR 1; + erster ypos index a := ypos index f; + letzter ypos index a := ypos index f; + yf. vorheriger ypos index := 0; + yf. naechster ypos index := 0; + erstes token bei neuer ypos; + + . fuege neue ypos ein : + letztes token bei gleicher ypos; + IF ya. ypos > aktuelle ypos + THEN richtige ypos ist oberhalb + ELSE richtige ypos ist unterhalb + FI; + + . richtige ypos ist oberhalb : + REP ypos index a := ya. vorheriger ypos index; + IF ypos index a = 0 + THEN fuege ypos vor erstem ypos index ein; + LEAVE richtige ypos ist oberhalb; + ELIF ya. ypos = aktuelle ypos + THEN neues token bei neuer ypos; + LEAVE richtige ypos ist oberhalb; + ELIF ya. ypos < aktuelle ypos + THEN fuege ypos nach ypos index ein; + LEAVE richtige ypos ist oberhalb; + FI; + PER; + + . richtige ypos ist unterhalb : + REP ypos index a := ya. naechster ypos index; + IF ypos index a = 0 + THEN fuege ypos nach letztem ypos index ein; + LEAVE richtige ypos ist unterhalb; + ELIF ya. ypos = aktuelle ypos + THEN neues token bei neuer ypos; + LEAVE richtige ypos ist unterhalb; + ELIF ya. ypos > aktuelle ypos + THEN fuege ypos vor ypos index ein; + LEAVE richtige ypos ist unterhalb; + FI; + PER; + + . fuege ypos vor erstem ypos index ein : + ypos index f INCR 1; + yf. vorheriger ypos index := 0; + yf. naechster ypos index := erster ypos index a; + erster ypos index a := ypos index f; + ypos index a := yf. naechster ypos index; + ya. vorheriger ypos index := ypos index f; + erstes token bei neuer ypos; + + . fuege ypos nach ypos index ein : + ypos index f INCR 1; + yf. vorheriger ypos index := ypos index a; + yf. naechster ypos index := ya. naechster ypos index; + ya. naechster ypos index := ypos index f; + ypos index a := yf. naechster ypos index; + ya. vorheriger ypos index := ypos index f; + erstes token bei neuer ypos; + + . fuege ypos vor ypos index ein : + ypos index f INCR 1; + yf. naechster ypos index := ypos index a; + yf. vorheriger ypos index := ya. vorheriger ypos index; + ya. vorheriger ypos index := ypos index f; + ypos index a := yf. vorheriger ypos index; + ya. naechster ypos index := ypos index f; + erstes token bei neuer ypos; + + . fuege ypos nach letztem ypos index ein : + ypos index f INCR 1; + yf. naechster ypos index := 0; + yf. vorheriger ypos index := letzter ypos index a; + letzter ypos index a := ypos index f; + ypos index a := yf. vorheriger ypos index; + ya. naechster ypos index := ypos index f; + erstes token bei neuer ypos; + +END PROC neuer token index; + + +PROC erstes token bei neuer ypos : + token index f INCR 1; + ypos index a := ypos index f; + ya. erster token index := token index f; + ya. ypos := aktuelle ypos; +END PROC erstes token bei neuer ypos; + + +PROC neues token bei neuer ypos : + token index f INCR 1; + ya. ypos := aktuelle ypos; + token index := ya. letzter token index; + t. naechster token index := token index f; +END PROC neues token bei neuer ypos; + + +PROC neues token bei gleicher ypos : + tf. naechster token index := token index f + 1; + token index f INCR 1; +END PROC neues token bei gleicher ypos; + + +PROC letztes token bei gleicher ypos : + tf. naechster token index := 0; + ya. letzter token index := token index f; +END PROC letztes token bei gleicher ypos; + + +PROC loesche letztes token : + + IF token index f = ya. erster token index + THEN loesche ypos + ELSE token index f DECR 1; + FI; + + . loesche ypos : + kette vorgaenger um; + kette nachfolger um; + bestimme letzten ypos index; + + . kette vorgaenger um : + ypos index := ya. vorheriger ypos index; + IF ypos index = 0 + THEN erster ypos index a := ya. naechster ypos index; + ELSE y. naechster ypos index := ya. naechster ypos index; + FI; + + . kette nachfolger um : + ypos index := ya. naechster ypos index; + IF ypos index = 0 + THEN letzter ypos index a := ya. vorheriger ypos index; + ELSE y. vorheriger ypos index := ya. vorheriger ypos index; + FI; + + . bestimme letzten ypos index : + IF ypos index a = ypos index f THEN ypos index f DECR 1 FI; + token index f DECR 1; + ypos index a := letzter ypos index a; + WHILE ypos index a <> 0 + CAND ya. letzter token index <> token index f + REP ypos index a := ya. vorheriger ypos index PER; + +END PROC loesche letztes token; + + +PROC blocke token xpos (INT CONST dehnung 1, dehnung 2, + anzahl dehnungen fuer dehnung 1 ) : + + INT VAR dehnung := 0, anzahl dehnungen := 0; + token index := erstes tab token; + WHILE token index <= token index f + REP erhoehe token xpos bei block token; + t. xpos INCR dehnung; + token index INCR 1; + PER; + + . erhoehe token xpos bei block token : + IF t. block token + THEN IF anzahl dehnungen < anzahl dehnungen fuer dehnung 1 + THEN anzahl dehnungen INCR 1; + dehnung INCR dehnung 1; + ELSE dehnung INCR dehnung 2; + FI; + FI; + +END PROC blocke token xpos; + + +PROC verschiebe token xpos (INT CONST verschiebung) : + + token index := erstes tab token; + WHILE token index <= token index f + REP t. xpos INCR verschiebung; + token index INCR 1; + PER; + +END PROC verschiebe token xpos; + + +PROC verschiebe token ypos (INT CONST verschiebung) : + + ypos index := erster ypos index a; + WHILE ypos index <> 0 + REP y. ypos INCR verschiebung; + ypos index := y. naechster ypos index; + PER; + +END PROC verschiebe token ypos; + + +PROC sortiere neue token ein : + +IF analysespeicher ist nicht leer + THEN IF druckspeicher ist nicht leer + THEN sortiere neue token in sortierte liste ein + ELSE sortierte liste ist leer + FI; +FI; + +. sortierte liste ist leer : + IF erster ypos index a <> 0 + THEN erster ypos index d := erster ypos index a; + letzter ypos index d := letzter ypos index a; + ypos index d := letzter ypos index a; + FI; + +. sortiere neue token in sortierte liste ein : + gehe zum ersten neuen token; + bestimme erste einsortierposition; + WHILE es gibt noch neue token + REP IF ypos index d = 0 + THEN haenge neue token ans ende der sortierten liste + ELIF ya. ypos > yd. ypos + THEN naechste ypos der sortierten liste + ELIF ya. ypos = yd. ypos + THEN neues token auf gleicher ypos + ELSE neue token vor ypos + FI; + PER; + + . gehe zum ersten neuen token : + ypos index a := erster ypos index a; + + . bestimme erste einsortierposition : + WHILE ypos index d <> 0 CAND ya. ypos < yd. ypos + REP ypos index d := yd. vorheriger ypos index PER; + IF ypos index d = 0 THEN erste neue token vor listen anfang FI; + + . erste neue token vor listen anfang : + ypos index d := erster ypos index d; + erster ypos index d := erster ypos index a; + REP ypos index a := ya. naechster ypos index; + IF ypos index a = 0 + THEN verkette letztes ya mit yd; + LEAVE sortiere neue token in sortierte liste ein + ELIF ya. ypos = yd. ypos + THEN verkette ya mit yd; + LEAVE erste neue token vor listen anfang + ELIF ya. ypos > yd. ypos + THEN verkette vorheriges ya mit yd; + ypos index d := yd. naechster ypos index; + LEAVE erste neue token vor listen anfang + FI; + PER; + + . es gibt noch neue token : + ypos index a <> 0 + + . haenge neue token ans ende der sortierten liste : + ypos index d := letzter ypos index d; + yd. naechster ypos index := ypos index a; + ya. vorheriger ypos index := ypos index d; + letzter ypos index d := letzter ypos index a; + ypos index d := letzter ypos index a; + ypos index a := 0; + + . naechste ypos der sortierten liste : + ypos index d := yd. naechster ypos index; + + . neues token auf gleicher ypos : + token index := yd. letzter token index; + t . naechster token index := ya. erster token index; + yd. letzter token index := ya. letzter token index; + ypos index a := ya. naechster ypos index; + ypos index d := yd. naechster ypos index; + IF ypos index d = 0 THEN ypos index d := letzter ypos index d FI; + + . neue token vor ypos : + verkette ya mit vorherigem yd; + REP ypos index a := ya. naechster ypos index; + IF ypos index a = 0 + THEN verkette letztes ya mit yd; + LEAVE sortiere neue token in sortierte liste ein + ELIF ya. ypos = yd. ypos + THEN verkette ya mit yd; + LEAVE neue token vor ypos + ELIF ya. ypos > yd. ypos + THEN verkette vorheriges ya mit yd; + ypos index d := yd. naechster ypos index; + LEAVE neue token vor ypos + FI; + PER; + + +. verkette ya mit vorherigem yd : + index := ypos index d; + ypos index d := yd. vorheriger ypos index; + yd. naechster ypos index := ypos index a; + ya. vorheriger ypos index := ypos index d; + ypos index d := index; + +. verkette letztes ya mit yd : + ypos index a := letzter ypos index a; + yd. vorheriger ypos index := ypos index a; + ya. naechster ypos index := ypos index d; + ypos index a := 0; + +. verkette vorheriges ya mit yd : + index := ypos index a; + ypos index a := ya. vorheriger ypos index; + yd. vorheriger ypos index := ypos index a; + ya. naechster ypos index := ypos index d; + ypos index a := index; + +. verkette ya mit yd : + verkette vorheriges ya mit yd; + neues token auf gleicher ypos; + +END PROC sortiere neue token ein; + +(***************************************************************) + +PROC drucke tokenspeicher + (INT CONST max ypos, + PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) : + +IF druckspeicher ist nicht leer + THEN gehe zur ersten ypos; + WHILE yd. ypos <= max ypos + REP drucke token bei ypos; + gehe zur naechsten ypos; + PER; + loesche gedruckte token; +FI; + +. gehe zur ersten ypos : + ypos index d := erster ypos index d; + +. drucke token bei ypos : + IF yd. ypos >= - y start + THEN druck durchgang; + IF bold pass THEN fett durchgang FI; + IF underline pass THEN unterstreich durchgang FI; + FI; + + . bold pass : bit (pass, bold bit) + + . underline pass : bit (pass, underline bit) + +. gehe zur naechsten ypos : + IF ypos index d = letzter ypos index d + THEN loesche druckspeicher; + LEAVE drucke tokenspeicher; + FI; + ypos index d := yd. naechster ypos index; + +. loesche gedruckte token : + erster ypos index d := ypos index d; + yd. vorheriger ypos index := 0; + +. + druck durchgang : + verschiebung := yd. ypos - d ypos; + y move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute); + gehe zum ersten token dieser ypos; + REP drucke token UNTIL kein token mehr vorhanden PER; + gib cr aus; + + . drucke token : + IF NOT token passt in zeile THEN berechne token teil FI; + font wechsel wenn noetig; + x move mit modifikations ueberpruefung; + IF token ist text token + THEN gib text token aus + (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute); + ELSE gib kommando token aus + FI; + + . gib kommando token aus : + execute (write cmd, d token. text, 1, LENGTH d token. text) + + . berechne token teil : + INT CONST fuenf punkte := 5 * char pitch (d token. font, punkt); + INT VAR token pos, token breite, anzahl punkte, zeichen laenge, zeichen breite; + IF d token. xpos < - x start + AND d token. xpos + d token. breite > - x start + THEN berechne token teil von links + ELIF d token. xpos < papierbreite + AND d token. xpos + d token. breite > papierbreite + THEN berechne token teil nach rechts + ELSE LEAVE drucke token + FI; + + . berechne token teil von links : + rest := min (x size, d token. xpos + d token. breite + x start); + d token. xpos := - x start; + IF rest <= fuenf punkte + THEN anzahl punkte := rest DIV char pitch (d token. font, punkt); + d token. text := anzahl punkte * punkt; + d token. breite := anzahl punkte * char pitch (d token. font, punkt); + ELSE token pos := LENGTH d token. text + 1; + token breite := fuenf punkte; + berechne token teil breite von hinten; + change (d token. text, 1, token pos - 1, 5 * punkt); + d token. breite := token breite; + FI; + + . berechne token teil breite von hinten : + WHILE naechstes zeichen passt noch davor + REP token breite INCR zeichen breite; + token pos DECR zeichen laenge; + PER; + + . naechstes zeichen passt noch davor : + IF within kanji (d token. text, token pos - 1) + THEN zeichen laenge := 2 + ELSE zeichen laenge := 1 + FI; + zeichen breite := char pitch (d token. font, + subtext (d token. text, token pos - zeichen laenge, token pos - 1)); + token breite + zeichen breite < rest + + . berechne token teil nach rechts : + rest := papier breite - d token. xpos; + IF rest <= fuenf punkte + THEN anzahl punkte := rest DIV char pitch (d token. font, punkt); + d token. text := anzahl punkte * punkt; + d token. breite := anzahl punkte * char pitch (d token. font, punkt); + ELSE token pos := 0; + token breite := fuenf punkte; + berechne token teil breite von vorne; + change (d token. text, token pos + 1, LENGTH d token. text, 5 * punkt); + d token. breite := token breite; + FI; + + . berechne token teil breite von vorne : + WHILE naechstes zeichen passt noch dahinter + REP token breite INCR zeichen breite; + token pos INCR zeichen laenge; + PER; + + . naechstes zeichen passt noch dahinter : + IF is kanji esc (d token. text SUB token pos + 1) + THEN zeichen laenge := 2 + ELSE zeichen laenge := 1 + FI; + zeichen breite := char pitch (d token. font, + subtext (d token. text, token pos + 1, token pos + zeichen laenge)); + token breite + zeichen breite < rest + +. + fett durchgang : + reset bit (pass, bold bit); + gehe zum ersten token dieser ypos; + REP gib token nochmal aus UNTIL kein token mehr vorhanden PER; + schalte modifikationen aus wenn noetig; + gib cr aus; + + . gib token nochmal aus : + INT CONST min verschiebung := bold offset (d token. font); + d token. xpos INCR min verschiebung; + IF bit (d token. modifikationen, bold bit) AND + token passt in zeile AND token ist text token + THEN verschiebung := d token. xpos - d xpos; + font wechsel wenn noetig; + schalte italics ein wenn noetig; + x move wenn noetig; + gib text token aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute); + FI; + d token. xpos DECR min verschiebung; + + . schalte italics ein wenn noetig : + IF bit (d token. modifikationen, italics bit) + THEN neue modifikationen := modifikations werte (italics bit + 1); + schalte modifikationen ein wenn noetig; + ELSE schalte modifikationen aus wenn noetig; + FI; + +. + unterstreich durchgang : + INT VAR l xpos := 0; + reset bit (pass, underline bit); + schalte modifikationen aus wenn noetig; + gehe zum ersten token dieser ypos; + REP unterstreiche token UNTIL kein token mehr vorhanden PER; + gib cr aus; + + . unterstreiche token : + IF token muss unterstrichen werden AND + token passt in zeile AND token ist text token + THEN font wechsel wenn noetig; + berechne x move laenge; + x move wenn noetig; + berechne unterstreich laenge; + unterstreiche; + FI; + l xpos := d token. xpos + d token. breite; + + . token muss unterstrichen werden : + bit (d token. modifikationen, underline bit) OR + bit (d token. modifikationen fuer x move, underline bit) + + . berechne x move laenge : + IF bit (d token. modifikationen fuer x move, underline bit) + THEN verschiebung := l xpos - d xpos + ELSE verschiebung := d token. xpos - d xpos + FI; + + . berechne unterstreich laenge : + INT VAR unterstreich verschiebung; + IF bit (d token. modifikationen, underline bit) + THEN unterstreich verschiebung := d token. xpos + + d token. breite - d xpos + ELSE unterstreich verschiebung := d token. xpos - d xpos + FI; + + +. gehe zum ersten token dieser ypos : + token index := yd. erster token index; + d token := t; + +. kein token mehr vorhanden : + token index := d token. naechster token index; + IF token index = 0 + THEN TRUE + ELSE d token := t; + FALSE + FI + +. token ist text token : + d token. offset index >= text token + +. token passt in zeile : + d token. xpos >= - x start AND + d token. xpos + d token. breite <= papier breite + +. font wechsel wenn noetig : + IF d token. font <> d font + THEN font wechsel (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) FI; + +. schalte modifikationen ein wenn noetig : + IF d modifikationen <> neue modifikationen + THEN schalte modifikationen ein (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) FI; + +. schalte modifikationen aus wenn noetig : + IF d modifikationen <> 0 + THEN schalte modifikationen aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) FI; + +. x move wenn noetig : + IF verschiebung <> 0 + THEN x move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) FI; + +. gib cr aus : + execute (carriage return, "", d xpos, 0); + d xpos := 0; + +. + x move mit modifikations ueberpruefung : + verschiebung := d token. xpos - d xpos; + IF verschiebung <> 0 + THEN neue modifikationen := d token. modifikationen fuer x move; + schalte modifikationen ein wenn noetig; + x move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute); + FI; + neue modifikationen := d token. modifikationen; + schalte modifikationen ein wenn noetig; + +. + unterstreiche : + IF unterstreich verschiebung > 0 + THEN disable stop; + d xpos INCR unterstreich verschiebung; + execute (draw, "", unterstreich verschiebung, 0); + IF is error + THEN unterstreiche nach cr; + FI; + enable stop; + FI; + + . unterstreiche nach cr : + clear error; + d xpos DECR unterstreich verschiebung; + verschiebung := d xpos; + gib cr aus; + x move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute); + d xpos INCR unterstreich verschiebung; + execute (draw, "", unterstreich verschiebung, 0); + IF is error + THEN clear error; + d xpos DECR unterstreich verschiebung; + gib cr aus; + LEAVE unterstreich durchgang; + FI; + +END PROC drucke tokenspeicher; + +PROC y move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) : + + IF verschiebung <> 0 + THEN disable stop; + d ypos INCR verschiebung; + execute (move, "", 0, verschiebung); + IF is error + THEN clear error; + d ypos DECR verschiebung; + verschiebung := 0; + FI; + enable stop; + FI; + +END PROC y move; + + +PROC x move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) : + + disable stop; + d xpos INCR verschiebung; + execute (move, "", verschiebung, 0); + IF is error + THEN fuehre x move nach cr aus + FI; + + . fuehre x move nach cr aus : + clear error; + schalte modifikationen aus wenn noetig; + gib cr aus; + IF d xpos <> 0 + THEN execute (move, "", d xpos, 0); + IF is error + THEN clear error; + d xpos := 0; + FI + FI; + schalte modifikationen ein wenn noetig; + + . gib cr aus : + execute (carriage return, "", d xpos - verschiebung, 0); + + . schalte modifikationen aus wenn noetig : + neue modifikationen := d modifikationen; + IF d modifikationen <> 0 + THEN schalte modifikationen aus + (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute); + FI; + + . schalte modifikationen ein wenn noetig : + IF d modifikationen <> neue modifikationen + THEN schalte modifikationen ein + (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute); + FI; + +END PROC x move; + + +PROC schalte modifikationen ein + (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) : + + disable stop; + INT VAR index; + IF d modifikationen <> 0 + THEN schalte modifikationen aus + (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute); + FI; + d modifikationen := neue modifikationen; + FOR index FROM 1 UPTO anzahl modifikationen + REP IF bit (d modifikationen, modifikations bit) + THEN modifikation muss eingeschaltet werden + FI; + PER; + + . modifikations bit : index - 1 + + . modifikation muss eingeschaltet werden : + IF bit (modifikations modus, modifikations bit) + THEN execute (on, "", modifikations werte (index), 0); + IF is error + THEN clear error; + reset bit (modifikations modus, modifikations bit); + set bit (pass, modifikations bit); + FI; + ELSE set bit (pass, modifikations bit); + FI; + +END PROC schalte modifikationen ein; + + +PROC schalte modifikationen aus + (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) : + + disable stop; + INT VAR index; + FOR index FROM 1 UPTO anzahl modifikationen + REP IF bit (d modifikationen, modifikations bit) + THEN modifikation muss ausgeschaltet werden + FI; + PER; + d modifikationen := 0; + + . modifikations bit : index - 1 + + . modifikation muss ausgeschaltet werden : + IF bit (modifikations modus, modifikations bit) + THEN execute (off, "", modifikations werte (index), 0); + IF is error THEN clear error FI; + FI; + +END PROC schalte modifikationen aus; + + +PROC font wechsel + (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) : + + disable stop; + d font := d token. font; + get replacements (d font, replacements, replacement tabelle); + execute (type, "", d font, 0); + IF is error THEN font wechsel nach cr FI; + enable stop; + + . font wechsel nach cr : + clear error; + verschiebung := d xpos; + gib cr aus; + execute (type, "", d font, 0); + IF NOT is error + THEN schalte modifikationen aus + (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute); + x move + (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute); + FI; + + . gib cr aus : + execute (carriage return, "", d xpos, 0); + d xpos := 0; + +END PROC font wechsel; + + +PROC gib text token aus + (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) : + + INT CONST token laenge := LENGTH d token. text; + INT VAR token pos := 1, alte token pos, summe := 0; + IF token laenge > 0 + THEN REP alte token pos := token pos; + stranalyze (replacement tabelle, summe, 0, + d token. text, token pos, token laenge, + ausgang); + IF ausgang = 0 + THEN gib token rest aus; + ELSE gib token teil aus; + gib ersatzdarstellung aus; + FI; + PER; + FI; + + . gib token rest aus : + IF token laenge >= alte token pos + THEN execute (write text, d token. text, alte token pos, token laenge) FI; + d xpos INCR d token. breite; + LEAVE gib text token aus; + + . gib token teil aus : + IF token pos >= alte token pos + THEN execute (write text, d token. text, alte token pos, token pos) FI; + + . gib ersatzdarstellung aus : + IF ausgang = maxint + THEN ersatzdarstellung := extended replacement (d token. font, + d token. text SUB token pos + 1, d token. text SUB token pos + 2); + execute (write text, ersatzdarstellung, 1, LENGTH ersatzdarstellung); + tokenpos INCR 3; + ELSE IF ausgang < 0 + THEN ausgang := ausgang XOR (-32767-1); + token pos INCR 1; + FI; + execute (write text, replacements, ausgang + 1, ausgang + code (replacements SUB ausgang)); + token pos INCR 2; + FI; + + . ersatzdarstellung : par1 + +END PROC gib text token aus; + + +PROC schliesse seite ab (PROC (INT CONST, INT CONST) close, + PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) : + +enable stop; +gebe restliche token aus; +seiten ende kommando; + +. gebe restliche token aus : + IF erster ypos index d <> 0 + THEN drucke tokenspeicher (maxint, + PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute); + FI; + rest := papier laenge - d ypos; + +. seiten ende kommando : + seite ist offen := FALSE; + a ypos := top margin; + aktuelle spalte := 1; + close (page, rest); + +END PROC schliesse seite ab; + + +PROC eroeffne seite (INT CONST x wanted, y wanted, + PROC (INT CONST, INT VAR, INT VAR) open ) : + +IF vor erster seite THEN eroeffne druck FI; +seiten anfang kommando; +initialisiere neue seite; + +. eroeffne druck : + open (document, x size, y size); + vor erster seite := FALSE; + d font := -1; + d modifikationen := 0; + +. seiten anfang kommando : + x start := x wanted; + y start := y wanted; + open (page, x start, y start); + gedruckte seiten INCR 1; + seite ist offen := TRUE; + +. initialisiere neue seite : + INT CONST dif left margin := x wanted - x start - left margin + indentation, + dif top margin := y wanted - y start - top margin; + IF dif left margin <> 0 + THEN erstes tab token := 1; + verschiebe token xpos (dif left margin); + a xpos INCR dif left margin; + left margin INCR dif left margin; + FI; + IF dif top margin <> 0 + THEN verschiebe token ypos (dif top margin); + a ypos INCR dif top margin; + top margin INCR dif top margin; + FI; + d xpos := 0; + d ypos := 0; + IF seitenlaenge <= papierlaenge + THEN seitenlaenge := top margin + pagelength; + ELSE seitenlaenge DECR papierlaenge; + FI; + papierlaenge := y size - y start; + papierbreite := x size - x start; + +END PROC eroeffne seite; + +(****************************************************************) + +PROC elan fuss und kopf (INT CONST fuss oder kopf, + PROC (INT CONST, INT CONST) close, + PROC (INT CONST, INT VAR, INT VAR) open, + PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) : + +IF fuss oder kopf <= 0 THEN elan fuss FI; +IF fuss oder kopf >= 0 THEN elan kopf FI; + +. + elan fuss : + y move zur fusszeile; + drucke elan fuss; + close page cmd; + +. y move zur fusszeile : + execute (carriage return, "", d xpos, 0); + d xpos := 0; + verschiebung := rest auf seite - font hoehe; + y move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute); + +. drucke elan fuss : + IF bottom label = "" + THEN seiten nr := "" + ELSE seiten nr := bottom label; + seiten nr CAT "/"; + FI; + seiten nr CAT text (gedruckte seiten); + elan text := seiten nr; + elan text CAT " "; + elan text cat blanks ((max zeichen fuss - LENGTH dateiname) DIV 2 - LENGTH elan text); + elan text CAT dateiname; + elan text cat blanks (max zeichen fuss - LENGTH seiten nr - LENGTH elan text - 3); + elan text CAT " "; + elan text CAT seiten nr; + IF LENGTH elan text > max zeichen zeile + THEN elan text := subtext (elan text, 1, max zeichen zeile) FI; + gib elan text aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute); + + . seiten nr : par1 + +. close page cmd : + close (page, papierlaenge - d ypos); + seite ist offen := FALSE; + +. + elan kopf : + open page cmd ; + y move zur kopfzeile; + drucke elan kopf; + +. open page cmd : + x start := x wanted; + y start := y wanted; + open (page, x start, y start); + IF fuss oder kopf = 1 THEN execute (type, "", d font, 0) FI; + gedruckte seiten INCR 1; + seite ist offen := TRUE; + top margin := y wanted - y start; + left margin := x wanted - x start; + rest auf seite := pagelength; + papierlaenge := y size - y start; + d ypos := 0; + d xpos := 0; + +. y move zur kopf zeile : + verschiebung := top margin; + y move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute); + IF verschiebung = 0 THEN rest auf seite INCR top margin FI; + +. drucke elan kopf : + elan text := headline pre; + elan text CAT date; + elan text CAT headline post; + elan text CAT datei name; + IF LENGTH elan text > max zeichen zeile + THEN elan text := subtext (elan text, 1, max zeichen zeile) FI; + gib elan text aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute); + cr plus lf (2, PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute); + +ENDPROC elan fuss und kopf; + + +PROC gib elan text aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) : + +cr plus lf (1, PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute); +linker rand wenn noetig; +d token. breite := LENGTH elan text * einrueckbreite; +gib text token aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute); + +. linker rand wenn noetig : + IF left margin > 0 + THEN disable stop; + d xpos := left margin; + execute (move, "", left margin, 0); + IF is error + THEN clear error; + d xpos := 0; + FI; + enable stop; + FI; + +END PROC gib elan text aus; + + +PROC cr plus lf (INT CONST anzahl, + PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) : + +gib cr aus; +gib lf aus; +rest auf seite DECR verschiebung; + +. gib cr aus : + execute (carriage return, "", d xpos, 0); + d xpos := 0; + +. gib lf aus : + verschiebung := anzahl * font hoehe; + y move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute); + +END PROC cr plus lf ; + + +END PACKET eumel printer; + diff --git a/system/multiuser/1.7.5/src/font store b/system/multiuser/1.7.5/src/font store new file mode 100644 index 0000000..ebb6a62 --- /dev/null +++ b/system/multiuser/1.7.5/src/font store @@ -0,0 +1,695 @@ +PACKET font store (* Autor : Rudolf Ruland *) + (* Stand : 18.02.86 *) + DEFINES font table, + list font tables, + list fonts, + + x step conversion, + y step conversion, + on string, + off string, + + font, + font exists, + next larger font exists, + next smaller font exists, + font lead, + font height, + font depth, + indentation pitch, + char pitch, + extended char pitch, + replacement, + extended replacement, + font string, + y offsets, + bold offset, + get font, + get replacements : + + +LET font task = "configurator"; + +LET ack = 0, + fetch code = 11, + all code = 17, + + underline = 1, + bold = 2, + italics = 4, + reverse = 8, + + first font = 1, + max fonts = 50, + max extensions = 120, + font table type = 3009, + + FONTTABLE = STRUCT ( + + THESAURUS font names, + + TEXT replacements, font name links, + extension chars, extension indexes, + + ROW 4 TEXT on strings, off strings, + + REAL x unit, y unit, + + ROW 256 INT replacements table, + + INT last font, last extension + + ROW max fonts STRUCT ( + TEXT font string, font name indexes, replacements, + extension chars, extension indexes, y offsets, + ROW 256 INT pitch table, replacements table, + INT indentation pitch, font lead, font height, font depth, + next larger font, next smaller font, bold offset ) fonts , + + ROW max extensions STRUCT ( + TEXT replacements, + ROW 256 INT pitch table, replacements table, + INT std pitch ) extensions , + + ); + +INT VAR font nr, help, reply, list index, last font, + index, char code 1, link nr, font store replacements length; + +TEXT VAR fo table := "", old font table, font name links, buffer; + +THESAURUS VAR font tables, font names; + +INITFLAG VAR in this task := FALSE, + init font ds := FALSE, + init ds := FALSE; + +BOUND FONTTABLE VAR font store; + +BOUND STRUCT (TEXT name, write pass, read pass) VAR msg; + +BOUND THESAURUS VAR all msg; + +BOUND TEXT VAR error msg; + +DATASPACE VAR font ds, ds; + +(*****************************************************************) + +PROC font table (TEXT CONST new font table) : + + disable stop; + get font table (new font table); + in this task := NOT (font table = "" OR type (font ds) <> font table type); + +END PROC font table; + + +PROC get font table (TEXT CONST new font table) : + + enable stop; + buffer := new font table; + change all (buffer, " ", ""); + IF exists (buffer) CAND type (old (buffer)) = font table type + THEN get font table from own task + ELIF exists task (font task) + THEN get font table from font task + ELSE errorstop ("Fonttabelle """ + buffer + """ gibt es nicht") + FI; + + . get font table from own task : + IF NOT initialized (init ds) THEN ds := nilspace FI; + forget (ds); ds := old (buffer); + new font store; + + . get font table from font task : + fetch font table (buffer); + IF type (ds) <> font table type + THEN forget (ds); + errorstop ("Fonttabelle """ + buffer + """ gibt es nicht") + FI; + new font store; + + . new font store : + disable stop; + IF NOT initialized (init font ds) THEN font ds := nilspace FI; + forget (font ds); + font ds := ds; + forget (ds); + font store := font ds; + fo table := buffer; + font names := font store. font names; + font name links := font store. font name links; + last font := font store. last font; + font store replacements length := LENGTH font store. replacements; + +END PROC get font table; + + +TEXT PROC font table : + + fo table + +END PROC font table; + + +PROC list font tables : + + enable stop; + font tables := empty thesaurus; + font tables in own task; + font tables in font task; + note font tables; + note edit; + + . font tables in own task : + list index := 0; + REP get (all, buffer, list index); + IF buffer = "" THEN LEAVE font tables in own task FI; + IF type (old (buffer)) = font table type + AND NOT (font tables CONTAINS buffer) + THEN insert (font tables, buffer) FI; + PER; + + . font tables in font task : + all file names from font task; + THESAURUS CONST names := all msg; + list index := 0; + REP get (names, buffer, list index); + IF buffer = "" + THEN forget (ds); + LEAVE font tables in font task + FI; + fetch font table (buffer); + IF type (ds) = font table type + AND NOT (font tables CONTAINS buffer) + THEN insert (font tables, buffer) FI; + PER; + + . note font tables : + list index := 0; + REP get (font tables, buffer, list index); + IF buffer = "" + THEN LEAVE note font tables; + ELSE note (buffer); note line; + FI; + PER; + +END PROC list font tables; + + +PROC list fonts (TEXT CONST name): + + initialize if necessary; + disable stop; + old font table := font table; + font table (name); + list fonts; + font table (old font table); + +END PROC list fonts; + + +PROC list fonts : + + enable stop; + initialize if necessary; + note font table; + FOR font nr FROM first font UPTO last font REP note font PER; + note edit; + +. note font table : + note ("FONTTABELLE : """); note (font table); note (""";"); noteline; + note (" x einheit = "); note (text (font store. x unit)); note (";"); noteline; + note (" y einheit = "); note (text (font store. y unit)); note (";"); noteline; + +. note font : + cout (font nr); + noteline; + note (" FONT : "); note font names; note (";"); noteline; + note (" einrueckbreite = "); note (text(font. indentation pitch)); note (";"); noteline; + note (" durchschuss = "); note (text(font. font lead)); note (";"); noteline; + note (" fonthoehe = "); note (text(font. font height)); note (";"); noteline; + note (" fonttiefe = "); note (text(font. font depth)); note (";"); noteline; + note (" groesserer font = """); note (next larger); note (""";"); noteline; + note (" kleinerer font = """); note (next smaller); note (""";"); noteline; + + . font : font store. fonts (font nr) + . next larger : name (font store. font names, font. next larger font) + . next smaller : name (font store. font names, font. next smaller font) + + . note font names : + INT VAR index; + note (""""); + note (name (font names, font. font name indexes ISUB 1)); + note (""""); + FOR index FROM 2 UPTO LENGTH font. font name indexes DIV 2 + REP note (", """); + note (name (font names, font. font name indexes ISUB index)); + note (""""); + PER; + +END PROC list fonts; + + +INT PROC x step conversion (REAL CONST cm) : + + initialize if necessary; + IF cm >= 0.0 + THEN int (cm * font store. x unit + 0.5 ) + ELSE int (cm * font store. x unit - 0.5 ) + FI + +END PROC x step conversion; + + +REAL PROC x step conversion (INT CONST steps) : + + initialize if necessary; + real (steps) / font store. x unit + +END PROC x step conversion; + + +INT PROC y step conversion (REAL CONST cm) : + + initialize if necessary; + IF cm >= 0.0 + THEN int (cm * font store. y unit + 0.5 ) + ELSE int (cm * font store. y unit - 0.5 ) + FI + +END PROC y step conversion; + + +REAL PROC y step conversion (INT CONST steps) : + + initialize if necessary; + real (steps) / font store. y unit + +END PROC y step conversion; + + +TEXT PROC on string (INT CONST modification) : + + initialize if necessary; + SELECT modification OF + CASE underline : font store. on strings (1) + CASE bold : font store. on strings (2) + CASE italics : font store. on strings (3) + CASE reverse : font store. on strings (4) + OTHERWISE : errorstop ("unzulaessige Modifikation"); "" + END SELECT + +END PROC on string; + + +TEXT PROC off string (INT CONST modification) : + + initialize if necessary; + SELECT modification OF + CASE underline : font store. off strings (1) + CASE bold : font store. off strings (2) + CASE italics : font store. off strings (3) + CASE reverse : font store. off strings (4) + OTHERWISE : errorstop ("unzulaessige Modifikation"); "" + END SELECT + +END PROC off string; + + +INT PROC font (TEXT CONST font name) : + + initialize if necessary; + buffer := font name; + change all (buffer, " ", ""); + INT CONST link nr := link (font names, buffer) + IF link nr <> 0 + THEN font name links ISUB link nr + ELSE 0 + FI + +END PROC font; + + +TEXT PROC font (INT CONST font number) : + + initialize if necessary; + IF font number >= first font AND font number <= last font + THEN name (font names, fonts. font name indexes ISUB 1) + ELSE "" + FI + + . fonts : font store. fonts (font number) + +END PROC font; + + +BOOL PROC font exists (TEXT CONST font name) : + + font (font name) <> 0 + +END PROC font exists; + + +BOOL PROC next larger font exists(INT CONST font number, + INT VAR next larger font) : + + initialize if necessary; + IF font number >= first font AND font number <= last font + THEN next larger font := fonts. next larger font; + IF next larger font <> 0 + THEN next larger font := font name links ISUB next larger font; + next larger font <> 0 + ELSE FALSE + FI + ELSE errorstop ("Font " + text (font number) + " gibt es nicht"); + FALSE + FI + + . fonts : font store. fonts (font number) + +END PROC next larger font exists; + + +BOOL PROC next smaller font exists (INT CONST font number, + INT VAR next smaller font) : + + initialize if necessary; + IF font number >= first font AND font number <= last font + THEN next smaller font := fonts. next smaller font; + IF next smaller font <> 0 + THEN next smaller font := font name links ISUB next smaller font; + next smaller font <> 0 + ELSE FALSE + FI + ELSE errorstop ("Font " + text (font number) + " gibt es nicht"); + FALSE + FI + + . fonts : font store. fonts (font number) + +END PROC next smaller font exists; + + +INT PROC font lead (INT CONST font number) : + + initialize if necessary; + IF font number >= first font AND font number <= last font + THEN fonts. font lead + ELSE errorstop ("Font " + text (font number) + " gibt es nicht"); 0 + FI + + . fonts : font store. fonts (font number) + +END PROC font lead; + + +INT PROC font height (INT CONST font number) : + + initialize if necessary; + IF font number >= first font AND font number <= last font + THEN fonts. font height + ELSE errorstop ("Font " + text (font number) + " gibt es nicht"); 0 + FI + + . fonts : font store. fonts (font number) + +END PROC font height; + + +INT PROC font depth (INT CONST font number) : + + initialize if necessary; + IF font number >= first font AND font number <= last font + THEN fonts. font depth + ELSE errorstop ("Font " + text (font number) + " gibt es nicht"); 0 + FI + + . fonts : font store. fonts (font number) + +END PROC font depth; + + +INT PROC indentation pitch (INT CONST font number) : + + initialize if necessary; + IF font number >= first font AND font number <= last font + THEN fonts. indentation pitch + ELSE errorstop ("Font " + text (font number) + " gibt es nicht"); 0 + FI + + . fonts : font store. fonts (font number) + +END PROC indentation pitch; + + +INT PROC char pitch (INT CONST font number, + TEXT CONST char ) : + + initialize if necessary; + IF font number >= first font AND font number <= last font + THEN INT CONST pitch := font. pitch table (code (char SUB 1) + 1); + IF pitch = maxint + THEN extended char pitch (font number, char SUB 1, char SUB 2) + ELIF pitch < 0 + THEN pitch XOR (-maxint-1) + ELSE pitch + FI + ELSE errorstop ("Font " + text (font number) + " gibt es nicht"); 0 + FI + + . font : font store. fonts (font number) + +END PROC char pitch; + + +INT PROC extended char pitch (INT CONST font number, + TEXT CONST esc char, char) : + + initialize if necessary; + IF font number >= first font AND font number <= last font + THEN extension. pitch table (code (char) + 1) + ELSE errorstop ("Font " + text (font number) + " gibt es nicht"); 0 + FI + + . font : font store. fonts (font number) + + . extension : font store. extensions (extension number) + + . extension number : + INT CONST index := pos (font. extension chars, esc char); + IF index = 0 + THEN errorstop ("""" + esc char + char + """ hat keine Erweiterung") FI; + font. extension indexes ISUB index + +END PROC extended char pitch; + + +TEXT PROC replacement (INT CONST font number, + TEXT CONST char ) : + + initialize if necessary; + IF font number >= first font AND font number <= last font + THEN link nr := font. replacements table (code (char SUB 1) + 1); + IF link nr = maxint + THEN extended replacement (font number, char SUB 1, char SUB 2) + ELSE process font replacement + FI + ELSE errorstop ("Font " + text (font number) + " gibt es nicht"); "" + FI + + . font : font store. fonts (font number) + + . process font replacement : + IF link nr < 0 THEN link nr := link nr XOR (-maxint-1) FI; + IF link nr = 0 + THEN char + ELIF link nr > font store replacements length + THEN link nr DECR font store replacements length; + replacement text (font. replacements) + ELSE replacement text (font store. replacements) + FI + +END PROC replacement; + + +TEXT PROC extended replacement (INT CONST font number, + TEXT CONST esc char, char ) : + + initialize if necessary; + IF font number >= first font AND font number <= last font + THEN process extension replacement + ELSE errorstop ("Font " + text (font number) + " gibt es nicht"); "" + FI + + . process extension replacement : + determine extension link nr; + IF link nr = 0 + THEN char + ELIF link nr > font store extension replacements length + THEN link nr DECR font store extension replacements length; + replacement text (font extension. replacements) + ELSE replacement text (font store extension. replacements) + FI + + . determine extension link nr : + INT CONST index 1 := pos (font. extension chars, esc char); + INT CONST index 2 := pos (font store. extension chars, esc char); + IF index 1 <> 0 + THEN link nr := font extension. replacements table (code (char) + 1); + ELIF index 2 <> 0 + THEN link nr := font store extension. replacements table (code (char) + 1); + ELSE errorstop ("""" + esc char + char + """ hat keine Erweiterung") + FI; + + . font extension : font store. extensions (font extension number) + + . font extension number : font. extension indexes ISUB index 1 + + . font : font store. fonts (font number) + + . font store extension : font store. extensions (font store extension number) + + . font store extension number : font store. extension indexes ISUB index 2 + + . font store extension replacements length : + IF index 2 = 0 + THEN 0 + ELSE LENGTH font store extension. replacements + FI + +END PROC extended replacement; + + +TEXT PROC replacement text (TEXT CONST replacements) : + + buffer := subtext (replacements, link nr + 1, + link nr + code (replacements SUB link nr)); + buffer + +END PROC replacement text; + + +TEXT PROC font string (INT CONST font number) : + + initialize if necessary; + IF font number >= first font AND font number <= last font + THEN fonts. font string + ELSE errorstop ("Font " + text (font number) + " gibt es nicht"); "" + FI + + . fonts : font store. fonts (font number) + +END PROC font string; + + +TEXT PROC y offsets (INT CONST font number) : + + initialize if necessary; + IF font number >= first font AND font number <= last font + THEN fonts. y offsets + ELSE errorstop ("Font " + text (font number) + " gibt es nicht"); "" + FI + + . fonts : font store. fonts (font number) + +END PROC y offsets; + + +INT PROC bold offset (INT CONST font number) : + + initialize if necessary; + IF font number >= first font AND font number <= last font + THEN fonts. bold offset + ELSE errorstop ("Font " + text (font number) + " gibt es nicht"); 0 + FI + + . fonts : font store. fonts (font number) + +END PROC bold offset; + + +PROC get font (INT CONST font number, + INT VAR indentation pitch, font lead, font height, font depth, + ROW 256 INT VAR pitch table ) : + + initialize if necessary; + IF font number >= first font AND font number <= last font + THEN indentation pitch := fonts. indentation pitch; + pitch table := fonts. pitch table; + font lead := fonts. font lead; + font height := fonts. font height; + font depth := fonts. font depth; + ELSE errorstop ("Font " + text (font number) + " gibt es nicht"); + FI; + + . fonts : font store. fonts (font number) + +END PROC get font; + + +PROC get replacements (INT CONST font number, + TEXT VAR replacements, + ROW 256 INT VAR replacements table) : + + initialize if necessary; + IF font number >= first font AND font number <= last font + THEN replacements := font store. replacements; + replacements CAT fonts. replacements; + replacements table := fonts. replacements table; + ELSE errorstop ("Font " + text (font number) + " gibt es nicht"); + FI; + + . fonts : font store. fonts (font number) + +END PROC get replacements; + + +PROC initialize if necessary : + + IF NOT initialized (in this task) + THEN IF font table = "" + THEN in this task := FALSE; + errorstop ("Fonttabelle noch nicht eingestellt"); + ELSE font table (font table); + FI; + FI; + +END PROC initialize if necessary; + + +PROC fetch font table (TEXT CONST font table name) : + + enable stop; + IF NOT initialized (init ds) THEN ds := nilspace FI; + forget (ds); ds := nilspace; + msg := ds; + msg. name := font table name; + msg. write pass := ""; + msg. read pass := ""; + call (task (font task), fetch code, ds, reply); + IF reply <> ack + THEN errorstop ("Fonttabelle """ + font table name + """ gibt es nicht") + FI; + +END PROC fetch font table; + + +PROC all file names from font task : + + enable stop; + IF NOT initialized (init ds) THEN ds := nilspace FI; + forget (ds); ds := nilspace; + call (task (font task), all code, ds, reply); + IF reply <> ack + THEN error msg := ds; + errorstop (error msg); + ELSE all msg := ds + FI; + +END PROC all file names from font task; + + +END PACKET font store; + diff --git a/system/multiuser/1.7.5/src/global manager b/system/multiuser/1.7.5/src/global manager new file mode 100644 index 0000000..b3d64cc --- /dev/null +++ b/system/multiuser/1.7.5/src/global manager @@ -0,0 +1,683 @@ +(* ------------------- VERSION 19 16.05.86 ------------------- *) +PACKET global manager DEFINES (* Autor: J.Liedtke *) + + ALL , + begin password , + call , + continue channel , + erase , + exists , + fetch , + free global manager , + free manager , + global manager , + list , + manager message , + manager question , + save , + std manager : + + +LET ack = 0 , + nak = 1 , + error nak = 2 , + message ack = 3 , + question ack = 4 , + second phase ack = 5 , + false code = 6 , + + begin code = 4 , + password code = 9 , + fetch code = 11 , + save code = 12 , + exists code = 13 , + erase code = 14 , + list code = 15 , + all code = 17 , + free code = 20 , + continue code = 100, + + + error pre = ""7""13""10""5"FEHLER : " , + cr lf = ""13""10"" ; + +INT VAR reply , order , last order, phase number ; + +DATASPACE VAR ds := nilspace ; + +BOUND STRUCT (TEXT name, write pass, read pass) VAR msg ; +BOUND TEXT VAR reply msg ; +BOUND THESAURUS VAR thesaurus msg ; + +TASK VAR order task, last order task ; + +FILE VAR list file ; + +TEXT VAR error message buffer := "" + ,record + ,received name + ,create son password := "" + ,save file name + ,save write password + ,save read password + ; + + +PROC fetch (TEXT CONST file name) : + + fetch (file name, father) + +ENDPROC fetch ; + +PROC fetch (TEXT CONST file name, TASK CONST manager) : + + enable stop ; + last param (file name) ; + IF NOT exists (file name) + THEN call (fetch code, file name, manager) + ELIF overwrite permitted + THEN call (fetch code, file name, manager) ; + forget (file name, quiet) + ELSE LEAVE fetch + FI ; + IF reply = ack + THEN disable stop ; + copy (ds, file name) ; + forget (ds) + ELSE forget (ds) ; + errorstop ("Task """ + name (manager) + """antwortet nicht mit ack") + FI . + +overwrite permitted : + say ("eigene Datei """) ; + say (file name) ; + yes (""" ueberschreiben") . + +ENDPROC fetch ; + +PROC fetch (DATASPACE VAR dest, TEXT CONST file name, TASK CONST manager) : + + disable stop ; + call (fetch code, file name, manager) ; + dest := ds ; + forget (ds) + +ENDPROC fetch ; + + +PROC save : + + save (last param) + +ENDPROC save ; + +PROC save (TEXT CONST file name) : + + save (file name, father) + +ENDPROC save ; + +PROC save (TEXT CONST file name, TASK CONST manager) : + + last param (file name) ; + call (save code, file name, old (file name), manager) ; + forget (ds) + +ENDPROC save ; + +PROC save (DATASPACE CONST source, TEXT CONST file name, TASK CONST manager): + + call (save code, file name, source, manager) ; + forget (ds) + +ENDPROC save ; + + +BOOL PROC exists (TEXT CONST file name, TASK CONST manager) : + + call (exists code, file name, manager) ; + forget (ds) ; + reply = ack . + +ENDPROC exists ; + + +PROC erase : + + erase (last param) + +ENDPROC erase ; + +PROC erase (TEXT CONST file name) : + + erase (file name, father) + +ENDPROC erase ; + +PROC erase (TEXT CONST file name, TASK CONST manager) : + + call (erase code, file name, manager) ; + forget (ds) + +ENDPROC erase ; + + +PROC list (TASK CONST manager) : + + IF manager = myself + THEN list + ELSE list from manager + FI . + +list from manager : + call (list code, "", manager) ; + IF reply = ack + THEN DATASPACE VAR save ds := ds ; + forget (ds) ; + list file := sequential file (modify, save ds) ; + insert station and name of task in headline if possible ; + show (list file) ; + forget (save ds) + ELSE forget (ds) + FI . + +insert station and name of task in headline if possible : + IF headline (list file) = "" + THEN headline (list file, station number if there is one + + " Task : " + name (manager)) + FI . + +station number if there is one : + IF station (manager) > 0 + THEN "Station : " + text (station (manager)) + ELSE "" + FI . + +ENDPROC list ; + +PROC list (FILE VAR f, TASK CONST manager) : + + IF manager = myself + THEN list (f) + ELSE list from manager + FI . + +list from manager : + call (list code, "", manager) ; + IF reply = ack + THEN DATASPACE VAR save ds := ds ; + forget (ds) ; + list file := sequential file (input, save ds) ; + copy attributes (list file, f) ; + insert station and name of task in headline if possible ; + REP + getline (list file, record) ; + putline (f, record) + UNTIL eof (list file) PER ; + forget (save ds) + ELSE forget (ds) + FI . + +insert station and name of task in headline if possible : + IF headline (list file) = "" + THEN headline (list file, station number if there is one + + " Task : " + name (manager)) + FI . + +station number if there is one : + IF station (manager) > 0 + THEN "Station : " + text (station (manager)) + ELSE "" + FI . + +ENDPROC list ; + +THESAURUS OP ALL (TASK CONST manager) : + + THESAURUS VAR result ; + IF manager = myself + THEN result := all + ELSE get all from manager + FI ; + result . + +get all from manager : + call (all code, "", manager) ; + IF reply = ack + THEN get result thesaurus + ELSE result := empty thesaurus + FI . + +get result thesaurus : + thesaurus msg := ds ; + result := CONCR (thesaurus msg) ; + forget (ds) . + +ENDOP ALL ; + + +PROC call (INT CONST op code, TEXT CONST file name, TASK CONST manager) : + + DATASPACE VAR dummy space ; + call (op code, file name, dummy space, manager) + +ENDPROC call ; + +PROC call (INT CONST op code, TEXT CONST file name, + DATASPACE CONST save space, TASK CONST manager) : + + enable stop ; + send first order first time ; + send second order if required first time ; + WHILE order restart required REP + pause (10) ; + send first order (op code, file name, manager) ; + send second order if required + PER ; + error or message if required . + +send first order first time : + send first order (op code, file name, manager) ; + WHILE order restart required REP + pause (10) ; + send first order (op code, file name, manager) + PER . + +send second order if required first time : + IF reply = question ack + THEN reply msg := ds ; + IF NOT yes (reply msg) + THEN LEAVE call + ELSE send second order (op code, file name, save space, manager) + FI + ELIF reply = second phase ack + THEN send second order (op code, file name, save space, manager) + FI . + +send second order if required : + IF reply = second phase ack OR reply = question ack + THEN send second order (op code, file name, save space, manager) + FI . + +error or message if required : + IF reply = message ack + THEN reply msg := ds ; + say (reply msg) ; + say (cr lf) + ELIF reply = error nak + THEN reply msg := ds ; + errorstop (reply msg) + FI . + +order restart required : reply = nak . + +ENDPROC call ; + +PROC send first order (INT CONST op code, TEXT CONST file name, + TASK CONST manager) : + + forget (ds) ; + ds := nilspace ; + msg := ds ; + msg.name := file name ; + msg.write pass := write password ; + msg.read pass := read password ; + call (manager, op code, ds, reply) ; + IF reply < 0 + THEN errorstop ("Task nicht vorhanden") + FI . + +ENDPROC send first order ; + +PROC send second order (INT CONST op code, TEXT CONST file name, + DATASPACE CONST save space, TASK CONST manager) : + + IF op code = save code + THEN send save space + ELSE send first order (second phase ack, file name, manager) + FI . + +send save space : + forget (ds) ; + ds := save space ; + call (manager, second phase ack, ds, reply) . + +ENDPROC send second order ; + + +PROC global manager : + + global manager + (PROC (DATASPACE VAR, INT CONST, INT CONST, TASK CONST) std manager) + +ENDPROC global manager ; + +PROC free global manager : + + global manager + (PROC (DATASPACE VAR, INT CONST, INT CONST, TASK CONST) free manager) + +ENDPROC free global manager ; + + +PROC global manager (PROC (DATASPACE VAR, + INT CONST, INT CONST, TASK CONST) manager) : + + DATASPACE VAR local ds := nilspace ; + break ; + set autonom ; + disable stop ; + command dialogue (FALSE) ; + remember heap size ; + last order task := niltask ; + REP + forget (local ds) ; + wait (local ds, order, order task) ; + IF order <> second phase ack + THEN prepare first phase ; + manager (local ds, order, phase number, order task) + ELIF order task = last order task + THEN prepare second phase ; + manager (local ds, order, phase number, order task) + ELSE send nak + FI ; + send error if necessary ; + collect heap garbage if necessary + PER . + +prepare first phase : + phase number := 1 ; + last order := order ; + last order task := order task . + +prepare second phase : + phase number INCR 1 ; + order := last order . + +send nak : + forget (local ds) ; + local ds := nilspace ; + send (order task, nak, local ds) . + +send error if necessary : + IF is error + THEN forget (local ds) ; + local ds := nilspace ; + reply msg := local ds ; + CONCR (reply msg) := error message ; + clear error ; + send (order task, error nak, local ds) + FI . + +remember heap size : + INT VAR old heap size := heap size . + +collect heap garbage if necessary : + IF heap size > old heap size + 8 + THEN collect heap garbage ; + old heap size := heap size + FI . + +ENDPROC global manager ; + +PROC std manager (DATASPACE VAR ds, + INT CONST order, phase, TASK CONST order task) : + + IF order task < myself OR order = begin code OR order task = supervisor + THEN free manager (ds, order, phase, order task) + ELSE errorstop ("kein Zugriffsrecht auf Task """ + name (myself) + """") + FI . + +ENDPROC std manager ; + +PROC free manager (DATASPACE VAR ds, + INT CONST order, phase, TASK CONST order task): + + enable stop ; + IF order > continue code AND + order task = supervisor THEN y maintenance + ELIF order = begin code THEN y begin + ELSE file manager order + FI . + +file manager order : + get message text if there is one ; + SELECT order OF + CASE fetch code : y fetch + 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 + OTHERWISE errorstop ("falscher Auftrag fuer Task """+name(myself)+"""") + ENDSELECT . + +get message text if there is one : + IF order >= fetch code AND order <= erase code AND phase = 1 + THEN msg := ds ; + received name := msg.name + FI . + +y begin : + BOUND STRUCT (TEXT tname, tpass, TASK task, PROCA start proc) VAR sv msg := ds ; + IF create son password = sv msg.tpass AND create son password <> "-" + THEN create son task + ELIF sv msg.tpass = "" + THEN ask for password + ELSE errorstop ("Passwort falsch") + FI . + +create son task : + begin (ds, PROC std begin, reply) ; + send (order task, reply, ds) . + +ask for password : + send (order task, password code, ds) . + + +y fetch : + IF read permission (received name, msg.read pass) + THEN forget (ds) ; + ds := old (received name) ; + send (order task, ack, ds) + ELSE errorstop ("Passwort falsch") + FI . + +y erase : + msg := ds ; + received name := msg.name ; + IF NOT exists (received name) + THEN manager message ("""" + received name + """ existiert nicht", order task) + ELIF phase = 1 + THEN manager question ("""" + received name + """ loeschen", order task) + ELIF write permission (received name, msg.write pass) + THEN forget (received name, quiet) ; + send (order task, ack, ds) + ELSE errorstop ("Passwort falsch") + FI . + +y save : + IF phase = 1 + THEN y save pre + ELSE y save post + FI . + +y save pre : + IF write permission (received name, msg.write pass) + THEN save file name := received name ; + save write password := msg.write pass ; + save read password := msg.read pass ; + IF exists (received name) + THEN manager question + ("""" + received name + """ ueberschreiben", order task) + ELSE send (order task, second phase ack, ds) + FI + ELSE errorstop ("Passwort falsch") + FI . + +y save post : + forget (save file name, quiet) ; + copy (ds, save file name) ; + enter password (save file name, save write password, save read password) ; + forget (ds) ; + ds := nilspace ; + send (order task, ack, ds) ; + cover tracks of save passwords . + +cover tracks of save passwords : + replace (save write password, 1, LENGTH save write password * " ") ; + replace (save read password, 1, LENGTH save read password * " ") . + +y exists : + IF exists (received name) + THEN send (order task, ack, ds) + ELSE send (order task, false code, ds) + FI . + +y list : + forget (ds) ; + ds := nilspace ; + list file := sequential file (output, ds) ; + list (list file) ; + send (order task, ack, ds) . + +y all : + BOUND THESAURUS VAR all names := ds ; + all names := all ; + send (order task, ack, ds) . + +y maintenance : + disable stop ; + call (supervisor, order, ds, reply) ; + forget (ds) ; + IF reply = ack + THEN put error message if there is one ; + REP + command dialogue (TRUE) ; + get command ("maintenance :") ; + reset editor ; + do command + UNTIL NOT on line PER ; + command dialogue (FALSE) ; + break ; + set autonom ; + save error message if there is one + FI ; + enable stop . + +put error message if there is one : + IF error message buffer <> "" + THEN out (error pre) ; + out (error message buffer) ; + out (cr lf) ; + error message buffer := "" + FI . + +reset editor : + WHILE aktueller editor > 0 REP + quit + PER ; + clear error . + +save error message if there is one : + IF is error + THEN error message buffer := error message ; + clear error + FI . + +ENDPROC free manager ; + +PROC manager message (TEXT CONST message) : + + forget (ds) ; + ds := nilspace ; + reply msg := ds ; + reply msg := message ; + send (order task, message ack, ds) + +ENDPROC manager message ; + +PROC manager question (TEXT CONST question) : + + forget (ds) ; + ds := nilspace ; + reply msg := ds ; + reply msg := question ; + send (order task, question ack, ds) + +ENDPROC manager question ; + +PROC manager message (TEXT CONST message, TASK CONST receiver) : + + forget (ds) ; + ds := nilspace ; + reply msg := ds ; + reply msg := message ; + send (receiver, message ack, ds) + +ENDPROC manager message ; + +PROC manager question (TEXT CONST question, TASK CONST receiver) : + + forget (ds) ; + ds := nilspace ; + reply msg := ds ; + reply msg := question ; + send (receiver, question ack, ds) + +ENDPROC manager question ; + +PROC std begin : + + do ("monitor") + +ENDPROC std begin ; + +PROC begin password (TEXT CONST password) : + + cover tracks of old create son password ; + create son password := password ; + say (""3""13""5"") ; + cover tracks . + +cover tracks of old create son password : + replace (create son password, 1, LENGTH create son password * " ") . + +ENDPROC begin password ; + + +PROC continue channel (INT CONST channel number) : + + TASK CONST channel owner := task (channel number) ; + IF i am not channel owner + THEN IF NOT is niltask (channel owner) + THEN ask channel owner to release the channel ; + IF channel owner does not release channel + THEN errorstop ("Task """ + name (channel owner) + + """ gibt Kanal " + + text (channel number) + + " nicht frei") + FI + FI ; + continue (channel number) + FI . + +i am not channel owner : + channel <> channel number . + +ask channel owner to release the channel : + forget (ds) ; + ds := nilspace ; + pingpong (channel owner, free code, ds, reply) . + +channel owner does not release channel : + (reply <> ack) AND task exists . + +task exists : + reply <> -1 . + +ENDPROC continue channel ; + + +END PACKET global manager ; + diff --git a/system/multiuser/1.7.5/src/indexer b/system/multiuser/1.7.5/src/indexer new file mode 100644 index 0000000..e60110a --- /dev/null +++ b/system/multiuser/1.7.5/src/indexer @@ -0,0 +1,1142 @@ +(* ------------------- VERSION 59 vom 21.02.86 -------------------- *) +PACKET index program DEFINES outline, + index, + index merge: + +(* Programm zur Behandlung von Indizes aus Druckdateien + Autor: Rainer Hahn + Stand: 1.7.1 (Febr. 1984) + 1.7.4 (Maerz 1985) 'outline' +*) + +LET escape = ""27"", + blank = " ", + trenn k = ""220"", + trennzeichen = ""221"", + minuszeichen = ""45"", + kommando zeichen = "#", + trenner = " ...", + ziffernanfang = "... ", + ziffern = "1234567890", + ib0 = 1, + ib1 = 2, + ib2 = 3, + ie0 = 4, + ie1 = 5, + ie2 = 6, + max indizes = 10, (* !!Anzahl möglichetr Indizes *) + punkt grenze = 50, + leer = 0, + fuellend = 1, + nicht angekoppelt = 2; + +INT VAR seiten nr, + zeilen nr, + erste fehler zeilennr, + zeilen seit index begin, + von, + komm anf, + komm ende, + kommando index, + index nr, + inhalt nr, + anz params, + anz zwischenspeicher, + y richtung; + +BOOL VAR outline modus, + inhaltsverzeichnis offen; + +TEXT VAR dummy, + dummy2, + fehlerdummy, + einrueckung, + akt zeile, + zweite zeile, + akt index, + zweiter index, + zeile, + kommando, + datei name, + kommando liste :: "ib:1.012ie:4.012", + par1, + par2; + +FILE VAR eingabe file, + ausgabe file; + +ROW max indizes FILE VAR f; + +ROW max indizes TEXT VAR zwischenspeicher; + +LET SAMMLER = STRUCT (TEXT index text, + TEXT seitennummer zusatz, + INT zustand); + +ROW max indizes SAMMLER VAR sammler; + +(******************************* outline-Routine **********************) + +PROC outline: + outline (last param) +END PROC outline; + +PROC outline (TEXT CONST eingabe datei): + outline modus := TRUE; + disable stop; + do outline (eingabe datei); + IF is error + THEN put error; + clear error + FI; + enable stop; + IF anything noted + THEN to line (eingabe file, erste fehler zeilennr); + note edit (eingabe file) + ELSE to line (eingabe file, 1); + last param (eingabe datei + ".outline") + FI; + line +END PROC outline; + +PROC do outline (TEXT CONST eingabe datei): + enable stop; + IF exists (eingabe datei) + THEN initialisiere bildschirm; + deaktiviere sammler; + anfrage auf inhaltsverzeichnis; + einrichten fuer zeilennummer ausgabe; + richte dateien ein; + verarbeite datei; + ELSE errorstop ("Datei nicht vorhanden") + FI; + cursor (1, y richtung + 1). + +initialisiere bildschirm: + eingabe file := sequential file (modify, eingabe datei); + page; + put ("OUTLINE"); put ("( für"); put (lines (eingabe file)); put ("Zeilen):"); + put (eingabe datei); + put ("->"); out (eingabe datei); out (".outline"); + cursor (1, 3). + +anfrage auf inhaltsverzeichnis: + put ("Bitte Index-Nr. für Inhaltsverzeichnis:"); + dummy := "9"; + REP + editget (dummy); + inhalt nr := int (dummy); + IF last conversion ok AND inhalt nr > 0 AND inhalt nr < 10 + THEN LEAVE anfrage auf inhaltsverzeichnis + ELSE line; put ("Nr. zwischen 0 und 9, bitte nochmal:") + FI + END REP. + +einrichten fuer zeilennummer ausgabe: + line (2); + INT VAR x; + get cursor (x, y richtung). + +richte dateien ein: + inhaltsverzeichnis offen := FALSE; + anz zwischenspeicher := 0; + einrueckung := ""; + erste fehler zeilennr := 0; + ggf ueberschreibe anfrage (eingabe datei + ".outline"); + ausgabe file := sequential file (output, eingabe datei + ".outline"); + to line (eingabe file, 1); + col (eingabe file, 1). + +verarbeite datei: + REP + suche naechste zeile mit kommandozeichen; + IF pattern found + THEN verarbeite ggf index kommandos + FI; + IF line no (eingabe file) = lines (eingabe file) + THEN LEAVE verarbeite datei + ELSE down (eingabe file); + col (eingabe file, 1) + FI + END REP. + +verarbeite ggf index kommandos: + komm anf := col (eingabe file); + von := komm anf; + REP + WHILE komm anf <> 0 REP + komplettiere alle fuellenden sammler (von, komm anf - 1); + entschluessele kommando; + von := komm ende + 1; + setze kommando um + END REP; + IF alle sammler leer + THEN LEAVE verarbeite ggf index kommandos + ELSE fuelle sammler mit restzeile und lese naechste zeile + FI + UNTIL line no (eingabe file) = lines (eingabe file) END REP. + +setze kommando um: + SELECT kommando index OF + CASE ib0, ib1, ib2: + zeilen seit index begin := 0; + IF anz params = 0 + THEN index nr := 1 + ELSE index nr := int (par1) + FI; + index anfang; + CASE ie0, ie1, ie2: + IF anz params = 0 + THEN index nr := 1 + ELSE index nr := int (par1) + FI; + index ende; + OTHERWISE + END SELECT. + +index anfang: + IF gueltiger index + THEN fange neuen index an + ELSE fehler (18, par1) + FI. + +fange neuen index an: + IF sammler fuellend (index nr) + THEN fehler (20, text (index nr)) + ELIF index ist inhaltsverzeichnis + THEN stelle einrueckung fest; + sammler [index nr] . index text := einrueckung; + einrueckung CAT " "; + inhaltsverzeichnis offen := TRUE + ELIF index ist hauptindex + THEN sammler [index nr] . index text := einrueckung; + ELSE sammler [index nr] . index text := einrueckung; + sammler [index nr] . index text CAT text (index nr); + sammler [index nr] . index text CAT " --> " + FI; + sammler [index nr] . zustand := fuellend. + +stelle einrueckung fest: + einrueckung := ""; + INT VAR punkt pos :: pos (zeile, "."); + WHILE punkt pos <> 0 REP + einrueckung CAT " "; + punkt pos := pos (zeile, ".", punkt pos + 1) + END REP. + +index ende: + IF gueltiger index + THEN IF sammler fuellend (index nr) + THEN IF kommando index = ie2 + THEN sammler [index nr] . index text CAT par2; + FI; + leere sammler in outline datei (index nr) + ELSE fehler (21, text (index nr)) + FI + ELSE fehler (18, text (index nr)) + FI; + sammler [index nr] . zustand := leer. + +index ist inhaltsverzeichnis: + index nr = inhalt nr. + +index ist hauptindex: + index nr = 1. +END PROC do outline; + +PROC leere sammler in outline datei (INT CONST nr): + IF index ist inhaltsverzeichnis + THEN line (ausgabe file); + putline (ausgabe file, sammler [nr] . index text); + inhaltsverzeichnis offen := FALSE; + leere zwischenspeicher + ELIF inhaltsverzeichnis offen + THEN fuelle zwischenspeicher + ELSE putline (ausgabe file, sammler [nr] . index text) + FI; + sammler [nr] . zustand := leer. + +index ist inhaltsverzeichnis: + nr = inhalt nr. + +leere zwischenspeicher: + INT VAR i; + FOR i FROM 1 UPTO anz zwischenspeicher REP + putline (ausgabe file, zwischenspeicher [i]) + END REP; + anz zwischenspeicher := 0. + +fuelle zwischenspeicher: + anz zwischenspeicher INCR 1; + IF anz zwischenspeicher <= max indizes + THEN zwischenspeicher [anz zwischenspeicher] := sammler [nr] . index text + FI. +END PROC leere sammler in outline datei; + +(********************* Utility Routinen *****************************) + +PROC ggf ueberschreibe anfrage (TEXT CONST d): + yrichtung INCR 1; + cursor (1, yrichtung); + IF exists (d) + THEN IF yes (d + " überschreiben") + THEN forget (d, quiet) + ELSE put ("wird angefügt") + FI + FI; + IF outline modus + THEN line + ELSE cursor (7, 3) + FI +END PROC ggf ueberschreibe anfrage; + +BOOL PROC gueltiger index: + last conversion ok AND index nr > 0 AND index nr <= max indizes +END PROC gueltiger index; + +PROC suche naechste zeile mit kommandozeichen: + TEXT VAR steuerzeichen :: incharety; + IF steuerzeichen = escape + THEN errorstop ("Abbruch durch ESC") + FI; + downety (eingabe file, "#", lines (eingabe file)); + read record (eingabe file, zeile); + zeilen nr := line no (eingabe file); + cout (zeilen nr); +END PROC suche naechste zeile mit kommandozeichen; + +PROC entschluessele kommando: + komm ende := pos (zeile, kommando zeichen, komm anf + 1); + IF komm ende <> 0 + THEN hole kommando text; + TEXT CONST kommando anfangs zeichen :: kommando SUB 1; + IF pos ("-/"":*", kommando anfangs zeichen) = 0 + THEN analysiere kommando + FI; + komm anf := pos (zeile, kommando zeichen, komm ende + 1); + ELSE fehler (2, ""); + komm anf := 0; + LEAVE entschluessele kommando + END IF. + +hole kommando text: + kommando := subtext (zeile, komm anf + 1, komm ende - 1). + +analysiere kommando: + kommando index := 0; + analyze command (kommando liste, kommando, 3, + kommando index, anz params, par1, par2); + disable stop; + command error; + IF is error + THEN dummy := error message; + clear error; + dummy CAT " -> "; + dummy CAT kommando; + fehler (22, dummy); + enable stop; + komm anf := 0; + kommando index := 0; + LEAVE entschluessele kommando + END IF; + enable stop +END PROC entschluessele kommando; + +PROC fuelle sammler mit restzeile und lese naechste zeile: + restzeile auffuellen; + naechste zeile und zaehlen; + zeilen seit index begin INCR 1; + von := pos (zeile, ""33"", ""255"", 1); + komm anf := pos (zeile, kommando zeichen, von); + IF zeilen seit index begin > 10 (* !!Anzahl Zeilen!! *) + THEN index aufnahme stoppen; + fehler (17, ""); + LEAVE fuelle sammler mit restzeile und lese naechste zeile + ELIF seitenbegrenzung + THEN index aufnahme stoppen; + fehler (7, ""); + END IF. + +restzeile auffuellen: + IF silbentrennung + THEN IF durch silbentrennung gewandeltes k + THEN replace (zeile, length (zeile) - 1, "c") + FI; + komplettiere alle fuellenden sammler (von, length (zeile) - 1) + ELIF bindestrich + THEN komplettiere alle fuellenden sammler (von, length (zeile)); + ELSE komplettiere alle fuellenden sammler (von, length (zeile)); + zeile := " "; + komplettiere alle fuellenden sammler (1, 1) + END IF. + +silbentrennung: + (zeile SUB length (zeile)) = trennzeichen. + +durch silbentrennung gewandeltes k: + (zeile SUB length (zeile) - 1) = trenn k. + +bindestrich: + (zeile SUB length (zeile)) = minuszeichen AND + (zeile SUB length (zeile) - 1) <> blank. +END PROC fuelle sammler mit restzeile und lese naechste zeile; + +(**************************** index routine *************************) + +PROC index: + index (last param) +END PROC index; + +PROC index (TEXT CONST eingabe datei): + outline modus := FALSE; + last param (eingabe datei); + disable stop; + suche indizes (eingabe datei); + IF is error + THEN put error; + clear error; + FI; + enable stop; + nachbehandlung. + +nachbehandlung: + IF anything noted + THEN to line (eingabe file, erste fehler zeilennr); + note edit (eingabe file) + ELSE to line (eingabe file, 1) + FI; + line. +END PROC index; + +(************************** eigentliche index routine *****************) + +PROC suche indizes (TEXT CONST eingabe datei): + enable stop; + IF exists (eingabe datei) + THEN IF pos (eingabe datei, ".p") = 0 + THEN errorstop ("Datei ist keine Druckdatei") + FI; + eingabe file := sequential file (modify, eingabe datei); + datei name := eingabe datei; + erste fehler zeilennr := 0; + initialisiere bildschirm; + deaktiviere sammler; + verarbeite datei; + sortiere die index dateien; + ELSE errorstop ("Datei existiert nicht") + END IF. + +initialisiere bildschirm: + page; + put ("INDEX"); put ("(für"); put (lines (eingabe file)); put ("Zeilen):"); + put (eingabe datei); + cursor (1, 3); + out ("Zeile: "); + out ("Seite:"); + y richtung := 4; + cursor (7, 3). + +verarbeite datei: + lese bis erste seitenbegrenzung; + WHILE NOT eof (eingabe file) REP + lese bis naechste seitenbegrenzung; + setze seiten nr; + gehe auf erste textzeile zurueck; + verarbeite indizes dieser seite + END REP. + +lese bis erste seitenbegrenzung: + to line (eingabe file, 1); + col (eingabe file, 1); + read record (eingabe file, zeile); + zeilen nr := 1; + cout (1); + REP + IF eof (eingabe file) + THEN errorstop ("Datei ist keine Druckdatei") + ELIF seitenbegrenzung + THEN LEAVE lese bis erste seitenbegrenzung + ELSE naechste zeile und zaehlen + END IF + END REP. + +lese bis naechste seitenbegrenzung: + IF line no (eingabe file) >= lines (eingabe file) + THEN LEAVE verarbeite datei + ELSE down (eingabe file) + FI; + INT VAR erste textzeile := line no (eingabe file); + down (eingabe file, "#page##----", lines (eingabe file)); + IF pattern found + THEN read record (eingabe file, zeile) + ELSE LEAVE verarbeite datei + FI. + +gehe auf erste textzeile zurueck: + to line (eingabe file, erste textzeile); + read record (eingabe file, zeile); + zeilennr := lineno (eingabe file); + cout (zeilennr). + +verarbeite indizes dieser seite: + REP + suche naechste zeile mit kommandozeichen; + IF seitenbegrenzung + THEN LEAVE verarbeite indizes dieser seite + FI; + verarbeite index kommandos der naechsten zeilen; + IF seitenbegrenzung + THEN LEAVE verarbeite indizes dieser seite + FI; + down (eingabe file); + col (eingabe file, 1) + END REP. + +verarbeite index kommandos der naechsten zeilen: + komm anf := col (eingabe file); + von := komm anf; + REP + WHILE komm anf <> 0 REP + komplettiere alle fuellenden sammler (von, komm anf - 1); + entschluessele kommando; + von := komm ende + 1; + setze kommando um + END REP; + IF alle sammler leer + THEN LEAVE verarbeite index kommandos der naechsten zeilen + ELSE fuelle sammler mit restzeile und lese naechste zeile + END IF + UNTIL seitenbegrenzung ENDREP; + fehler (7, ""). + +setze kommando um: +SELECT kommando index OF +CASE ib0, ib1, ib2: + zeilen seit index begin := 0; + IF anz params = 0 + THEN index nr := 1 + ELSE index nr := int (par1) + FI; + index anfang; +CASE ie0, ie1, ie2: + IF anz params = 0 + THEN index nr := 1 + ELSE index nr := int (par1) + FI; + index ende; +OTHERWISE +ENDSELECT. + +index anfang: + IF gueltiger index + THEN fange neuen index an + ELSE fehler (18, par1) + END IF. + +fange neuen index an: + IF sammler fuellend (index nr) + THEN fehler (20, text (index nr)) + ELSE fuelle sammler mit (index nr, ""); + IF anz params = 2 + THEN zusatz an seitennummer (index nr, par2) + ELSE zusatz an seitennummer (index nr, "") + END IF + END IF. + +index ende: + IF gueltiger index + THEN schreibe fuellenden sammler + ELSE fehler (18, text (index nr)) + END IF. + +schreibe fuellenden sammler: + IF sammler fuellend (index nr) + THEN IF anz params = 2 + THEN fuelle sammler mit (index nr, par2) + ENDIF; + schreibe sammler (index nr); + ELSE fehler (21, text (index nr)) + END IF. +END PROC suche indizes; + +(********************* Service Routinen ************************) + +BOOL PROC seitenbegrenzung: + subtext (zeile, 2, 5) = "page" AND subtext (zeile, 8, 12) = "-----" +END PROC seitenbegrenzung; + +PROC setze seiten nr: + seiten nr := int (subtext (zeile, ziffern anfang, ziffernende)); + cursor (20, 3); + put (seiten nr); + cursor (7, 3). + +ziffern anfang: + pos (zeile, "0", "9", 10). + +ziffern ende: + pos (zeile, " ", ziffern anfang) - 1 +END PROC setze seiten nr; + +PROC naechste zeile und zaehlen: + zeilen nr INCR 1; + cout (zeilen nr); + naechste zeile +END PROC naechste zeile und zaehlen; + +PROC naechste zeile: + down (eingabe file); + read record (eingabe file, zeile); + col (eingabe file, 1) +END PROC naechste zeile; + +(**************************** Fehler - Routine *********************) + +PROC fehler (INT CONST nr, TEXT CONST addition): + IF erste fehler zeilennr = 0 + THEN erste fehler zeilennr := zeilen nr + FI; + yrichtung INCR 1; + IF yrichtung > 23 + THEN yrichtung := 23; + FI; + cursor (1, yrichtung); + fehler melden; + fehlermeldung auf terminal ausgeben; + IF outline modus + THEN line + ELSE cursor (7, 3) + FI. + +fehler melden: + report text processing error (nr, zeilen nr, fehlerdummy, addition). + +fehlermeldung auf terminal ausgeben: + out (fehlerdummy); +END PROC fehler; + +PROC warnung (INT CONST nr, TEXT CONST addition): + IF erste fehler zeilennr = 0 + THEN erste fehler zeilennr := zeilen nr + FI; + yrichtung INCR 1; + IF yrichtung > 23 + THEN yrichtung := 23; + FI; + cursor (1, yrichtung); + fehler melden; + meldung auf terminal ausgeben; + IF outline modus + THEN line + ELSE cursor (7, 3) + FI. + +fehler melden: + report text processing warning (nr, zeilen nr, fehlerdummy, addition). + +meldung auf terminal ausgeben: + out (fehlerdummy); +END PROC warnung; + +(************************** Sammler-Dienste **************************) + +PROC index aufnahme stoppen: + zeile := "INDEX FEHLER"; + komplettiere alle fuellenden sammler (1, length (zeile)); + schreibe alle sammler; + read record (eingabe file, zeile) +END PROC index aufnahme stoppen; + +PROC deaktiviere sammler: + INT VAR i; + FOR i FROM 1 UPTO max indizes REP + sammler [i] . zustand := nicht angekoppelt + END REP +END PROC deaktiviere sammler; + +BOOL PROC sammler fuellend (INT CONST nr): + sammler [nr] . zustand = fuellend +END PROC sammler fuellend; + +BOOL PROC sammler angekoppelt (INT CONST nr): + NOT (sammler [nr] . zustand = nicht angekoppelt) +END PROC sammler angekoppelt; + +BOOL PROC alle sammler leer: + INT VAR i; + FOR i FROM 1 UPTO max indizes REP + IF sammler [i] . zustand = fuellend + THEN LEAVE alle sammler leer WITH FALSE + END IF + END REP; + TRUE +END PROC alle sammler leer; + +PROC komplettiere alle fuellenden sammler (INT CONST von pos, bis pos): + INT VAR i; + IF von pos > bis pos + THEN LEAVE komplettiere alle fuellenden sammler + FI; + dummy := subtext (zeile, von pos, bis pos); + FOR i FROM 1 UPTO max indizes REP + IF sammler [i] . zustand = fuellend + THEN sammler [i] . index text CAT dummy; + FI + END REP; +END PROC komplettiere alle fuellenden sammler; + +PROC fuelle sammler mit (INT CONST nr, TEXT CONST dazu): + IF sammler [nr] . zustand = nicht angekoppelt + THEN ankoppeln; + sammler [nr] . index text := dazu + ELIF sammler [nr] . zustand = leer + THEN sammler [nr] . index text := dazu + ELIF sammler fuellend (nr) + THEN sammler [nr] . index text CAT dazu + END IF; + sammler [nr] . zustand := fuellend. + +ankoppeln: + yrichtung INCR 1; + cursor (1, yrichtung); + put ("Indizes"); + put (nr); + put ("gehen in Datei:"); + dummy := datei name; + IF subtext (dummy, length (dummy) - 1) = ".p" + THEN replace (dummy, length (dummy) - 1, ".i") + ELSE dummy CAT ".i"; + END IF; + dummy CAT text (nr); + out (dummy); + ggf ueberschreibe anfrage (dummy); + f [nr] := sequential file (output, dummy); + copy attributes (eingabe file, f[nr]); + cursor (7, 3) +END PROC fuelle sammler mit; + +PROC zusatz an seitennummer (INT CONST nr, TEXT CONST zus text): + sammler [nr] . seitennummer zusatz := zus text +END PROC zusatz an seitennummer; + +PROC schreibe sammler (INT CONST nr): + entferne leading blanks; + IF outline modus + THEN leere sammler in outline datei (nr) + ELSE fuege punkte an; + fuege seiten nr an; + fuege zusatz an seitennummer an; + fuege absatzzeichen an; + leere sammler + FI. + +entferne leading blanks: + WHILE (aufgesammelter text SUB 1) = blank REP + delete char (aufgesammelter text, 1) + END REP. + +fuege punkte an: + aufgesammelter text CAT trenner; + IF length (aufgesammelter text) < punkt grenze + THEN dummy := (punkt grenze - length (aufgesammelter text)) * "."; + aufgesammelter text CAT dummy + END IF; + aufgesammelter text CAT " ". + +fuege seiten nr an: + aufgesammelter text CAT text (seiten nr). + +fuege zusatz an seitennummer an: + aufgesammelter text CAT sammler [nr]. seitennummer zusatz. + +fuege absatzzeichen an: + aufgesammelter text CAT blank. + +leere sammler: + putline (f [nr], aufgesammelter text); + sammler [nr] . zustand := leer. + +aufgesammelter text: + sammler [nr] . index text +END PROC schreibe sammler; + +PROC schreibe alle sammler: + INT VAR i; + FOR i FROM 1 UPTO max indizes REP + IF sammler fuellend (i) + THEN schreibe sammler (i) + END IF + END REP +END PROC schreibe alle sammler; + +(**************** Sortieren und Indizes zusammenfuehren ***************) + +PROC sortiere die index dateien: +INT VAR i; + FOR i FROM 1 UPTO max indizes REP + IF index datei erstellt + THEN sortiere diese datei + END IF + END REP. + +index datei erstellt: + sammler angekoppelt (i). + +sortiere diese datei: + y richtung INCR 1; + cursor (1, yrichtung); + dummy := datei name; + IF subtext (dummy, length (dummy) - 1) = ".p" + THEN replace (dummy, length (dummy) - 1, ".i") + ELSE dummy CAT ".i"; + END IF; + dummy CAT text (i); + put (dummy); + IF yes ("sortieren") + THEN lex sort (dummy); + eintraege zusammenziehen (dummy) + END IF; +END PROC sortiere die index dateien; + +PROC eintraege zusammenziehen (TEXT CONST fname): + FILE VAR sorted file :: sequential file (modify, fname); + INT VAR i :: 1; + to line (sorted file, 1); + read record (sorted file, akt zeile); + akt index := subtext (akt zeile, 1, pos (akt zeile, trenner) - 1); + down (sorted file); + WHILE NOT eof (sorted file) REP + read record (sorted file, zweite zeile); + zweiter index := subtext (zweitezeile, 1, pos (zweitezeile, trenner)-1); + i INCR 1; + cout (i); + IF akt index LEXEQUAL zweiter index + THEN fuege seitennummern von zweite in akt zeile ein + ELSE akt zeile := zweite zeile; + akt index := zweiter index + FI; + down (sorted file) + END REP; + to line (sorted file, 1). + +fuege seitennummern von zweite in akt zeile ein: + hole seitennummer der zweiten zeile; + fuege in akt zeile ein; + delete record (sorted file); + up (sorted file); + write record (sorted file, akt zeile). + +hole seitennummer der zweiten zeile: + INT VAR von := pos (zweite zeile, ziffernanfang) + length (ziffernanfang), + bis := von; + WHILE pos (ziffern, zweite zeile SUB bis) <> 0 REP + bis INCR 1 + END REP; + bis DECR 1; + INT VAR zweite nummer := int( subtext (zweite zeile, von, bis)); + TEXT VAR zweiter nummern text := + subtext (zweite zeile, von, length (zweite zeile) - 1). + +fuege in akt zeile ein: + suche einfuege position in akt zeile; + fuege ein. + +suche einfuege position in akt zeile: + INT VAR einfuege pos := + pos (akt zeile, ziffernanfang) + length (ziffernanfang); + von := einfuege pos; + REP + hole neue nummer; + UNTIL am ende der zeile END REP. + +am ende der zeile: + von >= length (akt zeile). + +hole neue nummer: + bis := von; + WHILE pos (ziffern, akt zeile SUB bis) <> 0 REP + bis INCR 1 + END REP; + bis DECR 1; + IF bis < von + THEN bis := von + FI; + INT VAR neue nummer := int (subtext (akt zeile, von, bis)); + IF zweite nummer = neue nummer + THEN fuege ggf zweiten nummern text mit textanhang ein + ELIF zweite nummer > neue nummer + THEN einfuege pos := von; + von := pos (akt zeile, ", ", bis) + 2; + IF von <= 2 + THEN von := length (akt zeile) + FI + ELSE einfuege pos := von; + LEAVE suche einfuege position in akt zeile + FI. + +fuege ggf zweiten nummern text mit textanhang ein: + bis := pos (akt zeile, ", ", von); + IF bis <= 0 + THEN bis := length (akt zeile); + FI; + IF die beiden nummern sind mit textanhang gleich + THEN LEAVE fuege in akt zeile ein + ELSE einfuege pos := von; + LEAVE suche einfuege position in akt zeile + FI. + +die beiden nummern sind mit textanhang gleich: + zweiter nummern text = subtext (akt zeile, von, bis - 1). + +fuege ein: + IF am ende der zeile + THEN change (akt zeile, length (akt zeile), length (akt zeile), ", "); + akt zeile CAT (zweiter nummern text + " ") + ELSE zweiter nummern text CAT ", "; + change + (akt zeile, einfuege pos, einfuege pos -1, zweiter nummern text); + FI. +END PROC eintraege zusammenziehen; + +(*********************** merge routine *********************) + +PROC index merge (TEXT CONST i1, i2): + disable stop; + indizes zusammenziehen (i1, i2); + IF is error + THEN put error; + clear error; + ELSE last param (i2) + FI; + enable stop; + line. +END PROC index merge; + +PROC indizes zusammenziehen (TEXT CONST i1, i2): + enable stop; + ueberschrift schreiben; + dateien assoziieren; + i1 vor i2 einfuegen; + sortieren; + forget (i1). + +dateien assoziieren: + IF exists (i1) + THEN eingabe file := sequential file (modify, i1) + ELSE errorstop (i1 + "existiert nicht") + END IF; + IF exists (i2) + THEN f[2] := sequential file (modify, i2) + ELSE errorstop (i2 + "existiert nicht") + END IF. + +ueberschrift schreiben: + page; + put ("INDEX MERGE:"); put (i1); put ("-->"); put (i2); + cursor (1, 3); + yrichtung := 3. + +i1 vor i2 einfuegen: + to first record (eingabe file); + to first record (f [2]); + zeilen nr := 0; + WHILE NOT eof (eingabe file) REP + zeilennr INCR 1; + cout (zeilennr); + read record (eingabe file, zeile); + insert record (f [2]); + write record (f[2], zeile); + down (f[2]); + down (eingabe file); + END REP. + +sortieren: + y richtung INCR 1; + cursor (1, yrichtung); + put (i2); + IF yes ("sortieren") + THEN lex sort (i2); + eintraege zusammenziehen (i2) + END IF +END PROC indizes zusammenziehen; +END PACKET index program; + +PACKET columns DEFINES col put, col get, col lineform, col autoform: + +INT VAR ende pos, + anfangs pos; + +FILE VAR file, spaltenfile; + +TEXT VAR dummy, + spalte, + zeile; + +LET geschuetztes blank = ""223"", + blank = " "; + +BOOL VAR spalte loeschen; + +DATASPACE VAR local space := nilspace; + +PROC col lineform: + spalte loeschen := TRUE; + columns put; + file := sequential file (modify, local space); + lineform (spaltenfile); + col get +END PROC col lineform; + +PROC col autoform: + spalte loeschen := TRUE; + columns put; + file := sequential file (modify, local space); + autoform (spaltenfile); + col get +END PROC col autoform; + +PROC col put: + spalte loeschen := yes ("Spalte löschen"); + columns put +END PROC col put; + +PROC columns put: + IF aktueller editor > 0 AND mark + THEN editor bereich bearbeiten + ELSE errorstop ("col put arbeitet nur auf markierten Bereich im Editor") + FI. + +editor bereich bearbeiten: + file := editfile; + anfangs pos einholen; + ende pos einholen; + INT VAR letzte zeile := line no (file), + erste zeile := mark line no (file); + to line (file, erste zeile); + col (file, 1); + spalten put; + to line (file, erste zeile); + col (file, anfangs pos); + mark (false); + ueberschrift neu. + +anfangs pos einholen: + anfangs pos := mark col (file). + +ende pos einholen: + ende pos := col (file) - 1; + IF ende pos < anfangs pos + THEN errorstop ("Markierungsende muß rechts vom -anfang sein") + FI. + +spalten put: + spaltendatei einrichten; + satznr neu; + WHILE line no (file) <= letzte zeile REP + satznr zeigen; + read record (file, zeile); + spalte herausholen; + spalte schreiben; + down (file) + END REP. + +spaltendatei einrichten: + forget (local space); + local space := nilspace; + spaltenfile := sequential file (output, local space). + +spalte herausholen: + spalte := subtext (zeile, anfangs pos, ende pos); + IF spalte loeschen + THEN change (zeile, anfangs pos, ende pos, ""); + write record (file, zeile) + FI; + WHILE length (spalte) > 1 AND (spalte SUB length (spalte)) = blank REP + delete char (spalte, length (spalte)) + END REP; + IF spaltenende ist geschuetztes blank + THEN delete char (spalte, length (spalte)); + spalte CAT " " + FI. + +spalte schreiben: + putline (spaltenfile, spalte). + +spaltenende ist geschuetztes blank: + (spalte SUB length (spalte)) = geschuetztes blank. +END PROC columns put; + +PROC col get: + IF aktueller editor > 0 + THEN editor bereich bearbeiten + ELSE errorstop ("col put kann nur im Editor aufgerufen werden") + FI; + columns get; + alles neu. + +editor bereich bearbeiten: + file := editfile; + spaltenfile := sequential file (input, local space). + +columns get: + anfangs pos := col (file) - 1; + spaltenbreite feststellen; + col (file, 1); + satznr neu; + WHILE NOT eof (spaltenfile) REP + satznr zeigen; + getline (spaltenfile, spalte); + read record (file, zeile); + spalte ggf verbreitern; + zeile ggf verbreitern; + spalte in zeile einfuegen; + zeile schreiben; + down (file); + IF eof (file) + THEN errorstop ("Spalte hat zu viele Zeilen für die Datei") + FI + END REP. + +zeile ggf verbreitern: + WHILE length (zeile) < anfangs pos REP + zeile CAT blank + END REP. + +spaltenbreite feststellen: + INT VAR anz spaltenzeichen :: 0; + WHILE NOT eof (spaltenfile) REP + getline (spaltenfile, spalte); + IF length (spalte) > anz spaltenzeichen + THEN anz spaltenzeichen := length (spalte) + FI + END REP; + spaltenfile := sequential file (input, local space). + +spalte ggf verbreitern: + IF (spalte SUB length (spalte)) = blank + THEN delete char (spalte, length (spalte)); + spalte CAT geschuetztes blank + FI; + IF anzufuegende spalte soll nicht ans zeilenende + THEN spalte verbreitern + FI. + +anzufuegende spalte soll nicht ans zeilenende: + anfangs pos <= length (zeile). + +spalte verbreitern: + WHILE length (spalte) < anz spaltenzeichen REP + spalte CAT blank + END REP. + +spalte in zeile einfuegen: + dummy := subtext (zeile, 1, anfangs pos); + dummy CAT spalte; + dummy CAT subtext (zeile, anfangs pos + 1); + zeile := dummy. + +zeile schreiben: + write record (file, zeile). +END PROC col get; +END PACKET columns; + diff --git a/system/multiuser/1.7.5/src/konfigurieren b/system/multiuser/1.7.5/src/konfigurieren new file mode 100644 index 0000000..016fef2 --- /dev/null +++ b/system/multiuser/1.7.5/src/konfigurieren @@ -0,0 +1,254 @@ +(* ------------------- VERSION 4 22.04.86 ------------------- *) +PACKET konfigurieren DEFINES (* Autor: D.Heinrichs *) + + + + ansi cursor, + baudrate , + bits , + cursor logic , + elbit cursor , + enter incode , + enter outcode , + flow , + input buffer size , + link , + new configuration , + new type , + ysize : + +LET max dtype nr = 5, (* maximum number of active device tables *) + device table = 32000, + ack = 0 ; + + +INT VAR next outstring, + next instring; + +BOUND STRUCT (ALIGN space, (* umsetzcodetabelle *) + ROW 128 INT outcodes, + ROW 64 INT outstrings, + ROW 64 INT instrings) VAR x; + + +ROW max dtype nr DATASPACE VAR device code table; + +THESAURUS VAR dtypes ; + + +PROC new configuration : + + dtypes := empty thesaurus ; + INT VAR i ; + insert (dtypes, "psi", i) ; + insert (dtypes, "transparent", i) ; + FOR i FROM 1 UPTO max dtype nr REP + forget (device code table (i)) + PER . + +ENDPROC new configuration ; + + +PROC block out (DATASPACE CONST ds, INT CONST page, code): + INT VAR err; + block out (ds,page,0,code,err); + announce error (err) +END PROC block out; + +PROC announce error (INT CONST err): + SELECT err OF + CASE 0: + CASE 1: errorstop ("unbekanntes Terminalkommando") + CASE 2: errorstop ("Nummer der Terminal-Typ-Tabelle falsch") + CASE 3: errorstop ("falsche Terminalnummer") + OTHERWISE errorstop ("blockout: unzulaessiger Kanal") + ENDSELECT +END PROC announce error; + +PROC flow (INT CONST nr, INT CONST dtype): + control (6, dtype, nr) +END PROC flow; + +PROC ysize (INT CONST channel ,new size, INT VAR old size) : + control (11, channel, new size, old size) +ENDPROC ysize ; + +PROC input buffer size (INT CONST nr,size): + INT VAR err; + control (2,nr,size,err) +END PROC input buffer size; + +PROC baudrate (INT CONST nr, rate) : + control (8, rate, nr) +ENDPROC baudrate ; + +PROC bits (INT CONST channel, number, parity) : + bits (channel, number-1 + 8*parity) +ENDPROC bits ; + +PROC bits (INT CONST channel, key) : + control (9, key, channel) +ENDPROC bits ; + +PROC control (INT CONST function, key, channel) : + + INT VAR err ; + IF key > -128 AND key < 127 + THEN control (function, channel, key, err) + ELIF key = -128 + THEN control (function, channel, -maxint-1, err) + FI + +ENDPROC control ; + + +PROC new type (TEXT CONST dtype): + x := new (dtype); + type (old (dtype), device table); + next outstring := 4; + next instring := 0; + INT VAR i; + (* Defaults, damit trmpret den cursor mitfuehrt: *) + FOR i FROM 1 UPTO 6 REP + enter outcode (i,i) + PER; + enter outcode (8,8); + enter outcode (10,10); + enter outcode (13,13); + enter outcode (14,126); + enter outcode (15,126); +END PROC new type; + +INT PROC activate dtype (TEXT CONST dtype): + + INT VAR i := link (dtypes, dtype); + IF (exists (dtype) CAND type (old (dtype)) = device table) + THEN IF i <= 0 + THEN insert (dtypes, dtype, i); + FI; + forget(device code table (i-2)); + device code table (i-2) := old (dtype) + FI; + IF i > max dtype nr +2 (* 5 neue Typen erlaubt *) + THEN delete (dtypes,i); + error stop ("Anzahl Terminaltypen > "+text (i));0 + ELIF i <= 0 + THEN error stop ("Unbekannter Terminaltyp" + dtype); 0 + ELSE i + FI. + +END PROC activate dtype; + +PROC link (INT CONST nr, TEXT CONST dtype): + + INT VAR lst nr := activate dtype (dtype)-3; + IF lst nr < 0 + THEN lst nr INCR 256 (* fuer std terminal und std device *) + ELSE blockout (device code table(lst nr+1), 2, lst nr); + FI; + INT VAR err := 0; + control (1,nr,lst nr,err) ; + announce error(err) + +END PROC link; + + +PROC enter outcode (INT CONST eumel code, ziel code): + + IF ziel code < 128 + THEN simple entry (eumel code, ziel code) + ELSE enter outcode (eumel code, 0, code (ziel code)) + FI . + +ENDPROC enter outcode ; + +PROC simple entry (INT CONST eumel code, ziel code) : + + INT CONST position := eumel code DIV 2 +1, + teil := eumel code - 2*position + 2; + TEXT VAR h :=" "; + replace (h,1,out word); + replace (h,1+teil,code (ziel code)); + out word := (h ISUB 1). + + out word: x.outcodes (position). + +END PROC simple entry ; + +PROC enter outcode (INT CONST eumel code, wartezeit, + TEXT CONST sequenz): + + INT VAR i; + simple entry (eumel code, next outstring + 128); + enter part (x.outstrings, next outstring, wartezeit); + FOR i FROM 1 UPTO length (sequenz) REP + enter part (x.outstrings, next outstring + i, code (sequenzSUBi)) + PER; + next outstring INCR length (sequenz)+2; + abschluss. + + abschluss: + enter part (x.outstrings, next outstring-1, 0) +END PROC enter outcode; + +PROC enter outcode (INT CONST eumelcode, TEXT CONST wert): + enter outcode (eumelcode,code(wert)) +END PROC enter outcode; + +PROC enter part (ROW 64 INT VAR a,INT CONST index, wert): + INT CONST position := index DIV 2 +1, + teil := index - 2*position + 2; + IF position > 64 THEN errorstop ("Ueberlauf der Terminaltyptabelle") FI; + TEXT VAR h :=" "; + replace (h,1,out word); + replace (h,1+teil,code (wert)); + out word := (h ISUB 1). + + out word: a (position). +END PROC enter part; + + +PROC enter incode (INT CONST elan code, TEXT CONST sequenz): + IF elan code > 254 OR elan code < 0 THEN errorstop ("kein Eingabecode") + ELSE + INT VAR i; + enter part (x.instrings, next instring, elan code); + FOR i FROM 1 UPTO length (sequenz) REP + enter part (x.instrings, next instring + i, code (sequenzSUBi)) + PER; + next instring INCR length (sequenz)+2; + + FI + +END PROC enter incode; + +PROC cursor logic (INT CONST dist, TEXT CONST pre, mid, post): + + cursor logic (dist,255,pre,mid,post) + +END PROC cursor logic; + +PROC ansi cursor (TEXT CONST pre, mid, post): + + cursor logic (0, 1, pre, mid, post) + +END PROC ansi cursor; + +PROC cursor logic (INT CONST dist, modus, TEXT CONST pre, mid, post): + + enter part (x.outstrings,2,dist); + enter part (x.outstrings,3,dist); + enter part (x.outstrings,0,modus); + enter part (x.outstrings,1,modus); + enter outcode (6,0,pre+""0"y"+mid+""0"x"+post+""0"") + +END PROC cursor logic; + +PROC elbit cursor: + cursor logic (0,""27"","",""); + enter part (x.outstrings,0,2); + enter part (x.outstrings,1,255); +END PROC elbit cursor; + +ENDPACKET konfigurieren; + diff --git a/system/multiuser/1.7.5/src/liner b/system/multiuser/1.7.5/src/liner new file mode 100644 index 0000000..bc1f41d --- /dev/null +++ b/system/multiuser/1.7.5/src/liner @@ -0,0 +1,3079 @@ +(* ------------------- VERSION 406 vom 28.05.86 ----(1.7.5)------------- *) +PACKET liner DEFINES line form, + autoform, + hyphenation width, + additional commands: + +(* Programm zur Zeilenformatierung mit unterschiedlichen Schriftypen + Autor: Rainer Hahn + Stand: 1.7.1 Febr. 1984 + 1.7.3 Juli 1984 + 1.7.4 Juni 1985 + 1.7.5 ab Okt. 1985 + *) + +(********************* form deklarationen ********************) + +TEXT VAR zeichen, + aufzaehlungszeichen, + par 1, + par 2, + kommando, + command store, + zielreferenzen, + herkunftsreferenzen, + aktuelle referenz, + alter schriftname, + dummy, + fehlerdummy, + footdummy, + scan symbol, + font table name :: "", + trennwort, + trennwort ohne komm, + wort1, + wort1 ohne komm, + wort2, + font nr speicher, + modifikations speicher, + mod zeilennr speicher, + index speicher, + ind zeilennr speicher, + counter numbering store, + counter reference store, + trennsymbol, + puffer, + neue zeile, + zeile, + einrueckung zweite zeile, + aktuelle blanks, + alte blanks, + zusaetzliche commands :: "", + kommando liste; + +INT CONST rueckwaerts :: -1, + esc char ohne zweites byte ausgang :: - maxint - 1; + +INT VAR anz tabs, + mitzuzaehlende zeichen, + anz blanks freihalten, + kommando index, + scan type, + font nr :: 1, + blankbreite fuer diesen schrifttyp, + aktuelle pitch zeilenlaenge, + eingestellte indentation pitch, + einrueckbreite, + zeilenbreite, + trennbreite in prozent :: 7, + trennbreite, + max trennlaenge, + max trenn laenge ohne komm, + zeichenwert ausgang, + formelbreite, + formelanfang, + zeilennr, + wortanfang, + wortende, + erste fehler zeilennr, + macro kommando ende, + von, + pufferlaenge, + zeichenpos, + zeichenpos bereits verarbeitet; + +BOOL VAR ask type and limit, + format file in situ, + lineform mode, + macro works, + kommandos speichern, + letzter puffer war absatz, + in d und e verarbeitung, + in tabelle, + in foot uebertrag, + in foot; + +LET hop = ""1"", + rechts = ""2"", + cl eol = ""5"", + links = ""8"", + return = ""13"", + begin mark = ""15"", + end mark = ""14"", + escape = ""27"", + trennzeichen = ""221"", + trenn k = ""220"", + blank = " ", + bindestrich = "-", + buchstaben = + "abcdefghijklmnopqrstuvwxyzüäößABCDEFGHIJKLMNOPQRSTUVWXYZÄÜö", + kommando zeichen = "#", + max tabs = 30, + extended char ausgang = 32767, + blank ausgang = 32766, + kommando ausgang = 32765, + such ausgang = 32764, + zeilenende ausgang = 0, + vorwaerts = 1, + type1 = 1, + linefeed = 3, + limit = 4, + free = 5, + page command0= 6, + page command1= 7, + on = 8, + off = 9, + page nr = 10, + pagelength = 11, + start = 12, + foot = 13, + end = 14, + head = 15, + headeven = 16, + headodd = 17, + bottom = 18, + bottomeven = 19, + bottomodd = 20, + block = 21, + material = 22, + columns = 23, + columnsend = 24, + ib0 = 25, + ib1 = 26, + ib2 = 27, + ie0 = 28, + ie1 = 29, + ie2 = 30, + topage = 31, + goalpage = 32, + count0 = 33, + count1 = 34, + setcount = 35, + value0 = 36, + value1 = 37, + table = 38, + table end = 39, + r pos = 40, + l pos = 41, + c pos = 42, + d pos = 43, + b pos = 44, + clear pos0 = 45, + clear pos1 = 46, + right = 47, + center = 48, + skip = 49, + skip end = 50, + u command = 51, + d command = 52, + e command = 53, + head on = 54, + head off = 55, + bottom on = 56, + bottom off = 57, + count per page=58, + fillchar = 59, + mark command = 60, + mark end = 61, + pageblock = 62, + bsp = 63, + counter1 = 64, + counter2 = 65, + setcounter = 66, + putcounter0 = 67, + putcounter1 = 68, + storecounter = 69, + ub = 70, + ue = 71, + fb = 72, + fe = 73; + +REAL VAR limit in cm :: 16.0, + fehler wert :: -1.0; + +FILE VAR eingabe, + ausgabe, + file; + +FRANGE VAR alter bereich; + +DATASPACE VAR ds; + +ROW 256 INT VAR pitch table; +ROW max tabs TEXT VAR tab zeichen; +ROW max tabs ROW 3 INT VAR tabs; +(* 1. Eintrag: Position + 2. Eintrag: Art + 3. Eintrag: Bis-Position +*) + +(************************** liner state-Routinen **********************) + +TYPE LINERSTATE = + STRUCT (INT position, from, + BOOL in macro, + TEXT buffer line, next line, + old blanks, actual blanks, + new line); + +LINERSTATE VAR before macro state, + before foot state; + +PROC get liner state (LINERSTATE VAR l): + l . position := zeichenpos; + l . from := von; + l . in macro := macro works; + l . buffer line := puffer; + l . next line := zeile; + l . old blanks := alte blanks; + l . actualblanks:= aktuelle blanks; + l . new line := neue zeile; +END PROC get liner state; + +PROC put liner state (LINERSTATE CONST l): + zeichenpos := l . position; + von := l . from; + macro works := l . in macro; + puffer := l . buffer line ; + zeile := l . next line ; + alte blanks := l . old blanks; + aktuelle blanks := l . actual blanks; + neue zeile := l . new line ; + pufferlaenge := length (puffer); +END PROC put liner state; + +(*********************** Utility Routinen **************************) + +PROC delete int (TEXT VAR resultat, INT CONST delete pos) : + change (resultat, delete pos * 2 - 1, delete pos * 2, "") +END PROC delete int; + +OP CAT (TEXT VAR resultat, INT CONST zahl) : + resultat CAT " "; + replace (resultat, LENGTH resultat DIV 2, zahl); +END OP CAT; + +PROC conversion (REAL VAR cm, INT VAR pitches): + disable stop; + INT VAR i :: x step conversion (cm); + IF is error + THEN dummy := error message; + clear error; + dummy CAT " -> "; + dummy CAT text (cm); + fehler (38, dummy); + cm := fehler wert + ELIF i < 0 + THEN fehler (38, "negativ"); + cm := fehler wert + ELSE pitches := i + FI; + enable stop +END PROC conversion; + +(************************** Fehlermeldungen **********************) + +PROC fehler (INT CONST nr, TEXT CONST addition): + fehler melden; + meldung auf terminal ausgeben und ggf zeilennummer merken. + +fehler melden: + report text processing error (nr, zeilen nr, fehlerdummy, addition). +END PROC fehler; + +PROC warnung (INT CONST nr, TEXT CONST addition): + warnung melden; + meldung auf terminal ausgeben und ggf zeilennummer merken. + +warnung melden: + report text processing warning (nr, zeilennr, fehlerdummy, addition). +END PROC warnung; + +PROC meldung auf terminal ausgeben und ggf zeilennummer merken: + IF online + THEN line ; + out (fehlerdummy); + line ; + FI; + IF erste fehler zeilennr = 0 + THEN erste fehler zeilennr := zeilennr + FI +END PROC meldung auf terminal ausgeben und ggf zeilennummer merken; + +(*********************** Macro-Bearbeitung ***********************) + +PROC fuehre initialisierung fuer macro aus: + get liner state (before macro state); + get macro line (puffer); + pufferlaenge := length (puffer); + get macro line (zeile); + zeichenpos := 1; + von := 1; + macro works := TRUE. +END PROC fuehre initialisierung fuer macro aus; + +PROC macro end command: + kommando := subtext (kommando, 2); + scan (kommando); + next symbol (scan symbol, scan type); + IF NOT macro works + THEN fehler (40, kommando); + LEAVE macro end command + ELIF scan symbol <> "macroend" + THEN fehler (33, kommando) + ELSE put liner state (before macro state); + FI +END PROC macro end command; + +(************************** Schrifttyp einstellen *********************) + +PROC stelle font ein: + IF alter schriftname = par1 + THEN IF zeilen nr > 2 + THEN warnung (8, par1) + ELSE LEAVE stelle font ein + FI + ELIF font exists (par1) + THEN font nr := font (par1); + ELSE fehler (1, par1); + par1 := font (1); + font nr := 1 + FI; + alter schriftname := par1; + hole font und stelle trennbreite ein +END PROC stelle font ein; + +PROC hole font: + INT VAR x; (* height Werte *) + get font (font nr, eingestellte indentation pitch, x, x, x, pitch table); + pitch table [code (kommandozeichen) + 1] := kommando ausgang; + blankbreite fuer diesen schrifttyp := pitch table [code (blank) + 1] +END PROC hole font; + +PROC hole font und stelle trennbreite ein: + hole font; + trennbreite setzen +END PROC hole font und stelle trennbreite ein; + +PROC trennbreite setzen: + trennbreite := berechnete trennbreite. + +berechnete trennbreite: + INT VAR eingestellte trennbreite; + conversion (limit in cm, eingestellte trennbreite); + eingestellte trennbreite := eingestellte trennbreite + DIV 100 * trennbreite in prozent; + IF eingestellte trennbreite <= zweimal blankbreite + THEN zweimal blankbreite + ELSE eingestellte trennbreite + FI. + +zweimal blankbreite: + 2 * eingestellte indentation pitch. +END PROC trennbreite setzen; + +PROC hyphenation width (INT CONST prozente): + IF prozente < 4 OR prozente > 20 + THEN putline ("Fehler: Einstellbare Trennbreite zwischen 4 und 20%") + ELSE trennbreite in prozent := prozente + FI +END PROC hyphenation width; + +(************************** kommando verarbeitung ****************) + +PROC additional commands (TEXT CONST k): + zusaetzliche commands := k +END PROC additional commands; + +TEXT PROC additional commands: + zusaetzliche commands +END PROC additional commands; + +BOOL PROC hinter dem kommando steht nix (INT CONST komm ende): + komm ende = pufferlaenge OR absatz hinter dem kommando. + +absatz hinter dem kommando: + komm ende + 1 = pufferlaenge AND puffer hat absatz. +END PROC hinter dem kommando steht nix; + +PROC verarbeite kommando und neue zeile auffuellen: + neue zeile auffuellen (von, zeichenpos - 1); + von := zeichenpos; + verarbeite kommando; + neue zeile auffuellen (von, zeichenpos - 1); + von := zeichenpos +END PROC verarbeite kommando und neue zeile auffuellen; + +PROC speichere kommando: + command store CAT "#"; + command store CAT kommando; + command store CAT "#" +END PROC speichere kommando; + +PROC execute stored commands: + IF length (command store) <> 0 + THEN kommandos speichern := FALSE; + dummy := puffer; + INT VAR zpos := zeichenpos; + zeichenpos := 1; + puffer := command store; + pufferlaenge := length (puffer); + execute commands; + puffer := dummy; + pufferlaenge := length (puffer); + zeichenpos := zpos; + command store := ""; + FI; + kommandos speichern := TRUE. + +execute commands: + WHILE zeichenpos < pufferlaenge REP + verarbeite kommando + END REP. +END PROC execute stored commands; + +PROC verarbeite kommando: +INT VAR anz params, + intparam, + kommando ende; +REAL VAR realparam; + zeichenpos INCR 1; + kommando ende := pos (puffer, kommando zeichen, zeichenpos); + IF kommando ende <> 0 + THEN kommando oder kommentar kommando verarbeiten; + zeichenpos := kommando ende + 1 + ELSE fehler (2, "") + FI. + +kommando oder kommentar kommando verarbeiten: + kommando := subtext (puffer, zeichenpos, kommando ende - 1); + TEXT CONST erstes kommandozeichen :: (kommando SUB 1); + IF pos ("-/"":*", erstes kommandozeichen) = 0 + THEN scanne kommando und fuehre es aus + ELSE restliche kommandos + FI. + +restliche kommandos: + IF erstes kommandozeichen = "-" OR erstes kommandozeichen = "/" + THEN + ELIF erstes kommandozeichen = """" + THEN scan (kommando); + next symbol (scan symbol, scan type); + INT VAR scan type2; + next symbol (scan symbol, scan type2); + IF scan type <> 4 OR scan type2 <> 7 + THEN fehler (58, kommando) + FI + ELIF erstes kommandozeichen = "*" + THEN zeichenpos := kommando ende + 1; + macroend command; + LEAVE verarbeite kommando + ELIF erstes kommandozeichen = ":" + THEN disable stop; + delete char (kommando, 1); + INT CONST line no before do := line no (eingabe); + do (kommando); + to line (eingabe, line no before do); + IF is error + THEN dummy := error message; + clear error; + dummy CAT " -> "; + dummy CAT kommando; + fehler (9, dummy) + FI; + enable stop + FI. + +scanne kommando und fuehre es aus: + analyze command (kommando liste, kommando, 3, + kommando index, anz params, par1, par2); + disable stop ; + command error ; + IF is error + THEN dummy := error message; + clear error; + dummy CAT " -> "; + dummy CAT kommando; + fehler (22, dummy); + enable stop; + LEAVE scanne kommando und fuehre es aus + FI; + enable stop; + setze kommando um. + +setze kommando um: + SELECT kommando index OF + +CASE type1: + stelle font ein; + modifikations speicher := ""; + mod zeilennr speicher := "" + +CASE limit: + realparam := real (par1); + IF kommandos speichern + THEN speichere kommando + ELIF last conversion ok AND pos (par1, ".") <> 0 + THEN IF realparam = 0.0 + THEN fehler (37, "") + ELSE conversion (realparam, aktuelle pitch zeilenlaenge); + IF realparam <> fehlerwert + THEN limit in cm := realparam; + trennbreite setzen + FI + FI + ELSE fehler (4, par1); + FI + +CASE on, ub, fb: + TEXT VAR mod zeichen; + IF kommando index = ub + THEN mod zeichen := "u" + ELIF kommando index = fb + THEN mod zeichen := "b" + ELSE mod zeichen := (par1 SUB 1); + FI; + INT VAR position :: pos (modifikations speicher, mod zeichen); + IF position <> 0 + THEN dummy := mod zeichen + " in Zeile "; + dummy CAT text (mod zeilennr speicher ISUB position); + fehler (54, dummy); + replace (mod zeilennr speicher, position, zeilennr); + ELSE modifikations speicher CAT mod zeichen; + mod zeilennr speicher CAT zeilennr + FI + +CASE off, fe, ue: + IF kommando index = ue + THEN mod zeichen := "u" + ELIF kommando index = fe + THEN mod zeichen := "b" + ELSE mod zeichen := (par1 SUB 1); + FI; + position := pos (modifikations speicher, mod zeichen); + IF position = 0 + THEN fehler (55, mod zeichen) + ELSE delete char (modifikations speicher, position); + delete int (mod zeilennr speicher, position) + FI + +CASE pagenr, pagelength, start, block, material, setcount, right, center, + linefeed: + +CASE head, headodd, headeven, bottom, bottomodd, bottomeven, end, free, + page command0, page command1, columns, columnsend: + IF NOT hinter dem kommando steht nix (kommando ende) + THEN fehler (19, kommando) + ELIF kommando ende = pufferlaenge + THEN IF (neue zeile SUB length (neue zeile)) = blank + THEN delete char (neue zeile, length (neue zeile)) + FI; + puffer CAT blank; + pufferlaenge := length (puffer) + FI; + in foot := FALSE + +CASE foot: + IF in foot uebertrag + THEN zeilenbreite := aktuelle pitch zeilenlaenge + 1 + ELIF in foot + THEN fehler (3, "") + ELSE fuelle ggf zeile vor foot auf (kommando ende) + FI + +CASE ib0, ib1, ib2: + TEXT VAR ind zeichen; + IF kommando index = ib0 + THEN ind zeichen:= "1" + ELSE ind zeichen := par1 + FI; + position := pos (index speicher, ind zeichen); + IF position <> 0 + THEN dummy := ind zeichen + " in Zeile "; + dummy CAT text (ind zeilennr speicher ISUB position); + fehler (56, dummy); + replace (ind zeilennr speicher, position, zeilennr) + ELSE index speicher CAT ind zeichen; + ind zeilennr speicher CAT zeilennr + FI + +CASE ie0, ie1, ie2: + IF kommando index = ie0 + THEN ind zeichen := "1" + ELSE ind zeichen := par1 + FI; + position := pos (index speicher, ind zeichen); + IF position = 0 + THEN fehler (57, ind zeichen) + ELSE delete char (index speicher, position); + delete int (ind zeilennr speicher, position) + FI + +CASE topage, count1: + herkunftsreferenzen speichern; + zeilenbreite um blankbreite erhoehen (3) + +CASE count0: + zeilenbreite um blankbreite erhoehen (3) + +CASE value0, value1: + IF anz params <> 0 + THEN zielreferenzen speichern ohne warnung + FI; + zeilenbreite um blankbreite erhoehen (3) + +CASE goalpage: + zielreferenzen speichern + +CASE table: + IF in tabelle + THEN fehler (41, "") + ELSE IF hinter dem kommando steht nix (kommando ende) + THEN zeichenpos := pufferlaenge; + neue zeile auffuellen und ausgabe bei zeilenende + ELSE neue zeile auffuellen (von, kommando ende); + puffer := subtext (puffer, kommandoende + 1); + schreibe und initialisiere neue zeile + FI; + verarbeite tabelle; + LEAVE verarbeite kommando + FI + +CASE table end: + IF NOT in tabelle + THEN fehler (59, "") + FI + +CASE r pos: + IF kommandos speichern + THEN speichere kommando + ELSE tabulatorposition eintragen (r pos) + FI + +CASE l pos: + IF kommandos speichern + THEN speichere kommando + ELSE tabulatorposition eintragen (l pos) + FI + +CASE c pos: + IF kommandos speichern + THEN speichere kommando + ELSE tabulatorposition eintragen (c pos) + FI + +CASE d pos: + IF kommandos speichern + THEN speichere kommando + ELSE tabulatorposition eintragen (d pos) + FI + +CASE b pos: + IF kommandos speichern + THEN speichere kommando + ELSE tabulatorposition eintragen (b pos) + FI + +CASE clear pos0: + IF kommandos speichern + THEN speichere kommando + ELSE anz tabs := 0; + FI + +CASE clear pos1: + IF kommandos speichern + THEN speichere kommando + ELSE tabulatorposition loeschen + FI + +CASE skip: + IF hinter dem kommando steht nix (kommando ende) + THEN neue zeile auffuellen und ausgabe bei zeilenende + ELSE neue zeile auffuellen (von, kommandoende); + puffer := subtext (puffer, kommandoende + 1); + schreibe und initialisiere neue zeile + FI; + skip zeilen verarbeiten; + kommando ende := zeichenpos; + +CASE skip end: + +CASE u command, d command: + INT VAR next smaller font; + speichere font nr; + IF next smaller font exists (font nr, next smaller font) + THEN font nr := next smaller font + FI; + hole font und stelle trennbreite ein; + IF NOT in d und e verarbeitung + THEN verarbeite index und exponenten; + LEAVE verarbeite kommando + FI + +CASE e command: + entspeichere font nr + +CASE head on, head off, bottom on, bottom off, count per page, fillchar, + mark command, markend, pageblock: + +CASE bsp: + zeichenpos DECR 2; + IF kommandoende = length (puffer) OR + (puffer SUB kommandoende + 1) = kommandozeichen OR + zeichenpos < 1 OR + (puffer SUB zeichenpos) = kommandozeichen + THEN fehler (28, ""); + LEAVE setze kommando um + FI; + begin of this char (puffer, zeichenpos); + kommandoende INCR 1; + INT VAR diese breite :: breite (puffer, zeichenpos), + naechste breite :: breite (puffer, kommandoende); + IF in d und e verarbeitung + THEN formelbreite DECR diese breite; + formelbreite INCR max (diese breite, naechste breite) + ELSE zeilenbreite DECR diese breite; + zeilenbreite INCR max (diese breite, naechste breite) + FI; + zeichenpos := kommandoende; + char pos move (vorwaerts); + LEAVE verarbeite kommando + +CASE counter1, counter2: + dummy := "#"; + dummy CAT par1; + dummy CAT "#"; + IF pos (counter numbering store, dummy) = 0 + THEN fehler (34, par1); + FI; + IF kommando index = counter1 + THEN par2 := "0" + FI; + anz blanks freihalten := 3 + 2 * int (par2); + zeilenbreite um blankbreite erhoehen (anz blanks freihalten) + +CASE set counter: + dummy := "#"; + dummy CAT par1; + dummy CAT "#"; + IF pos (counter numbering store, dummy) = 0 + THEN counter numbering store CAT dummy + ELSE warnung (15, par1) + FI + +CASE put counter0: + zeilenbreite um blankbreite erhoehen (anz blanks freihalten) + +CASE put counter1: + dummy := "#"; + dummy CAT par1; + dummy CAT "#"; + INT VAR begin pos :: pos (counter reference store, dummy); + IF begin pos = 0 + THEN counter reference store CAT "u"; + counter reference store CAT dummy + ELIF (counter reference store SUB begin pos - 1) <> "u" + THEN insert char (counter reference store,"u", max (begin pos, 1)) + FI; + zeilenbreite um blankbreite erhoehen (5) + +CASE store counter: + dummy := "#"; + dummy CAT par1; + dummy CAT "#"; + begin pos := pos (counter reference store, dummy); + IF begin pos <> 0 + THEN IF (counter reference store SUB begin pos - 1) = "i" OR + (counter reference store SUB begin pos - 2) = "i" + THEN fehler (35, par1) + ELIF (counter reference store SUB begin pos - 1) = "u" + THEN insert char (counter reference store, "i", + max (begin pos - 1, 1)) + ELSE insert char (counter reference store, "i", + max (begin pos, 1)) + FI + ELSE counter reference store CAT "i"; + counter reference store CAT dummy + FI + +OTHERWISE + IF macro command and then process parameters (kommando) + THEN IF macro works + THEN fehler (15, kommando) + ELSE zeichenpos := kommando ende + 1; + neue zeile auffuellen (von, zeichenpos - 1); + von := zeichenpos; + fuehre initialisierung fuer macro aus; + LEAVE verarbeite kommando + FI + ELIF zusaetzliche commands <> "" + THEN analyze command (zusaetzliche commands, kommando, 3, + kommando index, anz params, par1, par2); + IF kommando index = 0 + THEN fehler (8, kommando) + FI + ELSE fehler (8, kommando) + FI; +END SELECT. +END PROC verarbeite kommando; + +(************************* Indizes und Exponenten **********************) + +PROC zeilenbreite um blankbreite erhoehen (INT CONST anz): + INT CONST blankbreite mal anz :: anz * eingestellte indentation pitch; + IF in d und e verarbeitung + THEN formelbreite INCR blankbreite mal anz + ELSE zeilenbreite INCR blankbreite mal anz + FI; + mitzuzaehlende zeichen INCR anz +END PROC zeilenbreite um blankbreite erhoehen; + +PROC speichere font nr: + IF index oder exponent anfang + THEN suche wortanfang in neuer zeile; + zeilenbreite DECR formelbreite + FI; + font nr speicher CAT " "; + font nr speicher CAT text (font nr). + +index oder exponent anfang: + font nr speicher = "". + +suche wortanfang in neuer zeile: + auf das letzte zeichen stellen; + WHILE NOT wortanfang vor formel REP + formelbreite INCR breite (neue zeile, formelanfang); + IF formelanfang = 1 + THEN LEAVE suche wortanfang in neuer zeile + FI; + char pos move (neue zeile, formelanfang, rueckwaerts); + END REP; + char pos move (neue zeile, formelanfang, vorwaerts). + +wortanfang vor formel: + pos (" #", neue zeile SUB formelanfang) <> 0. + +auf das letzte zeichen stellen: + formelanfang := length (neue zeile); + formelbreite := 0; + IF formelanfang > 0 + THEN begin of this char (neue zeile, formelanfang); + ELSE formelanfang := 1; + LEAVE suche wortanfang in neuer zeile + FI +END PROC speichere font nr; + +PROC verarbeite index und exponenten: + in d und e verarbeitung := TRUE; + zeichenpos := pos (puffer, kommandozeichen, zeichenpos) + 1; + INT VAR altes zeichenpos := zeichenpos; + verarbeite index oder exponenten zeichen; + fehler (52, ""); + entspeichere font nr. + +verarbeite index oder exponenten zeichen: + REP + stranalyze (pitch table, formelbreite, + aktuelle pitch zeilenlaenge - zeilenbreite, + puffer, zeichenpos, pufferlaenge, zeichenwert ausgang); + IF zeichenwert ausgang = kommando ausgang + THEN verarbeite zeichen vor kommando; + verarbeite kommando und neue zeile auffuellen; + IF NOT in d und e verarbeitung + THEN zeilenbreite INCR formelbreite; + LEAVE verarbeite index und exponenten + FI; + altes zeichenpos := zeichenpos + ELIF zeichenwert ausgang = extended char ausgang + THEN char pos move (vorwaerts); + zeilenbreite INCR breite (puffer, zeichenpos); + char pos move (vorwaerts) + ELIF zeichenpos >= pufferlaenge + AND formelbreite + zeilenbreite < aktuelle pitch zeilenlaenge + THEN LEAVE verarbeite index oder exponenten zeichen + ELIF formelanfang <= 1 + THEN fehler (53, ""); + formelbreite := 0; + ELIF zeichenwert ausgang = esc char ohne zweites byte ausgang + THEN fehler (23, ""); + LEAVE verarbeite index oder exponenten zeichen + ELSE schreibe neue zeile vor formelanfang + FI + END REP. + +verarbeite zeichen vor kommando: + mitzuzaehlende zeichen INCR + number chars (puffer, altes zeichenpos, zeichenpos); + IF (puffer SUB zeichenpos) <> blank + THEN aufzaehlungszeichen := (puffer SUB zeichenpos) + FI; + char pos move (vorwaerts). + +schreibe neue zeile vor formelanfang: + dummy := subtext (neue zeile, formelanfang); + neue zeile := subtext (neue zeile, 1, formelanfang - 1); + loesche nachfolgende blanks; + schreibe und initialisiere neue zeile; + neue zeile CAT dummy; + formelanfang := 1; + char pos move (vorwaerts) +END PROC verarbeite index und exponenten; + +PROC entspeichere font nr: + INT VAR index := length (font nr speicher); + IF index <= 1 + THEN fehler (51, "") + ELSE suche nr anfang; + entspeichere; + FI. + +suche nr anfang: + WHILE (font nr speicher SUB index) <> " " AND index <> 0 REP + index DECR 1 + END REP. + +entspeichere: + font nr := int (subtext (font nr speicher, index + 1)); + IF index <= 1 + THEN font nr speicher := ""; + in d und e verarbeitung := FALSE + ELSE font nr speicher := subtext (font nr speicher, 1, index - 1) + FI; + hole font und stelle trennbreite ein +END PROC entspeichere font nr; + +(*************************** skip zeilen ****************************) + +PROC skip zeilen verarbeiten: + REP + IF dateiende + THEN errorstop ("Dateiende während skip-Anweisung") + ELIF skip ende kommando + THEN LEAVE skip zeilen verarbeiten + FI; + neue zeile auffuellen und ausgabe bei zeilenende + END REP. + +dateiende: + pufferlaenge = 0. + +skip ende kommando: + TEXT VAR kliste :: "skipend:1.0", k; + INT VAR k anf :: pos (puffer, kommandozeichen), + kende, anz params, kindex; + WHILE noch ein kommando vorhanden REP + kindex := 0; + analysiere das kommando + END REP; + FALSE. + +noch ein kommando vorhanden: + kanf <> 0. + +analysiere das kommando: + kende := pos (puffer, kommandozeichen, kanf + 1); + IF kende = 0 + THEN fehler (2, ""); + LEAVE skip ende kommando WITH FALSE + FI; + k := subtext (puffer, kanf + 1, kende - 1); + analyze command (kliste, k, 3, kindex, anz params, par1, par2); + IF kindex = 1 + THEN zeichenpos := kende; + LEAVE skip ende kommando WITH TRUE + FI; + kanf := pos (puffer, kommandozeichen, kende + 1). +END PROC skip zeilen verarbeiten; + +(**************** sonderbehandlung von zeilen vor foot *******************) + +PROC fuelle ggf zeile vor foot auf (INT VAR com ende): + IF foot am zeilenende ohne absatz AND NOT macro works + THEN letzter puffer war absatz := TRUE; + IF text vor foot AND NOT zeile hat richtige laenge + THEN INT VAR foot zeilennr := line no (eingabe); + INT CONST x1 := com ende; + in foot uebertrag := TRUE; + get liner state (before foot state); + formatiere diese zeile; + to line (eingabe, foot zeilennr); + footdummy := neue zeile; + put liner state (before foot state); + neue zeile := footdummy; + com ende := x1; + in foot uebertrag := FALSE + FI + ELIF NOT hinter dem kommando steht nix (com ende) + THEN fehler (19, kommando); + LEAVE fuelle ggf zeile vor foot auf + FI; + in foot := TRUE. + +foot am zeilenende ohne absatz: + com ende = pufferlaenge. + +text vor foot: + pos (neue zeile, ""33"", ""255"", 1) <> 0. + +formatiere diese zeile: + foot anweisung entfernen; + lese eingabe datei bis end kommando; + zeile nach end in zeile; + formatiere; + schreibe die veraenderte zeile nach end. + +foot anweisung entfernen: + zeichenpos := com ende; + ueberspringe das kommando (puffer, zeichenpos, rueckwaerts); + zeichenpos DECR 1; + puffer := subtext (puffer, 1, zeichenpos); + WHILE NOT within kanji (puffer, zeichenpos) AND + (puffer SUB zeichenpos) = blank AND foot stand nicht am zeilenanfang + REP + zeilenbreite DECR breite (blank); + delete char (puffer, zeichenpos); + delete char (neue zeile, length (neue zeile)); + zeichenpos DECR 1 + END REP; + pufferlaenge := length (puffer). + +foot stand nicht am zeilenanfang: + zeichenpos > 0. + +lese eingabe datei bis end kommando: + TEXT VAR kliste :: "end:1.0"; + dummy := zeile; + WHILE NOT foot ende kommando REP + IF eof (eingabe) + THEN LEAVE formatiere diese zeile + FI; + read record (eingabe, dummy); + down (eingabe); + ENDREP; + INT CONST zeile nach end := line no (eingabe); + IF NOT end kommando steht am zeilenende + THEN LEAVE formatiere diese zeile + FI. + +end kommando steht am zeilenende: + k ende = length (dummy) OR k ende + 1 = length (dummy). + +foot ende kommando: + INT VAR k anf, k ende :: 0, anz params, k index; + WHILE noch ein kommando vorhanden REP + k ende := pos (dummy, kommandozeichen, k anf + 1); + IF k ende = 0 + THEN LEAVE foot ende kommando WITH FALSE + ELSE kommando := subtext (dummy, k anf + 1, k ende - 1); + FI; + analyze command (kliste, kommando, 3, kindex, anz params, par1, par2); + IF k index = 1 + THEN LEAVE foot ende kommando WITH TRUE + FI; + END REP; + FALSE. + +noch ein kommando vorhanden: + k anf := pos (dummy, kommandozeichen, k ende + 1); + k anf <> 0. + +zeile nach end in zeile: + read record (eingabe, zeile); + INT VAR text anf := pos (zeile, ""33"", ""255"", 1); + IF zeile nach end ist leerzeile + THEN LEAVE formatiere diese zeile + ELSE IF text anf > 1 + THEN aktuelle blanks := subtext (zeile, 1, text anf - 1); + zeile := subtext (zeile, text anf) + FI; + FI. + +zeile nach end ist leerzeile: + text anf <= 0. + +formatiere: + IF foot stand nicht am zeilenanfang + THEN verarbeite letztes zeichen von puffer + ELSE puffer CAT zeile; + pufferlaenge := length (puffer) + FI; + REP + stranalyze (pitch table, zeilenbreite, aktuelle pitch zeilenlaenge, + puffer, zeichenpos, pufferlaenge, zeichenwert ausgang); + IF zeichenwert ausgang = kommando ausgang + THEN zeichenpos INCR 1; + neue zeile auffuellen (von, zeichenpos - 1); + von := zeichenpos; + INT VAR ende der neuen zeile := length (neue zeile), + zpos davor := zeichenpos; + verarbeite kommando; + neue zeile auffuellen (von, zeichenpos - 1); + von := zeichenpos; + IF kommando index = foot + THEN behandlung der zeile vor foot; + LEAVE formatiere + ELIF zeichenpos >= pufferlaenge + OR zeilenbreite > aktuelle pitch zeilenlaenge + THEN ende einer neuen zeile; + LEAVE formatiere + FI + ELIF zeichenwert ausgang = extended char ausgang + THEN char pos move (vorwaerts); + zeilenbreite INCR breite (puffer, zeichenpos); + char pos move (vorwaerts) + ELIF zeichenwert ausgang = zeilenende ausgang + OR zeichenwert ausgang = esc char ohne zweites byte ausgang + THEN up (eingabe); + delete record (eingabe); + neue zeile auffuellen; + IF zeichenwert ausgang = esc char ohne zweites byte ausgang + THEN fehler (23, "") + FI; + LEAVE formatiere diese zeile + ELSE ende einer neuen zeile; + LEAVE formatiere + FI + END REP. + +behandlung der zeile vor foot: + neue zeile := subtext (neue zeile, 1, ende der neuen zeile); + zeichenpos := zpos davor. + +schreibe die veraenderte zeile nach end: + to line (eingabe, zeile nach end); + dummy := (text anf - 1) * blank; + dummy CAT subtext (puffer, zeichenpos); + IF format file in situ + THEN insert record (eingabe) + FI; + write record (eingabe, dummy). +END PROC fuelle ggf zeile vor foot auf; + +(*************** Tabulator- und Tabellen verarbeitung ******************) + +PROC tabulatorposition eintragen (INT CONST tab type): + ROW 3 INT VAR akt tab pos; + IF anz tabs >= max tabs + THEN fehler (32, "") + ELIF tab in cm umwandeln (par1, tab pos in pitches) + THEN IF tab type = b pos AND tab in cm umwandeln (par2, bis tab) + THEN + ELSE bis tab := 0 + FI; + TEXT VAR zentrierzeichen; + IF tab type = d pos + THEN zentrierzeichen := par2 + ELSE zentrierzeichen := "" + FI; + tabs sortiert eintragen + FI. + +tabs sortiert eintragen: + INT VAR i; + type tab := tab type; + FOR i FROM 1 UPTO anz tabs REP + IF tab pos in pitches = tabs [i] [1] + THEN fehler (42, par1); + LEAVE tabulatorposition eintragen + ELIF tabs [i] [1] > tab pos in pitches + THEN vertauschen + FI; + IF ueberschneidende bpos + THEN fehler (12, text (xstepconversion (tab pos in pitches))) + FI; + END REP; + anz tabs INCR 1; + tabs [anz tabs] := akt tab pos; + tab zeichen [anz tabs] := zentrierzeichen. + +ueberschneidende bpos: + tabs [i] [2] = bpos AND naechste anfang pos liegt in diesem bpos bereich. + +naechste anfang pos liegt in diesem bpos bereich: + tab pos in pitches <= tabs [i] [3]. + +vertauschen: + ROW 3 INT CONST hilf1 :: tabs [i]; + TEXT CONST thilf :: tab zeichen [i]; + tabs [i] := akt tab pos; + tab zeichen [i] := zentrierzeichen; + akt tab pos := hilf1; + zentrierzeichen := thilf. + +tab pos in pitches: + akt tab pos [1]. + +type tab: + akt tab pos [2]. + +bis tab: + akt tab pos [3]. +END PROC tabulatorposition eintragen; + +BOOL PROC tab in cm umwandeln (TEXT CONST text wert, INT VAR f breite): + REAL VAR cm := real (text wert); + IF last conversion ok AND pos (text wert, ".") <> 0 + THEN umwandeln + ELSE fehler (4, par1); + TRUE + FI. + +umwandeln: + conversion (cm, f breite); + IF f breite > aktuelle pitch zeilenlaenge + THEN fehler (39, par1) + ELIF cm = fehlerwert + THEN + ELSE LEAVE tab in cm umwandeln WITH TRUE + FI; + FALSE +END PROC tab in cm umwandeln; + +PROC cm angabe der druckposition in dummy (INT CONST nr): + dummy := text (x step conversion (tabs [nr] [1])); + IF (dummy SUB length (dummy)) = "." + THEN dummy CAT "0" + FI; + dummy CAT " cm" +END PROC cm angabe der druckposition in dummy; + +PROC tabulator position loeschen: + INT VAR tab pos in pitches; + IF tab in cm umwandeln (par1, tab pos in pitches) + THEN versuche zu loeschen + FI. + +versuche zu loeschen: + INT VAR i; + FOR i FROM 1 UPTO anz tabs REP + IF tab pos in pitches = tabs [i] [1] + THEN verschiebe eintraege nach unten; + LEAVE tabulator position loeschen + FI + END REP; + fehler (43, par1). + +verschiebe eintraege nach unten: + INT VAR k; + FOR k FROM i UPTO anz tabs - 1 REP + tabs [k] := tabs [k + 1]; + tab zeichen [k] := tab zeichen [k + 1]; + END REP; + anz tabs DECR 1. +END PROC tabulatorposition loeschen; + +PROC verarbeite tabelle: + in tabelle := TRUE; + pitch table auf blank ausgang setzen; + verarbeite tabellenzeilen; + pitch table auf blank setzen; + IF suchausgang gesetzt + THEN pitch table [pos tab zeichen in pitch table] := + breite erstes dezimalzeichen; + suchausgang gesetzt := FALSE; + FI; + in tabelle := FALSE. + +verarbeite tabellenzeilen: + WHILE pufferlaenge <> 0 REP + ueberpruefe tabellenzeile; + zeichenpos := pufferlaenge; + neue zeile auffuellen und ausgabe bei zeilenende + END REP; + puffer := " "; + pufferlaenge := 1; + zeichenpos := 1; + fehler (49, ""). + +ueberpruefe tabellenzeile: +(* Achtung: Zeilenbreite ist Spaltenbreite; + tab zeilen breite ist Summe der Spalten und Positionen *) + INT VAR tab zeilen breite :: 0, + tab no :: 1; + WHILE noch tab positionen OR only command line (puffer) REP + positioniere auf naechste spalte; + errechne spaltenbreite; + IF anz tabs > 0 + THEN ueberpruefe ob es passt; + FI; + tab no INCR 1 + END REP; + IF tabellenzeile breiter als limit + THEN warnung (10, "") + ELIF noch mehr spaltentexte AND anz tabs <> 0 + THEN warnung (11, subtext (puffer, zeichenpos)) + FI. + +noch tab positionen: + tab no <= anz tabs. + +positioniere auf naechste spalte: + zeichenpos := pos (puffer, ""33"", ""255"", zeichenpos); + IF leerzeile oder rest der zeile ist leer + THEN IF NOT only command line (puffer) AND pufferlaenge > 1 + THEN warnung (14, "") + FI; + LEAVE ueberpruefe tabellenzeile + FI. + +leerzeile oder rest der zeile ist leer: + zeichenpos <= 0. + +errechne spaltenbreite: + zeilenbreite := 0; + BOOL VAR suchausgang gesetzt :: FALSE; + IF diese position ist dezimal pos + THEN setze dezimalzeichen auf suchausgang + FI; + REP + stranalyze (pitch table, zeilenbreite, aktuelle pitch zeilenlaenge, + puffer, zeichenpos, pufferlaenge, zeichenwert ausgang); + zeichenpos INCR 1; + IF zeichenwert ausgang = blank ausgang + THEN behandele dieses blank + ELIF zeichenwert ausgang = kommando ausgang + THEN verarbeite das kommando + ELIF zeichenwert ausgang = extended char ausgang + THEN char pos move (vorwaerts); + zeilenbreite INCR breite (puffer, zeichenpos); + char pos move (vorwaerts) + ELIF zeichenwert ausgang = such ausgang + THEN verarbeite ersten teil der dezimal zentrierung + ELIF zeichenwert ausgang = esc char ohne zweites byte ausgang + THEN fehler (23, ""); + LEAVE ueberpruefe tabellenzeile + ELIF zeilenbreite + zeichenwert ausgang > aktuelle pitch zeilenlaenge + THEN fehler (36, ""); + LEAVE ueberpruefe tabellenzeile + ELSE tabellenzeile ohne absatz + FI + END REP. + +diese position ist dezimal pos: + tabs [tab no] [2] = dpos. + +setze dezimalzeichen auf suchausgang: + INT CONST pos tab zeichen in pitch table :: + code (tab zeichen [tab no] SUB 1) + 1; + INT VAR breite erstes dezimalzeichen :=breite (tab zeichen [tab no] SUB 1), + breite excl dezimalzeichen := 0; + suchausgang gesetzt := TRUE; + pitch table [pos tab zeichen in pitch table] := such ausgang. + +verarbeite ersten teil der dezimal zentrierung: + IF pos (puffer, tab zeichen [tab no], zeichenpos) = zeichenpos + THEN pitch table [pos tab zeichen in pitch table] := + breite erstes dezimalzeichen; + suchausgang gesetzt := FALSE; + breite excl dezimalzeichen := zeilenbreite + FI; + zeilenbreite INCR breite (puffer SUB zeichenpos); + zeichenpos INCR 1. + +behandele dieses blank: + IF doppelblank OR absatz + THEN LEAVE errechne spaltenbreite + ELSE zeilenbreite INCR blankbreite fuer diesen schrifttyp; + zeichenpos INCR 1 + FI. + +doppelblank: + (puffer SUB zeichenpos + 1) = blank. + +verarbeite das kommando: + pitch table auf blank setzen; + verarbeite kommando und neue zeile auffuellen; + pitch table auf blank ausgang setzen; + IF kommando index = table end + THEN LEAVE verarbeite tabellenzeilen + ELIF suchausgang gesetzt AND + pitch table [pos tab zeichen in pitch table] <> suchausgang + THEN pitch table [pos tab zeichen in pitch table] := suchausgang + FI. + +tabellenzeile ohne absatz: + IF zeilenende eines macros + THEN zeile in puffer und zeile lesen; + zeichenpos := pos (puffer, ""33"", ""255"", zeichenpos); + ELSE LEAVE errechne spaltenbreite + FI. + +zeilenende eines macros: + zeichenwert ausgang = zeilenende ausgang AND macro works. + +ueberpruefe ob es passt: + INT CONST akt tab pos :: tabs [tab no] [1]; + IF vorherige spalte ueberschreibt tabulator position + THEN cm angabe der druckposition in dummy (tab no - 1); + fehler (44, dummy); + tab zeilenbreite := akt tab pos + ELIF only command line (puffer) + THEN + ELSE ueberpruefe nach art des tabulators + FI. + +ueberpruefe nach art des tabulators: + IF tabs [tab no] [2] = r pos + THEN nach links schreibend + ELIF tabs [tab no] [2] = l pos + THEN nach rechts schreibend + ELIF tabs [tab no] [2] = b pos + THEN nach rechts blockend schreibend + ELIF tabs [tab no] [2] = c pos + THEN zentrierend + ELSE zentrierend um zeichen + FI. + +vorherige spalte ueberschreibt tabulator position: + tab zeilenbreite > akt tab pos. + +nach links schreibend: + IF tab zeilenbreite + zeilenbreite > akt tab pos + THEN cm angabe der druckposition in dummy (tab no); + fehler (45, dummy); + FI; + tab zeilenbreite := akt tab pos. + +nach rechts schreibend: + tab zeilenbreite := akt tab pos + zeilenbreite. + +nach rechts blockend schreibend: + IF akt tab pos + zeilenbreite > tabs [tab no] [3] + THEN cm angabe der druckposition in dummy (tab no); + fehler (48, dummy) + FI; + tab zeilenbreite := tabs [tab no] [3]. + +zentrierend: + IF tab zeilenbreite + (zeilenbreite DIV 2) > akt tab pos + THEN cm angabe der druckposition in dummy (tab no); + fehler (46, dummy) + FI; + tab zeilenbreite := akt tab pos + (zeilenbreite DIV 2). + +zentrierend um zeichen: + IF breite excl dezimalzeichen = 0 + THEN cm angabe der druckposition in dummy (tab no); + fehler (50, dummy) + ELIF tab zeilenbreite + breite excl dezimalzeichen > akt tab pos + THEN cm angabe der druckposition in dummy (tab no); + fehler (47, dummy) + FI; + IF suchausgang gesetzt + THEN pitch table [pos tab zeichen in pitch table] := + breite erstes dezimalzeichen; + suchausgang gesetzt := FALSE; + FI; + tab zeilenbreite := akt tab pos + + (zeilenbreite - breite excl dezimalzeichen). + +tabellenzeile breiter als limit: + tab zeilenbreite > aktuelle pitch zeilenlaenge + einrueckbreite. + +noch mehr spaltentexte: + pos (puffer, ""33"", ""255"", zeichenpos) <> 0. +END PROC verarbeite tabelle; + +(*********************** referenzen ueberpruefen **********************) + +PROC aktuelle referenz erstellen: + aktuelle referenz := "#"; + aktuelle referenz CAT par1; + aktuelle referenz CAT "#"; +END PROC aktuelle referenz erstellen; + +PROC zielreferenzen speichern ohne warnung: + aktuelle referenz erstellen; + IF pos (zielreferenzen, aktuelle referenz) = 0 + THEN delete char (aktuelle referenz, 1); + zielreferenzen CAT aktuelle referenz + FI +END PROC zielreferenzen speichern ohne warnung; + +PROC zielreferenzen speichern: + aktuelle referenz erstellen; + IF pos (zielreferenzen, aktuelle referenz) <> 0 + THEN warnung (9, par1) + ELSE delete char (aktuelle referenz, 1); + zielreferenzen CAT aktuelle referenz + FI +END PROC zielreferenzen speichern; + +PROC herkunftsreferenzen speichern: + aktuelle referenz erstellen; + IF pos (herkunftsreferenzen, aktuelle referenz) = 0 + THEN delete char (aktuelle referenz, 1); + herkunftsreferenzen CAT aktuelle referenz + FI +END PROC herkunftsreferenzen speichern; + +PROC referenzen ueberpruefen: + ueberpruefe zielreferenzen; + ueberpruefe restliche herkunftsreferenzen. + +ueberpruefe zielreferenzen: + REP + hole naechste zielreferenz; + IF pos (herkunfts referenzen, aktuelle referenz) = 0 + THEN change all (aktuelle referenz,"#", ""); + warnung (3, aktuelle referenz) + ELSE delete char (aktuelle referenz, length (aktuelle referenz)); + change (herkunftsreferenzen, aktuelle referenz, ""); + FI + END REP. + +hole naechste zielreferenz: + IF length (zielreferenzen) > 1 + THEN aktuelle referenz := + subtext (zielreferenzen, 1, pos (zielreferenzen, "#", 2)); + zielreferenzen := + subtext (zielreferenzen, pos (zielreferenzen, "#", 2)) + ELSE LEAVE ueberpruefe zielreferenzen + FI. + +ueberpruefe restliche herkunftsreferenzen: + WHILE length (herkunftsreferenzen) > 1 REP + aktuelle referenz := + subtext (herkunftsreferenzen, 1, pos (herkunftsreferenzen, "#", 2) - 1); + change (herkunftsreferenzen, aktuelle referenz, ""); + delete char (aktuelle referenz, 1); + warnung (4, aktuelle referenz) + END REP. +END PROC referenzen ueberpruefen; + +(*************************** Utilities *******************************) + +INT PROC breite (TEXT CONST z): + INT VAR b; + IF z = "" + THEN display and pause (1) + ELIF z = kommandozeichen + THEN display and pause (2); b := 1 + ELSE b := pitch table [code (z) + 1] + FI; + IF zeilenbreite > maxint - b + THEN display and pause (3); b := 1 + FI; + b. +END PROC breite; + +INT PROC breite (TEXT CONST ein text, INT CONST zpos): + TEXT CONST z :: ein text SUB zpos; + INT VAR zeichen breite; + IF z = "" + THEN display and pause (4); zeichen breite := 1 + ELIF z = kommandozeichen + THEN display and pause (6); zeichen breite := 1 + ELSE zeichen breite := pitch table [code (z) + 1] + FI; + IF zeichen breite = extended char ausgang + THEN zeichen breite := extended char pitch (font nr, + ein text SUB zpos, ein text SUB zpos + 1) + FI; + zeichen breite +END PROC breite; + +PROC char pos move (INT CONST richtung): + char pos move (zeichenpos, richtung) +END PROC char pos move; + +PROC char pos move (INT VAR zpos, INT CONST richtung): + char pos move (puffer, zpos, richtung) +END PROC char pos move; + +BOOL PROC absatz: + zeichenpos = pufferlaenge AND puffer hat absatz +END PROC absatz; + +BOOL PROC puffer hat absatz: + NOT within kanji (puffer, pufferlaenge) AND + (puffer SUB pufferlaenge) = blank +END PROC puffer hat absatz; + +PROC pitch table auf blank ausgang setzen: + IF pitch table [code (blank) + 1] <> blank ausgang + THEN blank breite fuer diesen schrifttyp := breite (blank); + pitch table [code (blank) + 1] := blank ausgang + FI +END PROC pitch table auf blank ausgang setzen; + +PROC pitch table auf blank setzen: + pitch table [code (blank) + 1] := blank breite fuer diesen schrifttyp +END PROC pitch table auf blank setzen; + +(*PROC zustands test (TEXT CONST anf): +line ;put(anf); +line ;put("zeilenbreite, aktuelle pitch zeilenlaenge:"); + put(zeilenbreite);put(aktuelle pitch zeilenlaenge); +line ;put("zeichenpos, pufferlaenge, ausgang, zeichen:"); +put(zeichenpos);put(pufferlaenge); +IF zeichenwert ausgang = blank ausgang + THEN put ("blank") +ELIF zeichenwert ausgang = kommando ausgang + THEN put ("kommando") +ELIF zeichenwert ausgang = such ausgang + THEN put ("such") +ELIF zeichenwert ausgang = zeilenende ausgang + THEN put ("zeilenende") + ELSE put(zeichenwert ausgang); +FI; put ("ausgang"); +out(">");out(puffer SUB zeichenpos);out("<"); +line ;out("puffer >"); +IF length (puffer) > 65 + THEN outsubtext (puffer, 1, 65); + line ; outsubtext (puffer, 66) + ELSE out(puffer); +FI; +out("<"); +line ;out("zeile >"); +IF length (zeile) > 65 + THEN outsubtext (zeile, 1, 65); + line ; outsubtext (zeile, 66) + ELSE out (zeile); +FI; +out("<"); +line ;out("neue zeile >"); +IF length (neue zeile) > 65 + THEN outsubtext (neue zeile, 1, 65); + line ; outsubtext (neue zeile, 66) + ELSE out(neue zeile); +FI; +out("<"); +line ; +END PROC zustands test;*) + +(*************************** eigentliche form routine ********************) + +PROC zeilen form (TEXT CONST datei): + enable stop; + form initialisieren (datei); + formiere absatzweise; + letzte neue zeile ausgeben. + +formiere absatzweise: + REP + letzter puffer war absatz := FALSE; + einrueckbreite := eingestellte indentation pitch; + IF einfacher absatz nach absatz + THEN gebe einfachen absatz aus + ELSE verarbeite abschnitt nach absatz + FI + UNTIL pufferlaenge = 0 END REP. + +einfacher absatz nach absatz: + absatz. + +gebe einfachen absatz aus: + neue zeile := blank; + ausgabe bei zeilenende. + +verarbeite abschnitt nach absatz: + berechne erste zeile nach absatz; + IF NOT letzter puffer war absatz + THEN formiere + FI. + +formiere: + INT VAR letzte zeilennr; + REP + stranalyze (pitch table, zeilenbreite, aktuelle pitch zeilenlaenge, + puffer, zeichenpos, pufferlaenge, zeichenwert ausgang); + IF zeichenwert ausgang = kommando ausgang + THEN zeichenpos INCR 1; + verarbeite kommando und neue zeile auffuellen; + IF letzter puffer war absatz + THEN ausgabe bei zeilenende; + LEAVE verarbeite abschnitt nach absatz + ELIF zeichenpos > pufferlaenge OR absatz + THEN letzte zeilennr := zeilennr; + verarbeite letztes zeichen von puffer; + IF neue zeile ausgeloest + THEN LEAVE verarbeite abschnitt nach absatz + ELSE letzter puffer war absatz := FALSE + FI + FI + ELIF zeichenwert ausgang = extended char ausgang + THEN char pos move (vorwaerts); + zeilenbreite INCR breite (puffer, zeichenpos); + char pos move (vorwaerts) + ELIF zeichenwert ausgang = zeilenende ausgang + OR zeichenwert ausgang = esc char ohne zweites byte ausgang + THEN letzte zeilennr := zeilennr; + verarbeite letztes zeichen von puffer; + IF zeichenwert ausgang = esc char ohne zweites byte ausgang + THEN fehler (23, "") + FI; + IF neue zeile ausgeloest + THEN LEAVE verarbeite abschnitt nach absatz + ELSE letzter puffer war absatz := FALSE + FI + ELSE ende einer neuen zeile + FI; + UNTIL pufferlaenge = 0 END REP. + +neue zeile ausgeloest: + letzte zeilennr < zeilennr. +END PROC zeilen form; + +PROC berechne erste zeile nach absatz: + INT CONST anz einrueckungszeichen :: zeilenbreite DIV einrueckbreite; + INT VAR anz zeichen fuer einzeilige einrueckung :: 0, + anz zeichen :: 0, + schlepper zeichenpos :: 1, + letzte zeilennr; + BOOL CONST puffer hatte anfangs absatz :: puffer hat absatz; + BOOL VAR noch kein blank gewesen :: TRUE; + pitch table auf blank ausgang setzen; + berechne erste zeile; + pitch table auf blank setzen. + +berechne erste zeile: + REP + stranalyze (pitch table, zeilenbreite, aktuelle pitch zeilenlaenge, + puffer, zeichenpos, pufferlaenge, zeichenwert ausgang); + IF zeichenwert ausgang = blank ausgang + THEN verarbeite text + ELIF zeichenwert ausgang = extended char ausgang + THEN char pos move (vorwaerts); + zeilenbreite INCR breite (puffer, zeichenpos); + char pos move (vorwaerts) + ELIF zeichenwert ausgang = kommando ausgang + THEN verarbeite dieses kommando + ELIF zeichenwert ausgang = zeilenende ausgang + OR zeichenwert ausgang = esc char ohne zweites byte ausgang + THEN behandele zu kurze zeile + ELSE behandele zu lange zeile + FI + END REP. + +verarbeite dieses kommando: + textzeichen mitzaehlen; + IF pos (" #", (puffer SUB zeichenpos)) = 0 + THEN aufzaehlungszeichen := (puffer SUB zeichenpos) + FI; + char pos move (vorwaerts); + mitzuzaehlende zeichen := 0; + pitch table auf blank setzen; + verarbeite kommando und neue zeile auffuellen; + pitch table auf blank ausgang setzen; + IF letzter puffer war absatz + THEN neue zeile auffuellen und ausgabe bei zeilenende; + LEAVE berechne erste zeile + ELIF zeichenpos > pufferlaenge OR absatz + THEN letzte zeilennr := zeilennr; + verarbeite letztes zeichen von puffer; + IF neue zeile ausgeloest + THEN LEAVE berechne erste zeile + ELSE letzter puffer war absatz := FALSE + FI + ELIF anweisung erlaubt keine aufzaehlung + THEN LEAVE berechne erste zeile + FI; + anz zeichen INCR mitzuzaehlende zeichen; + schlepper zeichenpos := zeichenpos. + +neue zeile ausgeloest: + letzte zeilennr < zeilennr. + +anweisung erlaubt keine aufzaehlung: + kommando index = center OR kommando index = right. + +verarbeite text: + char pos move (vorwaerts); + IF absatz + THEN verarbeite letztes zeichen von puffer; + LEAVE berechne erste zeile + ELIF zeilenbreite + blankbreite fuer diesen schrifttyp > + aktuelle pitch zeilenlaenge + THEN behandele zu lange zeile + ELIF mehrfaches blank + THEN positionierung mit doppelblank + ELIF noch kein blank gewesen AND + anz zeichen + + number chars (puffer, schlepper zeichenpos, zeichenpos) <= 20 + THEN ggf aufzaehlung aufnehmen + ELSE zeilenbreite INCR blankbreite fuer diesen schrifttyp + FI; + noch kein blank gewesen := FALSE; + zeichenpos INCR 1. + +mehrfaches blank: + (puffer SUB zeichenpos + 1) = blank. + +positionierung mit doppelblank: + WHILE NOT within kanji (puffer, zeichenpos + 1) AND + (puffer SUB zeichenpos + 1) = blank REP + zeichenpos INCR 1 + END REP; + textzeichen mitzaehlen; + pruefe auf ueberschreibung + (zeilenbreite, anz zeichen + anz einrueckungszeichen). + +ggf aufzaehlung aufnehmen: + IF NOT within kanji (puffer, zeichenpos - 1) AND + (puffer SUB zeichenpos - 1) <> kommandozeichen + THEN aufzaehlungszeichen := (puffer SUB zeichenpos - 1); + FI; + textzeichen mitzaehlen; + IF aufzaehlungszeichen = ":" + OR (aufzaehlungszeichen = "-" AND anz zeichen <= 2) + OR (anz zeichen <= 7 AND ( aufzaehlungszeichen = ")" + OR aufzaehlungszeichen = ".")) + THEN anz zeichen fuer einzeilige einrueckung := anz zeichen; + pruefe auf ueberschreibung + (zeilenbreite, anz zeichen + anz einrueckungszeichen) + ELSE zeilenbreite INCR blankbreite fuer diesen schrifttyp + FI. + +textzeichen mitzaehlen: + anz zeichen INCR number chars (puffer, schlepper zeichenpos, zeichenpos); + IF is kanji esc (puffer SUB zeichenpos) + THEN schlepper zeichenpos := zeichenpos + 2 + ELSE schlepper zeichenpos := zeichenpos + 1 + FI. + +behandele zu kurze zeile: + textzeichen mitzaehlen; + IF zeichenwert ausgang = esc char ohne zweites byte ausgang + THEN fehler (23, ""); + neue zeile auffuellen; + schreibe und initialisiere neue zeile; + zeichenpos := 1; + LEAVE berechne erste zeile + FI; + letzte zeilennr := zeilennr; + verarbeite letztes zeichen von puffer; + IF neue zeile ausgeloest + THEN LEAVE berechne erste zeile + FI; + schlepper zeichenpos := 1. + +behandele zu lange zeile: + pitch table auf blank setzen; + IF zeilenende bei erstem zeichen + THEN loesche nachfolgende blanks; + schreibe und initialisiere neue zeile; + zeichenpos := 1; + LEAVE berechne erste zeile + ELIF (puffer SUB zeichenpos) = kommandozeichen + THEN zeichenpos INCR 1 + ELSE zeilenbreite DECR breite (puffer, zeichenpos) + FI; + IF puffer hatte anfangs absatz + THEN einrueckung gemaess pufferanfang + FI; + LEAVE berechne erste zeile. + +zeilenende bei erstem zeichen: + zeichenpos < 1. + +einrueckung gemaess pufferanfang: +alte blanks := +(anz einrueckungszeichen + anz zeichen fuer einzeilige einrueckung) * blank. +END PROC berechne erste zeile nach absatz; + +PROC pruefe auf ueberschreibung (INT CONST aufzaehlungsbreite, + anz aufzaehlungszeichen): + IF ueberschreibung + THEN fehlende blanks errechnen; + INT VAR aufzaehlungsende :: zeichenpos - 1; + WHILE (puffer SUB aufzaehlungsende) = blank REP + aufzaehlungsende DECR 1 + END REP; + dummy := ">"; + dummy CAT subtext (puffer, + aufzaehlungsende - 15, aufzaehlungsende); + dummy CAT "< Fehlende Blanks: "; + dummy CAT text (anz fehlende blanks); + warnung (12, dummy) + FI; + zeilenbreite := anz aufzaehlungszeichen * einrueckbreite. + +ueberschreibung: + INT CONST anz zeichen mal einrueckbreite :: + anz aufzaehlungszeichen * einrueckbreite, + min zwischenraum :: (einrueckbreite DIV 4); + aufzaehlungsbreite + min zwischenraum > anz zeichen mal einrueckbreite. + +fehlende blanks errechnen: + INT VAR anz fehlende blanks :: + (aufzaehlungsbreite + min zwischenraum + - anz zeichen mal einrueckbreite + einrueckbreite - 1) + DIV einrueckbreite. +END PROC pruefe auf ueberschreibung; + +(********************** eingabe routinen **************************) + +PROC zeile lesen: + alte blanks := aktuelle blanks; + hole zeile; + behandele einrueckung. + +hole zeile: + IF macro works + THEN get macro line (zeile); + ELIF eof (eingabe) + THEN zeile := ""; + LEAVE zeile lesen + ELSE lesen + FI; + IF zeile = "" + THEN zeile := blank + ELIF (zeile SUB length (zeile) - 1) = blank + THEN ggf ueberfluessige leerzeichen am ende entfernen + FI. + +lesen: + IF format file in situ + THEN read record (eingabe, zeile); + delete record (eingabe) + ELSE read record (eingabe, zeile); + down (eingabe) + FI. + +ggf ueberfluessige leerzeichen am ende entfernen: + WHILE NOT within kanji (zeile, length (zeile) - 1) AND + subtext (zeile, length (zeile) - 1) = " " REP + delete char (zeile, length (zeile)) + END REP. + +behandele einrueckung: + aktuelle blanks := ""; + IF zeile <> blank + THEN INT VAR einrueckung := pos (zeile, ""33"", ""255"", 1); + IF einrueckung > 1 + THEN aktuelle blanks := subtext (zeile, 1, einrueckung - 1); + zeile := subtext (zeile, einrueckung) + FI + FI +END PROC zeile lesen; + +PROC zeile in puffer und zeile lesen: + puffer := zeile; + zeichenpos := 1; + von := 1; + zeile lesen; + pufferlaenge := length (puffer); + ggf absatz an puffer anfuegen; +END PROC zeile in puffer und zeile lesen; + +PROC ggf absatz an puffer anfuegen: + IF (zeile ist nur absatz AND NOT puffer hat absatz) + OR (NOT puffer hat absatz AND only command line (puffer) + AND only command line (zeile)) + THEN puffer CAT blank; + pufferlaenge := length (puffer) + ELIF puffer ist nur absatz AND (zeile SUB length (zeile)) <> " " AND + only command line (zeile) + THEN zeile CAT " " + FI. + +puffer ist nur absatz: + puffer = blank. + +zeile ist nur absatz: + zeile = blank. +END PROC ggf absatz an puffer anfuegen; + +(****************** routinen fuer zeilenende behandlung ***********) + +PROC verarbeite letztes zeichen von puffer: + zeichenpos := length (puffer); + begin of this char (puffer, zeichenpos); + zeichen := puffer SUB zeichenpos; + IF trennung vorhanden + THEN IF zeile hat richtige laenge + THEN neue zeile auffuellen und ausgabe bei zeilenende + ELSE getrennte zeilen zusammenziehen + FI + ELSE neue zeile auffuellen; + IF absatz + THEN letzter puffer war absatz := TRUE; + IF letztes kommando war macro AND macro hat absatz getaetigt + THEN zeile in puffer und zeile lesen; + initialisiere neue zeile; + ELSE ausgabe bei zeilenende; + FI + ELSE neue zeile ggf weiterfuehren + FI + FI. + +neue zeile ggf weiterfuehren: + IF macro end in dieser oder naechster zeile + THEN + ELIF zeile = "" + THEN schreibe und initialisiere neue zeile; + letzter puffer war absatz := TRUE + ELIF zeilenbreite + blank breite fuer diesen schrifttyp > + aktuelle pitch zeilenlaenge + THEN loesche nachfolgende blanks; + schreibe und initialisiere neue zeile + ELIF in neuer zeile steht etwas + THEN neue zeile CAT blank; + zeilenbreite INCR blank breite fuer diesen schrifttyp + FI; + zeile in puffer und zeile lesen. + +macro end in dieser oder naechster zeile: + macro works AND (pos (puffer, "#*") <> 0 OR pos (zeile, "#*") <> 0). + +in neuer zeile steht etwas: + pos (neue zeile, ""33"", ""255"", 1) <> 0. + +letztes kommando war macro: + pos (kommando, "macro") <> 0. + +macro hat absatz getaetigt: + NOT in neuer zeile steht etwas. +END PROC verarbeite letztes zeichen von puffer; + +PROC getrennte zeilen zusammenziehen: + zeichen := puffer SUB pufferlaenge; + IF NOT within kanji (puffer, pufferlaenge) AND zeichen = trennzeichen + THEN zeilenbreite DECR breite (trennzeichen); + delete char (puffer, pufferlaenge); + pufferlaenge := length (puffer); + IF ((puffer SUB pufferlaenge) = trenn k) AND ((zeile SUB 1) = "k") + THEN replace (puffer, pufferlaenge, "c"); + zeilenbreite DECR breite ("k"); + zeilenbreite INCR breite ("c"); + FI; + zeichenpos := pufferlaenge + 1 + FI; + puffer CAT zeile; + zeile lesen; + pufferlaenge := length (puffer); + ggf absatz an puffer anfuegen; +END PROC getrennte zeilen zusammenziehen; + +BOOL PROC trennung vorhanden: + IF within kanji (puffer, pufferlaenge) + THEN LEAVE trennung vorhanden WITH FALSE + FI; + zeichen := puffer SUB pufferlaenge; + zeichen = trennzeichen OR wort mit bindestrich. + +wort mit bindestrich: + zeichen = bindestrich AND kein leerzeichen davor + AND NOT naechstes wort ist konjunktion AND kein loser gedankenstrich. + +kein leerzeichen davor: + NOT within kanji (puffer, pufferlaenge - 1) AND + (puffer SUB pufferlaenge - 1) <> blank. + +naechstes wort ist konjunktion: + pos (zeile, "und") = 1 + OR pos (zeile, "oder") = 1 + OR pos (zeile, "bzw") = 1 + OR pos (zeile, "sowie") = 1. + +kein loser gedankenstrich: + pufferlaenge > 1. +END PROC trennung vorhanden; + +BOOL PROC zeile hat richtige laenge: + zeilenbreite > aktuelle pitch zeilenlaenge - trennbreite +END PROC zeile hat richtige laenge; + +(*********************** ausgabe routinen *******************) + +PROC ende einer neuen zeile: + IF zeichenpos > 0 + THEN begin of this char (puffer, zeichenpos); + FI; + zeichen := puffer SUB zeichenpos; + zeichenpos bereits verarbeitet := 0; + IF naechstes zeichen ist absatz + THEN zeichenpos := pufferlaenge; + verarbeite letztes zeichen von puffer; + LEAVE ende einer neuen zeile + ELIF zeichen = blank + THEN neue zeile auffuellen (von, zeichenpos - 1); + zeichenpos := pos (puffer, ""33"", ""255"", zeichenpos); + von := zeichenpos; + ELIF nach zeichenpos beginnt ein neues wort + THEN neue zeile auffuellen (von, zeichenpos); + zeichenpos := pos (puffer, ""33"", ""255"", zeichenpos + 1); + von := zeichenpos + ELIF letzter puffer passte genau + THEN (* erstes zeichen des neuen puffers > zeilenbreite *) + zeichenpos := 1; + von := 1 + ELSE zeichenpos bereits verarbeitet := zeichenpos; + trennung eventuell vornehmen; + IF erstes wort auf der absatzzeile laesst sich nicht trennen + THEN alte blanks := aktuelle blanks + FI + FI; + loesche nachfolgende blanks; + IF NOT in foot uebertrag + THEN schreibe und initialisiere neue zeile; + zeilenbreite und zeichenpos auf das bereits verarbeitete + zeichen setzen; + FI. + +erstes wort auf der absatzzeile laesst sich nicht trennen: + pos (neue zeile, ""33"", ""255"", 1) = 0 AND (*keine buchstaben*) + length (neue zeile) > 1 AND (*einrueckung*) + (neue zeile SUB length (neue zeile)) = blank. (* Absatz *) + +naechstes zeichen ist absatz: + zeichenpos + 1 = pufferlaenge AND puffer hat absatz. + +nach zeichenpos beginnt ein neues wort: + (pufferlaenge > zeichenpos + 2) AND (puffer SUB zeichenpos + 1) = blank. + +letzter puffer passte genau: + zeichenpos <= 0. + +zeilenbreite und zeichenpos auf das bereits verarbeitete zeichen setzen: + IF zeichenpos bereits verarbeitet <> 0 + THEN INT VAR bis := zeichenpos, einfuege pos := bis; + zeilenbreite um die bereits verarbeiteten zeichen erhoehen; + zeichenpos := zeichenpos bereits verarbeitet; + IF einfuege pos > 1 + THEN insert char (puffer, blank, einfuege pos); + pufferlaenge := length (puffer); + von := einfuege pos + 1; + char pos move (vorwaerts) + FI; + char pos move (vorwaerts); + FI. + +zeilenbreite um die bereits verarbeiteten zeichen erhoehen: + zeichenpos := zeichenpos bereits verarbeitet; + WHILE (puffer SUB bis) = kommandozeichen REP + bis := pos (puffer, kommandozeichen, bis + 1) + 1 + END REP; + begin of this char (puffer, zeichenpos); + WHILE zeichenpos >= bis REP + IF (puffer SUB zeichenpos) = kommandozeichen + THEN ueberspringe das kommando (puffer, zeichenpos, rueckwaerts) + ELSE zeilenbreite INCR breite (puffer, zeichenpos); + FI; + IF zeichenpos <= 1 + THEN LEAVE zeilenbreite um die bereits verarbeiteten zeichen erhoehen + FI; + char pos move (rueckwaerts) + END REP. +END PROC ende einer neuen zeile; + +PROC loesche nachfolgende blanks: + WHILE NOT within kanji (neue zeile, length (neue zeile)) AND + (neue zeile SUB length (neue zeile)) = blank REP + delete char (neue zeile, length (neue zeile)) + END REP +END PROC loesche nachfolgende blanks; + +PROC neue zeile auffuellen: + dummy := subtext (puffer, von); + neue zeile CAT dummy +END PROC neue zeile auffuellen; + +PROC neue zeile auffuellen (INT CONST from, to): + dummy := subtext (puffer, from, to); + neue zeile CAT dummy +END PROC neue zeile auffuellen; + +PROC schreibe neue zeile: + IF macro works + THEN IF alte neue zeile einschliesslich macro ist auszugeben + THEN schreibe textteil einschliesslich macro; + FI + ELSE schreibe; + pruefe auf abbruch + FI. + +alte neue zeile: + before macro state . new line. + +alter puffer: + before macro state . buffer line. + +alte neue zeile einschliesslich macro ist auszugeben: + INT VAR text anf :: pos (alte neue zeile, ""33"", ""255"", 1); + text anf <> 0. + +schreibe textteil einschliesslich macro: + dummy := neue zeile; + neue zeile := alte neue zeile; + IF macro hatte absatz danach + THEN neue zeile CAT " " + ELSE zeilennr INCR 1 + FI; + schreibe; + neue zeile := dummy; + alte neue zeile := subtext (alte neue zeile, 1, text anf - 1). + +macro hatte absatz danach: + length (alter puffer) - 1 = length (alte neue zeile) AND + (alter puffer SUB length (alter puffer)) = " ". + +pruefe auf abbruch: + IF incharety = escape + THEN errorstop ("Abbruch mit ESC") + FI. +END PROC schreibe neue zeile; + +PROC schreibe: + IF format file in situ + THEN insert record (eingabe); + write record (eingabe, neue zeile); + down (eingabe) + ELSE insert record (ausgabe); + write record (ausgabe, neue zeile); + down (ausgabe); + speicher ueberlauf + FI; + execute stored commands; + IF (neue zeile SUB length (neue zeile)) = blank + THEN einrueckbreite := eingestellte indentation pitch + FI. + +speicher ueberlauf: + INT VAR size, used; + storage (size, used); + IF used > size + THEN errorstop ("Speicherengpaß") + FI. +END PROC schreibe; + +PROC schreibe und initialisiere neue zeile: + schreibe neue zeile; + initialisiere neue zeile +END PROC schreibe und initialisiere neue zeile; + +PROC ausgabe bei zeilenende: + schreibe und initialisiere neue zeile; + zeile in puffer und zeile lesen +END PROC ausgabe bei zeilenende; + +PROC neue zeile auffuellen und ausgabe bei zeilenende: + neue zeile auffuellen; + schreibe und initialisiere neue zeile; + zeile in puffer und zeile lesen +END PROC neue zeile auffuellen und ausgabe bei zeilenende; + +PROC initialisiere neue zeile: + einrueckung in die neue zeile; + zeilennummer mitzaehlen. + +einrueckung in die neue zeile: + IF zeichenpos < pufferlaenge AND + (puffer hat absatz OR foot ohne absatz am zeilenende) + THEN neue zeile := alte blanks + ELSE neue zeile := aktuelle blanks + FI; + zeilenbreite := length (neue zeile) * einrueckbreite; + IF zeilenbreite +trennbreite +einrueckbreite >= aktuelle pitch zeilenlaenge + THEN fehler (10, ""); + zeilenbreite := 0; + FI. + +foot ohne absatz am zeilenende: + pos (puffer, "#foot#") > 1 AND pos (puffer, "#foot#") = length (puffer) -5. + +zeilennummer mitzaehlen: + IF NOT macro works + THEN zeilennr INCR 1; + cout (zeilennr); + FI. +END PROC initialisiere neue zeile; + +PROC letzte neue zeile ausgeben: + IF pos (neue zeile, ""33"", ""255"", 1) <> 0 + THEN schreibe neue zeile + FI; + offene modifikationen ausgeben; + offene indizes ausgeben; + IF aktueller editor < 1 + THEN referenzen ueberpruefen; + offene counter referenzen ausgeben; + FI. + +offene modifikationen ausgeben: + WHILE length (modifikations speicher) <> 0 REP + dummy := (modifikations speicher SUB 1); + delete char (modifikations speicher, 1); + dummy CAT " in Zeile "; + dummy CAT text (mod zeilennr speicher ISUB 1); + delete int (mod zeilennr speicher, 1); + warnung (5, dummy) + END REP. + +offene indizes ausgeben: + WHILE length (index speicher) <> 0 REP + dummy := (index speicher SUB 1); + delete char (index speicher, 1); + dummy CAT " in Zeile "; + dummy CAT text (ind zeilennr speicher ISUB 1); + delete int (ind zeilennr speicher, 1); + warnung (6, dummy) + END REP. + +offene counter referenzen ausgeben: + INT VAR begin pos := pos (counter reference store, "#"); + WHILE begin pos > 0 REP + INT VAR end pos := pos (counter reference store, "#", begin pos + 1); + IF (counter reference store SUB begin pos - 1) <> "u" + THEN fehler (60, subtext (counter reference store, begin pos + 1, + end pos - 1)) + ELIF (counter reference store SUB begin pos - 2) <> "i" + THEN fehler (61, subtext (counter reference store, begin pos + 1, + end pos - 1)) + FI; + begin pos := pos (counter reference store, "#", end pos + 1) + END REP. +END PROC letzte neue zeile ausgeben; + +(*********************** silbentrenn routinen *******************) + +INT PROC position von (TEXT CONST such zeichen, INT CONST richtung, + INT VAR anz zeich, breite der z): + INT VAR index :: zeichenpos; + TEXT VAR akt z; + anz zeich := 0; + breite der z := 0; + WHILE index > 1 AND index < pufferlaenge REP + akt z := puffer SUB index; + IF akt z = such zeichen + THEN LEAVE position von WITH index + ELIF akt z = kommandozeichen + THEN ueberspringe das kommando (puffer, index, richtung); + IF nur ein kommandozeichen gefunden + THEN gehe nur bis erstes kommandozeichen + ELIF index <= 1 OR index >= pufferlaenge + THEN LEAVE position von WITH index + FI + ELSE anz zeich INCR 1; + breite der z INCR breite (puffer, index) + FI; + char pos move (index, richtung) + END REP; + anz zeich INCR 1; + breite der z INCR breite (puffer, index); + index. + +nur ein kommandozeichen gefunden: + (puffer SUB index) <> kommandozeichen. + +gehe nur bis erstes kommandozeichen: + index := zeichenpos; anz zeich := 0; breite der z := 0; + WHILE (puffer SUB index) <> kommandozeichen REP + anz zeich INCR 1; + breite der z INCR breite (puffer, index); + char pos move (index, richtung) + END REP; + IF richtung <> rueckwaerts + THEN index DECR 1 + FI; + LEAVE position von WITH index. +END PROC position von; + +PROC ueberspringe das kommando (TEXT CONST t, INT VAR i, INT CONST richtung): + REP + i INCR richtung; + IF within kanji (t, i) + THEN i INCR richtung + FI + UNTIL (t SUB i) = kommandozeichen OR i <= 1 OR i >= length (t) END REP. +END PROC ueberspringe das kommando; + +PROC trennung eventuell vornehmen: +INT VAR xwort1, ywort1, + anz zeichen davor, + breite davor; + IF macro works + THEN fehler (6, "") + FI; + trennsymbol := trennzeichen; + wortanfang := position von + (blank, rueckwaerts, anz zeichen davor, breite davor); + bereite neue zeile bis wortanfang auf; + IF trennung sinnvoll + THEN versuche zu trennen + ELSE zeichenpos := wortanfang + FI. + +bereite neue zeile bis wortanfang auf: + IF wortanfang > 1 + THEN wortanfang INCR 1 + FI; + IF von > wortanfang + THEN eliminiere zeichen in neuer zeile bis wortanfang + ELSE neue zeile auffuellen (von, wortanfang - 1) + FI; + von := wortanfang. + +eliminiere zeichen in neuer zeile bis wortanfang: + INT VAR y :: length (neue zeile); + begin of this char (neue zeile, y); + WHILE y >= 1 REP + IF (neue zeile SUB y) = kommandozeichen + THEN ueberspringe das kommando (neue zeile, y, rueckwaerts) + FI; + char pos move (neue zeile, y, rueckwaerts) + UNTIL (neue zeile SUB y) = blank END REP; + neue zeile := subtext (neue zeile, 1, y). + +trennung sinnvoll: + anz zeichen davor > 2 AND breite davor > trennbreite. + +versuche zu trennen: + INT CONST k := zeichenpos; + naechste zeile ggf heranziehen; + zeichenpos := k; + wortteile holen; + trenn (trennwort ohne komm, wort1 ohne komm, trennsymbol, + max trennlaenge ohne komm); + wort1 mit komm ermitteln; + IF lineform mode + THEN wort2 := subtext (trennwort, length (wort1) + 1, max trennlaenge); + display vorherige zeile bis wortanfang; + schreibe nicht trennbaren teil des trennwortes; + schreibe zeile nach trennwort; + skip input; + interaktive worttrennung + FI; + neue zeile mit trennwort versehen; + IF wort1 <> "" AND NOT lineform mode + THEN note (zeilen nr); note (": "); + note (trennwort); + note (" --> "); + note (wort1); note (trennsymbol); + wort2 := subtext (trennwort, length (wort1) + 1); + note (wort2); + note line + FI. + +wortteile holen: + zeichenpos durch trennzeichenbreite verschieben; + wort1 := subtext (puffer, wortanfang, zeichenpos); + max trennlaenge := length (wort1); + wortende ermitteln; + wort2 := subtext (puffer, zeichenpos, wortende); + trennwort := subtext (puffer, wortanfang, wortende); + trennwort ohne komm ermitteln; + wort1 ohne komm := subtext (trennwort ohne komm, 1, anz zeichen davor); + max trenn laenge ohne komm := anz zeichen davor. + +trennwort ohne komm ermitteln: + trennwort ohne komm := trennwort; + WHILE pos (trennwort ohne komm, kommando zeichen) <> 0 REP + INT CONST komm anf := pos (trennwort ohne komm, kommando zeichen), + komm ende:= pos (trennwort ohne komm, kommando zeichen, + komm anf + 1); + IF komm ende = 0 + THEN LEAVE trennwort ohne komm ermitteln + FI; + dummy := subtext (trennwort ohne komm, komm ende + 1); + trennwort ohne komm := subtext (trennwort ohne komm, 1, komm anf - 1); + trennwort ohne komm CAT dummy; + END REP. + +wort1 mit komm ermitteln: + IF length (wort1 ohne komm) = 0 + THEN wort1 := ""; + LEAVE wort1 mit komm ermitteln + FI; + INT VAR index ohne := 0, + index mit := 0; + REP + index ohne INCR 1; + index mit INCR 1; + WHILE (wort1 SUB index mit) = kommando zeichen REP + index mit := pos (wort1, kommando zeichen, index mit + 1) + 1 + END REP; + UNTIL index ohne >= length (wort1 ohne komm) END REP; + wort1 := subtext (wort1, 1, index mit). + +zeichenpos durch trennzeichenbreite verschieben: + REP + zeichen := puffer SUB zeichenpos; + IF zeichen = kommandozeichen + THEN ueberspringe das kommando (puffer, zeichenpos, rueckwaerts); + char pos move (rueckwaerts) + ELIF zeichenpos < wortanfang + 1 + THEN zeichenpos := wortanfang; + LEAVE trennung eventuell vornehmen + ELSE zeilenbreite DECR breite (puffer, zeichenpos); + anz zeichen davor DECR 1; + char pos move (rueckwaerts); + IF zeilenbreite+breite(trennzeichen) <= aktuellepitchzeilenlaenge + AND (puffer SUB zeichenpos) <> kommandozeichen + THEN LEAVE zeichenpos durch trennzeichenbreite verschieben + FI + FI; + END REP. + +wortende ermitteln: + INT VAR x1, x2; + wortende := position von (blank, 1, x1, x2); + IF pufferlaenge > wortende + THEN wortende DECR 1 + FI. + +display vorherige zeile bis wortanfang: + dummy := neue zeile; + dummy CAT subtext (puffer, von, wortanfang - 2); + line ; + outsubtext (dummy, length (dummy) - 78). + +schreibe nicht trennbaren teil des trennwortes: + line ; + get cursor (xwort1, ywort1); + IF length (trennwort) < 70 + THEN cursor (max trennlaenge + 4, ywort1); + outsubtext (trennwort, max trennlaenge + 1) + FI. + +schreibe zeile nach trennwort: + dummy := subtext (puffer, wortende + 1); + get cursor (trennwort endepos, ywort1); + IF length (trennwort) >= 70 + THEN + ELIF length (dummy) > 75 - trennwort ende pos + THEN outsubtext (dummy, 1, 75 - trennwort endepos); + ELSE out (dummy); + IF (dummy SUB length (dummy)) = blank + THEN cursor (78, ywort1); + out (begin mark); + out (end mark) + FI + FI. + +trennwort endepos: + xwort1. + +interaktive worttrennung: + REP + out (return); + schreibe erstes wort; + get cursor (xwort1, ywort1); + schreibe trennung; + schreibe zweites wort; + schreibe rest bei zu langem trennwort; + cursor (xwort1, ywort1); + hole steuerzeichen und veraendere worte + END REP. + +schreibe erstes wort: + out (begin mark); + IF length (trennwort) < 70 + THEN out (wort1) + ELSE outsubtext (wort1, length (wort1) - 60) + FI. + +schreibe trennung: + IF ck vorhanden + THEN out (links); out ("k"); + FI; + out (trennsymbol). + +schreibe zweites wort: + IF length (trennwort) < 70 + THEN out (wort2) + ELSE outsubtext (wort2, 1, 70 - xwort1); + FI; + out (end mark). + +schreibe rest bei zu langem trennwort: + IF length (trennwort) >= 70 + THEN INT VAR xakt pos; + out (cl eol); + get cursor (xakt pos, ywort1); + outsubtext (trennwort, max trennlaenge + 1, + max trennlaenge + 1 + (78 - xakt pos)) + FI. + +ck vorhanden: + (wort1 SUB length (wort1)) = "c" AND + (trennwort SUB (length (wort1) + 1)) = "k". + +hole steuerzeichen und veraendere worte: +TEXT VAR steuerzeichen; + inchar (steuerzeichen); + IF steuerzeichen = links + THEN nach links + ELIF steuerzeichen = rechts + THEN nach rechts + ELIF steuerzeichen = hop + THEN sprung + ELIF steuerzeichen = return + THEN line ; + LEAVE interaktive worttrennung + ELIF steuerzeichen = escape + THEN errorstop ("Abbruch mit ESC") + ELIF code (steuerzeichen) < 32 + THEN + ELSE trennsymbol := steuerzeichen; + LEAVE hole steuerzeichen und veraendere worte + FI; + IF wort1 = "" + OR (wort1 SUB length (wort1)) = bindestrich + THEN trennsymbol := blank + ELSE trennsymbol := trennzeichen + FI. + +nach links: +TEXT VAR ein zeichen; +INT VAR position; + IF length (wort1) <> 0 + THEN position := length (wort1); + IF (wort1 SUB position) = kommando zeichen + THEN ueberspringe das kommando (wort1, position, rueckwaerts); + FI; + position DECR 1; + wort1 := subtext (trennwort, 1, position); + wort2 := subtext (trennwort, position + 1, max trennlaenge); + IF rechtes teilwort mit bindestrich + THEN ein zeichen := (wort1 SUB length (wort1)); + delete char (wort1, length (wort1)); + insert char (wort2, ein zeichen, 1) + FI + FI. + +nach rechts: + IF length (wort1) < max trennlaenge + THEN position := length (wort1) + 1; + IF (trennwort SUB position) = kommando zeichen + THEN ueberspringe das kommando (trennwort, position, +1); + FI; + wort1 := subtext (trennwort, 1, position); + wort2 := subtext (trennwort, position + 1, max trennlaenge); + IF rechtes teilwort mit bindestrich + THEN wort1 CAT bindestrich; + delete char (wort2, 1) + FI + FI. + +rechtes teilwort mit bindestrich: + (wort2 SUB 1) = bindestrich AND + pos (buchstaben, wort1 SUB length (wort1)) <> 0. + +sprung: + inchar(steuerzeichen); + IF steuerzeichen = rechts + THEN wort1 := subtext (trennwort, 1, max trennlaenge); + wort2 := "" + ELIF steuerzeichen = links + THEN wort1 := ""; + wort2 := subtext (trennwort, 1, max trennlaenge) + FI. + +neue zeile mit trennwort versehen: + IF wort1 = "" + THEN keine trennung + ELSE zeichenpos := wortanfang + length (wort1); + mit trennsymbol trennen; + von := zeichenpos + FI. + +keine trennung: + IF wort ist zu lang fuer limit + THEN warnung (7, trennwort); + neue zeile CAT trennwort; + zeichenpos := wortende + 1; + zeichenpos bereits verarbeitet := 0; + von := zeichenpos + ELSE loesche nachfolgende blanks; + zeichenpos := wortanfang + FI. + +wort ist zu lang fuer limit: + length (alte blanks) * einrueckbreite + breite davor + trennbreite + >= aktuelle pitch zeilenlaenge. + +mit trennsymbol trennen: + IF (wort1 SUB length (wort1)) = "c" AND + (trennwort SUB (length (wort1) + 1)) = "k" + THEN replace (wort1, length (wort1), trenn k) + FI; + neue zeile CAT wort1; + IF trennsymbol <> blank + THEN neue zeile CAT trennsymbol + FI. +END PROC trennung eventuell vornehmen; + +PROC naechste zeile ggf heranziehen: + IF puffer hat absatz + OR puffer hat noch mindestens zwei woerter + OR zeile hat eine foot anweisung + OR in foot uebertrag + THEN LEAVE naechste zeile ggf heranziehen + ELIF trennung vorhanden + THEN IF zeichenpos < pufferlaenge + THEN zeilenbreite INCR breite (trennzeichen) + FI; + getrennte zeilen zusammenziehen; + LEAVE naechste zeile ggf heranziehen + FI; + puffer CAT blank; + puffer CAT zeile; + zeile lesen; + pufferlaenge := length (puffer); + ggf absatz an puffer anfuegen. + +puffer hat noch mindestens zwei woerter: + INT VAR anz :: 0, i :: zeichenpos; + WHILE pos (puffer, " ", i) > 0 REP + anz INCR 1; + i := pos (puffer, " ", i) + 1 + END REP; + anz > 1. + +zeile hat eine foot anweisung: + pos (puffer, "#foot") <> 0. +END PROC naechste zeile ggf heranziehen; + +(******************** initialisierungs routine *******************) + +PROC form initialisieren (TEXT CONST datei): + kommando liste := +"type:1.1linefeed:3.1limit:4.1free:5.1page:6.01on:8.1off:9.1pagenr:10.2 +pagelength:11.1start:12.2foot:13.0end:14.0head:15.0headeven:16.0 +headodd:17.0bottom:18.0bottomeven:19.0bottomodd:20.0block:21.0"; + kommando liste CAT +"material:22.1columns:23.2columnsend:24.0ib:25.012ie:28.012topage:31.1 +goalpage:32.1count:33.01setcount:35.1value:36.01table:38.0tableend:39.0 +rpos:40.1lpos:41.1cpos:42.1dpos:43.2bpos:44.2clearpos:45.01right:47.0"; + kommando liste CAT +"center:48.0skip:49.0skipend:50.0u:51.0d:52.0e:53.0headon:54.0headoff:55.0 +bottomon:56.0bottomoff:57.0countperpage:58.0fillchar:59.1mark:60.2 +markend:61.0pageblock:62.0b:63.0counter:64.12setcounter:66.2putcounter:67.01 +storecounter:69.1"; + kommando liste CAT +"ub:70.0ue:71.0fb:72.0fe:73.0"; + line ; + erste fehlerzeilennr := 0; + anz tabs := 0; + zeilennr := 0; + zeilenbreite := 0; + anz blanks freihalten := 3; + herkunftsreferenzen := "#"; + zielreferenzen := "#"; + aktuelle blanks := ""; + font nr speicher := ""; + modifikationsspeicher := ""; + mod zeilennr speicher := ""; + index speicher := ""; + ind zeilennr speicher := ""; + counter numbering store := ""; + counter reference store := ""; + command store := ""; + kommando := ""; + neue zeile := ""; + zeile := ""; + puffer := " "; + macro works := FALSE; + in tabelle := FALSE; + in d und e verarbeitung := FALSE; + kommandos speichern := TRUE; + in foot := FALSE; + in foot uebertrag := FALSE; + test ob font table vorhanden; + bildschirm initialisieren; + zeile lesen; + zeile in puffer und zeile lesen; + einrueckung zweite zeile := "xxx"; + limit und type ggf anfragen; + einrueckbreite := eingestellte indentation pitch ; + initialisiere neue zeile; + IF einrueckung zweite zeile <> "xxx" + THEN aktuelle blanks := einrueckung zweite zeile + FI. + +test ob font table vorhanden: + INT VAR xxx :: x step conversion (0.0). + +bildschirm initialisieren: + IF online + THEN init + FI. + +init: + page; + IF lineform mode + THEN put ("LINEFORM") + ELSE put ("AUTOFORM") + FI; + put ("(für"); put (lines (eingabe)); put ("Zeilen):"); + put (datei); + cursor (1, 3). +END PROC form initialisieren; + +PROC limit und type ggf anfragen: + conversion (limit in cm, aktuelle pitch zeilenlaenge); + IF ask type and limit + THEN type und limit setzen + ELSE alter schriftname := kein vorhandener schriftname; + stelle font ein + FI; + REAL VAR x :: limit in cm; + conversion (x, aktuelle pitch zeilenlaenge); + IF x = fehler wert + THEN limit in cm := 16.0; + conversion (limit in cm, aktuelle pitch zeilenlaenge) + ELSE limit in cm := x + FI; + trennbreite setzen. + +type und limit setzen: + LET type text = "#type (""", + limit text = "#limit (", + kommando ende text = ")#", + kein vorhandener schriftname = "#####"; + IF type und limit anweisungen nicht vorhanden + THEN type und limit fragen + ELSE hole font; + alter schriftname := kein vorhandener schriftname + FI. + +type und limit fragen: + type anfragen; + type in neue zeile; + limit anfragen; + limit in neue zeile; + IF NOT format file in situ + THEN schreibe neue zeile; + zeilen nr INCR 1 + FI; + IF NOT puffer hat absatz + THEN einrueckung zweite zeile := aktuelle blanks; + aktuelle blanks := alte blanks;(* Einrueckung fuer die erste zeile*) + FI; + line. + +type und limit anweisungen nicht vorhanden: + (pos (puffer, type text) <> 1 OR pos (puffer, "limit") < 12). + +type anfragen: + put ("Bitte Schrifttyp :"); + IF font table name = font table + THEN dummy := font (font nr); + ELSE dummy := font (1); + font table name := font table + FI; + REP + editget (dummy); + IF font exists (dummy) + THEN alter schriftname := dummy; + font nr := font (dummy); + hole font; + LEAVE type anfragen + ELSE line ; + put ("ERROR: unbekannter Schrifttyp"); + line (2); + put ("Schrifttyp bitte nochmal:") + FI + END REP. + +type in neue zeile: + neue zeile := type text; + neue zeile CAT dummy; + neue zeile CAT """"; + neue zeile CAT kommando ende text. + +limit anfragen: + line ; + put ("Zeilenbreite (in cm):"); + dummy := text (limit in cm); + REP + editget (dummy); + limit in cm := real (dummy); + IF last conversion ok AND pos (dummy, ".") <> 0 + THEN LEAVE limit anfragen + ELSE line ; + put ("ERROR: Falsche Angabe"); + line (2); + put ("Zeilenbreite (in cm) bitte nochmal:"); + FI + END REP. + +limit in neue zeile: + neue zeile CAT limit text; + neue zeile CAT dummy; + neue zeile CAT kommando ende text; + neue zeile CAT " ". +END PROC limit und type ggf anfragen; + +PROC start form (TEXT CONST datei): + IF NOT format file in situ + THEN last param (datei); + FI; + disable stop; + dateien assoziieren; + zeilen form (datei); + IF is error + THEN fehlerbehandlung + ELSE datei neu nach alt kopieren + FI; + zwischendatei loeschen; + enable stop; + col (eingabe, 1); + IF aktueller editor > 0 + THEN set range (file, alter bereich) + FI; + IF anything noted + THEN IF aktueller editor = 0 + THEN to line (eingabe, erste fehler zeilen nr); + ELSE alles neu + FI; + note edit (eingabe) + ELIF NOT format file in situ + THEN to line (eingabe, 1) + FI. + +dateien assoziieren: + IF format file in situ + THEN + ELIF exists (datei) + THEN IF subtext (datei, length (datei) - 1) = ".p" + THEN errorstop + ("'.p'-Datei kann nicht mit lineform bearbeitet werden") + FI; + eingabe := sequential file (modify, datei); + ausgabe datei einrichten + ELSE errorstop ("Datei existiert nicht") + FI; + to line (eingabe, 1); + col (eingabe, 1). + +ausgabe datei einrichten: + ds := nilspace; + ausgabe := sequential file (modify, ds); + to line (ausgabe, 1); + copy attributes (eingabe, ausgabe). + +fehlerbehandlung: + put error; + clear error; + font nr := 1; + font table name := ""; + limit in cm := 16.0; + IF format file in situ + THEN insert record (eingabe); + write record (eingabe, neue zeile); + down (eingabe); + insert record (eingabe); + write record (eingabe, puffer); + down (eingabe); + insert record (eingabe); + write record (eingabe, zeile) + FI. + +datei neu nach alt kopieren: + IF NOT format file in situ + THEN forget (datei, quiet); + copy (ds, datei); + eingabe := sequential file (modify, datei) + FI. + +zwischendatei loeschen: + IF NOT format file in situ + THEN forget (ds) + FI. +END PROC start form; + +(************** line/autoform fuer benannte Dateien ******************) + +PROC lineform: + IF aktueller editor > 0 + THEN IF mark + THEN editor bereich bearbeiten + ELSE errorstop ("kein markierter Bereich") + FI + ELSE lineform (last param) + FI. + +editor bereich bearbeiten: + disable stop; + file := editfile; + set marked range (file, alter bereich); + lineform (file); + enable stop; +END PROC lineform; + +PROC lineform (TEXT CONST datei): + ask type and limit := TRUE; + lineform mode := TRUE; + format file in situ := FALSE; + start form (datei) +END PROC lineform; + +PROC autoform: + IF aktueller editor > 0 + THEN IF mark + THEN editor bereich bearbeiten + ELSE errorstop ("kein markierter Bereich") + FI + ELSE auto form (last param) + FI. + +editor bereich bearbeiten: + disable stop; + file := editfile; + set marked range (file, alter bereich); + autoform (file); + enable stop +END PROC autoform; + +PROC autoform (TEXT CONST datei): + ask type and limit := TRUE; + lineform mode := FALSE; + format file in situ := FALSE; + start form (datei) +END PROC autoform; + +(******************** line/autoform fuer files ************************) + +PROC lineform (FILE VAR f): + enable stop; + eingabe := f; + format file in situ := TRUE; + ask type and limit := TRUE; + lineform mode := TRUE; + start form (""); +END PROC lineform; + +PROC autoform (FILE VAR f): + enable stop; + eingabe := f; + format file in situ := TRUE; + ask type and limit := TRUE; + lineform mode := FALSE; + start form (""); +END PROC autoform; + +PROC lineform (FILE VAR f, TEXT CONST type name, REAL CONST file limit): + eingabe := f; + format file in situ := TRUE; + lineform mode := TRUE; + ask type and limit := FALSE; + par1 := type name; + limit in cm := file limit; + start form (""); +END PROC lineform; + +PROC autoform (FILE VAR f, TEXT CONST type name, REAL CONST file limit): + eingabe := f; + format file in situ := TRUE; + lineform mode := FALSE; + ask type and limit := FALSE; + par1 := type name; + limit in cm := file limit; + start form (""); +END PROC autoform; +END PACKET liner; +(* +REP + copy("lfehler","zz"); + IF yes ("autoform") + THEN autoform ("zz") + ELSE lineform ("zz") + FI; + edit("zz"); + forget("zz") +UNTIL yes ("ENDE") ENDREP; +*) + diff --git a/system/multiuser/1.7.5/src/macro store b/system/multiuser/1.7.5/src/macro store new file mode 100644 index 0000000..dc13a1b --- /dev/null +++ b/system/multiuser/1.7.5/src/macro store @@ -0,0 +1,298 @@ +(* ------------------- VERSION 13 vom 28.05.86 -------------------- *) +PACKET macro store DEFINES macro command and then process parameters, + get macro line, + number macro lines, + load macros, + list macros: + +(* Programm zur Behandlung von Textkosemtik-Macros + Autor: Rainer Hahn + Stand: 1.7.1 (Febr. 1984) +*) + +INITFLAG VAR this packet :: FALSE; + +DATASPACE VAR ds; + +BOUND MACROTABLE VAR macro table; + +FILE VAR f; + +LET MACROTABLE = STRUCT (ROW max macros TEXT replacement store, + ROW max macro zeilen TEXT macro zeilen, + ROW max macros TEXT macro namen, + ROW max macros INT anz parameter, + ROW max macros INT macro start); + + +LET tag = 1, + number = 3, + delimiter = 6, + end of scan = 7, + max macro zeilen = 1000, + max macros = 200; + +INT VAR index aktuelle macro zeile, + type, + anz zeilen in macro, + anz macro zeilen, + anz macros :: 0; + +TEXT VAR symbol, + fehlertext, + dummy, + kommando, + zeile; + +BOOL VAR with parameters, + macro end gewesen; + +PROC init macros: + IF NOT initialized (this packet) + THEN ds := nilspace; + macro table := ds; + macros leeren + FI. + +macros leeren: + anz macro zeilen := 0; + anz macros := 0. +END PROC init macros; + +PROC load macros (TEXT CONST fname): + init macros; + line; + IF exists (fname) + THEN f := sequential file (input, fname); + forget (ds); + ds := nilspace; + macro table := ds; + macros einlesen + ELSE errorstop ("Datei existiert nicht") + FI. + +macros einlesen: + macro end gewesen := TRUE; + anz macros := 0; + anz macro zeilen := 0; + WHILE NOT eof (f) REP + anz macro zeilen INCR 1; + IF anz macro zeilen > max macro zeilen + THEN errorstop ("Zu viele Zeilen (max.1000)") + FI; + cout (anz macro zeilen); + getline (f, zeile); + IF zeile = "" + THEN zeile := " " + ELIF pos (zeile, "#*") > 0 + THEN macro name oder end vermerken + FI; + IF macro end gewesen AND zeile = " " + THEN anz macro zeilen DECR 1 + ELSE macro table . macro zeilen [anz macro zeilen] := zeile + FI + END REP; + anz macro zeilen INCR 1; + macro table . macro zeilen [anz macro zeilen] := " "; + IF anz macros = 0 + THEN putline ("Macros geleert") + FI. + +macro name oder end vermerken: + INT CONST komm anfang :: pos (zeile, "#*") + 2, + komm ende :: pos (zeile, "#", komm anfang); + IF komm anfang <> 3 OR hinter dem kommando steht noch was + THEN errorstop ("Macro-Anweisung steht nicht alleine auf der Zeile"); + FI; + kommando := subtext (zeile, komm anfang, komm ende -1); + scan (kommando); + next symbol (symbol, type); + IF type = tag + THEN macro namen aufnehmen + ELSE errorstop ("kein Macroname nach #*") + FI; + next symbol (symbol, type); + IF type >= end of scan + THEN macro table . anz parameter [anz macros] := 0; + LEAVE macro name oder end vermerken + ELIF symbol = "(" + THEN parameter aufsammeln; + ELSE errorstop ("keine ( nach Macro-Name") + FI. + +macro namen aufnehmen: + IF symbol = "macroend" + THEN put ("mit"); put (macro table . anz parameter [anz macros]); + put ("Parameter(n) geladen"); + macro end gewesen := TRUE; + line; + LEAVE macro name oder end vermerken + ELIF NOT macro end gewesen + THEN errorstop ("macro end fehlt") + ELSE macro end gewesen := FALSE; + anz macros INCR 1; + IF anz macros > max macros + THEN errorstop ("Zu viele Macros (max. 200") + FI; + macro table . macro namen [anz macros] := symbol; + macro table . macro start [anz macros] := anz macro zeilen; + line; + put (symbol); + FI. + +hinter dem kommando steht noch was: + NOT (komm ende = length (zeile) COR + (komm ende + 1 = length (zeile) AND (zeile SUB komm ende + 1) = " ")). + +parameter aufsammeln: + INT VAR parameter number :: 1; + next symbol (symbol, type); + WHILE symbol = "$" REP + next symbol (symbol, type); + IF type = number CAND int (symbol) = parameter number + THEN IF parameter number > 9 + THEN errorstop ("Anzahl Parameter > 9") + FI; + macro table . anz parameter [anz macros] := parameter number; + parameter number INCR 1; + ELSE errorstop ("Parameter-Nummer inkorrekt: " + symbol) + FI; + next symbol (symbol, type); + IF symbol = ")" + THEN LEAVE parameter aufsammeln + ELIF symbol = "," + THEN next symbol (symbol, type) + ELSE errorstop (", oder ) erwartet:" + symbol) + FI + END REP; + errorstop ("Parameterliste inkorrekt bei" + symbol). +END PROC load macros; + +PROC load macros: + load macros (last param) +END PROC load macros; + +PROC list macros: + init macros; + note (""); + INT VAR i := 1; + WHILE i <= anz macro zeilen REP + cout (i); + note (macro table . macro zeilen [i]); + note line; + i INCR 1 + END REP; + note edit +END PROC list macros; + +BOOL PROC macro exists (TEXT CONST name, INT VAR anz params): + INT VAR i; + FOR i FROM 1 UPTO anz macros REP + IF macro table . macro namen [i] = name + THEN anz params := macro table . anz parameter [i]; + index aktuelle macro zeile := macro table . macro start [i] + 1; + berechne anzahl zeilen in macro; + IF anz params = 0 + THEN with parameters := FALSE + ELSE with parameters := TRUE; + lade macro in replacement store; + index aktuelle macro zeile := 1; + FI; + LEAVE macro exists WITH TRUE + FI + END REP; + FALSE. + +berechne anzahl zeilen in macro: + IF i = anz macros + THEN anz zeilen in macro := + anz macro zeilen - index aktuelle macro zeile; + ELSE anz zeilen in macro := + macro table . macro start [i + 1] - index aktuelle macro zeile + FI. + +lade macro in replacement store: + INT VAR k; + FOR k FROM 1 UPTO anz zeilen in macro REP + macro table . replacement store [k] := + macro table . macro zeilen [index aktuelle macro zeile +k-1] + END REP. +END PROC macro exists; + +PROC replace macro parameter (INT CONST number, TEXT CONST param): + TEXT VAR param text := "$" + text (number); + INT VAR k; + FOR k FROM 1 UPTO anz zeilen in macro - 1 REP + change all (macro table . replacement store [k], param text, param); + END REP +END PROC replace macro parameter; + +BOOL PROC macro command and then process parameters (TEXT VAR komm): + init macros; + LET tag = 1; + scan (komm); + next symbol (symbol, type); + IF type = tag + THEN untersuche ob deklariertes macro + ELSE FALSE + FI. + +untersuche ob deklariertes macro: + INT VAR anz macro params; + IF macro exists (symbol, anz macro params) + THEN fehlertext := "in Makro: "; fehlertext CAT symbol; + IF anz macro params > 0 + THEN macro parameter ersetzen + FI; + TRUE + ELSE FALSE + FI. + +macro parameter ersetzen: + next symbol (symbol, type); + IF symbol = "(" + THEN ersetze + ELSE report text processing error (34, 0, dummy, symbol + fehlertext); + LEAVE macro command and then process parameters WITH FALSE + FI. + +ersetze: + LET text type = 4, + end of scan = 7; + INT VAR number parameter :: 1; + REP + next symbol (symbol, type); + IF type = texttype + THEN replace macro parameter (number parameter, symbol); + ELSE report text processing error (35, 0, dummy, fehlertext + symbol); + LEAVE macro command and then process parameters WITH FALSE + FI; + number parameter INCR 1; + IF number parameter > anz macro params + THEN LEAVE macro command and then process parameters WITH TRUE + FI; + next symbol (symbol, type); + IF symbol <> "," OR type >= end of scan + THEN report text processing error (36, 0, dummy, fehlertext + symbol); + LEAVE macro command and then process parameters WITH FALSE + FI + END REP. +END PROC macro command and then process parameters; + +PROC get macro line (TEXT VAR macro zeile): + IF index aktuelle macro zeile > anz zeilen in macro + THEN macro zeile := "#### " + ELIF with parameters + THEN macro zeile := + macro table . replacement store [index aktuelle macro zeile] + ELSE macro zeile := + macro table . macro zeilen [index aktuelle macro zeile] + FI; + index aktuelle macro zeile INCR 1; +END PROC get macro line; + +INT PROC number macro lines: + anz zeilen in macro +END PROC number macro lines; +END PACKET macro store; + diff --git a/system/multiuser/1.7.5/src/multi user monitor b/system/multiuser/1.7.5/src/multi user monitor new file mode 100644 index 0000000..dd3051e --- /dev/null +++ b/system/multiuser/1.7.5/src/multi user monitor @@ -0,0 +1,93 @@ +(* ------------------- VERSION 2 16.05.86 ------------------- *) +PACKET multi user monitor DEFINES (* Autor: J.Liedtke *) + + monitor : + + +LET command list = + +"edit:1.01run:4.01runagain:6.0insert:7.01forget:9.01rename:11.2copy:12.2 +list:13.0storageinfo:14.0taskinfo:15.0 +fetch:16.1save:17.01break:19.0saveall:20.0 " ; + +LET text param type = 4 ; + + +INT VAR command index , number of params , previous heap size ; +TEXT VAR param 1, param 2 ; + + + lernsequenz auf taste legen ("q", ""1""8""1""12"break"13"") ; + lernsequenz auf taste legen ("e", ""1""8""1""12"edit"13"") ; + + +PROC monitor : + + disable stop ; + previous heap size := heap size ; + REP + command dialogue (TRUE) ; + sysin ("") ; + sysout ("") ; + cry if not enough storage ; + get command ("gib kommando :") ; + reset editor ; + analyze command (command list, text param type, + command index, number of params, param1, param2) ; + execute command ; + collect heap garbage if necessary + PER . + +collect heap garbage if necessary : + IF heap size > previous heap size + 10 + THEN collect heap garbage ; + previous heap size := heap size + FI . + +cry if not enough storage : + INT VAR size, used ; + storage (size, used) ; + IF used > size + THEN out (""7"Speicher Engpass! Dateien loeschen!"13""10"") + FI . + +reset editor : + WHILE aktueller editor > 0 REP + quit + PER ; + clear error . + +ENDPROC monitor ; + +PROC execute command : + + enable stop ; + SELECT command index OF + CASE 1 : edit + CASE 2 : edit (param1) + CASE 3 : (* war frueher paralleleditor *) + CASE 4 : run + CASE 5 : run (param1) + CASE 6 : run again + CASE 7 : insert + CASE 8 : insert (param1) + CASE 9 : forget + CASE 10: forget (param1) + CASE 11: rename (param1, param2) + CASE 12: copy (param1, param2) + CASE 13: list + CASE 14: storage info + CASE 15: task info + CASE 16: fetch (param1) + CASE 17: save + CASE 18: save (param1) + CASE 19: break + CASE 20: save all + + OTHERWISE do command + ENDSELECT . + +ENDPROC execute command ; + +ENDPACKET multi user monitor ; + diff --git a/system/multiuser/1.7.5/src/nameset b/system/multiuser/1.7.5/src/nameset new file mode 100644 index 0000000..8ea4359 --- /dev/null +++ b/system/multiuser/1.7.5/src/nameset @@ -0,0 +1,355 @@ +(* ------------------- VERSION 3 17.03.86 ------------------- *) +PACKET name set DEFINES (* Autor: J.Liedtke *) + + ALL , + SOME , + LIKE , + + , + - , + / , + do , + FILLBY , + remainder , + + fetch , + save , + fetch all , + save all , + forget , + erase , + insert , + edit : + + +LET cr lf = ""13""10"" ; + +TEXT VAR name ; +DATASPACE VAR edit space ; + +THESAURUS VAR remaining thesaurus := empty thesaurus ; + + +THESAURUS OP + (THESAURUS CONST left, right) : + + THESAURUS VAR union := left ; + INT VAR index := 0 ; + get (right, name, index) ; + WHILE name <> "" REP + IF NOT (union CONTAINS name) + THEN insert (union, name) + FI ; + get (right, name, index) + PER ; + union . + +ENDOP + ; + +THESAURUS OP + (THESAURUS CONST left, TEXT CONST right) : + + THESAURUS VAR union := left ; + IF NOT (union CONTAINS right) + THEN insert (union, right) + FI ; + union . + +ENDOP + ; + +THESAURUS OP - (THESAURUS CONST left, right) : + + THESAURUS VAR difference := empty thesaurus ; + INT VAR index := 0 ; + get (left, name, index) ; + WHILE name <> "" REP + IF NOT (right CONTAINS name) + THEN insert (difference, name) + FI ; + get (left, name, index) + PER ; + difference . + +ENDOP - ; + +THESAURUS OP - (THESAURUS CONST left, TEXT CONST right) : + + THESAURUS VAR difference := left ; + INT VAR index ; + delete (difference, right, index) ; + difference . + +ENDOP - ; + +THESAURUS OP / (THESAURUS CONST left, right) : + + THESAURUS VAR intersection := empty thesaurus ; + INT VAR index := 0 ; + get (left, name, index) ; + WHILE name <> "" REP + IF right CONTAINS name + THEN insert (intersection, name) + FI ; + get (left, name, index) + PER ; + intersection . + +ENDOP / ; + +THESAURUS OP ALL (TEXT CONST file name) : + + FILE VAR file := sequential file (input, file name) ; + THESAURUS VAR thesaurus := empty thesaurus ; + thesaurus FILLBY file ; + thesaurus . + +ENDOP ALL ; + +THESAURUS OP SOME (THESAURUS CONST thesaurus) : + + copy thesaurus into file ; + edit file ; + copy file into thesaurus . + +copy thesaurus into file : + forget (edit space) ; + edit space := nilspace ; + FILE VAR file := sequential file (output, edit space) ; + file FILLBY thesaurus . + +edit file : + modify (file) ; + edit (file) . + +copy file into thesaurus : + THESAURUS VAR result := empty thesaurus ; + input (file) ; + result FILLBY file ; + forget (edit space) ; + result . + +ENDOP SOME ; + +THESAURUS OP SOME (TASK CONST task) : + + SOME ALL task + +ENDOP SOME ; + +THESAURUS OP SOME (TEXT CONST file name) : + + SOME ALL file name + +ENDOP SOME ; + +THESAURUS OP LIKE (THESAURUS CONST thesaurus, TEXT CONST pattern) : + + THESAURUS VAR result:= empty thesaurus ; + INT VAR index:= 0 ; + REP get (thesaurus, name, index) ; + IF name = "" + THEN LEAVE LIKE WITH result + ELIF name LIKE pattern + THEN insert (result, name) + FI + PER ; + result . + +ENDOP LIKE ; + +THESAURUS PROC remainder : + + remaining thesaurus + +ENDPROC remainder ; + +PROC do (PROC (TEXT CONST) operate, THESAURUS CONST thesaurus) : + + INT VAR index := 0 , operation number := 0 ; + TEXT VAR name ; + + remaining thesaurus := empty thesaurus ; + disable stop ; + work off thesaurus ; + fill leftover with remainder . + +work off thesaurus : + REP + get (thesaurus, name, index) ; + IF name = "" + THEN LEAVE work off thesaurus + FI ; + operation number INCR 1 ; + cout (operation number) ; + execute (PROC (TEXT CONST) operate, name) + UNTIL is error ENDREP . + +fill leftover with remainder : + WHILE name <> "" REP + insert (remaining thesaurus, name) ; + get (thesaurus, name, index) + PER . + +ENDPROC do ; + +PROC execute (PROC (TEXT CONST) operate, TEXT CONST name) : + + enable stop ; + operate (name) + +ENDPROC execute ; + +PROC do (PROC (TEXT CONST, TASK CONST) operate, THESAURUS CONST thesaurus, + TASK CONST task) : + + INT VAR index := 0 , operation number := 0 ; + TEXT VAR name ; + + remaining thesaurus := empty thesaurus ; + disable stop ; + work off thesaurus ; + fill leftover with remainder . + +work off thesaurus : + REP + get (thesaurus, name, index) ; + IF name = "" + THEN LEAVE work off thesaurus + FI ; + operation number INCR 1 ; + cout (operation number) ; + execute (PROC (TEXT CONST, TASK CONST) operate, name, task) + UNTIL is error ENDREP . + +fill leftover with remainder : + WHILE name <> "" REP + insert (remaining thesaurus, name) ; + get (thesaurus, name, index) + PER . + +ENDPROC do ; + +PROC execute (PROC (TEXT CONST, TASK CONST) operate, + TEXT CONST name, TASK CONST task) : + + enable stop ; + operate (name, task) + +ENDPROC execute ; + +OP FILLBY (THESAURUS VAR thesaurus, FILE VAR file) : + + WHILE NOT eof (file) REP + getline (file, name) ; + delete trailing blanks ; + IF name <> "" CAND NOT (thesaurus CONTAINS name) + THEN insert (thesaurus, name) + FI + PER . + +delete trailing blanks : + WHILE (name SUB LENGTH name) = " " REP + name := subtext (name, 1, LENGTH name - 1) + PER . + +ENDOP FILLBY ; + +OP FILLBY (FILE VAR file, THESAURUS CONST thesaurus) : + + INT VAR index := 0 ; + REP + get (thesaurus, name, index) ; + IF name = "" + THEN LEAVE FILLBY + FI ; + putline (file, name) + PER . + +ENDOP FILLBY ; + +OP FILLBY (TEXT CONST file name, THESAURUS CONST thesaurus) : + + FILE VAR f := sequential file (output, file name) ; + f FILLBY thesaurus + +ENDOP FILLBY ; + + + +PROC fetch (THESAURUS CONST nameset) : + + do (PROC (TEXT CONST) fetch, nameset) + +ENDPROC fetch ; + +PROC fetch (THESAURUS CONST nameset, TASK CONST task) : + + do (PROC (TEXT CONST, TASK CONST) fetch, nameset, task) + +ENDPROC fetch ; + +PROC save (THESAURUS CONST nameset) : + + do (PROC (TEXT CONST) save, nameset) + +ENDPROC save ; + +PROC save (THESAURUS CONST nameset, TASK CONST task) : + + do (PROC (TEXT CONST, TASK CONST) save, nameset, task) + +ENDPROC save ; + +PROC fetch all : + + fetch all (father) + +ENDPROC fetch all ; + +PROC fetch all (TASK CONST manager) : + + fetch (ALL manager, manager) + +ENDPROC fetch all ; + +PROC save all : + + save all (father) + +ENDPROC save all ; + +PROC save all (TASK CONST manager) : + + save (ALL myself, manager) + +ENDPROC save all ; + +PROC forget (THESAURUS CONST nameset) : + + do (PROC (TEXT CONST) forget, nameset) + +ENDPROC forget ; + +PROC erase (THESAURUS CONST nameset) : + + do (PROC (TEXT CONST) erase, nameset) + +ENDPROC erase ; + +PROC erase (THESAURUS CONST nameset, TASK CONST task) : + + do (PROC (TEXT CONST, TASK CONST) erase, nameset, task) + +ENDPROC erase ; + +PROC insert (THESAURUS CONST nameset) : + + do (PROC (TEXT CONST) insert, nameset) + +ENDPROC insert ; + +PROC edit (THESAURUS CONST nameset) : + + do (PROC (TEXT CONST) edit, nameset) + +ENDPROC edit ; + +ENDPACKET name set ; + diff --git a/system/multiuser/1.7.5/src/pager b/system/multiuser/1.7.5/src/pager new file mode 100644 index 0000000..35189a4 --- /dev/null +++ b/system/multiuser/1.7.5/src/pager @@ -0,0 +1,2451 @@ +(*-------------------- VERSION 197 vom 05.05.86 -------(1.7.5)------ *) +PACKET seiten formatieren DEFINES pageform, + auto pageform, + number empty lines before foot, + first head, + last bottom: + +(* Programm zur interaktiven Formatierung von Seiten, Fussnoten, Kopf- und + Fusszeilen, Seitennummern usw. + Autor: Rainer Hahn + *) + +(***************** Deklarationen fuer pageform ************) + +LET type1 = 1, + linefeed = 3, + limit = 4, + free = 5, + page command0= 6, + page command1= 7, + pagenr = 8, + pagelength = 9, + foot = 10, + end = 11, + head = 12, + headeven = 13, + headodd = 14, + bottom = 15, + bottomeven = 16, + bottomodd = 17, + columns = 18, + columnsend = 19, + topage = 20, + goalpage = 21, + count0 = 22, + count1 = 23, + setcount = 24, + value0 = 25, + value1 = 26, + on = 27, + off = 28, + head on = 29, + head off = 30, + bottom on = 31, + bottom off = 32, + count per page=33, + foot contd = 34, + table = 35, + table end = 36, + r pos = 37, + l pos = 38, + c pos = 39, + d pos = 40, + b pos = 41, + clearpos0 = 42, + clearpos1 = 43, + fillchar = 44, + pageblock = 45, + counter1 = 46, + counter2 = 47, + counter store= 48, + countervalue0= 49, + countervalue1= 50, + set counter = 51, + u = 52, + d = 53, + e = 54, + fehler index = 100, + hop = ""1"", + upchar = ""3"", + cl eop = ""4"", + cl eol = ""5"", + downchar = ""10"", + rub in = ""11"", + rub out = ""12"", + return = ""13"", + end mark = ""14"", + begin mark = ""15"", + begin end mark = ""15""14"", + esc = ""27"", + blank = " ", + kommando zeichen = "#", + kopf = 1, + kopf gerade = 2, + fuss = 3, + fuss gerade = 4, + kopf ungerade = 5, + fuss ungerade = 6, + foot note = 7, + dina4 limit = "16.0", + dina4 pagelength = 25.0, + pos seitengrenze = 17, + zeilen nach oben = 13, + zeilen nach unten = 6, + max foot zeilen = 120, + max zeilen zahl = 15, + max refers = 300, + max anz seitenzeichen = 3; + +BOOL VAR interaktiv, + bereich aufnehmen, + zeile noch nicht verarbeitet, + es war ein linefeed in der zeile, + mindestens ein topage gewesen, + insert first head :: TRUE, + insert last bottom :: TRUE, + pageblock on, + ausgeschalteter head, + ausgeschalteter bottom, + count seitenzaehlung, + file works, + in tabelle, + in nullter seite, + letzte textzeile war mit absatz, + letztes seitenende war mit absatz, + letztes seitenende war in tabelle; + +INT VAR kommando anfangs pos, + kommando ende pos, + kommando index, + number blank lines before foot :: 1, + in index oder exponent, + durchgang, + nummer erste seite, + nummer letzte seite, + laufende spaltennr, + anz refers, + counter, + anz spalten, + anz zeilen nach oben, + anz vertauschte zeilen, + font nr, + type zeilenvorschub, + berechneter zeilenvorschub, + max zeilenvorschub, + max type zeilenvorschub, + textbegin zeilennr, + anz textzeilen, + text laenge vor columns, + bereichshoehe, + aktuelle seitenlaenge, + eingestellte seitenlaenge; + +REAL VAR real eingestellter zeilenvorschub, + realparam; + +TEXT VAR kommando, + par1, par2, + macro line, + vor macro, + nach macro, + dummy, + fehlerdummy, + modifikation, + modifikations speicher, + kommando seitenspeicher, + dec value, + counter numbering store, + counter reference store, + letzte kommandoleiste, + kommando speicher, + tab pos speicher, + bereich kommando speicher, + seitenzeichen, + name druck datei, + name eingabe datei, + zeile, + eingestellter typ, + eingestelltes limit; + +TEXT VAR kommando liste :: +"type:1.1linefeed:3.1limit:4.1free:5.1page:6.01pagenr:8.2pagelength:9.1 +foot:10.0end:11.0head:12.0headeven:13.0headodd:14.0bottom:15.0bottomeven:16.0 +bottomodd:17.0columns:18.2columnsend:19.0topage:20.1goalpage:21.1count:22.01 +setcount:24.1"; + +kommando liste CAT +"value:25.01on:27.1off:28.1headon:29.0headoff:30.0bottomon:31.0bottomoff:32.0 +countperpage:33.0footcontinued:34.0table:35.0tableend:36.0rpos:37.1lpos:38.1 +cpos:39.1dpos:40.2bpos:41.2clearpos:42.01fillchar:44.1pageblock:45.0"; + +kommando liste CAT +"counter:46.12storecounter:48.1putcounter:49.01setcounter:51.2u:52.0d:53.0 +e:54.0"; + +FILE VAR eingabe, + ausgabe; + +ROW 6 ROW max zeilenzahl TEXT VAR kopf fuss zeilen; + +ROW max foot zeilen TEXT VAR foot zeilen; + +ROW max foot zeilen BOOL VAR kommandos vorhanden; + +ROW 7 INT VAR anz kopf oder fuss zeilen, + kopf oder fuss laenge; + +ROW max anz seitenzeichen INT VAR laufende seitennr; + +BOUND ROW max refers REFER VAR refer sammler; + +LET REFER = STRUCT (TEXT kennzeichen, INT nummer, BOOL referenced); + +DATASPACE VAR ds; + +(********************* Einstell-Prozeduren ***************************) + +PROC first head (BOOL CONST was): + insert first head := was +END PROC first head; + +PROC last bottom (BOOL CONST was): + insert last bottom := was +END PROC last bottom; + +PROC number empty lines before foot (INT CONST n): + IF n >= 0 AND n < 10 + THEN number blank lines before foot := n + ELSE errorstop ("nur einstellbar zwischen 0 und 9") + FI +END PROC number empty lines before foot; + +(************************** Fehlermeldungen **********************) + +PROC fehler (INT CONST nr, TEXT CONST addition): + IF durchgang = 1 OR + kommando index = goalpage OR kommandoindex = count0 OR + kommando index = count1 OR kommando index = value1 OR + kommando index = topage OR kommando index = pagelength OR + kommando index = counterstoreOR kommando index = counter1 OR + kommando index = counter2 OR kommando index = countervalue1 + THEN fehler melden; + fehlermeldung auf terminal ausgeben + FI. + +fehler melden: + report text processing error (nr, line no (ausgabe), fehlerdummy, addition). + +fehlermeldung auf terminal ausgeben: + IF interaktiv + THEN cursor(1,2); out(cleop); + ELSE line + FI; + out (fehlerdummy); + line. +END PROC fehler; + +PROC warnung (INT CONST nr, TEXT CONST addition): + IF durchgang = 1 OR + kommando index = goalpage OR kommandoindex = count0 OR + kommando index = count1 OR kommando index = value1 OR + kommando index = topage OR kommando index = set counter + THEN fehler melden; + meldung auf terminal ausgeben + FI. + +fehler melden: + report text processing warning (nr, line no (ausgabe), fehlerdummy, addition). + +meldung auf terminal ausgeben: + IF interaktiv + THEN cursor(1,2); out(cleop); + ELSE line + FI; + out (fehlerdummy); + line. +END PROC warnung; + +(*************************** Globale Dateibehandlung **************) + +PROC datei assoziieren: + IF exists (name eingabe datei) + THEN ausgabe datei einrichten + ELSE errorstop (name eingabe datei + " existiert nicht") + FI. + +ausgabe datei einrichten: + IF name eingabe datei = name druck datei + THEN errorstop ("Name Eingabedatei = Name Ausgabedatei") + ELIF subtext (name eingabe datei, length (name eingabe datei) - 1) = ".p" + THEN errorstop ("Druckdatei kann nicht nochmal formatiert werden") + ELSE eingabe := sequential file (input, name eingabe datei); + copy (name eingabedatei, name druck datei); + ausgabe := sequential file (modify, name druck datei); + copy attributes (eingabe, ausgabe); + headline (ausgabe, name druck datei); + FI +END PROC datei assoziieren; + +PROC record einfuegen (TEXT CONST rec): + insert record (ausgabe); + write record (ausgabe, rec); + down (ausgabe); +END PROC record einfuegen; + +(******************** Kopf- oder Fusszeilen aufnehmen *************) + +PROC fussnote aufnehmen: + bereich aufnehmen := TRUE; + IF keine zeichen ausser blank nach dem kommando + THEN aufnehmen (footnote) + ELSE fehler (19, kommando) + FI; + in index oder exponent := 0; + bereich aufnehmen := FALSE +END PROC fussnote aufnehmen; + +PROC aufnehmen (INT CONST was): + kommando zustand vor bereich speichern; + aktuelle zeile ggf mitzaehlen; + aufnehmen initialisieren; + kopf oder fuss zeilen aufnehmen. + +kommando zustand vor bereich speichern: + kommandos in dummy speichern; + bereich kommando speicher := dummy. + +aktuelle zeile ggf mitzaehlen: +INT VAR einleitungs kommando anfang :: kommando anfangs pos; + IF kommando anfangs pos > 1 + THEN IF NOT only command line (zeile) + THEN aktuelle seitenlaenge INCR max zeilenvorschub + FI; + read record (ausgabe, zeile) + FI. + +aufnehmen initialisieren: + IF was = foot note + THEN initialisierung fuer fussnoten + ELSE anz kopf oder fuss zeilen [was] := 1; + kommandos in dummy speichern; + kopf fuss zeilen [was] [1] := dummy; + kopf oder fuss laenge [was] := 0; + FI; + bereichshoehe := kopf oder fusslaenge [was]. + +initialisierung fuer fussnoten: + INT CONST fussnotenlaenge vorher :: kopf oder fuss laenge [footnote], + anz fusszeilen vorher :: anz kopf oder fusszeilen [footnote]; + anz kopf oder fuss zeilen [footnote] INCR 1; + kommandos in dummy speichern; + kommandoleiste in fussnote speichern; (* davor *) + IF anz kopf oder fuss zeilen [footnote] = 1 + THEN unterstreichungsstrich + FI. + +kommandoleiste in fussnote speichern: + foot zeilen [anz kopf oder fuss zeilen [footnote]] := dummy; + kommandos vorhanden [anz kopf oder fuss zeilen [footnote]]:= TRUE. + +unterstreichungsstrich: + FOR i FROM 2 UPTO max foot zeilen REP + kommandos vorhanden [i] := FALSE + ENDREP; + FOR i FROM 1 UPTO number blank lines before foot REP + foot zeilen [i + 1] := " " + END REP; + foot zeilen [number blank lines before foot + 2] := + "#on(""underline"")#               #off(""underline"")# "; + kopf oder fuss laenge [footnote] := + (number blank lines before foot + 1) * berechneter zeilenvorschub; + anz kopf oder fuss zeilen [footnote] := number blank lines before foot + 2. + +kopf oder fuss zeilen aufnehmen: +INT VAR anzahl :: 1; + REP + naechste zeile lesen; + cout (line no (ausgabe)); + IF mindestens ein kommando vorhanden + THEN kommandos von kopf oder fuss verarbeiten + FI; + in index oder exponent := 0; + zeile aufnehmen; + anzahl INCR 1 + UNTIL eof (ausgabe) END REP; + errorstop ("end fehlt bei Dateiende"). + +kommandos von kopf oder fuss verarbeiten: + max zeilenvorschub := berechneter zeilenvorschub; + max type zeilenvorschub := type zeilenvorschub; + kommando anfangs pos := pos (zeile, kommando zeichen); + WHILE kommando anfangs pos <> 0 REP + verarbeite kommando; + kommandos von kopf oder fuss pruefen; + kommando anfangs pos := + pos (zeile, kommando zeichen, kommando ende pos + 1) + END REP. + +kommandos von kopf oder fuss pruefen: + IF kommandoindex = end + THEN aufnehmen beenden + ELIF kommando index = free + THEN IF y step conversion (realparam) >= eingestellte seitenlaenge + THEN fehler (24, text (realparam)) + ELSE kopf oder fusslaenge [was] INCR y step conversion (realparam) + FI + ELIF seitenende + THEN INT VAR xx := durchgang; + durchgang := 1; + fehler (25, ""); + durchgang := xx; + zeile zurueck lesen; + kommando index := end; + LEAVE aufnehmen + ELIF kommando index = fehler index + THEN LEAVE aufnehmen + ELIF kommando index > free AND kommando index < to page + THEN fehler (11, kommando); + kommando index := fehler index; + LEAVE aufnehmen + FI. + +aufnehmen beenden: + IF kommando anfangs pos > 1 + THEN IF absatzzeile + THEN zeile := subtext (zeile, 1, kommando anfangs pos -1); + zeile CAT blank; + ELSE zeile := subtext (zeile, 1, kommando anfangs pos -1); + FI; + zeile aufnehmen + FI; + IF NOT (durchgang = 1 AND was = footnote) + THEN die aufgenommenen zeilen in druckdatei loeschen + FI; + LEAVE aufnehmen. + +die aufgenommenen zeilen in druckdatei loeschen: + INT VAR i; + delete record (ausgabe); + FOR i FROM 1 UPTO anzahl - 1 REP + up (ausgabe); + delete record (ausgabe) + END REP; + zeile zurueck lesen; + letztes kommando dieser zeile loeschen; + ggf kommandoleiste generieren. + +letztes kommando dieser zeile loeschen: + IF einleitungs kommando anfang = 1 + THEN delete record (ausgabe); + IF line no (ausgabe) = 1 + THEN zeile noch nicht verarbeitet := TRUE + ELSE zeile zurueck lesen + FI + ELSE dummy := subtext (zeile, 1, einleitungs kommando anfang - 1); + IF absatz zeile + THEN dummy CAT blank; + ELIF (dummy SUB length (dummy)) = " " + THEN delete char (dummy, length (dummy)) + FI; + write record (ausgabe, dummy) + FI. + +ggf kommandoleiste generieren: + kommandos in dummy speichern; + IF was = footnote + THEN anz kopf oder fusszeilen [footnote] INCR 1; + kommandoleiste in fussnote speichern (* danach *) + FI; + IF dummy <> bereich kommando speicher + THEN down (ausgabe); + record einfuegen (dummy); + up (ausgabe, 2); + FI. + +zeile aufnehmen: + zeile speichern (was, anzahl); + IF erreichte seitenlaenge > eingestellte seitenlaenge + THEN bereich aufnehmen := FALSE; + IF kommando index = end + THEN seitenende nach geteilter fussnote + ELSE seitenende vor der fussnote + FI; + kommando index := end; + LEAVE aufnehmen + FI. + +seitenende nach geteilter fussnote: + kopf oder fuss laenge [footnote] DECR max zeilenvorschub; + anz kopf oder fuss zeilen [footnote] DECR 1; + seitenende einbringen und zurueck. + +seitenende vor der fussnote: + kopf oder fuss laenge [footnote] := fussnotenlaenge vorher; + anz kopf oder fuss zeilen [footnote] := anz fusszeilen vorher; + ende einer seite. +END PROC aufnehmen; + +PROC zeile speichern (INT CONST was, anzahl): + zeile mitzaehlen; + IF was = footnote + THEN fussnote aufnehmen + ELIF anz kopf oder fuss zeilen [was] > max zeilenzahl + THEN errorstop ("Zu viele 'head' oder 'bottom' Zeilen"); + ELSE kopf fuss zeilen [was] [anz kopf oder fuss zeilen [was]] := zeile + FI. + +zeile mitzaehlen: + anz kopf oder fuss zeilen [was] INCR 1; + IF NOT only command line (zeile) + THEN IF mindestens ein kommando vorhanden + THEN kopf oder fuss laenge [was] INCR max zeilenvorschub; + bereichshoehe INCR max zeilenvorschub + ELSE kopf oder fuss laenge [was] INCR berechneter zeilenvorschub; + bereichshoehe INCR berechneter zeilenvorschub + FI; + IF bereichshoehe >= eingestellte seitenlaenge + THEN errorstop + ("head, bottom oder footzeilen > Seitenlänge (end vergessen?)") + FI + FI; + IF es war ein linefeed in der zeile + THEN berechne zeilenvorschub; + es war ein linefeed in der zeile := FALSE + FI; + IF erreichte seitenlaenge > eingestellte seitenlaenge + THEN fussnotenumbruch pruefung + FI. + +fussnote aufnehmen: + IF anz kopf oder fuss zeilen [footnote] > max footzeilen + THEN errorstop ("Zu viele Fußnotenzeilen") + ELIF bereichshoehe > eingestellte seitenlaenge - seitenlaenge fester teil + - (eingestellte seitenlaenge DIV 100 * 15) + THEN errorstop ("Fußnote > 85% der Seitenlänge (end vergessen?)") + ELSE foot zeilen [anz kopf oder fuss zeilen [footnote]] := zeile + FI. + +fussnotenumbruch pruefung: + IF fussnotenumbruch moeglich + THEN ggf fussnote aufbrechen + ELSE lese rueckwaerts um (anzahl); + IF only command line (zeile) + THEN lese rueckwaerts um (1) + FI + FI. + +fussnotenumbruch moeglich: + was = footnote AND anzahl > 2. + +ggf fussnote aufbrechen: + up (ausgabe); + IF interaktiv + THEN fussnotenumbruch anfrage; + line (2) + FI; + anweisungen fuer umbruch einfuegen. + +fussnotenumbruch anfrage: + schreibe titelzeile ("Weiterführen der Fußnote auf nächster Seite (j/n)?"); + line (2); + schreibe bildschirm; + cursor (53, 1); + skip input; + REP + TEXT VAR steuerzeichen; + inchar (steuerzeichen); + IF steuerzeichen = "n" + THEN lese rueckwaerts um (anzahl - 1); + IF only command line (zeile) + THEN lese rueckwaerts um (1) + FI; + LEAVE ggf fussnote aufbrechen + ELIF steuerzeichen = "j" OR steuerzeichen = return + THEN LEAVE fussnotenumbruch anfrage + ELIF steuerzeichen = esc + THEN errorstop ("Abbruch durch ESC") + FI + END REP. + +anweisungen fuer umbruch einfuegen: + record einfuegen ("#end#"); + record einfuegen ("#foot continued#"); + kommandos in dummy speichern; + record einfuegen (dummy); + record einfuegen ("Forts. von letzter Seite: "); + lese rueckwaerts um (3); + kommando index := end. +END PROC zeile speichern; + +PROC lese rueckwaerts um (INT CONST anzahl): + to line (ausgabe, line no (ausgabe) - anzahl); + read record (ausgabe, zeile) +END PROC lese rueckwaerts um; + +PROC schreibe kopf oder fuss (INT CONST was): + IF was = footnote + THEN fussnoten generieren + ELIF laufende spaltennr < 2 + THEN kopf oder fuss zeilen generieren + FI. + +kopf oder fusszeilen generieren: +INT VAR i :: 1; +BOOL VAR in generierter zeile war kommando :: FALSE; + ggf anfangs kommandos generieren; + FOR i FROM 2 UPTO anz kopf oder fuss zeilen [was] REP + dummy := kopf fuss zeilen [was] [i]; + IF NOT in generierter zeile war kommando + THEN in generierter zeile war kommando := + pos (dummy, kommandozeichen) <> 0 + FI; + fuege seitennr ein; + record einfuegen (dummy) + END REP; + ggf ende kommandos generieren. + +ggf anfangs kommandos generieren: + kommandos in dummy speichern; + IF dummy <> kopf fuss zeilen [was] [1] + THEN record einfuegen (kopf fuss zeilen [was] [1]) + FI. + +ggf ende kommandos generieren: + kommandos in dummy speichern; + IF dummy <> kopf fuss zeilen [was] [1] OR + in generierter zeile war kommando + THEN record einfuegen (dummy) + FI. + +fuege seitennr ein: +INT VAR k; + change all (dummy, + (seitenzeichen SUB 1) + (seitenzeichen SUB 1), + text (laufende seitennr [1] +1)); + FOR k FROM 1 UPTO length (seitenzeichen) REP + change all (dummy, seitenzeichen SUB k, text (laufende seitennr [k])); + END REP. + +fussnoten generieren: + kommandos in dummy speichern; + letzte kommandoleiste := dummy; + i := 1; + WHILE i < anz kopf oder fusszeilen [footnote] REP + IF kommandos vorhanden [i] + THEN IF letzte kommandoleiste <> footzeilen [i] + THEN record einfuegen (footzeilen [i]); + letzte kommandoleiste := footzeilen [i] + FI + ELSE record einfuegen (footzeilen [i]) + FI; + i INCR 1 + END REP; + IF footzeilen [i] <> dummy + THEN record einfuegen (dummy) + FI +END PROC schreibe kopf oder fuss; + +PROC fussnoten loeschen: + kopf oder fuss laenge [footnote] := 0; + anz kopf oder fuss zeilen [footnote] := 0 +END PROC fussnoten loeschen; + +PROC schreibe ggf fuss: + record einfuegen ("#text end#"); + ggf tabellenende generieren; + letztes seitenende war mit absatz := letzte textzeile war mit absatz; + IF erreichte seitenlaenge <> eingestellte seitenlaenge + THEN schreibe freien platz + FI; + IF kopf oder fuss laenge [footnote] > 0 + THEN ggf tabellenende generieren; + schreibe kopf oder fuss (footnote); + fussnoten loeschen + FI; + IF (NOT insert last bottom AND laufende seitennr [1] = nummer letzte seite) + OR ausgeschalteter bottom + THEN + ELSE schreibe mal fussbereich + FI. + +schreibe mal fussbereich: + IF kopf oder fuss laenge [fuss] > 0 + THEN schreibe kopf oder fuss (fuss) + ELIF kopf oder fuss laenge [fuss gerade] > 0 AND + (laufende seitennr [1] MOD 2 = 0) + THEN schreibe kopf oder fuss (fuss gerade) + ELIF kopf oder fuss laenge [fuss ungerade] > 0 AND + (laufende seitennr [1] MOD 2 <> 0) + THEN schreibe kopf oder fuss (fuss ungerade) + FI. + +ggf tabellenende generieren: + IF tab pos speicher <> "" + THEN record einfuegen ("#clear pos# ") + FI; + IF in tabelle + THEN record einfuegen ("#table end# "); + letztes seitenende war in tabelle := TRUE; + in tabelle := FALSE + FI. + +schreibe freien platz: + IF pageblock on + THEN schreibe ggf stauchung oder streckungs anweisung + ELSE schreibe free (eingestellte seitenlaenge - erreichte seitenlaenge) + FI. + +schreibe ggf stauchung oder streckungs anweisung: + IF interaktiv AND seitenluecke > fuenf prozent der seitenlaenge + THEN cursor (1, 2); + dummy := begin mark; + dummy CAT "Soll die Seite beim Druck gestreckt werden ("; + dummy CAT text (ystepconversion (seitenluecke)); + dummy CAT " cm)"; + dummy CAT end mark; + IF no (dummy) + THEN cursor (1, 2); + out (cl eol); + schreibe free + (eingestellte seitenlaenge - erreichte seitenlaenge); + line; + LEAVE schreibe ggf stauchung oder streckungs anweisung + FI; + cursor (1, 2); + out (cl eol); + line + FI; + INT VAR i :: lineno (ausgabe); + to line (ausgabe, textbegin zeilennr); + dummy := "#textbegin ("; + dummy CAT text (anz textzeilen); + dummy CAT ", """; + dummy CAT text (ystepconversion (seitenluecke)); + dummy CAT """)#"; + read record (ausgabe, zeile); + IF (zeile SUB length (zeile)) = blank + THEN dummy CAT blank + FI; + write record (ausgabe, dummy); + to line (ausgabe, i). + +seitenluecke: + eingestellte seitenlaenge - erreichte seitenlaenge. + +fuenf prozent der seitenlaenge: + ((eingestellte seitenlaenge + 99) DIV 100) * 5. +END PROC schreibe ggf fuss; + +(**************************** kommando speicherung *****************) + +PROC grenzmarkierung in dummy speichern: + dummy := "#page##"; + dummy CAT (3 * "-----------"); + dummy CAT " Ende der Seite "; + IF in nullter seite + THEN dummy CAT "0 " + ELSE dummy CAT (text (laufende seitennr [1]) + blank) + FI; + IF anz spalten > 1 + THEN dummy CAT "und Spalte "; + dummy CAT (text (laufende spaltennr) + blank) + ELSE dummy CAT "-----------" + FI; + dummy CAT kommando zeichen +END PROC grenzmarkierung in dummy speichern; + +PROC kommandos in dummy speichern: + type speichern; + dummy CAT modifikation; + limit speichern; + linefeed mit absatzblank speichern. + +type speichern: + dummy := "#type("""; + dummy CAT eingestellter typ; + dummy CAT """)#". + +limit speichern: + dummy CAT "#limit("; + dummy CAT eingestelltes limit; + dummy CAT ")#". + +linefeed mit absatzblank speichern: + dummy CAT "#linefeed(0"; + dummy CAT text (real eingestellter zeilenvorschub); + dummy CAT ")# ". +END PROC kommandos in dummy speichern; + +PROC kommandos aufheben: + kommandos in dummy speichern; + kommando speicher := dummy +END PROC kommandos aufheben; + +PROC kommandos wiederherstellen: + zeile := kommando speicher; + kommandos verarbeiten; + berechneter zeilenvorschub := + int (real (type zeilenvorschub) * real eingestellter zeilenvorschub + 0.5); + max zeilenvorschub := berechneter zeilenvorschub; + max type zeilenvorschub := type zeilenvorschub +END PROC kommandos wiederherstellen; + +(**************************** headzeilen einfuegen ************************) + +PROC schreibe ggf kopf: + IF (NOT insert first head AND laufende seiten nr [1] = nummer erste seite) + OR ausgeschalteter head + THEN + ELSE schreibe mal + FI; + ggf tabellenanfang generieren; + text begin anweisung generieren. + +schreibe mal: + IF kopf oder fuss laenge [kopf] > 0 + THEN schreibe kopf oder fuss (kopf); + aktuelle seitenlaenge INCR kopf oder fuss laenge [kopf] + ELIF kopf oder fuss laenge [kopf gerade] > 0 + AND (laufende seitennr [1] MOD 2 = 0) + THEN schreibe kopf oder fuss (kopf gerade); + aktuelle seitenlaenge INCR kopf oder fuss laenge [kopf gerade] + ELIF kopf oder fuss laenge [kopf ungerade] > 0 + AND (laufende seitennr [1] MOD 2 <> 0) + THEN schreibe kopf oder fuss (kopf ungerade); + aktuelle seitenlaenge INCR kopf oder fuss laenge [kopf ungerade] + FI. + +ggf tabellenanfang generieren: + IF tab pos speicher <> "" + THEN record einfuegen ("#clearpos#"); + record einfuegen (tab pos speicher) + FI; + IF letztes seitenende war in tabelle + THEN record einfuegen ("#table# "); + letztes seitenende war in tabelle := FALSE; + in tabelle := TRUE + FI. + +text begin anweisung generieren: + dummy := "#text begin#"; + IF letztes seitenende war mit absatz + THEN dummy CAT " " + FI; + record einfuegen (dummy); + textbegin zeilennr := line no (ausgabe) - 1. +END PROC schreibe ggf kopf; + +PROC erhoehe seiten und spaltennr: + IF anz spalten > 1 + THEN erhoehe spaltennummer + FI; + IF NOT in nullter seite + THEN erhoehe seitennummer + FI. + +erhoehe spaltennummer: + laufende spaltennr INCR 1; + IF laufende spaltennr > anz spalten + THEN laufende spaltennr := 1; + text laenge vor columns := 0 + ELSE LEAVE erhoehe seiten und spaltennr + FI. + +erhoehe seitennummer: + INT VAR i; + FOR i FROM 1 UPTO length (seitenzeichen) REP + laufende seitennr [i] INCR 1 + END REP +END PROC erhoehe seiten und spaltennr; + +PROC seitennummer setzen (INT CONST akt nummer): + IF pos (seitenzeichen, par1) = 0 + THEN IF length (seitenzeichen) >= max anz seitenzeichen + THEN fehler (16, ""); + LEAVE seitennummer setzen + FI; + seitenzeichen CAT par1 + FI; + laufende seitennr [pos (seitenzeichen, par1)] := akt nummer. +END PROC seitennummer setzen; + +PROC kommando seitenspeicher fuellen: + kommando seitenspeicher CAT "#"; + kommando seitenspeicher CAT kommando; + kommando seitenspeicher CAT "#" +END PROC kommando seitenspeicher fuellen; + +(************************** kommandos verarbeiten ********************) + +PROC verarbeite kommando: +INT VAR anz params, intparam; + kommando ende pos := + pos (zeile, kommando zeichen, kommando anfangs pos + 1); + IF kommando ende pos <> 0 + THEN kommando oder kommentar kommando verarbeiten + ELSE fehler (2, + subtext (zeile, kommandoanfangspos, kommandoanfangspos+9)+"..."); + zeile CAT kommando zeichen; + write record (ausgabe, zeile); + kommando ende pos := length (zeile) + FI. + +kommando oder kommentar kommando verarbeiten: + IF pos ("-/"":", zeile SUB kommando anfangs pos + 1) = 0 + THEN kommando := + subtext (zeile, kommando anfangs pos + 1, kommando ende pos - 1); + scanne kommando; + setze kommando um + ELSE kommando index := 0 + FI. + +scanne kommando: + analyze command (kommandoliste, kommando, 3, + kommando index, anz params, par1, par2); + disable stop; + command error; + IF is error + THEN dummy := error message; + clear error; + dummy CAT " -> "; + dummy CAT kommando; + fehler (22, dummy); + enable stop; + LEAVE verarbeite kommando + FI; + enable stop. + +setze kommando um: + IF durchgang = 3 AND kommando index <> value1 AND kommando index <> to page + AND kommando index <> counter value1 + THEN LEAVE verarbeite kommando + FI; + SELECT kommando index OF + +CASE type1: + modifikation := ""; + IF in index oder exponent > 0 + THEN LEAVE setze kommando um + ELIF font exists (par1) + THEN font nr := font (par1); + eingestellter typ := par1; + type zeilenvorschub := + font height (fontnr) + font lead (fontnr) + font depth (fontnr); + IF type zeilenvorschub > max type zeilenvorschub + THEN max type zeilenvorschub := type zeilenvorschub + FI + ELSE fehler (1, par1) + FI; + berechne zeilenvorschub + +CASE linefeed: + realparam := real (par1); + IF last conversion ok AND pos (par1, ".") <> 0 + THEN real eingestellter zeilenvorschub := realparam; + es war ein linefeed in der zeile := TRUE + ELSE fehler (4, par1) + FI + +CASE limit: + eingestelltes limit := par1 + +CASE free: + realparam := real (par1); + IF last conversion ok AND pos (par1, ".") <> 0 + THEN IF keine zeichen ausser blank nach dem kommando + THEN free kommando ausfuehren + ELSE fehler (19, kommando); + FI + ELSE fehler (4, par1) + FI + +CASE page command0: + IF keine zeichen ausser blank nach dem kommando + THEN page behandlung; + schreibe titelzeile + ELSE fehler (19, kommando) + FI + +CASE page command1: + IF keine zeichen ausser blank nach dem kommando + THEN INT VAR seitennummer mit page := int (par1); + page behandlung; + laufende spaltennr := 1; + text laenge vor columns := 0; + IF seitennummer mit page <= 0 + THEN fehler (27, "page (" + text (seitennummer mit page) + ")") + ELSE laufende seitennr [1] := seitennummer mit page + FI + ELSE fehler (19, kommando) + FI + +CASE pagenr: + IF in nullter seite OR durchgang = 4 + THEN intparam := int (par2); + IF length (par1) <> 1 + THEN fehler (14, "") + ELIF NOT last conversion ok + THEN fehler (5, kommando) + ELIF intparam <= 0 + THEN fehler (27, kommando) + ELSE seitennummer setzen (intparam) + FI + ELIF durchgang = 2 + THEN kommando seitenspeicher fuellen + FI + +CASE pagelength: + realparam := real (par1); + IF last conversion ok AND pos (par1, ".") <> 0 + THEN IF in nullter seite OR durchgang = 4 + THEN eingestellte seitenlaenge := y step conversion (realparam) + ELIF durchgang = 2 + THEN kommando seitenspeicher fuellen + FI + ELSE fehler (4, kommando) + FI + +CASE foot, foot contd: + fussnote aufnehmen + +CASE end: + IF NOT bereich aufnehmen + THEN fehler (31, "") + FI; + bereich aufnehmen := FALSE; + kommando index := end; + IF NOT keine zeichen ausser blank nach dem kommando + THEN fehler (19, kommando) + FI + +CASE head: + bereich aufnehmen := TRUE; + IF keine zeichen ausser blank nach dem kommando + THEN kopf oder fuss laenge [kopf ungerade] := 0; + kopf oder fuss laenge [kopf gerade] := 0; + aufnehmen (kopf) + ELSE fehler (19, kommando) + FI; + bereich aufnehmen := FALSE + +CASE headeven: + bereich aufnehmen := TRUE; + IF keine zeichen ausser blank nach dem kommando + THEN kopf oder fuss laenge [kopf] := 0; + aufnehmen (kopf gerade) + ELSE fehler (19, kommando) + FI; + bereich aufnehmen := FALSE + +CASE headodd: + bereich aufnehmen := TRUE; + IF keine zeichen ausser blank nach dem kommando + THEN kopf oder fuss laenge [kopf] := 0; + aufnehmen (kopf ungerade) + ELSE fehler (19, kommando) + FI; + bereich aufnehmen := FALSE + +CASE bottom: + bereich aufnehmen := TRUE; + IF keine zeichen ausser blank nach dem kommando + THEN kopf oder fuss laenge [fuss ungerade] := 0; + kopf oder fuss laenge [fuss gerade] := 0; + aufnehmen (fuss) + ELSE fehler (19, kommando) + FI; + bereich aufnehmen := FALSE + +CASE bottomeven: + bereich aufnehmen := TRUE; + IF keine zeichen ausser blank nach dem kommando + THEN kopf oder fuss laenge [fuss] := 0; + aufnehmen (fuss gerade) + ELSE fehler (19, kommando) + FI; + bereich aufnehmen := FALSE + +CASE bottomodd: + bereich aufnehmen := TRUE; + IF keine zeichen ausser blank nach dem kommando + THEN kopf oder fuss laenge [fuss] := 0; + aufnehmen (fuss ungerade) + ELSE fehler (19, kommando) + FI; + bereich aufnehmen := FALSE + +CASE columns: + IF anz spalten > 1 + THEN fehler (29, "") + ELSE anz spalten := int (par1); + laufende spalten nr := 1; + IF anz spalten < 2 + THEN fehler (26, ""); + anz spalten := 2 + FI; + text laenge vor columns := + aktuelle seitenlaenge + kopf oder fuss laenge [footnote] + FI + +CASE columnsend: + IF durchgang = 1 + THEN delete record (ausgabe); + IF NOT nur dateiende danach + THEN seitenende einbringen und zurueck; + record einfuegen ("#columnsend#"); + text laenge vor columns := 0; + laufende spaltennr := 1; + anz spalten := 1; + kommando index := page command0; + down (ausgabe) + FI + FI + +CASE topage: + IF durchgang > 1 + THEN ggf gespeicherte nummer einsetzen (par1); + mindestens ein topage gewesen := TRUE + FI + +CASE goalpage: + IF durchgang > 1 + THEN nummer und kennzeichen speichern (laufende seitennr[1], par1) + FI + +CASE count0, count1: + IF durchgang > 1 + THEN counter INCR 1; + change (zeile, + kommando anfangs pos, kommando ende pos, text(counter)); + kommando ende pos := kommando anfangs pos; + write record (ausgabe, zeile); + IF anz params = 1 + THEN nummer und kennzeichen speichern (counter, par1) + FI + FI + +CASE setcount: + intparam := int (par1); + IF last conversion ok AND intparam >= 0 + THEN counter := intparam - 1 + ELSE fehler (30, par1) + FI + +CASE value0: + IF durchgang > 1 + THEN change (zeile, kommando anfangs pos, kommando ende pos, + text (counter)); + write record (ausgabe, zeile); + kommando ende pos := kommando anfangs pos + FI + +CASE value1: + IF durchgang > 1 + THEN ggf gespeicherte nummer einsetzen (par1) + FI + +CASE on: + change all (par1, " ", ""); + par1 := (par1 SUB 1); + modifikation CAT "#on(""" + par1 + """)#" + +CASE off: + change all (par1, " ", ""); + par1 := (par1 SUB 1); + changeall (modifikation, "#on(""" + par1 + """)#", ""); + +CASE head on: ausgeschalteter head := FALSE +CASE head off: ausgeschalteter head := TRUE + +CASE bottom on: ausgeschalteter bottom := FALSE +CASE bottom off: ausgeschalteter bottom := TRUE + +CASE count per page: count seitenzaehlung := TRUE + +CASE table: + IF durchgang > 1 + THEN in tabelle := TRUE + FI + +CASE table end: + IF durchgang > 1 + THEN in tabelle := FALSE + FI + +CASE r pos, l pos, c pos, d pos, b pos, clearpos1, fillchar: + IF durchgang > 1 + THEN tab pos speicher CAT "#"; + tab pos speicher CAT kommando; + tab pos speicher CAT "#" + FI + +CASE clearpos0: + IF durchgang > 1 + THEN tab pos speicher := "" + FI + +CASE pageblock : pageblock on := TRUE + +CASE counter1, counter2: + IF durchgang > 1 + THEN process counter + FI + +CASE set counter: + IF durchgang > 1 + THEN process set counter + FI + +CASE counter store: + IF durchgang > 1 + THEN process counter store + FI + +CASE counter value0: + IF durchgang > 1 + THEN write dec value into file + FI + +CASE counter value1: + IF durchgang > 1 + THEN process counter value + FI + +CASE u, d: + in index oder exponent INCR 1 + +CASE e: + in index oder exponent DECR 1 + +OTHERWISE + kommando index := 0; + IF macro command and then process parameters (kommando) + THEN ersetze macro + FI +END SELECT. + +nur dateiende danach: + INT VAR diese zeile :: line no (ausgabe); + WHILE NOT eof (ausgabe) REP + read record (ausgabe, zeile); + IF length (zeile) > 1 + THEN to line (ausgabe, diese zeile); + read record (ausgabe, zeile); + LEAVE nur dateiende danach WITH FALSE + FI; + down (ausgabe) + END REP; + to line (ausgabe, diese zeile); + read record (ausgabe, zeile); + TRUE. +END PROC verarbeite kommando; + +(************************ Makro-Ersetzung **************************) + +PROC ersetze macro: + INT VAR erste zeile :: line no (ausgabe); + hole texte um macro herum; + fuege macro zeilen ein; + fuege text nach macro an; + positioniere zurueck. + +hole texte um macro herum: + vor macro := subtext (zeile, 1, kommando anfangs pos - 1); + nach macro := subtext (zeile, kommando ende pos + 1). + +fuege macro zeilen ein: + INT VAR anz :: 1; + WHILE anz < number macro lines REP + get macro line (macro line); + IF anz = 1 + THEN vor macro CAT macro line ; + write record (ausgabe, vor macro); + ELSE down (ausgabe); + insert record (ausgabe); + write record (ausgabe, macro line) + FI; + anz INCR 1 + END REP. + +fuege text nach macro an: + read record (ausgabe, zeile); + IF length (nach macro) <> 0 + THEN zeile CAT nach macro + ELIF (zeile SUB length (zeile)) <> blank AND number macro lines > 2 + THEN delete record (ausgabe); + read record (ausgabe, dummy); + zeile CAT dummy + FI; + IF subtext (zeile, length (zeile) - 1, length (zeile)) = " " + THEN delete char (zeile, length (zeile)) + FI; + write record (ausgabe, zeile). + +positioniere zurueck: + to line (ausgabe, erste zeile); + read record (ausgabe, zeile); + IF in nullter seite + THEN zeile noch nicht verarbeitet := TRUE + FI; + kommando ende pos := kommando anfangs pos - 1. +END PROC ersetze macro; + +(************************ Zeilenvorschub-Berechnung ****************) + +PROC berechne zeilenvorschub: + berechneter zeilenvorschub := + int (real (type zeilenvorschub) * real eingestellter zeilenvorschub + 0.5); + IF real eingestellter zeilenvorschub >= 1.0 + THEN max zeilenvorschub := max + (int (real (max type zeilenvorschub)*real eingestellter zeilenvorschub + 0.5), + berechneter zeilenvorschub) + ELIF berechneter zeilenvorschub > max zeilenvorschub + THEN max zeilenvorschub := berechneter zeilenvorschub + FI +END PROC berechne zeilenvorschub; + +(**************************** counter processing **********************) + +PROC process counter: + dummy := "#"; + dummy CAT par1; + dummy CAT "#"; + IF pos (counter numbering store, dummy) = 0 + THEN fehler (34, par1); + LEAVE process counter + FI; + get dec value (counter numbering store); + IF kommando index = counter2 + THEN resize dec value to needed points + FI; + IF dec value was just initialized + THEN dec value := subtext (dec value, 2) + ELIF kommando index = counter1 + THEN digit value := int (dec value); + digit value INCR 1; + dec value := text (digit value) + ELSE incr counter value + FI; + write dec value into file; + replace value in numbering store (dec value). + +resize dec value to needed points: + INT VAR needed points :: int (par2), + begin of last digit :: 1; + WHILE needed points > 0 REP + IF next point pos = 0 + THEN IF needed points = 1 + THEN dec value CAT ".0" + ELSE dec value CAT ".1" + FI; + begin of last digit := length (dec value) + ELSE begin of last digit := next point pos + 1 + FI; + needed points DECR 1 + END REP; + INT VAR end of last digit := next point pos - 1; + IF end of last digit < 0 + THEN end of last digit := length (dec value) + FI; + dec value := subtext (dec value, 1, end of last digit). + +next point pos: + pos (dec value, ".", begin of last digit). + +dec value was just initialized: + (dec value SUB 1) = "i". + +incr counter value: + INT VAR digit value :: int ( + subtext (dec value, begin of last digit, end of last digit)); + digit value INCR 1; + change (dec value, begin of last digit, end of last digit, + text (digit value)). +END PROC process counter; + +PROC process set counter: + dummy := "#"; + dummy CAT par1; + dummy CAT "#"; + IF pos (counter numbering store, dummy) <> 0 + THEN warnung (15, par1); + replace value in numbering store (par2); + INT VAR begin pos :: pos (counter numbering store, dummy) + 1; + begin pos := pos (counter numbering store, "#", beginpos) + 1; + insert char (counter numbering store, "i", begin pos) + ELSE counter numbering store CAT dummy; + counter numbering store CAT "i"; + counter numbering store CAT par2 + FI. +END PROC process set counter; + +PROC process counter store: + IF pos (counter reference store, par1) <> 0 + THEN fehler (35, par1) + ELSE store it + FI. + +store it: + counter reference store CAT "#"; + counter reference store CAT par1; + counter reference store CAT "#"; + counter reference store CAT dec value +END PROC process counter store; + +PROC process counter value: + dummy := "#"; + dummy CAT par1; + dummy CAT "#"; + IF pos (counter reference store, dummy) <> 0 + THEN get dec value (counter reference store); + write dec value into file + ELIF durchgang = 3 + THEN fehler (61, par1) + FI. +END PROC process counter value; + +PROC replace value in numbering store (TEXT CONST val): + INT VAR begin pos :: pos (counter numbering store, dummy) + 1; + begin pos := pos (counter numbering store, "#", begin pos) + 1; + INT VAR end pos := pos (counter numbering store, "#", begin pos)-1; + IF end pos <= 0 + THEN end pos := length (counter numbering store) + FI; + change (counter numbering store, begin pos, end pos, val) +END PROC replace value in numbering store; + +PROC write dec value into file: + change (zeile, kommando anfangs pos, kommando ende pos, dec value); + kommando ende pos := kommando anfangs pos; + write record (ausgabe, zeile) +END PROC write dec value into file; + +PROC get dec value (TEXT CONST store): + INT VAR value begin :: pos (store, dummy); + value begin := pos (store, "#", value begin + 1) + 1; + INT VAR value end :: pos (store, "#", value begin)-1; + IF value end < 0 + THEN value end := length (store) + FI; + dec value := subtext (store, value begin, value end). +END PROC get dec value; + +(************************** Zaehler routinen ('refer') ***************) + +PROC nummer und kennzeichen speichern (INT CONST number, TEXT VAR kennung): + ueberpruefe auf bereits vorhandenes kennzeichen; + anz refers INCR 1; + IF anz refers > max refers + THEN errorstop ("Anzahl Referenzen zu gross") + FI; + refer sammler [anz refers] . kennzeichen := kennung; + refer sammler [anz refers] . nummer := number; + refer sammler [anz refers] . referenced := FALSE. + +ueberpruefe auf bereits vorhandenes kennzeichen: + INT VAR i; + FOR i FROM 1 UPTO anz refers REP + IF refer sammler [i] . kennzeichen = kennung + THEN warnung (9, kennung); + LEAVE nummer und kennzeichen speichern + FI + END REP. +END PROC nummer und kennzeichen speichern; + +PROC ggf gespeicherte nummer einsetzen (TEXT VAR kennung): + IF kennzeichen vorhanden + THEN change (zeile, kommando anfangs pos, kommando ende pos, textnummer); + refer sammler [i] . referenced := TRUE; + kommando ende pos := kommando anfangs pos; + write record (ausgabe, zeile) + ELIF durchgang = 3 + THEN warnung (4, kennung) + FI. + +textnummer: + text (refer sammler [i] . nummer). + +kennzeichen vorhanden: +INT VAR i; + FOR i FROM 1 UPTO anz refers REP + IF refer sammler [i] . kennzeichen = kennung + THEN LEAVE kennzeichen vorhanden WITH TRUE + FI + END REP; + FALSE. +END PROC ggf gespeicherte nummer einsetzen; + +(************************** free-Kommando *****************************) + +PROC free kommando ausfuehren: +INT CONST wert in y steps :: y step conversion (realparam); + IF bereich aufnehmen + THEN + ELIF wert in y steps>=eingestellte seitenlaenge - seitenlaenge fester teil + THEN fehler (13, "") + ELIF erreichte seitenlaenge + wert in y steps > eingestellte seitenlaenge + THEN ende einer seite; + kommando index := fehler index + ELSE aktuelle seitenlaenge INCR wert in y steps + FI +END PROC free kommando ausfuehren; + +(*************************** page-Kommando ******************************) + +PROC page behandlung: +TEXT VAR steuerzeichen; + page kommando entfernen; + IF aktuelle seitenlaenge <= 0 + THEN IF line no (ausgabe) = 1 + THEN zeile noch nicht verarbeitet := TRUE + ELSE up (ausgabe) + FI; + LEAVE page behandlung + FI; + IF interaktiv + THEN initialisiere bildschirm fuer page; + mit page interaktiv formatieren; + schreibe titelzeile; + FI; + BOOL CONST hilf :: pageblock on; + pageblock on := FALSE; + seitenende einbringen und zurueck; + pageblock on := hilf; + kommando index := page command0. + +page kommando entfernen: + IF kommando anfangs pos = 1 + THEN delete record (ausgabe); + IF line no (ausgabe) = 1 + THEN zeile noch nicht verarbeitet := TRUE + FI + ELSE zeile := subtext (zeile, 1, kommando anfangs pos - 1); + write record (ausgabe, zeile); + IF NOT only command line (zeile) + THEN aktuelle seitenlaenge INCR max zeilenvorschub + FI; + down (ausgabe) + FI. + +initialisiere bildschirm fuer page: + schreibe titelzeile + ("#page# bestaetigen: RETURN / loeschen: HOP RUBOUT / Abbruch: ESC"); + line ; out (cleol); + put ("#page# nach"); + put (y step conversion (erreichte seitenlaenge)); put ("cm"); + schreibe bildschirm; + out (hop). + +mit page interaktiv formatieren: + REP + inchar (steuerzeichen); + IF steuerzeichen = return + THEN zeilenmitteilung loeschen; + LEAVE mit page interaktiv formatieren + ELIF steuerzeichen = rubout + THEN weitermachen + ELIF steuerzeichen = esc + THEN errorstop ("Abbruch mit ESC") + FI + END REP. + +weitermachen: + zeilenmitteilung loeschen; + up (ausgabe); + LEAVE page behandlung. + +zeilenmitteilung loeschen: + cursor (1, 2); out (cleol); line. +END PROC page behandlung; + +PROC seite nochmal durchgehen: + zurueck bis seitenende; + kommandos wiederherstellen; + down (ausgabe); + IF count seitenzaehlung + THEN counter := 0 + FI; + schreibe ggf kopf; + read record (ausgabe, zeile); + seitenlaenge initialisieren; + fussnoten loeschen; + bis seitenende lesen und kommandos verarbeiten; + schreibe ggf fuss; + initialisieren fuer neue seite. + +bis seitenende lesen und kommandos verarbeiten: + durchgang := 2; + zeilen und kommandos verarbeiten; + durchgang := 1. + +zeilen und kommandos verarbeiten: + anz textzeilen := 0; + WHILE NOT seitenende REP + IF mindestens ein kommando vorhanden + THEN IF NOT only command line (zeile) + THEN anz textzeilen INCR 1 + FI; + kommandos verarbeiten und ggf zeile mitzaehlen; + ELSE aktuelle seitenlaenge INCR berechneter zeilenvorschub; + anz textzeilen INCR 1 + FI; + naechste zeile lesen + END REP. + +initialisieren fuer neue seite: + kommandos aufheben; + fussnoten loeschen; + erhoehe seiten und spaltennr; + seitenlaenge initialisieren +END PROC seite nochmal durchgehen; + +PROC seitenlaenge initialisieren: + IF anz spalten > 1 AND laufende spaltennr > 1 + THEN aktuelle seitenlaenge := text laenge vor columns + ELSE aktuelle seitenlaenge := 0; + verarbeite seitenkommandos + FI. + +verarbeite seitenkommandos: + IF kommando seitenspeicher <> "" + THEN zeile := kommando seitenspeicher; + kommando seitenspeicher := ""; + INT CONST xx := durchgang; + durchgang := 4; + kommandos verarbeiten; + durchgang := xx + FI. +END PROC seitenlaenge initialisieren; + +PROC zurueck bis seitenende: + up (ausgabe, "#page##---", line no (ausgabe)); + IF anz spalten > 1 AND laufende spaltennr > 1 + THEN down (ausgabe); + schreibe free (text laenge vor columns + head laenge); + up (ausgabe) + FI; + read record (ausgabe, zeile); + cout (line no (ausgabe)); +END PROC zurueck bis seitenende; + +BOOL PROC seitenende: + pos (zeile, "#page#") = 1 AND pos (zeile, "-----", 8) = 8 +END PROC seitenende; + +(**************************** eigentliche seitenform-routine *********) + +PROC seiten form: + enable stop; + datei assoziieren; + page form initialisieren; + to line (ausgabe, 1); + read record (ausgabe, zeile); + in nullter seite := TRUE; + nullte seite verarbeiten; + nullte seitengrenze einfuegen; + in nullter seite := FALSE; + formieren. + +nullte seite verarbeiten: + aktuelle seitenlaenge := 0; + WHILE only command line (zeile) REP + IF seitenende + THEN errorstop ("Bitte Originaldatei bearbeiten (keine Druckdatei)") + FI; + kommandos verarbeiten; + IF es war ein free kommando OR tabellen kommando + THEN LEAVE nullte seite verarbeiten + ELIF es war ein linefeed in der zeile + THEN berechne zeilenvorschub; + es war ein linefeed in der zeile := FALSE; + naechste zeile lesen + ELIF zeile noch nicht verarbeitet + THEN read record (ausgabe, zeile); + zeile noch nicht verarbeitet := FALSE + ELSE naechste zeile lesen + FI; + cout (line no (ausgabe)) + ENDREP. + +es war ein free kommando: + aktuelle seitenlaenge <> 0. + +tabellen kommando: + kommando index >= 35 AND kommando index <= 44. + +nullte seitengrenze einfuegen: + laufende spaltennr := 0; + grenzmarkierung in dummy speichern; + record einfuegen (dummy); + read record (ausgabe, zeile); + kommandos aufheben; + aktuelle seitenlaenge := 0; + erhoehe seiten und spaltennr; + nummer erste seite := laufende seiten nr [1]. + +formieren: + REP + cout (line no (ausgabe)); + IF mindestens ein kommando vorhanden + THEN kommandos verarbeiten und ggf zeile mitzaehlen + ELSE aktuelle seitenlaenge INCR berechneter zeilenvorschub; + FI; + IF erreichte seitenlaenge > eingestellte seitenlaenge + THEN ende einer seite + FI; + IF eof (ausgabe) + THEN eof behandlung; + LEAVE formieren + ELSE down (ausgabe); + IF eof (ausgabe) + THEN eof behandlung; + LEAVE formieren + ELSE read record (ausgabe, zeile) + FI + FI + END REP. +END PROC seiten form; + +PROC eof behandlung: + grenzmarkierung in dummy speichern; + insert record (ausgabe); + write record (ausgabe, dummy); + nummer letzte seite := laufende seiten nr [1]; + pageblock on := FALSE; + seite nochmal durchgehen; + IF anz refers <> 0 OR mindestens ein topage gewesen + OR counter reference store <> "" + THEN ausgabe datei nochmals durchgehen; + offene referenzen pruefen + FI. + +ausgabe datei nochmals durchgehen: + to line (ausgabe, 1); col (ausgabe, 1); + durchgang := 3; + REP + down (ausgabe, "#", lines (ausgabe)); + IF pattern found + THEN read record (ausgabe, zeile); + cout (line no (ausgabe)); + kommandos verarbeiten; + IF eof (ausgabe) + THEN LEAVE ausgabe datei nochmals durchgehen + ELSE down (ausgabe); col (ausgabe, 1) + FI + ELSE LEAVE ausgabe datei nochmals durchgehen + FI + END REP. + +offene referenzen pruefen: + INT VAR i; + FOR i FROM 1 UPTO anz refers REP + IF NOT refer sammler [i] . referenced + THEN report text processing warning + (3, 0, fehlerdummy, CONCR(refersammler) [i] . kennzeichen) + FI + END REP. +END PROC eof behandlung; + +(************************** kommando verarbeitung **********) + +BOOL PROC mindestens ein kommando vorhanden: + pos (zeile, kommando zeichen) <> 0. +END PROC mindestens ein kommando vorhanden; + +PROC kommandos verarbeiten: + kommando anfangs pos := pos (zeile, kommando zeichen); + WHILE kommando anfangs pos <> 0 REP + verarbeite kommando; + IF kommando index = end OR kommando index = page command0 + OR kommando index = page command1 OR kommando index = fehler index + THEN LEAVE kommandos verarbeiten + ELSE kommando anfangs pos := + pos (zeile, kommando zeichen, kommando ende pos + 1) + FI + END REP. +END PROC kommandos verarbeiten; + +PROC kommandos verarbeiten und ggf zeile mitzaehlen: + max zeilenvorschub := berechneter zeilenvorschub; + max type zeilenvorschub := type zeilenvorschub; + kommandos verarbeiten; + in index oder exponent := 0; + zeile zur seitenlaenge ggf addieren; + IF es war ein linefeed in der zeile + THEN berechne zeilenvorschub; + es war ein linefeed in der zeile := FALSE + FI. + +zeile zur seitenlaenge ggf addieren: + IF only command line (zeile) OR + kommando index = end OR kommando index = page command0 OR + kommando index = page command1 OR kommando index = fehler index + THEN + ELSE aktuelle seitenlaenge INCR max zeilenvorschub; + FI. +END PROC kommandos verarbeiten und ggf zeile mitzaehlen; + +BOOL PROC keine zeichen ausser blank nach dem kommando: + IF kommando anfangs pos > 1 AND + pos (zeile, ""33"", ""255"", 1) = kommando anfangs pos + THEN warnung (13, kommando) + FI; + kommando ende pos = length (zeile) OR + pos (zeile, ""33"", ""254"", kommando ende pos + 1) = 0 +END PROC keine zeichen ausser blank nach dem kommando; + +BOOL PROC absatz zeile: + (zeile SUB length (zeile)) = blank +END PROC absatz zeile; + +(********************** routinen fuers seitenende *************) + +INT PROC erreichte seitenlaenge: + aktuelle seitenlaenge + kopf oder fuss laenge [footnote] + + seitenlaenge fester teil +END PROC erreichte seitenlaenge; + +INT PROC seitenlaenge fester teil: + head laenge + bottom laenge. + +bottom laenge: + IF (NOT insert last bottom AND laufende seitennr [1] = nummer letzte seite) + OR ausgeschalteter bottom + THEN 0 + ELSE kopf oder fuss laenge [fuss] + + bottom laenge fuer gerade oder ungerade seiten + FI. + +bottom laenge fuer gerade oder ungerade seiten: + IF laufende seitennr [1] MOD 2 = 0 + THEN kopf oder fuss laenge [fuss gerade] + ELSE kopf oder fuss laenge [fuss ungerade] + FI. +END PROC seitenlaenge fester teil; + +INT PROC head laenge: + IF (NOT insert first head AND laufende seitennr [1] = nummer erste seite) + OR ausgeschalteter head + THEN 0 + ELSE kopf oder fuss laenge [kopf] + + head laenge fuer gerade oder ungerade seiten + FI. + +head laenge fuer gerade oder ungerade seiten: + IF laufende seitennr [1] MOD 2 = 0 + THEN kopf oder fuss laenge [koπ3Πφ&η6φζ� + ELSE kopf oder fuss laenge [kopf ungerade] + FI. +END PROC head laenge; + +PROC ende einer seite: + IF interaktiv + THEN seitenende ggf verschieben + ELSE seitenende fuer autopageform ggf verschieben + FI; + seitenende einbringen und zurueck. + +seitenende ggf verschieben: + BOOL VAR veraenderungen in der seite :: FALSE; + formatiere ueber bildschirm (veraenderungen in der seite); + schreibe titelzeile; + IF veraenderungen in der seite + THEN zum seitenanfang zur erneuten bearbeitung; + LEAVE ende einer seite + FI. + +seitenende fuer autopageform ggf verschieben: +INT VAR i, hier :: line no (ausgabe); + FOR i FROM 1 UPTO 4 REP + zeile zurueck lesen; + IF absatz zeile OR line no (ausgabe) <= 2 + THEN ggf um leerzeilen nach oben lesen; + naechste zeile lesen; + LEAVE seitenende fuer autopageform ggf verschieben + FI + END REP; + to line (ausgabe, hier); + read record (ausgabe, zeile); + IF pageblock on + THEN FOR i FROM 1 UPTO 4 REP + IF absatz zeile OR eof (ausgabe) OR pos (zeile, "#foot") <> 0 + OR pos (zeile, "#free") <> 0 + THEN naechste zeile lesen; + LEAVE seitenende fuer autopageform ggf verschieben + FI; + naechste zeile lesen + END REP; + to line (ausgabe, hier); + read record (ausgabe, zeile) + FI. + +ggf um leerzeilen nach oben lesen: + INT VAR ii := i; + WHILE zeile = " " AND pageblock on AND ii <= 4 REP + IF line no (ausgabe) <= 2 + THEN LEAVE ggf um leerzeilen nach oben lesen + FI; + zeile zurueck lesen; + ii INCR 1 + END REP. +END PROC ende einer seite; + +PROC seitenende einbringen und zurueck: + letzte textzeile war mit absatz := letzte zeile; + down (ausgabe); + grenzmarkierung in dummy speichern; + record einfuegen (dummy); + up (ausgabe); + seite nochmal durchgehen. + +letzte zeile: + up (ausgabe); + read record (ausgabe, zeile); + absatz zeile. +END PROC seitenende einbringen und zurueck; + +PROC zum seitenanfang zur erneuten bearbeitung: + zurueck bis seitenende; + durchgang := 1; + aktuelle seitenlaenge := 0; + fussnoten loeschen; + kommandos wiederherstellen +END PROC zum seitenanfang zur erneuten bearbeitung; + +(********************** positionierungs routinen ************) + +PROC naechste zeile lesen: + down (ausgabe); + read record (ausgabe, zeile) +END PROC naechste zeile lesen; + +PROC zeile zurueck lesen: + up (ausgabe); + read record (ausgabe, zeile); +END PROC zeile zurueck lesen; + +(***************** seitenende interaktiv positionieren **********) + +PROC formatiere ueber bildschirm (BOOL VAR veraenderungen): + veraenderungen := FALSE; + anz zeilen nach oben := 0; + erste bildschirmzeile schreiben; + schreibe bildschirm; + REP + positioniere lfd satz nach steuerzeichen und ggf schirm schreiben + END REP. + +positioniere lfd satz nach steuerzeichen und ggf schirm schreiben: +TEXT VAR steuerzeichen; + inchar (steuerzeichen); + IF steuerzeichen = upchar + THEN nach oben; + IF fussnoten ende + THEN ueberspringe fussnote nach oben; + schreibe bildschirm + FI + ELIF steuerzeichen = downchar + THEN IF fussnoten anfang + THEN ueberspringe fussnote nach unten; + schreibe bildschirm + ELSE nach unten; + IF fussnoten anfang + THEN ueberspringe fussnote nach unten; + schreibe bildschirm + FI + FI + ELIF steuerzeichen = hop + THEN sprung oder leerzeilen veraenderung; + schreibe bildschirm; + ELIF steuerzeichen = return + THEN IF anz zeilen nach oben < 0 + THEN down (ausgabe); + read record (ausgabe, zeile) + FI; + IF zeile = "" OR zeile = " " + THEN leerzeilen vor neuer seite loeschen + FI; + LEAVE formatiere ueber bildschirm + ELIF steuerzeichen = esc + THEN errorstop ("Abbruch mit ESC") + FI. + +fussnoten anfang: + pos (zeile, "#foot") <> 0 AND anz zeilen nach oben > 0. + +fussnoten ende: + pos (zeile, "#end") <> 0. + +nach oben: + IF anz zeilen nach oben < 0 + THEN nach oben unterhalb der seitengrenze + ELIF eine zeile nach oben war moeglich + THEN IF fussnoten ende + THEN ueberspringe fussnote nach oben; + schreibe bildschirm + ELIF anz vertauschte zeilen < zeilen nach oben + THEN out (upchar); raus; out (upchar); + schreibe seitenbegrenzung auf bildschirm; + anz vertauschte zeilen INCR 1 + ELSE schreibe bildschirm + FI + FI. + +nach oben unterhalb der seitengrenze: + IF anz zeilen nach oben = -1 + THEN cursor (1, pos seitengrenze); out (cl eop); + schreibe seitenbegrenzung auf bildschirm; + cursor (1, pos seitengrenze); + schreibe untere zeilen; + anz zeilen nach oben := 0 + ELSE INT VAR bildschirmzeile unterhalb :: + pos seitengrenze + abs (anz zeilen nach oben) + 1; + cursor (1, bildschirmzeile unterhalb); + out (cl eol); + outsubtext (zeile, 1, 76); + anz zeilen nach oben INCR 1; + bildschirmzeile unterhalb DECR 1; + cursor (1, bildschirmzeile unterhalb); + schreibe seitenbegrenzung auf bildschirm; + zeile zurueck lesen; + cursor (1, pos seitengrenze) + FI. + +nach unten: + IF anz zeilen nach oben < -4 + THEN + ELIF anz zeilen nach oben < 1 + THEN ggf nach unten formatieren + ELIF anz vertauschte zeilen > 0 + THEN out (upchar); raus; line ; + schreibe seitenbegrenzung auf bildschirm; + eine zeile nach unten wenn moeglich; + anz vertauschte zeilen DECR 1 + ELSE eine zeile nach unten wenn moeglich; + IF fussnoten anfang + THEN ueberspringe fussnote nach unten; + FI; + schreibe bildschirm + FI. + +ggf nach unten formatieren: + IF pageblock on + THEN zeile nach unten ueber seitengrenze; + cursor (1, pos seitengrenze); + FI. + +zeile nach unten ueber seitengrenze: + IF eof (ausgabe) OR page oder free oder foot anweisung + THEN LEAVE zeile nach unten ueber seitengrenze + ELSE naechste zeile lesen; + IF eof (ausgabe) OR page oder free oder foot anweisung + THEN zeile zurueck lesen; + LEAVE zeile nach unten ueber seitengrenze + FI; + zeile zurueck lesen + FI; + IF anz zeilen nach oben = 0 + THEN out (cl eol); + out (begin mark); + out ("Über Seitenende hinaus (Stauchung): UP/DOWN"); + out (end mark); + cursor (1, pos seitengrenze + 1); + schreibe untere zeilen; + ELSE naechste zeile lesen; + FI; + cursor (1, pos seitengrenze + abs (anz zeilen nach oben) + 1); + out (cl eol); + outsubtext (zeile, 1, 76); + anz zeilen nach oben DECR 1; + cursor (1, pos seitengrenze + abs (anz zeilen nach oben) + 1); + schreibe seitenbegrenzung auf bildschirm. + +page oder free oder foot anweisung: + pos (zeile, "#page") <> 0 OR pos (zeile, "#free") <> 0 + OR pos (zeile, "#foot") <> 0. + +sprung oder leerzeilen veraenderung: + INT VAR i :: 0; + REP + inchar (steuerzeichen); + IF steuerzeichen = upchar + THEN sprung nach oben + ELIF steuerzeichen = downchar + THEN sprung nach unten + ELIF steuerzeichen = rub out + THEN zeile loeschen; + ELIF steuerzeichen = rub in + THEN leerzeilen einfuegen; + FI + END REP. + +sprung nach oben: + WHILE eine zeile nach oben war moeglich REP + i INCR 1; + IF fussnoten ende + THEN ueberspringe fussnote nach oben; + LEAVE sprung oder leerzeilen veraenderung + FI + UNTIL i >= zeilen nach oben END REP; + LEAVE sprung oder leerzeilen veraenderung. + +sprung nach unten: + WHILE i < zeilen nach oben REP + IF fussnoten anfang + THEN ueberspringe fussnote nach unten; + LEAVE sprung oder leerzeilen veraenderung + ELSE eine zeile nach unten wenn moeglich; + i INCR 1; + FI; + IF fussnoten anfang + THEN ueberspringe fussnote nach unten; + LEAVE sprung oder leerzeilen veraenderung + FI + END REP; + LEAVE sprung oder leerzeilen veraenderung. + +zeile loeschen: + veraenderungen := TRUE; + up (ausgabe); + read record (ausgabe, zeile); + IF seiten ende + THEN down (ausgabe); + ELSE delete record (ausgabe); + FI; + LEAVE formatiere ueber bildschirm. + +leerzeilen einfuegen: + veraenderungen := TRUE; + out (cl eop); + REP + inchar (steuerzeichen); + IF steuerzeichen = return + THEN insert record (ausgabe); + zeile := " "; + write record (ausgabe, zeile); + out (upchar); + raus; + line + ELIF steuerzeichen = rubin + THEN LEAVE formatiere ueber bildschirm + FI + END REP. +END PROC formatiere ueber bildschirm; + +PROC leerzeilen vor neuer seite loeschen: + WHILE zeile = "" OR zeile = " " REP + delete record (ausgabe); + IF eof (ausgabe) + THEN LEAVE leerzeilen vor neuer seite loeschen + ELSE read record (ausgabe, zeile) + FI + END REP. +END PROC leerzeilen vor neuer seite loeschen; + +PROC ueberspringe fussnote nach oben: + WHILE eine zeile nach oben war moeglich REP + IF fussnoten anfang + THEN IF eine zeile nach oben war moeglich + THEN + FI; + LEAVE ueberspringe fussnote nach oben + FI + END REP. + +fussnoten anfang: + pos (zeile, "#foot#") <> 0. +END PROC ueberspringe fussnote nach oben; + +PROC ueberspringe fussnote nach unten: + REP + eine zeile nach unten wenn moeglich; + IF fussnoten ende + THEN eine zeile nach unten wenn moeglich; + LEAVE ueberspringe fussnote nach unten + FI + END REP. + +fussnoten ende: + pos (zeile, "#end#") <> 0. +END PROC ueberspringe fussnote nach unten; + +PROC schreibe free (INT CONST wert): +REAL CONST wert in y steps :: y step conversion (wert); + dummy := "#free("; + IF wert in y steps < 1.0 + THEN dummy CAT "0"; + FI; + dummy CAT text (wert in y steps); + dummy CAT ")#"; + record einfuegen (dummy); +END PROC schreibe free; + +BOOL PROC eine zeile nach oben war moeglich: + IF line no (ausgabe) = 1 + THEN FALSE + ELSE zeile zurueck lesen; + IF seitenende OR columns kommando in dieser zeile + THEN naechste zeile lesen; + FALSE + ELSE anz zeilen nach oben INCR 1; + TRUE + FI + FI. + +columns kommando in dieser zeile: + anz spalten > 1 AND pos (zeile, "#columns") <> 0. +END PROC eine zeile nach oben war moeglich; + +PROC eine zeile nach unten wenn moeglich: + IF anz zeilen nach oben > 0 + THEN naechste zeile lesen; + anz zeilen nach oben DECR 1 + FI +END PROC eine zeile nach unten wenn moeglich; + +PROC erste bildschirmzeile schreiben: + IF anz spalten > 1 + THEN dummy := "Spalten" + ELSE dummy := "Seiten" + FI; + dummy CAT "ende verschieben: UP, DOWN / bestaetigen: RETURN / Abbruch: ESC"; + schreibe titelzeile (dummy). +END PROC erste bildschirmzeile schreiben; + +PROC schreibe bildschirm: + anz vertauschte zeilen := 0; + cursor (1, 3); + out (cl eop); + gehe zurueck; + wieder nach vorne und zeilen ausgeben; + cursor (1, pos seitengrenze); + schreibe seitenbegrenzung auf bildschirm; + cursor (1, pos seitengrenze); + schreibe untere zeilen. + +gehe zurueck: + INT VAR hier :: line no (ausgabe) -1; + to line (ausgabe, hier - zeilen nach oben + 1); + INT VAR anz read zeilen :: hier - line no (ausgabe) + 2. + + wieder nach vorne und zeilen ausgeben: + IF line no (ausgabe) = 1 + THEN ggf leerzeilen auf bildschirm schreiben; + FI; + WHILE line no (ausgabe) <= hier REP + read record (ausgabe, zeile); + raus; + down (ausgabe); + END REP; + read record (ausgabe, zeile). + +ggf leerzeilen auf bildschirm schreiben: + IF zeilen nach oben - anz read zeilen >= 0 + THEN INT VAR i; + FOR i FROM 1 UPTO zeilen nach oben - anz read zeilen REP + line ; out (cl eol); out(" ") + END REP; + line ; out (cl eol); + out ("<< DATEI ANFANG >>"); out (return) + FI. +END PROC schreibe bildschirm; + +PROC schreibe untere zeilen: + gehe weiter und gebe zeilen aus; + gehe wieder zurueck; + skip input; + cursor (1, pos seitengrenze). + +gehe weiter und gebe zeilen aus: +INT VAR anz read zeilen :: 0, + i :: line no (ausgabe); + WHILE anz read zeilen < zeilen nach unten REP + IF eof (ausgabe) + THEN line ; out (cleol); out ("<< DATEI ENDE >>"); + LEAVE gehe weiter und gebe zeilen aus + FI; + raus; + naechste zeile lesen; + anz read zeilen INCR 1 + END REP. + +gehe wieder zurueck: + to line (ausgabe, i); + read record (ausgabe, zeile). +END PROC schreibe untere zeilen; + +(***************** schreib-routinen fuer den bildschirm ************) + +PROC schreibe seitenbegrenzung auf bildschirm: + out (cl eol); out (begin mark); + grenzmarkierung in dummy speichern; + out (dummy); + out (end mark); + out (return) +END PROC schreibe seitenbegrenzung auf bildschirm; + +PROC raus: +INT VAR xzeile, yspalte; + line ; out (cl eol); + outsubtext (zeile, 1, 76); + IF absatz zeile + THEN get cursor (yspalte, xzeile); + cursor (77, xzeile); + out (begin end mark) + FI; + out (return) +END PROC raus; + +PROC schreibe titelzeile: + IF online + THEN schreibe + FI. + +schreibe: + out (hop); out (cleol); + put ("PAGEFORM"); put ("(für"); put (lines (ausgabe)); put ("Zeilen):"); + put (name eingabe datei); + put ("->"); + put (name druck datei); + cursor (1, 3). +END PROC schreibe titelzeile; + +PROC schreibe titelzeile (TEXT CONST t): + IF online + THEN schreibe + FI. + +schreibe: + out (hop); out (cl eol); + out (begin mark); + out (t); + out (end mark) +END PROC schreibe titelzeile; + +(************************** initialisierungs-routine ************) + +PROC page form initialisieren: +BOOL VAR exists; +INT VAR i; + letzte textzeile war mit absatz := TRUE; + letztes seitenende war mit absatz := TRUE; + pageblock on := FALSE; + zeile noch nicht verarbeitet := FALSE; + bereich aufnehmen := FALSE; + count seitenzaehlung := FALSE; + ausgeschalteter head := FALSE; + ausgeschalteter bottom := FALSE; + in tabelle := FALSE; + es war ein linefeed in der zeile := FALSE; + letztes seitenende war in tabelle := FALSE; + mindestens ein topage gewesen := FALSE; + in index oder exponent := 0; + anz refers := 0; + kommando index := 0; + counter := 0; + laufende seitennr [1] := 1; + durchgang := 1; + anz spalten := 1; + modifikation := ""; + tab pos speicher := ""; + kommando seitenspeicher := ""; + counter numbering store := ""; + counter reference store := ""; + dec value := ""; + seitenzeichen := "%"; + eingestelltes limit := dina4 limit; + IF NOT file works + THEN font nr := 1; + eingestellter typ := font (1); + type zeilenvorschub := + font height (1) + font lead (1) + font depth (1); + eingestellte seitenlaenge := y step conversion (dina4 pagelength); + real eingestellter zeilenvorschub := 1.0 + FI; + berechneter zeilenvorschub := + int (real (type zeilenvorschub) * real eingestellter zeilenvorschub + 0.5); + max zeilenvorschub := berechneter zeilenvorschub; + max type zeilenvorschub := type zeilenvorschub; + FOR i FROM 1 UPTO 7 REP + kopf oder fuss laenge [i] := 0; + anz kopf oder fuss zeilen [i] := 0 + END REP; + IF online + THEN page + FI; + IF command dialogue + THEN interaktiv := TRUE; + ELSE interaktiv := FALSE; + FI; + IF online + THEN page + FI; + schreibe titelzeile +END PROC page form initialisieren; + +PROC central pagefo9ü̈NSγJr+�Cβ+̂γ��{s�β�KrΓλγb�#Τκ�ZK�� + name eingabe datei := input; + name druck datei := druck; + IF exists (druck) + THEN forget (druck, quiet) + FI; + disable stop; + ds := nilspace; + refer sammler := ds; + seiten form; + forget(ds); + IF is error + THEN put error; + clear error; + last param (name eingabe datei) + ELSE last param (name druck datei) + FI; + enable stop; + IF anything noted + THEN note edit (ausgabe) + FI. +END PROC central pageform routine; + +PROC pageform (TEXT CONST input, druck): + file works := FALSE; + central pageform routine (input, druck). +END PROC pageform; + +PROC pageform (TEXT CONST input): + file works := FALSE; + central pageform routine (input, input + ".p"). +END PROC pageform; + +PROC pageform: + file works := FALSE; + pageform (last param) +END PROC pageform; + +PROC pageform (TEXT CONST input, REAL CONST lf, seitenlaenge): + file works := TRUE; + eingestellte seitenlaenge := y step conversion (seitenlaenge); + real eingestellter zeilenvorschub := lf; + central pageform routine (input, input + ".p") +END PROC pageform; + +PROC autopageform: + autopageform (last param) +END PROC autopageform; + +PROC autopageform (TEXT CONST input): + command dialogue (false); + pageform (input); + command dialogue (true) +END PROC autopageform; +END PACKET seiten formatieren; +(* +REP + IF yes ("autopageform") + THEN autopageform ("pfehler") + ELSE pageform ("pfehler") + FI; + edit("pfehler.p"); +UNTIL yes ("ENDE") ENDREP; +*) + diff --git a/system/multiuser/1.7.5/src/print cmd b/system/multiuser/1.7.5/src/print cmd new file mode 100644 index 0000000..1fcb475 --- /dev/null +++ b/system/multiuser/1.7.5/src/print cmd @@ -0,0 +1,29 @@ + +PACKET print cmd DEFINES print, printer : + +PROC print : + + print (last param) + +ENDPROC print ; + +PROC print (TEXT CONST file name) : + + save (file name, task ("PRINTER")) ; + +ENDPROC print ; + +PROC print (THESAURUS CONST nameset) : + + do (PROC (TEXT CONST) print, nameset) + +ENDPROC print ; + +TASK PROC printer : + + task ("PRINTER") + +ENDPROC printer ; + +ENDPACKET print cmd ; + diff --git a/system/multiuser/1.7.5/src/priv ops b/system/multiuser/1.7.5/src/priv ops new file mode 100644 index 0000000..a92ee76 --- /dev/null +++ b/system/multiuser/1.7.5/src/priv ops @@ -0,0 +1,268 @@ +(* ------------------- VERSION 10 22.04.86 ------------------- *) +PACKET privileged operations DEFINES (* Autor: J.Liedtke *) + + block , + calendar , + collect garbage blocks , + define collector , + fixpoint , + info password , + prio , + save system , + send , + set clock , + set date , + shutup , + unblock : + +LET prio field = 6 , + cr = ""13"" , + archive channel = 31 , + + ack = 0 , + + garbage collect code = 1 , + fixpoint code = 2 , + shutup code = 4 , + shutup and save code = 12 , + reserve code = 19 , + release code = 20 ; + + + +INT PROC prio (TASK CONST task) : + pcb (task, prio field) +ENDPROC prio ; + +PROC prio (TASK CONST task, INT CONST new prio) : + pcb (task, prio field, new prio) +ENDPROC prio ; + +TEXT VAR date text ; + +PROC collect garbage blocks : + + system operation (garbage collect code) + +ENDPROC collect garbage blocks ; + +PROC fixpoint : + + system operation (fixpoint code) + +ENDPROC fixpoint ; + +PROC info password (TEXT CONST old info password, new info password) : + + INT VAR error code ; + IF online + THEN say (""3""5""10"") + FI ; + IF LENGTH new info password < 10 + THEN infopw (old info password + cr, new info pw, error code) ; + IF error code = 0 + THEN shutup + ELSE errorstop ("Falsches Info-Passwort") + FI + ELSE errorstop ("Passwort zu lang (max. 9 Zeichen)") + FI ; + cover tracks . + +new info pw : + IF new info password = "-" + THEN "-" + 9 * "0" + ELSE new info password + "cr" + FI . + +ENDPROC info password ; + +PROC shutup : + + system operation (shutup code) ; + IF command dialogue + THEN wait for configurator ; + page ; + set date + FI + +ENDPROC shutup ; + +PROC save system : + + INT VAR reply ; + TASK VAR channel owner ; + enable stop ; + reserve archive channel ; + IF yes ("Leere Floppy eingelegt") + THEN + reserve archive channel ; + system operation (shutup and save code) ; + release archive channel ; + IF command dialogue + THEN wait for configurator ; + page ; + set date + FI + FI ; + release archive channel . + +reserve archive channel : + channel owner := task (archive channel) ; + IF NOT is niltask (channel owner) + THEN ask channel owner to reserve the channel ; + IF channel owner does not reserve channel + THEN errorstop ("Task """ + name (channel owner) + + """ gibt Kanal " + + text (archive channel) + + " nicht frei") + FI + FI . + +ask channel owner to reserve the channel : + forget (ds) ; + ds := nilspace ; + pingpong (channel owner, reserve code, ds, reply) . + +channel owner does not reserve channel : + (reply <> ack) AND task exists . + +task exists : + reply <> -1 . + +release archive channel : + forget (ds) ; + ds := nilspace ; + pingpong (channel owner, release code, ds, reply) . + +ENDPROC save system ; + +PROC system operation (INT CONST code) : + + INT VAR size, used ; + storage (size, used) ; + IF used <= size + THEN sys op (code) + ELSE errorstop ("Speicherengpass") + FI + +ENDPROC system operation ; + +DATASPACE VAR ds := nilspace ; + +PROC wait for configurator : + + INT VAR i , receipt ; + FOR i FROM 1 UPTO 20 WHILE configurator exists REP + pause (30) ; + forget (ds) ; + ds := nilspace ; + ping pong (configurator, ack, ds, receipt) + UNTIL receipt >= 0 PER . + +configurator exists : + disable stop ; + TASK VAR configurator := task ("configurator") ; + clear error ; + NOT is niltask (configurator) . + +ENDPROC wait for configurator ; + +BOOL VAR hardware clock ok ; +REAL VAR now ; + +PROC set date : + + hardware clock ok := TRUE ; + try to get date and time from hardware ; + IF NOT hardware clock ok + THEN get date and time from user + FI ; + define date and time . + +try to get date and time from hardware : + disable stop ; + REAL VAR previous now ; + now := 0.0 ; + INT VAR try ; + FOR try FROM 1 UPTO 3 WHILE hardware clock ok REP + previous now := now ; + now := date (hardwares today) + time (hardwares time) + UNTIL now = previous now OR is error PER ; + clear error ; + enable stop . + +get date and time from user : + line (2) ; + put (" Bitte geben Sie das heutige Datum ein :") ; + date text := date ; + TEXT VAR exit char ; + editget (date text, cr, "", exit char) ; + now := date (date text) ; + line ; + put (" und die aktuelle Uhrzeit :") ; + date text := time of day ; + editget (date text, cr, "", exit char) ; + now INCR time (date text) ; + IF NOT last conversion ok + THEN errorstop ("Falsche Zeitangabe") + FI . + +hardwares today : calendar (3) + "." + calendar (4) + "." + calendar (5) . + +hardwares time : calendar (2) + ":" + calendar (1) . + +define date and time : + set clock (now) . + +ENDPROC set date ; + +TEXT PROC calendar (INT CONST index) : + + INT VAR bcd ; + control (10, index, 0, bcd) ; + IF bcd < 0 + THEN hardware clock ok := FALSE ; "" + ELSE text (low digit + 10 * high digit) + FI . + +low digit : bcd AND 15 . + +high digit: (bcd AND (15*256)) DIV 256 . + +ENDPROC calendar ; + +PROC infopw (TEXT CONST old, new, INT VAR error code) : + EXTERNAL 81 +ENDPROC infopw ; + +PROC sys op (INT CONST code) : + EXTERNAL 90 +ENDPROC sys op ; + +PROC set clock (REAL CONST time) : + EXTERNAL 103 +ENDPROC set clock ; + +PROC pcb (TASK CONST task, INT CONST field, value) : + EXTERNAL 105 +ENDPROC pcb ; + +PROC unblock (TASK CONST task) : + EXTERNAL 108 +ENDPROC unblock ; + +PROC block (TASK CONST task) : + EXTERNAL 109 +ENDPROC block ; + +PROC send (TASK CONST from, to, INT CONST order, DATASPACE VAR ds, + INT VAR receipt) : + EXTERNAL 127 +ENDPROC send ; + +PROC define collector (TASK CONST task) : + EXTERNAL 128 +ENDPROC define collector ; + +ENDPACKET privileged operations ; + diff --git a/system/multiuser/1.7.5/src/silbentrennung b/system/multiuser/1.7.5/src/silbentrennung new file mode 100644 index 0000000..dfbdf75 --- /dev/null +++ b/system/multiuser/1.7.5/src/silbentrennung @@ -0,0 +1,1166 @@ +(* ------------------- VERSION 170 vom 30.09.85 -------------------- *) +PACKET silbentrennung DEFINES + trenn, + schreibe trennvektor, + ist ausnahme wort, + lade ausnahmen, + entlade ausnahmen: + +(* Programm zur Silbentrennung + Autor: Klaus-Uwe Koschnick / Rainer Hahn + Stand: 1.7.1 (Febr. 1984) + 1.7.4 (Mai 1984) (Ausnahme-Woerterbuch, Verbesserungen) +*) + +(*--------------------- Ausnahme Woerterbuch -----------------------*) + +DATASPACE VAR ds1 :: nilspace; + +FILE VAR f; + +LET name table length = 1024, + max hash chars = 5; + +INT VAR anz worte :: 0, + hash index; + +INITFLAG VAR this packet :: FALSE; + +TEXT VAR dummy, + name ohne trennstellen, + trennstellen, + blanked name; + +BOUND ROW name table length TEXT VAR name table; + +PROC init packet: + IF NOT initialized (this packet) + THEN anz worte := 0 + FI +END PROC init packet; + +PROC init name table: + forget (ds1); + ds1 := nilspace; + name table := ds1; + INT VAR i; + FOR i FROM 1 UPTO name table length REP + cout (i); + name table [i] := "" + END REP; + anz worte := 0. +END PROC init name table; + +PROC lade ausnahmen: + lade ausnahmen (last param) +END PROC lade ausnahmen; + +PROC lade ausnahmen (TEXT CONST filename): + IF exists (filename) + THEN lade + ELSE errorstop ("Datei nicht vorhanden") + FI. + +lade: + init packet; + IF anz worte > 0 + THEN IF yes ("überschreiben") + THEN init nametable + ELIF no ("anfügen") + THEN LEAVE lade ausnahmen + FI + ELSE init nametable + FI; + line (2); + f := sequential file (input, file name); + WHILE NOT eof (f) REP + get (f, dummy); + IF subtext (dummy, 1, 2) = "(*" + THEN ueberlese kommentar + ELSE lade wort (* Vor.: Worte ohne Blanks *) + FI + END REP. + +ueberlese kommentar: + WHILE NOT eof (f) AND pos (dummy, "*)") = 0 REP + get (f, dummy); + END REP. + +lade wort: + line ; + anz worte INCR 1; + put (anz worte); + stelle namen ohne trennstellen her; + put (name ohne trennstellen); + blanked name := " "; + name ohne trennstellen CAT " "; + blanked name CAT name ohne trennstellen; + hash; + IF pos (name table [hash index], blanked name) > 0 + THEN put ("(bereits geladen)") + ELSE insert char (name ohne trennstellen, " ", 1); + name ohne trennstellen CAT trennstellen; + name table [hash index] CAT name ohne trennstellen; + FI. + +stelle namen ohne trennstellen her: + INT VAR number; + name ohne trennstellen := dummy; + trennstellen := ""; + WHILE pos (name ohne trennstellen, "-") > 0 REP + number := pos (name ohne trennstellen, "-"); + delete char (name ohne trennstellen, number); + trennstellen CAT text (number - 1); + trennstellen CAT " " + END REP. +END PROC lade ausnahmen; + +PROC entlade ausnahmen (TEXT CONST file name): + init packet; + IF exists (file name) + THEN errorstop ("Datei existiert bereits") + ELSE unload + FI. + +unload: + f := sequential file (output, file name); + INT VAR i; + FOR i FROM 1 UPTO name table length REP + cout (i); + IF name table [i] <> "" + THEN putline (f, name table [i]) + FI + END REP. +END PROC entlade ausnahmen; + +BOOL PROC ist ausnahme wort (TEXT CONST word, + INT CONST maximum, INT VAR trenn position): + init packet; + IF anz worte > 0 + THEN blanked name fuer hash bilden; + hash; + IF pos (name table [hash index], blanked name) > 0 + THEN trennstelle suchen + FI + FI; + FALSE. + +blanked name fuer hash bilden: + blanked name := " "; + IF maximum <= max hash chars + THEN eliminiere ggf satzzeichen hinter dem wort; + blanked name CAT + subtext (word, 1, min (max hash chars, wortlaenge)) + ELSE blanked name CAT subtext (word, 1, maximum); + FI. + +eliminiere ggf satzzeichen hinter dem wort: + INT VAR wort laenge := length (word); + WHILE letztes zeichen ist kein buchstabe REP + wort laenge DECR 1; + IF wort laenge <= 2 + THEN LEAVE ist ausnahme wort WITH FALSE + FI + END REP. + +letztes zeichen ist kein buchstabe: + TEXT CONST letztes zeichen :: (word SUB wortlaenge); + NOT (letztes zeichen >= "A" AND letztes zeichen <= "Z" OR + letztes zeichen >= "a" AND letztes zeichen <= "z" OR + letztes zeichen >= "Ä" AND letztes zeichen <= "k" OR + letztes zeichen = "ß"). + +trennstelle suchen: + index der ersten ziffer suchen; + INT VAR neue ziffer := 0; + trenn position := 0; + ziffern holen. + +index der ersten ziffer suchen: + dummy := name table [hash index]; + INT VAR ziffern index := pos (dummy, blanked name); + ziffern index := pos (dummy, " ", ziffern index + 1) + 1. + +ziffern holen: + WHILE ist ziffer REP + hole neue ziffer; + IF gefundene ziffer ist ausserhalb des trennbereichs + THEN LEAVE ist ausnahme wort WITH TRUE + FI; + trenn position := neue ziffer + END REP; + LEAVE ist ausnahme wort WITH TRUE. + +ist ziffer: + ziffern index < length (dummy) AND +((dummy SUB ziffern index + 1) = " " OR (dummy SUB ziffern index + 2) = " "). + +hole neue ziffer: + INT VAR ende position :: pos (dummy, " ", ziffern index); + neue ziffer := int (subtext (dummy, ziffern index, ende position - 1)); + ziffern index := ende position + 1. + +gefundene ziffer ist ausserhalb des trennbereichs: + neue ziffer > maximum. +END PROC ist ausnahme wort; + +PROC hash: + INT VAR i; + hash index := code (blanked name SUB 2); + FOR i FROM 3 UPTO min (length (blanked name), max hash chars) REP + hash index INCR hash index; + hash index INCR code (blanked name SUB i); + decrementiere hash index + END REP. + +decrementiere hash index: + WHILE hash index > name table length REP + hash index DECR 1023 + END REP. +END PROC hash; + +(*-------------- eigentlicher Trenn-Algorithmus --------------*) + +LET zeichenkette n = "-/", + regelmaessig = " bl br chl chr dr fl fr gl gr kl kn kr pf ph pl pr + sp st schl schm schn schr schw th tr zw ", + vokal string = "aeiouyäöü", + buchstaben = + "abcdefghijklmnopqrstuvwxyzäöüßABCDEFGHIJKLMNOPQRSTUVWXYZÄÖÜ", + grosse buchstaben = "ABCDEFGHIJKLMNOPQRSTUVWXYZ", + trennstrich = ""221"", + cv a = 97 , cv b = 98 , cv c = 99 , cv d = 100, cv e = 101, + cv f = 102, cv g = 103, cv i = 105, cv k = 107, + cv l = 108, cv m = 109, cv n = 110, cv o = 111, + cv p = 112, cv r = 114, cv s = 115, cv t = 116, + cv u = 117, cv w = 119, cv x = 120, cv y = 121, + cv ae = 217 , cv oe = 218 , cv ue = 219 , cv sz = 251, + weder h noch ch = 0 , + buchstabe h = 1 , + zeichenfolge ch = 2 ; + +INT CONST minus one :: - 1; + +INT VAR i, grenze, absolute grenze, sonderzeichen trennpos, + zeichen vor teilwort, teilwort laenge, a pos, e pos, + a pos minus 2, a pos minus 1, a pos plus 1, a pos plus 2, + e pos minus 1; + +ROW 50 INT VAR vektor ; + +TEXT VAR wort, + teilwort, + kons gr, + search, + zeichen; + +BOOL VAR trennstelle gefunden ; + +PROC trenn (TEXT CONST word, TEXT VAR part1, trennsymbol, INT CONST maximum): + IF ist ausnahme wort (word, maximum, position) + THEN ausnahme wort behandlung; + LEAVE trenn + FI; + INT VAR laenge :: length (word) ; + IF laenge < 4 + THEN trennung nicht moeglich + ELSE wort := word ; + grenze := min (50, maximum) ; + absolute grenze := min (laenge, grenze + 5) ; + trennung versuchen + FI . + +ausnahme wort behandlung: + IF position <= 0 + THEN trennung nicht moeglich + ELSE part1 := subtext (word, 1, position); + IF pos (zeichenkette n, word SUB position + 1) > 0 + THEN trennsymbol := " " + ELSE trennsymbol := trennstrich + FI + FI. + +trennung nicht moeglich : + part 1 := ""; + trennsymbol := " ". + +trennung versuchen : + erstelle trennvektor ; + IF sonderzeichen trennpos > 0 + THEN part 1 := subtext (word, 1, sonderzeichen trennpos) ; + trennsymbol := " " + ELSE bestimme trennposition ; + IF position = 0 + THEN trennung nicht moeglich + ELSE part 1 := subtext (wort, 1, position) ; + trennsymbol := trennstrich + FI + FI . + +bestimme trennposition : + INT VAR position ; + FOR position FROM grenze DOWNTO 1 REP + IF vektor [position] = 1 + THEN LEAVE bestimme trennposition + FI + END REP ; + position := 0 +END PROC trenn ; + +BOOL PROC buchstabe (INT CONST posi) : + pos (buchstaben, wort SUB posi) > 0 OR spezialcode. + +spezialcode: + INT CONST z code :: code (wort SUB posi) ; + (zcode > 96 AND zcode < 123). +END PROC buchstabe ; + +OP SPERRE (INT CONST element) : + INT CONST w element :: zeichen vor teilwort + element ; + IF w element > 0 AND w element <= grenze + THEN vektor [w element] := minus one + FI +END OP SPERRE ; + +OP SETZE (INT CONST element) : + INT CONST w element :: zeichen vor teilwort + element; + IF w element > 0 AND w element <= grenze AND vektor [w element] <> minus one + THEN vektor [w element] := 1 ; + trennstelle gefunden := TRUE + FI +END OP SETZE ; + +BOOL PROC vorletzter buchstabe oderkeine trennung oder sperre gesetzt + (INT CONST akt buchstabenpos): + vorletzter buchstabe (akt buchstabenpos) + OR NOT trennung oder sperre gesetzt (akt buchstabenpos). +END PROC vorletzter buchstabe oderkeine trennung oder sperre gesetzt; + +BOOL PROC vorletzter buchstabe (INT CONST akt buchstabenpos): + akt buchstabenpos = absolute grenze - 1 +END PROC vorletzter buchstabe; + +BOOL PROC trennung oder sperre gesetzt (INT CONST element): + INT CONST w element :: zeichen vor teilwort + element; + IF w element > 1 AND w element < teilwort laenge + THEN vektor [w element] = 1 OR gesperrt + ELSE TRUE + FI. + +gesperrt: + IF w element >= length (wort) - 1 + THEN TRUE + ELSE vektor [w element] = minus one + FI. +END PROC trennung oder sperre gesetzt; + +PROC sperren und setzen (INT CONST element) : + INT CONST w element :: zeichen vor teilwort + element ; + vektor [w element - 1] := minus one; + vektor [w element] := 1 +END PROC sperren und setzen ; + +TEXT PROC string (INT CONST anf pos, end pos) : + subtext (teilwort, maximum, minimum). + +maximum: + IF anf pos > 1 + THEN anf pos + ELSE 1 + FI. + +minimum: + IF teilwort laenge < end pos + THEN teilwort laenge + ELSE end pos + FI. +END PROC string ; + +BOOL PROC silbenanfang vor (INT CONST akt buchstabenpos): + zwei silber (akt buchstabenpos - 2) OR drei silber (akt buchstabenpos - 3) +END PROC silbenanfang vor; + +BOOL PROC silbenanfang nach (INT CONST akt buchstabenpos): + zwei silber (akt buchstabenpos + 1) OR drei silber (akt buchstabenpos + 1) +END PROC silbenanfang nach; + +BOOL PROC zwei silber (INT CONST akt buchstabenpos): + TEXT VAR zweier :: string (akt buchstabenpos, akt buchstabenpos + 1); + length (zweier) = 2 AND + pos ("ab an ar be er ge in um un zu re", zweier) > 0 +END PROC zwei silber; + +BOOL PROC drei silber (INT CONST akt buchstabenpos): + TEXT VAR dreier :: string (akt buchstabenpos, akt buchstabenpos + 2); + length (dreier) = 3 AND + pos ("auf aus bei ein end ent mit", dreier) > 0 +END PROC drei silber; + +BOOL PROC reg (INT CONST st pos) : + INT CONST code one :: code (teilwort SUB st pos) , + code two :: code (teilwort SUB st pos + 1) ; + pos (regelmaessig, konsonanten) > 0 . + +konsonanten : + search := " " ; + IF code one = cv c + THEN search CAT string (st pos, st pos + 2) + ELIF code one = cv s AND code two = cv c + THEN search CAT string (st pos, st pos + 3) + ELSE search CAT string (st pos, st pos + 1) + FI ; + search CAT " " ; + search +END PROC reg ; + +INT PROC grenz position (INT CONST start pos, richtung): + INT VAR posit :: start pos ; + REP + posit INCR richtung + UNTIL sonderzeichen oder position unzulaessig END REP; + posit - richtung. + +sonderzeichen oder position unzulaessig: + posit = 0 AND posit > absolute grenze OR ist kein buchstabe. + +ist kein buchstabe: + pos (buchstaben, wort SUB posit) = 0 AND kein spezialcode. + +kein spezialcode: + INT CONST z code :: code (wort SUB posit) ; + (zcode < 97 OR zcode > 121). +END PROC grenz position ; + +PROC schreibe trennvektor (TEXT CONST ttt): +line ; put (ttt); INT VAR ii; +FOR ii FROM 1 UPTO length (wort) REP put(vektor [ii]) PER +END PROC schreibe trennvektor; + +PROC erstelle trennvektor : +INT VAR akt pos, anfang teilwort, ende teilwort, anzahl, + zuletzt, tr pos, ind, code 1, code 2, code 3, + rechts von a pos, z code, posit; +BOOL VAR sonderzeichen modus, + aktueller buchstabe ist vokal, + vorsilbe oder nachsilbe; + + sonderzeichen trennpos := 0 ; + trennstelle gefunden := FALSE ; + initialisiere trennvektor ; + akt pos := grenze ; + IF buchstabe (akt pos) + THEN zuerst teilwort + ELSE zuerst sonderzeichenblock + FI; + WHILE akt pos > 0 REP + IF sonderzeichen modus + THEN behandle sonderzeichenblock + ELSE suche trennstellen in teilwort + FI + END REP. + +initialisiere trennvektor : + FOR i FROM 1 UPTO grenze REP vektor [i] := 0 END REP . + +zuerst teilwort: + ende teilwort := grenz position (akt pos, 1) ; + sonderzeichen modus := FALSE . + +zuerst sonderzeichenblock: + sonderzeichen modus := TRUE . + +behandle sonderzeichenblock: + WHILE sonderzeichen modus REP + IF buchstabe (akt pos) + THEN sonderzeichen modus := FALSE + ELSE zeichen := wort SUB akt pos ; + IF pos (zeichenkette n, zeichen) <> 0 + THEN sonderzeichen trennpos := akt pos ; + LEAVE erstelle trennvektor + FI ; + akt pos DECR 1 ; + IF akt pos = 0 + THEN LEAVE erstelle trennvektor + FI + FI + END REP; + ende teilwort := akt pos . + +suche trennstellen in teilwort: + bestimme anfang von teilwort ; + IF teilwort lang genug + THEN teilwort ausbauen und wandeln ; + SPERRE 1 ; SPERRE (teilwort laenge - 1) ; + vorsilben untersuchen ; + nachsilben untersuchen ; + vorsilbe oder nachsilbe := trennstelle gefunden ; + trennstelle gefunden := FALSE ; + weitere trennstellen suchen ; + IF vorsilbe oder nachsilbe + THEN LEAVE erstelle trennvektor + FI + FI ; + akt pos := anfang teilwort - 1 ; + sonderzeichen modus := TRUE . + +bestimme anfang von teilwort: + anfang teilwort := grenz position (ende teilwort, minus one) . + +teilwort lang genug: + teilwort laenge := ende teilwort - anfang teilwort + 1 ; + teilwort laenge > 3 . + +teilwort ausbauen und wandeln: + teilwort := subtext (wort, anfang teilwort, ende teilwort); + zeichen vor teilwort := anfang teilwort - 1 ; + IF pos (grosse buchstaben, teilwort SUB 1) > 0 + THEN replace (teilwort, 1, code (code (teilwort SUB 1) + 32)) + FI . + (* Es ist nicht notwendig, gross geschriebene Umlaute am + Wortanfang zu wandeln! *) + +weitere trennstellen suchen: + e pos := teilwort laenge ; + aktueller buchstabe ist vokal := letzter buchstabe ist vokal ; + WHILE e pos > 1 REP + anzahl := 0 ; + a pos := e pos ; + IF aktueller buchstabe ist vokal + THEN behandle vokalgruppe + ELSE behandle konsonantengruppe + FI ; + IF trennstelle gefunden + THEN LEAVE erstelle trennvektor + FI ; + e pos := a pos - 1 ; + END REP . + +letzter buchstabe ist vokal: + pos (vokal string,teilwort SUB e pos) > 0 . + +behandle vokalgruppe: + vokalgruppe lokalisieren ; + IF a pos > 1 AND e pos < teilwort laenge + THEN a pos plus 1 := a pos + 1 ; + a pos plus 2 := a pos + 2 ; + IF anzahl = 2 + THEN vokal 2 + ELIF anzahl > 2 + THEN vokal 3 + ELSE vokal 1 + FI + FI . + +vokalgruppe lokalisieren: + zuletzt := 0 ; + WHILE aktueller buchstabe ist vokal REP + zeichen := teilwort SUB a pos ; + IF pos (vokal string,zeichen) > 0 + THEN z code := code(zeichen) ; + IF zuletzt <> cv e + OR (z code <> cv a AND z code <> cv o AND z code <> cv u) + THEN anzahl INCR 1 + FI ; + IF a pos > 1 + THEN a pos DECR 1 ; + zuletzt := z code + ELSE aktueller buchstabe ist vokal := FALSE + FI + ELSE a pos INCR 1 ; + aktueller buchstabe ist vokal := FALSE + FI + END REP . + +behandle konsonantengruppe: + konsonantengruppe lokalisieren ; + IF a pos > 1 AND e pos < teilwort laenge + THEN a pos minus 2 := a pos - 2 ; + a pos minus 1 := a pos - 1 ; + a pos plus 1 := a pos + 1 ; + a pos plus 2 := a pos + 2 ; + e pos minus 1 := e pos - 1 ; + SELECT anzahl OF + CASE 1 : konsonant 1 + CASE 2 : konsonant 2 + OTHERWISE : konsonant 3 + END SELECT + FI . + +konsonantengruppe lokalisieren: + rechts von a pos := weder h noch ch ; + REP + zeichen := teilwort SUB a pos ; + IF pos (vokal string, zeichen) = 0 + THEN anzahl INCR 1 ; + IF zeichen = "h" + THEN rechts von a pos := buchstabe h + ELIF zeichen = "c" AND rechts von a pos = buchstabe h + THEN anzahl DECR 1 ; + rechts von a pos := zeichenfolge ch + ELIF zeichen = "s" AND rechts von a pos = zeichenfolge ch + THEN anzahl DECR 1 ; + rechts von a pos := weder h noch ch + ELSE rechts von a pos := weder h noch ch + FI ; + IF a pos > 1 + THEN a pos DECR 1 + ELSE aktueller buchstabe ist vokal := TRUE + FI + ELSE a pos INCR 1 ; + aktueller buchstabe ist vokal := TRUE + FI + UNTIL aktueller buchstabe ist vokal END REP . + +vorsilben untersuchen: + code 2 := code (teilwort SUB 2); + code 3 := code (teilwort SUB 3); + IF ch vierer silbe + THEN sperren und setzen (4) + ELSE restliche vorsilben + FI. + +ch vierer silbe: + string (2, 4) = "ach" OR string (2, 4) = "och" OR string (2, 4) = "uch". + +restliche vorsilben: + ind := pos ("abdefghimnrstuvwüu", teilwort SUB 1); +SELECT ind OF +CASE1(*a*): IF drei silber (1) + THEN sperren und setzen (3) + ELIF code 2 = cv b (*ab*) + THEN IF string(3,5) = "end" (*abend*) + THEN SPERRE 2; sperren und setzen (5) + ELIF string(3,4) = "er" (*aber*) + THEN sperren und setzen (4) + ELSE sperren und setzen (2) + FI + ELIF code 2 = cv n AND string(3,5) <> "alo" (*analo*) + THEN SETZE 2 + FI +CASE2(*b*): IF code 2 = cv e (* be *) + THEN IF (teilwort SUB 3) = "h" (* be-handeln usw *) + OR (teilwort SUB 3) = "a" (* beamter *) + THEN sperren und setzen (2) + ELIF string (3, 4) = "ob" (* beobachten *) + THEN SETZE 2; sperren und setzen (4) + FI + ELIF string (2, 3) = "au" (* bauer usw *) + THEN sperren und setzen (3) + FI +CASE3(*d*): IF (code 3 = cv s AND (code 2 = cv i OR code 2 = cv e)) + OR string (2, 3) = "ar" (* dis, des, dar*) + THEN sperren und setzen (3) + ELIF string (2, 4) = "enk" (* denk.. *) + THEN sperren und setzen (4) + ELIF string(2,5) = "urch" (*durch*) + THEN SPERRE 3 ; SETZE 5 + FI +CASE4(*e*): IF code 2 = cv r AND code 3 <> cv n AND code 3 <> cv d + AND string (3, 4) <> "ro" (* er, aber nicht: ern, erd, erro *) + THEN SETZE 2 + ELIF code 2 = cv x (* ex *) + THEN SETZE 2 + ELIF (code 2 = cv m AND code 3 = cv p AND (teilwort SUB 4) = "f") + OR (code 2 = cv n AND code 3 = cv t) (* empf, ent *) + THEN sperren und setzen (3) + FI +CASE5(*f*): +CASE6(*g*): IF string (2, 5) = "egen" (* gegen *) + THEN sperren und setzen (5) + ELIF string (2, 6) = "leich" (* gleich *) + THEN IF vorletzter buchstabe (5) + THEN SPERRE 6 + ELIF vorletzter buchstabe (6) + THEN sperren und setzen (4) + ELSE sperren und setzen (6) + FI + ELIF zwei silber (1) + THEN SETZE 2 + FI +CASE7(*h*): IF string (2, 3) = "in" OR string (2, 3) = "er" (* hin, her *) + THEN sperren und setzen (3) + FI +CASE8(*i*): IF code 2 = cv n (* in *) + THEN IF string (3, 5) = "ter" (* inter *) + THEN sperren und setzen (5) + ELIF subtext (teilwort, 1, 5) = "insbe" + THEN sperren und setzen (3) + ELSE sperren und setzen (2) + FI; + FI +CASE9(*m*): IF string (2, 3) = "ög" AND teilwort laenge > 5 (* mög *) + THEN sperren und setzen (3); + FI +CASE10(*n*): IF string (2, 4) = "ach" AND teilwort laenge >= 7 + AND (teilwort SUB 5) <> "t" (* nach, aber nicht: nacht *) + THEN SETZE 4 + ELIF string (2, 6) = "ieder" (* nieder *) + THEN sperren und setzen (6) + ELIF string (2, 5) = "icht" (* nicht *) + THEN sperren und setzen (5) + ELIF string (2, 3) = "eu" (* neu *) + THEN sperren und setzen (3); + IF dreisilber (4) + THEN sperren und setzen (6) + FI + ELIF string (2, 5) = "iste" + THEN sperren und setzen (2) + FI +CASE11(*r*): IF code 2 = cv e (* re *) + THEN IF silbenanfang nach (4) (* Realeinkommen *) + THEN sperren und setzen (4) + ELSE sperren und setzen (2) + FI + FI +CASE12(*s*): IF string (2, 6) = "elbst" (* selbst *) + THEN sperren und setzen (6); SPERRE 4 + FI +CASE13(*t*): IF string (2, 3) = "at" (* tat *) + THEN sperren und setzen (3) + ELIF string (2, 5) = "rans" (* trans *) + THEN sperren und setzen (5) + ELIF string (2, 4) = "heo" (* theo *) + THEN sperren und setzen (4) + FI +CASE14(*u*): IF code 2 = cv m (* um *) + THEN SETZE 2 + ELIF code 2 = cv n (* un *) + THEN IF code 3 = cv i (* uni *) + THEN sperren und setzen (3) + ELSE sperren und setzen (2); + IF string (3, 5) = "ter" (* unter *) + THEN sperren und setzen (5) + FI + FI + FI +CASE15(*v*): IF string (2, 3) = "or" OR string (2, 3) = "on" OR + string (2, 3) = "er" (* vor, von, ver *) + THEN sperren und setzen (3) + FI +CASE16(*w*): IF code 2 = cv e AND code 3 = cv g (* weg *) + THEN sperren und setzen (3) + ELIF code 2 = cv i (* wi *) + THEN IF string(3,5) = "der" (* wider *) + THEN sperren und setzen (5) + ELIF string(3,6) = "eder" (* weder *) + THEN sperren und setzen (6) + FI + FI +CASE17(*ü*): IF string (2, 4) = "ber" (* über *) + THEN sperren und setzen (4) + FI +CASE18(*z*): IF code 2 = cv u (*zu*) + THEN sperren und setzen (2); + IF drei silber (3) (* zuein *) + THEN sperren und setzen (5) + FI + FI +END SELECT. + +nachsilben untersuchen: + IF (teilwort SUB teilwort laenge) = "t" + THEN IF (string (teilwort laenge - 3,teilwort laenge) = "heit" + AND (teilwort SUB teilwort laenge - 4) <> "c") + OR string (teilwort laenge - 3, teilwort laenge -1) = "kei" + THEN sperren und setzen (teilwort laenge - 4) + FI + ELIF string (teilwort laenge - 2, teilwort laenge) = "tag" + THEN sperren und setzen (teilwort laenge - 3) + ELIF string (teilwort laenge - 3, teilwort laenge) = "tags" + THEN sperren und setzen (teilwort laenge - 4) + FI. + +vokal 1: + IF string (a pos, a pos plus 2) = "uel" + THEN SETZE a pos + FI. + +vokal 2 : + ind := pos (vokal string, teilwort SUB a pos); + code 2 := code (teilwort SUB a pos plus 1); +SELECT ind OF +CASE1(*a*): IF code 2 = cv a OR code 2 = cv i OR code 2 = cv y (*aa,ai,ay*) + THEN + ELIF code 2 = cv u + THEN silbe au behandlung + ELSE SETZE a pos + FI +CASE2(*e*): IF code 2 = cv u AND (teilwort SUB a pos plus 2) = "e" (*eue*) + THEN SETZE a pos plus 1 + ELIF code 2 = cv o OR code 2 = cv ae OR code 2 = cv ue + OR code 2 = cv oe (*eo, eä, eü, eö *) + THEN SETZE a pos + FI +CASE3(*i*): IF code 2 <> cv e AND code 2 <> cv o (* i, aber nicht: ie, io *) + THEN SETZE a pos + FI +CASE4(*o*): IF code 2 = cv o OR code 2 = cv u (* oo, ou *) + THEN + ELIF code 2 = cv e (* oe *) + THEN SETZE a pos plus 1 + ELSE SETZE a pos + FI +CASE5(*u*): IF (teilwort SUB a pos - 1) = "q" (* qu *) + THEN + ELIF code 2 = cv e (* ue *) + THEN SETZE a pos plus 1 + ELSE SETZE a pos + FI +CASE7(*y*): IF code 2 <> cv u (* yu *) + THEN SETZE a pos + FI +OTHERWISE (*äöü*): SETZE a pos +END SELECT. + +silbe au behandlung: + IF (teilwort SUB a pos + 2) = "e" (* aue, wie in dau-ernd *) + THEN SETZE a pos plus 1 + ELIF a pos > 2 AND trennung oder sperre gesetzt (a pos + 2) AND + ((teilwort SUB a pos + 2) = "f" OR (teilwort SUB a pos + 2) = "s") + (* aus- oder auf-Mittelsilben *) + THEN SETZE (a pos - 1) + FI. + +vokal 3 : + IF string (a pos, a pos plus 2) <> "eau" + AND string (a pos plus 1, a pos+3) <> "eau" + THEN IF e pos - a pos = anzahl - 1 + THEN SETZE a pos plus 1 + ELSE code 1 := code(teilwort SUB a pos) ; + tr pos := a pos plus 1 ; + IF (code 1 = cv a OR code 1 = cv o OR code 1 = cv u) + AND (teilwort SUB a pos plus 1) = "e" + THEN tr pos INCR 1 + FI; + code 2 := code (teilwort SUB tr pos) ; + IF (code 2 = cv a OR code 2 = cv o OR code 2 = cv u) + AND (teilwort SUB tr pos + 1) = "e" + THEN tr pos INCR 1 + FI ; + SETZE tr pos + FI + FI . + +konsonant 1 : + ind := pos ("bcklmnrstß", teilwort SUB a pos); +SELECT ind OF +CASE1(*b*): IF string (a pos minus 1, a pos plus 2) = "über" + THEN SETZE a pos minus 2 + ELIF silbenanfang nach (a pos) + AND NOT trennung oder sperre gesetzt (a pos minus 1) + THEN SETZE a pos + ELIF vorletzter buchstabe oderkeine trennung oder sperre gesetzt + (a pos) + THEN SETZE a pos minus 1 + FI; +CASE2(* c oder ch *): + IF ((teilwort SUB a pos plus 1) = "h" + AND (silbenanfang nach (a pos plus 1) + OR string (a pos, a pos + 3) = "chen")) + OR (teilwort SUB a pos plus 1) <> "h" + THEN SETZE a pos minus 1 + ELSE SETZE a pos plus 1 + FI +CASE3(*k*): IF string (a pos minus 2, a pos minus 1) = "ti" (* tik *) + AND silbenanfang nach (a pos) + THEN SETZE a pos + ELSE SETZE a pos minus 1 + FI +CASE4(*l*): IF string (a pos - 3, a pos plus 1) = "reali" + THEN SETZE a pos plus 1 + ELIF string (a pos minus 1, a pos plus 1) = "aly" + THEN SETZE a pos minus 1 + ELIF string (a pos minus 2, a pos minus 1) = "ta" (*..tal..*) + OR string (a pos minus 2, a pos minus 1) = "na" (*..nal..*) + OR string (a pos minus 2, a pos minus 1) = "ia" (*..ial..*) + THEN SETZE a pos + ELSE SETZE a pos minus 1 + FI +CASE5(*m*): IF string (a pos minus 2, a pos minus 1) = "to" (* ..tom..*) + THEN SETZE a pos + ELSE SETZE a pos minus 1 + FI +CASE6(*n*): IF string (a pos - 4, a pos minus 1) = "gege" + OR string (a pos - 4, a pos minus 1) = "nebe" (*gegen, neben*) + THEN SETZE (a pos - 3) ; SETZE a pos + ELIF string (a pos minus 1, a pos plus 1) = "ini" + THEN + ELIF NOT silbenanfang vor (a pos) + AND ((teilwort SUB a pos minus 1) = "e" (* en *) + OR (teilwort SUB a pos minus 1) = "u") (* un *) + AND (silbenanfang nach (a pos) + OR string (a pos plus 1, a pos plus 2) = "ob") + THEN SETZE a pos + ELIF string (a pos minus 2, a pos plus 1) = "eina" + THEN SETZE a pos + ELSE SETZE a pos minus 1 + FI +CASE7(*r*): IF string (a pos minus 2, a pos minus 1) = "tu" (*..tur..*) + THEN IF string (a pos plus 1, a pos plus 2) = "el" + OR (string (a pos plus 1, a pos plus 2) = "en" + AND string (a pos minus 1, apos +3) <> "ent") + (* turel OR <>turentwick*) + THEN SETZE a pos minus 1 + ELSE SETZE a pos + FI + ELIF string (a pos minus 2, a pos minus 1) = "ve" (*..ver..*) + OR string (a pos minus 2, a pos minus 1) = "vo" (*..vor..*) + THEN SETZE a pos + ELIF string (a pos minus 2, a pos minus 1) = "te" (* ter *) + THEN IF dreisilber (a pos plus 1) + OR string (a pos plus 1, a pos plus 1) = "a" (*tera*) + OR string (a pos - 3, a pos minus 2) <> "zt" (*zter*) + THEN SETZE a pos + ELSE SETZE a pos minus 1 + FI + ELIF (teilwort SUB a pos minus 1) = "e" (* er*) + AND silbenanfang nach (a pos) + AND string (a pos plus 1, a pos + 3) <> "ung" (*erung*) + AND string (a pos plus 1, a pos plus 2) <> "er" (*erer*) + THEN SETZE a pos + ELIF vorletzter buchstabe oderkeine trennung oder sperre gesetzt + (a pos) + THEN SETZE a pos minus 1 + FI +CASE8(*s*): IF string (a pos minus 2, a pos minus 1) = "de" (* des *) + OR string (a pos minus 2, a pos minus 1) = "xi" (* ..xis *) + THEN SETZE a pos + ELIF string (a pos minus 2, a pos minus 1) = "ni" (* nis *) + AND silbenanfang nach (a pos) + THEN SETZE a pos + ELIF vorletzter buchstabe oderkeine trennung oder sperre gesetzt + (a pos) + THEN SETZE apos minus 1 + FI +CASE9(*t*): IF string (a pos plus 1, a pos + 3) = "ion" (* tion *) + THEN SETZE a pos minus 1 + ELIF string (a pos plus 1, a pos + 3) <> "ier" (* imitieren *) + AND (string (a pos minus 2, a pos minus 1) = "mi"(*...mit..*) + OR string (a pos minus 2, a pos minus 1) = "va"(*privat..*) + OR string (a pos minus 2, a pos minus 1) = "fi"(*profit..*) + OR string (a pos - 3, a pos minus 1) = "zei")(*..zeit..*) + THEN SETZE a pos + ELSE SETZE a pos minus 1 + FI +CASE10(*ß*): IF string (a pos, a pos plus 2) = "ßen" + OR vorletzter buchstabe (a pos) + THEN SETZE a pos minus 1 + ELSE SETZE a pos + FI +OTHERWISE: IF vorletzter buchstabe oderkeine trennung oder sperre gesetzt + (a pos) + THEN SETZE a pos minus 1 + FI +END SELECT. + +konsonant 2 : + kons gr := string (a pos, e pos); + IF a pos > 2 AND trennung oder sperre gesetzt (a pos minus 1) + THEN + ELIF ausnahme fuer zwei konsonanten + THEN SETZE a pos + ELIF kons gr = "ts" + THEN IF NOT trennung oder sperre gesetzt (a pos) + (* für <> Tatsache, tatsächlich *) + THEN SETZE e pos + FI + ELIF kons gr = "tz" + THEN IF (teilwort SUB a pos plus 2) = "e" (* ..tze.. *) + OR (teilwort SUB a pos plus 2) = "u" (* ..tzu.. *) + THEN SETZE a pos + ELSE SETZE a pos plus 1 + FI + ELIF string (a pos, a pos plus 1) = "ch"(* ch zaehlt als 1 Buchstabe *) + THEN SETZE a pos plus 1 (* darum keine Abfrage mit kons gr *) + ELIF (kons gr = "dt" OR kons gr = "kt") + AND silbenanfang nach (e pos) + THEN SETZE e pos + ELIF kons gr = "ns" AND + (string (a pos - 2, a pos - 1) = "io" (* ..ions *) + OR (string (a pos minus 1, a pos) ="en" (*..ens..*) + AND (teilwort SUB a pos minus 2) <> "t")) (* aber nicht ..tensiv*) + THEN SETZE e pos + ELIF string (a pos minus 2, a pos plus 1) = "nach" + THEN IF (teilwort SUB a pos plus 2) <> "t" + THEN SETZE a pos plus 1 + FI + ELIF string (e pos, e pos + 3) = "lich" + THEN IF string (a pos minus 2, a pos) = "mög" + THEN SETZE a pos + ELIF pos ("hg", teilwort SUB e pos minus 1) > 0 + THEN SPERRE e pos minus 1 + ELSE SETZE e pos minus 1 + FI; + ELIF (reg (a pos) AND NOT trennung oder sperre gesetzt (a pos)) + OR (kons gr = "sp" AND silbenanfang vor (a pos)) + THEN SETZE a pos minus 1 + ELIF string (a pos, a pos plus 2) = "sch" + THEN SETZE a pos plus 2 + ELSE SETZE a pos + FI. + +ausnahme fuer zwei konsonanten: + string (a pos minus 2, a pos) = "nis" AND a pos > 1 + (*..nis.., aber nicht nisten *) + OR string (a pos minus 2, a pos plus 1) = "rafr" (* strafrecht *) + OR string (a pos - 4, a pos) = "undes" (* Bundes *) + OR string (a pos minus 1, a pos + 3) = "unter" + OR silbenanfang vor (e pos). + +konsonant 3 : + code 1 := code (teilwort SUB a pos); + code 2 := code (teilwort SUB a pos plus 1); + code 3 := code (teilwort SUB a pos plus 2); + IF NOT (ausnahme 1 OR ausnahme 2 OR ausnahme 3 OR ausnahme 4) + THEN suche regelmaessige konsonantenverbindung + FI. + +ausnahme 1 : + ind := pos ("cfgklnprt", code (code 1)); + SELECT ind OF +CASE1(*c*): IF code 2 = cv k (* ck *) + THEN SETZE a pos plus 1 + ELIF string (a pos, a pos + 3) = "chts" + (* Rechts.., Gesichts.., .. machts..*) + THEN SETZE (a pos + 3) + ELIF string (a pos plus 1, a pos + 5) = "hstag" (* Reichstag *) + OR (string (a pos, a pos plus 2) = "chs" AND (* ..chs.. *) + string (a pos plus 2, a pos +3) <> "st") + THEN SETZE a pos plus 2 + ELSE LEAVE ausnahme 1 WITH FALSE + FI; + TRUE +CASE2(*f*): IF code 2 = cv f (*ff*) + THEN IF code 3 = cv s + THEN SETZE a pos plus 2 (* ffs *) + ELSE SETZE a pos plus 1 + FI + ELIF string (a pos minus 1, a pos plus 1) = "aft" (*..aft..*) + THEN IF (teilwort SUB a pos plus 2) = "s" + THEN SETZE a pos plus 2 + ELSE SETZE a pos plus 1 + FI + ELSE LEAVE ausnahme 1 WITH FALSE + FI; + TRUE +CASE3(*g*): IF string (a pos minus 2, a pos minus 1) = "ag" (* ags *) + THEN SETZE a pos plus 1 + ELSE LEAVE ausnahme 1 WITH FALSE + FI; + TRUE +CASE4(*k*): IF string (a pos, a pos plus 1) = "kt" + AND silbenanfang nach (a pos plus 1) + THEN SETZE a pos plus 1 + ELSE LEAVE ausnahme 1 WITH FALSE + FI; + TRUE +CASE5(*l*): IF code 2 = cv d OR code 2 = cv g OR code 2 = cv k (*ld, lg, lk*) + THEN SETZE a pos plus 1 + ELIF string (a pos, a pos + 4) = "ltspr" (* Anwaltsprogramm *) + THEN SETZE (a pos + 2) + ELSE LEAVE ausnahme 1 WITH FALSE + FI; + TRUE +CASE6(*n*): IF string (a pos - 2, a pos) = "ein" + THEN SETZE a pos + ELIF code 2 = cv d (* nd *) + THEN IF code 3 = cv s (* nds, wie in ...stands... *) + THEN SETZE a pos plus 2 + ELSE SETZE a pos plus 1 + FI + ELIF code 2 = cv g (* ng *) + THEN IF code 3 = cv s (* ..ngs.. *) + THEN SETZE a pos plus 2 + ELIF code 3 = cv r (* ..ngr.. *) + THEN SETZE a pos + ELIF code 3 = cv l (* ungleich *) + THEN + ELSE SETZE a pos plus 1 + FI + ELIF string (a pos - 3, a pos plus 1) = "trans" + OR string (a pos - 3, a pos plus 1) = "tions" (*tionsplan*) + THEN SETZE a pos plus 1 + ELIF string (a pos plus 1, a pos + 6) = "ftsper" (*ftsperspek*) + THEN SETZE (a pos + 3) + ELSE LEAVE ausnahme 1 WITH FALSE + FI; + TRUE +CASE7(*p*): IF code 2 = cv p (* pp *) + OR (code 2 = cv f AND code 3 = cv t) (* pft *) + THEN SETZE a pos plus 1; TRUE + ELSE FALSE + FI +CASE8(*r*): IF string (a pos plus 1, a pos + 4) = "tner" (* rtner *) + THEN SETZE a pos plus 1 + ELIF trennung oder sperre gesetzt (a pos) + THEN + ELSE LEAVE ausnahme 1 WITH FALSE + FI; + TRUE +CASE9(*t*): IF string (a pos plus 1, a pos plus 2) = "st" (*tst*) + THEN SETZE a pos + ELIF string (a pos plus 1, a pos plus 2) = "zt" + (* letzt.. *) + THEN IF (teilwort SUB a pos + 3) = "e" (*letzte..*) + THEN SETZE a pos plus 1 + ELSE SETZE a pos plus 2 + FI + ELIF string (apos - 2, a pos plus 1) = "eits" + (* ..heits.., ..keits.., ..beits.. *) + OR string (a pos plus 1, a pos plus 1)= "z" (*tz*) + THEN SETZE a pos plus 1 + ELSE LEAVE ausnahme 1 WITH FALSE + FI; + TRUE +OTHERWISE: FALSE +END SELECT. + +ausnahme 2 : + IF e pos - a pos = 2 + THEN FALSE + ELIF code 2 = cv p AND string (a pos plus 2, a pos + 3) = "ft" (* pft *) + THEN SETZE a pos plus 2; TRUE + ELSE FALSE + FI . + +ausnahme 3 : + IF code 1 = cv s + THEN IF code 2 = cv t AND code 3 <> cv r (* st, aber nicht: str *) + AND pos (vokal string, teilwort SUB a pos plus 2) = 0 + THEN SETZE a pos plus 1 ; TRUE + ELSE FALSE + FI + ELIF code 2 = cv s + THEN IF code 3 = cv t AND (teilwort SUB a pos + 3) <> "r" + AND pos (vokal string, teilwort SUB (a pos + 3)) = 0 + THEN SETZE a pos plus 2; TRUE + ELSE FALSE + FI + ELSE FALSE + FI . + +ausnahme 4 : + IF string (e pos, e pos + 3) = "lich" + THEN IF pos ("hg", teilwort SUB e pos minus 1) > 0 + THEN SPERRE e pos minus 1 + ELSE SETZE e pos minus 1 + FI; + TRUE + ELSE FALSE + FI . + +suche regelmaessige konsonantenverbindung : + FOR posit FROM a pos UPTO e pos minus 1 REP + IF reg (posit) + THEN SETZE (posit - 1); LEAVE konsonant 3 + FI + END REP ; + IF (teilwort SUB e pos) <> "h" OR (teilwort SUB e pos minus 1) <> "c" + THEN SETZE e pos minus 1 + ELIF (teilwort SUB e pos - 2) <> "s" + THEN SETZE (e pos - 2) + ELSE SETZE (e pos - 3) + FI +END PROC erstelle trennvektor ; +END PACKET silbentrennung; + diff --git a/system/multiuser/1.7.5/src/spool manager b/system/multiuser/1.7.5/src/spool manager new file mode 100644 index 0000000..ac0295a --- /dev/null +++ b/system/multiuser/1.7.5/src/spool manager @@ -0,0 +1,887 @@ +PACKET spool manager DEFINES (* Autor: J. Liedtke *) + (* R. Nolting *) + (* R. Ruland *) + (* Stand: 25.04.86 *) + + spool manager , + + server channel , + spool duty, + station only, + spool control task : + +LET que size = 101 , + + ack = 0 , + nak = 1 , + error nak = 2 , + message ack = 3 , + question ack = 4 , + second phase ack = 5 , + + fetch code = 11 , + save code = 12 , + file save code old = 13 , + erase code = 14 , + list code = 15 , + all code = 17 , + param fetch code = 21 , + file save code = 22 , + entry line code = 23 , + killer code = 24 , + first code = 25 , + start code = 26 , + stop code = 27 , + halt code = 28 , + wait for halt code = 29 , + + continue code = 100 , + + file type = 1003 ; + +LET begin char = ""0"", + end char = ""1""; + +LET PARAMS = STRUCT (TEXT name, userid, password, sendername, INT station), + ENTRY = STRUCT (PARAMS ds params, TEXT entry line, DATASPACE space); + +ROW que size ENTRY VAR que ; + +PARAMS CONST empty params := PARAMS : ("", "", "", "", -1); + +PARAMS VAR save params, file save params; + +ENTRY VAR fetch entry; + +FILE VAR file; + +INT VAR order, last order, phase, reply, old heap size, first, last, list index, + begin pos, end pos, order task station, sp channel, counter; + +TEXT VAR order task name, buffer, sp duty, start time; + +BOOL VAR server is waiting, stop command pending, stat only, valid fetch entry; + +TASK VAR order task, last order task, server, calling parent, task in control; + +INITFLAG VAR in this task := FALSE; + +DATASPACE VAR ds; + +BOUND STRUCT (TEXT name, userid, password) VAR msg; +BOUND STRUCT (TEXT entry line, INT index) VAR control msg; +BOUND PARAMS VAR fetch msg; +BOUND THESAURUS VAR all msg; +BOUND TEXT VAR error msg ; + + +. first entry : que (first) +. list entry : que (list index) +. last entry : que (last) + +. que is empty : first = last +. que is full : first = next (last) +.; + +sp channel := 0; +sp duty := ""; +stat only := FALSE; +task in control := myself; + +PROC server channel (INT CONST channel nr) : + IF channel nr <= 0 OR channel nr >= 33 + THEN errorstop ("falsche Kanalangabe") FI; + sp channel := channel nr; +END PROC server channel; + +INT PROC server channel : + sp channel +END PROC server channel; + + +PROC station only (BOOL CONST flag) : + stat only := flag +END PROC station only; + +BOOL PROC station only : + stat only +END PROC station only; + + +PROC spool duty (TEXT CONST duty) : + sp duty := duty; +END PROC spool duty; + +TEXT PROC spool duty : + sp duty +END PROC spool duty; + + +PROC spool control task (TASK CONST task id): + task in control := task id; +END PROC spool control task; + +TASK PROC spool control task : + task in control +END PROC spool control task; + + +PROC spool manager (PROC server start) : + + spool manager (PROC server start, TRUE) + +END PROC spool manager; + + +PROC spool manager (PROC server start, BOOL CONST with start) : + + set autonom ; + break ; + disable stop ; + initialize spool manager ; + REP forget (ds) ; + wait (ds, order, order task) ; + IF order <> second phase ack + THEN prepare first phase ; + spool (PROC server start); + ELIF order task = last order task + THEN prepare second phase ; + spool (PROC server start); + ELSE send nak + FI ; + send error if necessary ; + collect heap garbage if necessary + PER + + . initialize spool manager : + initialize if necessary; + stop; + erase fetch entry; + IF with start THEN start (PROC server start) FI; + + . initialize if necessary : + IF NOT initialized (in this task) + THEN FOR list index FROM 1 UPTO que size + REP list entry. space := nilspace PER; + fetch entry. space := nilspace; + ds := nilspace; + last order task := niltask; + server := niltask; + calling parent := niltask; + server is waiting := FALSE; + stop command pending := FALSE; + old heap size := 0; + clear spool; + FI; + + . prepare first phase : + IF order = save code OR order = erase code OR order = stop code + THEN phase := 1 ; + last order := order ; + last order task := order task ; + FI; + + . prepare second phase : + phase INCR 1 ; + order := last order + + . send nak : + forget (ds) ; + ds := nilspace ; + send (order task, nak, ds); + + . send error if necessary : + IF is error + THEN forget (ds) ; + ds := nilspace ; + error msg := ds ; + CONCR (error msg) := error message; + clear error; + send (order task, error nak, ds) + FI; + + . collect heap garbage if necessary : + IF heap size > old heap size + 2 + THEN collect heap garbage; + old heap size := heap size; + FI; + +END PROC spool manager; + + +PROC spool (PROC server start): + + command dialogue (FALSE); + enable stop; + IF station only CAND station (ordertask) <> station (myself) + THEN errorstop ("kein Zugriffsrecht auf Task " + text (station(myself)) + + "/""" + name(myself) + """") + FI; + + SELECT order OF + + CASE fetch code : out of que + CASE param fetch code : send fetch params + CASE save code : new que entry + CASE file save code, file save code old : + new file que entry + CASE erase code : erase que entry + CASE list code : send spool list + CASE all code : send owners ds names + + OTHERWISE : + + IF order >= continue code AND order task = supervisor + THEN forget (ds); + spool command (PROC server start) + + ELIF spool control allowed by order task + THEN SELECT order OF + CASE entry line code : send next entry line + CASE killer code : kill entry + CASE first code : make to first + CASE start code : start server + CASE stop code : stop server + CASE halt code : halt server + CASE wait for halt code : wait for halt + OTHERWISE : errorstop ("falscher Auftrag fuer Task """ + + name(myself) + """") + END SELECT + + ELSE errorstop ("falscher Auftrag fuer Task """ + + name(myself) + """") + FI; + END SELECT; + + +. spool control allowed by order task : + (order task = spool control task OR order task < spool control task + OR spool control task = supervisor) + AND station (order task) = station (myself) +. + out of que : + IF NOT (order task = server) + THEN errorstop ("keine Servertask") + ELIF stop command pending + THEN forget (ds); + stop; + erase fetch entry; + ELIF que is empty + THEN forget (ds) ; + erase fetch entry; + server is waiting := TRUE; + ELSE send first entry; + FI; + +. + send fetch params : + IF order task = server + THEN send params + ELSE errorstop ("keine Servertask") + FI; + + . send params : + forget(ds); ds := nilspace; fetch msg := ds; + fetch msg := fetch entry. ds params; + send (order task, ack, ds); + +. + new que entry : + IF phase = 1 + THEN prepare into que + ELSE into que + FI; + +. + prepare into que : + msg := ds ; + save params. name := msg.name; + save params. userid := msg.userid; + save params. password := msg.password; + save params. sendername := name (order task); + save params. station := station (order task); + forget (ds); ds := nilspace; + send (order task, second phase ack, ds); + +. + new file que entry : + IF type (ds) <> file type + THEN errorstop ("Datenraum hat falschen Typ"); + ELSE get file params; + into que; + FI; + + . get file params : + file := sequential file (input, ds); + end pos := 0; + next headline information (file save params. name); + next headline information (file save params. userid); + next headline information (file save params. password); + next headline information (file save params. sendername); + next headline information (buffer); + file save params. station := int (buffer); + IF NOT last conversion ok + THEN file save params. station := station (order task) FI; + IF file save params. sendername = "" + THEN file save params. sendername := name (order task) FI; + IF file save params. name = "" + THEN IF headline (file) <> "" + THEN file save params. name := headline (file); + ELSE errorstop ("Name unzulaessig") + FI; + ELSE headline (file, file save params. name); + FI; + +. + erase que entry : + msg := ds ; + order task name := name (order task); + order task station := station (order task); + IF phase = 1 + THEN ask for erase + ELSE erase entry from order task + FI; + + . ask for erase : + to first que entry; + WHILE next que entry found + REP IF is entry from order task (msg. name) + THEN manager question ("""" + msg.name + """ loeschen"); + LEAVE erase que entry + FI; + PER ; + manager message ("""" + msg.name + """ existiert nicht"); + + . erase entry from order task : + IF is entry from order task (msg. name) + THEN delete que entry; + LEAVE erase que entry + ELSE to first que entry; + WHILE next que entry found + REP IF is entry from order task (msg. name) + THEN delete que entry; + LEAVE erase que entry + FI ; + PER ; + manager message ("""" + msg.name + """ existiert nicht"); + FI; + + . delete que entry : + erase entry (list index) ; + send ack; + +. + send owners ds names: + order task name := name (order task); + order task station := station (order task); + forget (ds); ds := nilspace; all msg := ds; + all msg := empty thesaurus; + to first que entry; + WHILE next que entry found + REP IF is entry from order task ("") + THEN insert (all msg, list entry. ds params. name) + FI; + PER; + send (order task, ack, ds) + +. + send spool list : + list spool; + send (order task, ack, ds); + +. + send next entry line : + control msg := ds; + get next entry line (control msg. entry line, control msg. index); + send (order task, ack, ds); + +. + kill entry : + control msg := ds; + list index := control msg. index; + IF is valid que entry (list index) + THEN erase entry (list index) + FI; + send (order task, ack, ds); + +. + make to first : + control msg := ds; + list index := control msg. index; + IF is valid que entry (list index) + THEN new first (list entry); + erase entry (list index); + FI; + send (order task, ack, ds); + +. + start server : + IF exists (server) THEN errorstop ("Spool muß zuerst gestoppt werden") FI; + start (PROC server start); + IF server channel <= 0 OR server channel >= 33 + THEN manager message ("WARNUNG : Serverkanal nicht eingestellt"); + ELSE send ack + FI; + +. + stop server: + IF phase = 1 + THEN stop; + IF valid fetch entry + THEN valid fetch entry := FALSE; + manager question (""13""10"" + + fetch entry. entry line + " neu eintragen"); + ELSE erase fetch entry; + send ack; + FI; + ELSE IF fetch entry. entry line <> "" THEN new first (fetch entry) FI; + erase fetch entry; + send ack; + FI; + +. + halt server : + stop command pending := TRUE; + IF NOT exists (server) OR server is waiting + THEN stop; + erase fetch entry; + FI; + send ack; + +. + wait for halt : + IF exists (calling parent) + THEN errorstop ("Task """ + name (calling parent) + """ wartet schon auf halt") + ELSE calling parent := order task; + stop command pending := TRUE; + forget (ds); + IF NOT exists (server) OR server is waiting + THEN stop; + erase fetch entry; + FI; + FI; + +END PROC spool; + + +PROC send first entry : + + forget (ds); ds := first entry. space; + send (server, ack, ds, reply) ; + IF reply = ack + THEN server is waiting := FALSE; + start time := time of day; + start time CAT " am "; + start time CAT date; + erase fetch entry; + fetch entry := first entry; + erase entry (first); + valid fetch entry := TRUE; + ELSE forget (ds); + FI; + +END PROC send first entry; + + +PROC into que : + + IF que is full + THEN errorstop ("Spool ist voll") + ELSE make new entry; + send ack; + awake server if necessary + FI; + + . make new entry : + IF order = save code + THEN last entry. ds params := save params; + save params := empty params; + ELSE last entry. ds params := file save params; + file save params := empty params; + FI; + last entry. space := ds; + counter INCR 1; + build entry line; + last := next (last) ; + + . build entry line : + IF LENGTH last entry. ds params. sender name > 16 + THEN buffer := subtext (last entry. ds params. sender name, 1, 13); + buffer CAT "..."""; + ELSE buffer := last entry. ds params. sender name; + buffer CAT """"; + buffer := text (buffer, 17); + FI; + last entry. entry line := text (last entry. ds params. station, 2); + last entry. entry line CAT "/"""; + last entry. entry line CAT buffer; + last entry. entry line CAT " : """ ; + last entry. entry line CAT last entry. ds params. name; + last entry. entry line CAT """ (" ; + last entry. entry line CAT text (storage (last entry. space)); + last entry. entry line CAT " K)"; + + . awake server if necessary : + IF server is waiting THEN send first entry FI; + +END PROC into que; + + +PROC list spool : + + forget (ds); ds := nilspace; + file := sequential file (output, ds) ; + max line length (file, 1000); + headline(file, text (station(myself)) + "/""" + name (myself) + """"); + put spool duty; + put current job; + put spool que; + + . put spool duty : + IF spool duty <> "" + THEN write (file, "Aufgabe: "); + write (file, spool duty ); + line (file, 2); + FI; + + . put current job : + IF valid fetch entry AND exists (server) + THEN write (file, "In Bearbeitung seit "); + write (file, start time); + write (file, ":"); + line (file, 2); + putline (file, fetch entry. entry line); + IF stop command pending + THEN putline (file, "Spool wird nach diesem Auftrag deaktiviert"); + FI; + line (file); + ELSE write (file, "kein Auftrag in Bearbeitung"); + IF NOT exists (server) + THEN write (file, ", da Spool deaktiviert"); + ELIF que is empty + THEN write (file, ", da Warteschlange leer"); + LEAVE list spool; + FI; + line (file, 2); + FI; + + . put spool que : + IF que is empty + THEN putline (file, "Warteschlange ist leer"); + ELSE write (file, "Warteschlange ("); + write (file, text (counter)); + write (file, " Auftraege):"); + line (file, 2); + to first que entry ; + WHILE next que entry found + REP putline (file, list entry. entry line) PER; + FI; + +END PROC list spool ; + + +PROC clear spool : + + first := 1; + last := 1; + counter := 0; + FOR list index FROM 1 UPTO que size + REP list entry. ds params := empty params; + list entry. entry line := ""; + forget (list entry. space) + PER; + +END PROC clear spool; + +(*********************************************************************) +(* Hilfsprozeduren zum Spoolmanager *) + +BOOL PROC is valid que entry (INT CONST index) : + + que (index). entry line <> "" + +END PROC is valid que entry; + + +INT PROC next (INT CONST index) : + + IF index < que size + THEN index + 1 + ELSE 1 + FI + +END PROC next; + + +PROC to first que entry : + + list index := first - 1; + +ENDPROC to first que entry ; + + +BOOL PROC next que entry found : + + list index := next (list index); + WHILE is not last que entry + REP IF is valid que entry (list index) + THEN LEAVE next que entry found WITH TRUE FI; + list index := next (list index); + PER; + FALSE + + . is not last que entry : + list index <> last + +ENDPROC next que entry found ; + + +PROC get next entry line (TEXT VAR entry line, INT VAR index) : + + IF index = 0 + THEN list index := first - 1 + ELSE list index := index + FI; + IF next que entry found + THEN entry line := list entry. entry line; + index := list index; + ELSE entry line := ""; + index := 0; + FI; + +END PROC get next entry line; + + +PROC new first (ENTRY VAR new first entry) : + + IF que is full + THEN errorstop ("Spool ist voll") + ELSE first DECR 1 ; + IF first = 0 THEN first := que size FI; + first entry := new first entry; + counter INCR 1; + FI; + +END PROC new first; + + +PROC erase entry (INT CONST index) : + + entry. ds params := empty params; + entry. entry line := ""; + forget (entry.space) ; + counter DECR 1; + IF index = first + THEN inc first + FI ; + + . entry : que (index) + + . inc first : + REP first := next (first) + UNTIL que is empty OR is valid que entry (first) PER + +END PROC erase entry; + + +PROC erase fetch entry : + + fetch entry. ds params := empty params; + fetch entry. entry line := ""; + forget (fetch entry. space); + valid fetch entry := FALSE; + +END PROC erase fetch entry; + + +BOOL PROC is entry from order task (TEXT CONST file name) : + + correct order task CAND correct filename + + . correct order task : + order task name = list entry. ds params. sendername + AND order task station = list entry. ds params. station + + . correct file name : + file name = "" OR file name = list entry. ds params. name + +END PROC is entry from order task; + + +PROC start (PROC server start): + + begin (PROC server start, server); + +END PROC start; + + +PROC stop : + + stop server; + send calling parent reply if necessary; + + . stop server: + IF exists (server) THEN end (server) FI; + server := niltask; + server is waiting := FALSE; + stop command pending := FALSE; + + . send calling parent reply if necessary : + IF exists (calling parent) + THEN forget (ds); ds := nilspace; + send (calling parent, ack, ds); + calling parent := niltask; + FI; + +END PROC stop; + + +PROC next headline information (TEXT VAR t): + + begin pos := pos (headline (file), begin char, end pos + 1); + IF begin pos = 0 + THEN begin pos := LENGTH headline (file) + 1; + t := ""; + ELSE end pos := pos (headline (file), end char, begin pos + 1); + IF end pos = 0 + THEN end pos := LENGTH headline (file) + 1; + t := ""; + ELSE t := subtext (headline (file), begin pos+1, end pos-1) + FI + FI + +END PROC next headline information; + + +PROC send ack : + + forget (ds); ds := nilspace; + send (order task, ack, ds) + +END PROC send ack; + + +PROC manager question (TEXT CONST question) : + + forget (ds); ds := nilspace; error msg := ds ; + error msg := question ; + send (order task, question ack, ds) + +ENDPROC manager question ; + + +PROC manager message (TEXT CONST message) : + + forget (ds); ds := nilspace; error msg := ds ; + error msg := message ; + send (order task, message ack, ds) + +ENDPROC manager message ; + +(*********************************************************************) +(* Spool - Kommandos *) + +INT VAR command index , params ; +TEXT VAR command line, param 1, param 2 ; + +LET spool command list = +"break:1.0start:2.01stop:4.0halt:5.0first:6.0killer:7.0listspool:8.0 +clearspool:9.0spoolcontrolby:10.1"; + +PROC spool command (PROC server start) : + + enable stop ; + continue (order - continue code) ; + disable stop ; + REP command dialogue (TRUE) ; + get command ("gib Spool-Kommando:", command line); + analyze command (spool command list, command line, 3, command index, + params, param1, param2); + execute command (PROC server start); + UNTIL NOT online PER; + command dialogue (FALSE); + break (quiet); + set autonom; + +END PROC spool command; + + +PROC execute command (PROC server start) : + + enable stop; + SELECT command index OF + CASE 1 : break + CASE 2 : start server + CASE 3 : start server with new channel + CASE 4 : stop server + CASE 5 : halt server + CASE 6 : first cmd + CASE 7 : killer cmd + CASE 8 : show spool list + CASE 9 : clear spool + CASE 10 : spool control task (task (param1)) + OTHERWISE do (command line) + END SELECT; + + . start server : + IF server channel <= 0 OR server channel >= 33 + THEN line; + putline ("WARNUNG : Serverkanal nicht eingestellt"); + FI; + stop server; + start (PROC server start); + + . start server with new channel: + INT VAR i := int (param1); + IF last conversion ok + THEN server channel (i); + start server; + ELSE errorstop ("falsche Kanalangabe") + FI; + + . stop server : + disable stop; + stop; + IF valid fetch entry CAND + yes (""13""10"" + fetch entry. entry line + " neu eintragen") + THEN new first (fetch entry) FI; + erase fetch entry; + enable stop; + + . halt server : + stop command pending := TRUE; + IF NOT exists (server) OR server is waiting + THEN stop server; + erase fetch entry; + FI; + + . first cmd : + line ; + to first que entry ; + WHILE next que entry found + REP say (list entry. entry line) ; + IF yes (" als erstes") + THEN new first (list entry); + erase entry (list index); + LEAVE first cmd + FI ; + PER; + + . killer cmd : + line ; + to first que entry ; + WHILE next que entry found + REP say (list entry. entry line) ; + IF yes (" loeschen") THEN erase entry (list index) FI ; + PER; + + . show spool list : + list spool; + disable stop; + show (file); + forget (ds); + +ENDPROC execute command ; + +ENDPACKET spool manager; + diff --git a/system/multiuser/1.7.5/src/supervisor b/system/multiuser/1.7.5/src/supervisor new file mode 100644 index 0000000..00874b2 --- /dev/null +++ b/system/multiuser/1.7.5/src/supervisor @@ -0,0 +1,774 @@ +(* ------------------- VERSION 19 03.06.86 ------------------- *) +PACKET supervisor : (* Autor: J.Liedtke *) + + + + +LET ack = 0 , + nak = 1 , + error nak = 2 , + + system catalogue code = 3 , + begin code = 4 , + end code = 5 , + break code = 6 , + rename code = 7 , + halt code = 8 , + password code = 9 , + family password code = 40 , + set autonom code = 41 , + reset autonom code = 42 , + define canal code = 43 , + go back to old canal code = 44 , + task of channel code = 45 , + canal of channel code = 46 , + set automatic startup code = 47 , + reset automatic startup code = 48 , + + continue code low = 100 , + continue code high = 132 , + + system start code = 100 , + define station code = 32000 , + max station no = 127 , + + nil = 0 , + + number of tasks = 125 , + + number of channels = 32 , + highest terminal channel = 16 , + highest user channel = 24 , + highest system channel = 32 , + configurator channel = 32 , + + shutup and save code = 12 , + + channel field = 4 , + fromid field = 11 , + nilchannel = 0 ; + + + +TASK VAR order task ; +INT VAR order code , + channel nr , + channel index ; + +DATASPACE VAR ds ; + +BOUND STRUCT (TEXT tname, tpass, TASK task, PROCA start proc) VAR msg ; +BOUND TEXT VAR error msg ; + +REAL VAR last rename time := 0.0 ; + + +TEXT VAR actual password, supply password ; + + +ROW highest terminal channel TASK VAR canal ; + +ROW number of channels TASK VAR connected task ; + +FOR channel index FROM 1 UPTO highest terminal channel REP + canal (channel index) := niltask ; +PER ; +FOR channel index FROM 1 UPTO number of channels REP + connected task (channel index) := niltask +PER ; + + +ROW number of tasks BOOL VAR autonom flag ; +ROW number of tasks BOOL VAR automatic startup flag ; +ROW number of tasks TEXT VAR task password ; + +task password (1) := "-" ; +task password (2) := "-" ; + +set clock (date ("09.06.86")) ; + +TASK VAR dummy task ; +command dialogue (TRUE) ; + +ke ; (* maintenance ke *) + +create son (myself, "SYSUR", dummy task, proca (PROC sysur)) ; + +PROC sysur : + + disable stop ; + begin ("ARCHIVE", PROC archive manager, dummy task) ; + begin ("OPERATOR", PROC monitor, dummy task) ; + begin ("conf", PROC configurator, dummy task) ; + system manager + +ENDPROC sysur ; + +PROC configurator : + + page ; + REP UNTIL yes("Archiv 'dev' eingelegt") PER; + archive ("dev") ; + fetch all (archive) ; + release (archive) ; + REP UNTIL yes ("save system") PER ; + command dialogue (FALSE) ; + save system ; + command dialogue (TRUE) ; + rename myself ("configurator") ; + disable stop ; + REP + configuration manager ; + clear error + PER + +ENDPROC configurator ; + + +erase last bootstrap source dataspace ; +channel (myself, 1) ; +command dialogue (TRUE) ; +IF yes("Leere Floppy eingelegt") + THEN channel (myself, nilchannel) ; + command dialogue (FALSE) ; + sys op (shutup and save code) + ELSE channel (myself, nilchannel) ; + command dialogue (FALSE) +FI ; +supervisor ; + + +PROC supervisor : + + disable stop ; + INT VAR old session := session ; + REP + wait (ds, order code, order task) ; + IF is niltask (order task) + THEN interrupt + ELIF station (order task) = station (myself) + THEN order from task + FI + PER . + +interrupt : + IF order code = 0 + THEN IF old session <> session + THEN disconnect all terminal tasks ; + old session := session + FI ; + system start interrupt + ELSE supervisor interrupt (canal (order code), order code, + connected task (order code)) + FI . + +disconnect all terminal tasks : + INT VAR i ; + FOR i FROM 1 UPTO highest terminal channel REP + TASK VAR id := connected task (i) ; + IF NOT (is niltask (id) COR automatic startup flag (index (id)) + COR is niltask (canal (i))) + THEN break task + FI + PER . + +break task : + IF task direct connected to channel + THEN channel (id, nilchannel) ; + connected task (i) := niltask + ELSE disconnect if at terminal but overloaded by canal + FI . + +task direct connected to channel : + pcb (id, channel field) <> nilchannel . + +disconnect if at terminal but overloaded by canal : + connected task (i) := niltask . + +order from task : + channel index := channel (order task) ; + IF is command analyzer task + THEN order from command analyzer (connected task (channel index)) + ELSE order from user task + FI ; + IF is error + THEN send back error message + FI . + +is command analyzer task : + channel index <> nilchannel + CAND channel index <= highest terminal channel + CAND order task = canal (channel index) . + +send back error message : + forget (ds) ; + ds := nilspace ; + error msg := ds ; + CONCR (error msg) := error message ; + clear error ; + send (order task, error nak, ds) . + +ENDPROC supervisor ; + +PROC supervisor interrupt (TASK VAR command analyzer, INT CONST channel nr, + TASK VAR terminal task) : + + IF NOT is niltask (terminal task) + THEN channel (terminal task, nilchannel) + FI ; + create command analyzer if necessary ; + IF already at terminal + THEN halt process (command analyzer) + ELSE send acknowledge + FI ; + channel (command analyzer, channel nr) ; + activate (command analyzer) . + +create command analyzer if necessary : + IF is niltask (command analyzer) + THEN create son (myself, "-", command analyzer, proca (PROC analyze supervisor command)) + FI . + +send acknowledge : + forget (ds) ; + ds := nilspace ; + send (command analyzer, ack, ds) . + +already at terminal : channel (command analyzer) = channel nr . + +ENDPROC supervisor interrupt ; + +PROC order from command analyzer (TASK VAR terminal task) : + +enable stop ; +IF is continue THEN sv cmd continue +ELIF order code = system catalogue code THEN task info cmd +ELIF order code = task of channel code THEN sv cmd task of channel +ELSE SELECT order code OF CASE ack : + CASE end code : sv cmd end + CASE break code : sv cmd break + CASE halt code : sv cmd halt + OTHERWISE errorstop ("falscher Auftrag fuer Task ""SUPERVISOR""") + END SELECT ; + channel (command analyzer, nilchannel) +FI ; + +forget (ds) ; +IF NOT is niltask (terminal task) AND order code <> system catalogue code + THEN channel (order task, nilchannel) ; + channel (terminal task, channel index) ; + activate (terminal task) +FI . + +sv cmd task of channel : + msg := ds ; + msg.task := terminal task ; + send (order task,ack, ds) ; + LEAVE order from command analyzer . + +sv cmd end : + IF NOT is niltask (terminal task) + THEN delete task (terminal task) ; + terminal task := niltask + FI . + +sv cmd break : + terminal task := niltask . + +sv cmd continue : + sv cmd break ; + continue cmd by canal . + +sv cmd halt : + IF is niltask (terminal task) + THEN errorstop ("keine Task angekoppelt") + ELSE halt process (terminal task) + FI . + +is continue : + order code > continue code low AND order code <= continue code high . + +command analyzer : canal (channel index) . + +ENDPROC order from command analyzer ; + +PROC order from user task : + + enable stop ; + SELECT order code OF + CASE nak, error nak : + CASE system catalogue code : task info cmd + CASE begin code : user begin cmd + CASE end code : user end cmd + CASE break code : user break cmd + CASE rename code : user rename cmd + CASE password code : password cmd + CASE family password code : family password cmd + CASE set autonom code : set autonom cmd + CASE reset autonom code : reset autonom cmd + CASE define canal code : define new canal + CASE go back to old canal code : go back to old canal + CASE task of channel code : task of channel + CASE canal of channel code : canal of channel + CASE set automatic startup code : set automatic startup cmd + CASE reset automatic startup code : reset automatic startup cmd + OTHERWISE IF is continue + THEN user continue cmd + ELIF is define station + THEN define new station + ELSE errorstop ("falscher Auftrag fuer Task ""SUPERVISOR""") + FI + ENDSELECT . + +user begin cmd : + msg := ds ; + create son (order task, new task name, new task, new start proc) ; + send (order task, ack, ds) . + +user end cmd : + msg := ds ; + TASK VAR to be erased := CONCR (msg).task ; + IF task end permitted + THEN delete task (to be erased) + ELSE errorstop ("'end' unzulaessig") + FI ; + IF exists (order task) + THEN send (order task, ack, ds) + ELSE forget (ds) + FI . + +task end permitted : + ( (task is dead AND system catalogue contains entry) OR exists (to be erased)) + CAND ( to be erased = order task + COR to be erased < order task + COR (order task < myself AND NOT (order task < to be erased)) ) . + +task is dead : + status (to be erased) > 6 . + +system catalogue contains entry : + task in catalogue (to be erased, index (to be erased)) . + +user rename cmd : + IF last rename was long ago + THEN msg := ds ; + name (order task, CONCR (msg).tname) ; + update entry in connected task array ; + send (order task, ack, ds) ; + remember rename time + ELSE send (order task, nak, ds) + FI . + +update entry in connected task array : + IF channel (order task) <> nilchannel + THEN connected task (channel (order task)) := order task + FI . + +remember rename time : + last rename time := clock (1) . + +last rename was long ago : abs (clock (1) - last rename time) > 20.0 . + +user break cmd : + break order task ; + send (order task, ack, ds) . + +break order task : + IF task direct connected to channel + THEN channel (order task, nilchannel) ; + terminal task := niltask + ELSE disconnect if at terminal but overloaded by canal + FI . + +task direct connected to channel : channel index <> nilchannel . + +terminal task : connected task (channel index) . + +disconnect if at terminal but overloaded by canal : + INT VAR i ; + FOR i FROM 1 UPTO highest terminal channel REP + IF connected task (i) = order task + THEN connected task (i) := niltask ; + LEAVE disconnect if at terminal but overloaded by canal + FI + PER . + +user continue cmd : + INT CONST dest channel := order code - continue code low ; + IF dest channel <= highest user channel OR order task < myself + THEN IF NOT channel really existing + THEN errorstop ("kein Kanal") + ELIF dest channel is free OR task is already at dest channel + THEN break order task ; + continue (order task, dest channel) ; + autonom flag (index (order task)) := FALSE ; + send (order task, ack, ds) + ELSE errorstop ("Kanal belegt") + FI + ELSE errorstop ("ungueltiger Kanal") + FI . + +channel really existing : + channel type (dest channel) <> 0 OR dest channel = configurator channel . + +dest channel is free : + (is niltask (connected task (dest channel)) OR channel (connected task (dest channel)) = nilchannel) + AND no canal active . + +no canal active : + dest channel > highest terminal channel COR + is niltask (canal (dest channel)) COR + channel (canal (dest channel)) = nilchannel . + +task is already at dest channel : + channel index = dest channel . + + +password cmd : + msg := ds ; + task password (index (order task)) := new task password ; + forget (ds) ; + ds := nilspace ; + send (order task, ack, ds) . + +family password cmd : + msg := ds ; + actual password := new task password ; + supply password := task password (index (order task)) ; + change pw of all sons where necessary (son (order task)) ; + task password (index (order task)) := actual password ; + forget (ds) ; + ds := nilspace ; + send (order task, ack, ds) . + +set autonom cmd : + autonom flag (index (order task)) := TRUE ; + send (order task, ack, ds) . + +reset autonom cmd : + autonom flag (index (order task)) := FALSE ; + send (order task, ack, ds) . + +define new canal : + IF order task < myself AND + channel index > 0 AND channel index <= highest terminal channel CAND + is niltask (canal (channel index)) + THEN canal (channel index) := order task ; + connected task (channel index) := niltask ; + send (order task, ack, ds) + ELSE errorstop ("falscher Auftrag fuer Task ""SUPERVISOR""") + FI . + +go back to old canal : + IF order task < myself AND + channel index > 0 AND channel index <= highest terminal channel + THEN IF NOT is niltask (canal (channel index)) + THEN delete task (canal (channel index)) + FI ; + send (order task, ack, ds) + ELSE errorstop ("falscher Auftrag fuer Task ""SUPERVISOR""") + FI . + +task of channel : + msg := ds ; + channel nr := int (msg.tname) ; + msg.task := channel task ; + send (order task, ack, ds). + +channel task : + IF channel nr <= highest terminal channel + THEN IF no command analyzer active + THEN connected task (channel nr) + ELSE canal (channel nr) + FI + ELSE connected task (channel nr) + FI . + +no command analyzer active : + channel (canal (channel nr)) = nilchannel . + +canal of channel : + msg := ds ; + channel nr := int (msg.tname) ; + msg.task := canal (channel nr) ; + send (order task, ack, ds). + +set automatic startup cmd : + automatic startup flag (index (order task)) := TRUE ; + send (order task, ack, ds) . + +reset automatic startup cmd : + automatic startup flag (index (order task)) := FALSE ; + send (order task, ack, ds) . + +is continue : + order code > continue code low AND order code <= continue code high . + +new task name : CONCR (msg).tname . + +new task : CONCR (msg).task . + +new task password : subtext (CONCR (msg).tpass, 1, 100) . + +new start proc : CONCR (msg).start proc . + +is define station : + order code >= define station code AND order task < myself AND + order code <= define station code + max station no . + +ENDPROC order from user task ; + +PROC continue cmd by canal : + + access task name and password ; + check password if necessary ; + continue or send continue request ; + channel (order task, nilchannel) . + +access task name and password : + msg := ds ; + TASK CONST user task := task (CONCR (msg).tname) ; + INT CONST task index := index (user task) ; + actual password := task password (task index) ; + supply password := CONCR (msg).tpass . + +check password if necessary : + IF actual password <> "" + THEN IF supply password = "" + THEN ask for password ; + LEAVE continue cmd by canal + ELIF actual password <> supply password OR actual password = "-" + THEN errorstop ("Passwort falsch") + FI + FI . +ask for password : + send (order task, password code, ds) . + +continue or send continue request : + IF autonom flag (task index) + THEN send continue request to user task + ELSE continue (user task, order code - continue code low) + FI . + +send continue request to user task : + INT VAR request count , quit ; + FOR request count FROM 1 UPTO 10 REP + send (user task, order code, ds, quit) ; + IF quit = ack + THEN LEAVE send continue request to user task + FI ; + pause (3) + PER ; + errorstop ("Task antwortet nicht") . + +ENDPROC continue cmd by canal ; + +PROC continue (TASK CONST id, INT CONST channel nr) : + + IF NOT is niltask (id) CAND channel (id) <> channel nr + THEN check whether not linked to another channel ; + channel (id, channel nr) ; + connected task (channel nr) := id ; + prio (id, 0) ; + activate (id) + FI . + +check whether not linked to another channel : + INT VAR i ; + FOR i FROM 1 UPTO number of channels REP + IF connected task (i) = id + THEN errorstop ("bereits an Kanal " + text (i) ) ; + LEAVE continue + FI + PER . + +ENDPROC continue ; + +PROC task info cmd : + + forget (ds) ; + ds := sys cat ; + send (order task, ack, ds) . + +ENDPROC task info cmd ; + +PROC delete task (TASK CONST superfluous) : + + delete all sons of superfluous ; + delete superfluous itself . + +delete superfluous itself : + update cpu time of father ; + erase process (superfluous) ; + delete (superfluous) ; + erase terminal connection remark . + +update cpu time of father : + TASK CONST father task := father (superfluous) ; + IF NOT is niltask (father task) + THEN disable stop ; + REAL CONST father time := clock (father task) + clock (superfluous); + IF is error + THEN clear error + ELSE set clock (father task, father time) + FI ; + enable stop + FI . + +erase terminal connection remark : + INT VAR i ; + FOR i FROM 1 UPTO number of channels REP + IF connected task (i) = superfluous + THEN connected task (i) := niltask ; + LEAVE erase terminal connection remark + FI + PER ; + FOR i FROM 1 UPTO highest terminal channel REP + IF canal (i) = superfluous + THEN canal (i) := niltask ; + LEAVE erase terminal connection remark + FI + PER . + +delete all sons of superfluous : + TASK VAR son task ; + REP + son task := son (superfluous) ; + IF is niltask (son task) + THEN LEAVE delete all sons of superfluous + FI ; + delete task (son task) + PER . + +ENDPROC delete task ; + +PROC create son (TASK CONST father, TEXT CONST task name, TASK VAR new task, PROCA CONST start) : + + entry (father, task name, new task) ; + autonom flag (index (new task)) := FALSE ; + automatic startup flag (index (new task)) := TRUE ; + task password (index (new task)) := "" ; + create (father, new task, privilege, start) . + +privilege : + IF new task < myself + THEN 1 + ELSE 0 + FI . + +ENDPROC create son ; + + +PROC system start interrupt : + + IF exists task ("configurator") + THEN send system start message + FI . + +send system start message : + ds := nilspace ; + INT VAR request count, quit ; + FOR request count FROM 1 UPTO 10 REP + send (task ("configurator"), system start code, ds, quit) ; + IF quit = ack + THEN LEAVE send system start message + FI ; + pause (3) + PER ; + forget (ds) . + +ENDPROC system start interrupt ; + +PROC define new station : + + INT CONST station := order code - define station code ; + INT VAR i ; + FOR i FROM 1 UPTO highest terminal channel REP + IF NOT is niltask (canal (i)) + THEN delete task (canal (i)) + FI + PER ; + define station (station) ; + FOR i FROM 1 UPTO number of channels REP + update (connected task (i)) + PER ; + forget (ds) . + +ENDPROC define new station ; + +PROC change pw of all sons where necessary (TASK CONST first son) : + + TASK VAR actual task := first son ; + WHILE NOT is niltask (actual task) REP + change pw ; + change pw of all sons where necessary (son (actual task)); + actual task := brother (actual task) + PER. + + change pw : + IF task password (index (actual task)) = supply password + OR + task password (index (actual task)) = "" + THEN task password (index (actual task)) := actual password + FI. + +END PROC change pw of all sons where necessary ; + +(******************* basic supervisor operations **********************) + + +PROC channel (TASK CONST id, INT CONST channel nr) : + pcb (id, channel field, channel nr) +ENDPROC channel ; + +INT PROC channel type (INT CONST channel nr) : + disable stop ; + channel (myself, channel nr) ; + INT VAR type ; + control (1, 0, 0, type) ; + channel (myself, nilchannel) ; + type +ENDPROC channel type ; + +PROC erase last bootstrap source dataspace : + + disable stop ; + errorstop ("") ; + clear error + +ENDPROC erase last bootstrap source dataspace ; + +PROC set clock (TASK CONST id, REAL CONST clock value) : + EXTERNAL 82 +ENDPROC set clock ; + +PROC sys op (INT CONST code) : + EXTERNAL 90 +END PROC sys op ; + +PROC create (TASK CONST father, son, INT CONST priv, PROCA CONST start) : + EXTERNAL 95 +ENDPROC create ; + +PROC pcb (TASK CONST id, INT CONST field, value) : + EXTERNAL 105 +ENDPROC pcb ; + +PROC activate (TASK CONST id) : + EXTERNAL 108 +ENDPROC activate ; + +PROC deactivate (TASK CONST id) : + EXTERNAL 109 +ENDPROC deactivate ; + +PROC halt process (TASK CONST id) : + EXTERNAL 110 +ENDPROC halt process ; + +PROC erase process (TASK CONST id) : + EXTERNAL 112 +ENDPROC erase process ; + +ENDPACKET supervisor ; + diff --git a/system/multiuser/1.7.5/src/sysgen off b/system/multiuser/1.7.5/src/sysgen off new file mode 100644 index 0000000..9cb999b --- /dev/null +++ b/system/multiuser/1.7.5/src/sysgen off @@ -0,0 +1,9 @@ +ke ; (* maintenance ke *) + +PROC sysgen off (INT CONST mode, INT VAR a,b,c,d,e,f,g,h,i,j,k) : + EXTERNAL 256 +ENDPROC sysgen off ; + +INT VAR x := 0 ; +sysgen off (3,x,x,x,x,x,x,x,x,x,x,x) ; + diff --git a/system/multiuser/1.7.5/src/system info b/system/multiuser/1.7.5/src/system info new file mode 100644 index 0000000..c29dfc2 --- /dev/null +++ b/system/multiuser/1.7.5/src/system info @@ -0,0 +1,342 @@ + +PACKET system info DEFINES (* Autor: J.Liedtke *) + (* Stand: 10.09.84 *) + task info , + task status , + storage info , + help : + + +LET supervisor mode = 0 , + simple mode = 1 , + status mode = 2 , + storage mode = 3 , + + ack = 0 , + + channel field = 4 , + prio field = 6 , + + cr lf = ""13""10"" , + cr = ""13"" , + page = ""1""4"" , + begin mark= ""15"" , + end mark = ""14"" , + bell = ""7"" , + esc = ""27"" ; + + + +TEXT VAR task name , record ; +DATASPACE VAR ds := nilspace ; + + +PROC task info : + + task info (simple mode) + +ENDPROC task info ; + +PROC task info (INT CONST mode) : + + open list file ; + task info (mode, list file) ; + show task info . + +open list file : + forget (ds) ; + ds := nilspace ; + FILE VAR list file := sequential file (output, ds) . + +show task info : + IF mode <> supervisor mode + THEN show (list file) + ELSE open editor (list file, FALSE) ; + edit (groesster editor, "q", PROC (TEXT CONST) no orders) + FI . + +ENDPROC task info ; + +PROC task info (INT CONST mode, FILE VAR list file) : + + access catalogue ; + IF mode > simple mode + THEN generate head + FI ; + list tree (list file, supervisor,0, mode) . + +generate head : + put (list file, date) ; + put (list file, " ") ; + put (list file, time of day) ; + put (list file, " ") ; + IF mode = storage mode + THEN put (list file, "K ") + FI ; + put (list file, " CPU PRIO CHAN STATUS") ; + line (list file) . + +ENDPROC task info ; + +PROC task info (INT CONST level, fremdstation): + IF fremdstation = station (myself) + THEN task info (level) + ELSE + disable stop; + DATASPACE VAR x:= nilspace; + BOUND INT VAR l := x; l := level; + call (collector, 256+fremdstation, x, rtn); + INT VAR rtn; + IF rtn = ack + THEN FILE VAR ti:= sequential file (modify, x) ; + show (ti) + ELSE forget (x) ; + errorstop ("Station " + text (fremdstation) + " antwortet nicht") + FI ; + forget (x) + FI +END PROC task info; + +PROC no orders (TEXT CONST ed kommando taste) : + + IF ed kommando taste = "q" + THEN quit + ELSE out (""7"") + FI + +ENDPROC no orders ; + +PROC list tree (FILE VAR list file, + TASK CONST first son, INT CONST depth, mode) : + + enable stop ; + TASK VAR actual task := first son ; + WHILE NOT is niltask (actual task) REP + list actual task ; + list tree (list file, son (actual task), depth+1, mode) ; + actual task := brother (actual task) + PER . + +list actual task : + record := "" ; + generate layout and task name ; + IF mode > simple mode + THEN tab to info position ; + show storage if wanted ; + record CAT cpu time of (actual task) ; + record CAT prio of actual task ; + record CAT channel of actual task ; + record CAT " " ; + record CAT status of (actual task) + FI ; + putline (list file, record) . + +generate layout and task name : + INT VAR i ; + FOR i FROM 1 UPTO depth REP + record CAT " " + PER ; + task name := name (actual task) ; + record CAT task name . + +tab to info position : + record := subtext (record, 1, 40) ; + FOR i FROM LENGTH record + 1 UPTO 40 REP + record CAT "." + PER ; + record CAT " " . + +show storage if wanted : + IF mode = storage mode + THEN record CAT text (storage (actual task), 5) ; + record CAT " " + FI . + +prio of actual task : + text (pcb (actual task, prio field),4) . + +channel of actual task : + INT CONST channel := pcb (actual task, channel field) ; + IF channel = 0 + THEN " -" + ELSE text (channel,4) + FI . + +ENDPROC list tree ; + +TEXT PROC cpu time of (TASK CONST actual task) : + + disable stop ; + TEXT VAR result := subtext (time (clock (actual task), 12), 1, 10) ; + IF is error + THEN clear error ; + result := 10 * "*" + FI ; + result + +ENDPROC cpu time of ; + +TEXT PROC status of (TASK CONST actual task) : + + SELECT status (actual task) OF + CASE 0 : "-busy-" + CASE 1 : "i/o" + CASE 2 : "wait" + CASE 4 : "busy-blocked" + CASE 5 : "i/o -blocked" + CASE 6 : "wait-blocked" + OTHERWISE "--dead--" + END SELECT . + +ENDPROC status of ; + +PROC task status : + + task status (myself) + +ENDPROC task status ; + +PROC task status (TEXT CONST task name) : + + task status (task (task name)) + +ENDPROC task status ; + +PROC task status (TASK CONST actual task) : + + IF exists (actual task) + THEN put status of task + ELSE errorstop ("Task nicht vorhanden") + FI . + +put status of task : + line ; + put (date); put (time of day) ; + put (" TASK:") ; + put (name (actual task)) ; + line (2) ; + put ("Speicher:"); put (storage (actual task)); putline ("K"); + put ("CPU-Zeit:"); put (cpu time of (actual task)) ; line; + put ("Zustand :"); write (status of (actual task)); + put (", (prio"); + write (text (pcb (actual task, prio field))); + put ("), Kanal") ; + IF channel (actual task) = 0 + THEN put ("-") + ELSE put (channel (actual task)) + FI ; + line . + +ENDPROC task status ; + +PROC storage info : + + INT VAR size, used ; + storage (size, used) ; + out (""13""10" ") ; + put (used) ; + put ("K von") ; + put (size plus reserve) ; + putline ("K sind belegt!") . + +size plus reserve : + int (real (size + 24) * 64.0 / 63.0 ) . + +ENDPROC storage info ; + + +PROC help : + + IF NOT exists ("help") + THEN get help file + FI ; + FILE VAR f := sequential file (modify, "help") ; + help (f) . + +get help file : + TEXT VAR old std param := std ; + IF exists ("help", father) + THEN fetch ("help") + ELSE fetch ("help", public) + FI ; + last param (old std param) . + +ENDPROC help ; + +PROC help (FILE VAR help file) : + + initialize help command ; + REP + out (page) ; + to paragraph ; + show paragraph ; + get show command + UNTIL is quit command PER . + +initialize help command : + TEXT VAR + help command := getcharety ; + IF help command = "" + THEN help command := "0" + FI . + +to paragraph : + col (help file, 1) ; + to line (help file, 1) ; + downety (help file, "#" + help command + "#") ; + IF eof (help file) + THEN to line (help file, 1) ; + out (bell) + FI . + +show paragraph : + show headline ; + WHILE NOT end of help subfile REP + show help line + PER ; + show bottom line . + +show headline : + out (begin mark) ; + INT CONST dots := (x size - len (help file) - 5) DIV 2 ; + dots TIMESOUT "." ; + exec (PROC show line, help file, 4) ; + dots TIMESOUT "." ; + out (end mark) ; + down (help file) . + +show help line : + out (cr lf) ; + exec (PROC show line, help file, 1) ; + down (help file) . + +show bottom line : + cursor (5, y size) ; + exec (PROC show line, help file, 3) ; + out (cr) . + +get show command : + TEXT VAR char ; + get char (char) ; + IF char = esc + THEN get char (char) + FI ; + IF char >= " " + THEN help command := char + ELSE out (bell) + FI . + +end of help subfile : pos (help file,"##",1) <> 0 OR eof (help file) . + +is quit command : help command = "q" OR help command = "Q" . + +ENDPROC help ; + +PROC show line (TEXT CONST line, INT CONST from) : + + outsubtext (line, from, x size - from) + +ENDPROC show line ; + +ENDPACKET system info ; + diff --git a/system/multiuser/1.7.5/src/system manager b/system/multiuser/1.7.5/src/system manager new file mode 100644 index 0000000..5406ff0 --- /dev/null +++ b/system/multiuser/1.7.5/src/system manager @@ -0,0 +1,117 @@ +(* ------------------- VERSION 4 vom 31.01.86 ------------------- *) +PACKET system manager DEFINES (* F. Klapper *) + system manager , + generate shutup manager , + put log : + +LET ack = 0 , + error nak = 2 , + fetch code = 11 , + list code = 15 , + all code = 17 , + log code = 21 , + eszet = ""251"" , + log file name = "logbuch"; + +DATASPACE VAR ds; + +BOUND STRUCT (TEXT name, write pass, read pass) VAR msg ; +BOUND TEXT VAR log message, + error msg; + +INT VAR reply; + +TEXT VAR xname; + +FILE VAR log file; + +PROC system manager: + lernsequenz auf taste legen ("s", eszet) ; + global manager + (PROC (DATASPACE VAR, INT CONST, INT CONST, TASK CONST) sys manager) + +END PROC system manager; + +PROC sys manager (DATASPACE VAR ds, INT CONST order, phase, + TASK CONST order task): + enable stop; + SELECT order OF + CASE log code : y put log + CASE list code : y list + CASE all code : y all + CASE fetch code : y fetch + OTHERWISE std manager (ds, order, phase, order task) + END SELECT. + +y fetch : + msg := ds; + xname := msg.name; + IF read permission (xname, msg.read pass) + THEN forget (ds) ; + ds := old (xname) ; + send (order task, ack, ds) + ELSE errorstop ("Passwort falsch") + FI . + +y list : + forget (ds) ; + ds := nilspace ; + FILE VAR list file := sequential file (output, ds) ; + list (list file) ; + send (order task, ack, ds) . + +y all : + forget (ds); + ds := nilspace; + BOUND THESAURUS VAR all names := ds ; + all names := all ; + send (order task, ack, ds) . + +y put log : + log file := sequential file (output, log file name) ; + IF lines (log file) < 4000 + THEN max line length (log file,1000); + put (log file, date) ; + put (log file, time of day) ; + put (log file, text (name (order task), 8)); + log message := ds ; + put (log file, CONCR (log message)) ; + FI ; + send (order task, ack, ds) . + +END PROC sys manager; + +PROC put log (TEXT CONST message) : + enable stop; + forget (ds) ; + ds := nilspace ; + log message := ds ; + CONCR (log message) := message ; + call (task("SYSUR"), log code, ds, reply) . + +ENDPROC put log ; + +PROC generate shutup manager : + + TASK VAR son ; + begin ("shutup", PROC shutup manager, son) + +ENDPROC generate shutup manager ; + +PROC shutup manager : + disable stop ; + task password ("") ; + command dialogue (TRUE) ; + REP + break ; + line ; + IF yes ("shutup") + THEN clear error ; + shutup + FI + PER + +ENDPROC shutup manager ; + +ENDPACKET system manager ; + diff --git a/system/multiuser/1.7.5/src/tasks b/system/multiuser/1.7.5/src/tasks new file mode 100644 index 0000000..276011e --- /dev/null +++ b/system/multiuser/1.7.5/src/tasks @@ -0,0 +1,978 @@ +(* ------------------- VERSION 9 vom 09.06.86 ------------------- *) +PACKET tasks DEFINES (* Autor: J.Liedtke *) + + TASK , + PROCA , + := , + = , + < , + / , + niltask , + is niltask , + exists , + exists task , + supervisor , + myself , + public , + proca , + collector , + access , + name , + task , + canal , + dataspaces , + index , + station , + update , + father , + son , + brother , + next active , + access catalogue , + family password , + task in catalogue , + entry , + delete , + define station , + + pcb , + status , + channel , + clock , + storage , + callee , + + send , + wait , + call , + pingpong , + collected destination , + + begin , + end , + break , + continue , + rename myself , + task password , + set autonom , + reset autonom , + set automatic startup , + reset automatic startup , + + sys cat : + + + +LET nil = 0 , + + max version = 30000 , + max task = 125 , + max station no = 127 , + sv no = 1 , + + hex ff = 255 , + hex 7f00 = 32512 , + + collected dest field 1 = 2 , + collected dest field 2 = 3 , + channel field = 4 , + myself no field = 9 , + myself version field = 10 , + callee no field = 11 , + callee version field = 12 , + + highest terminal channel = 16 , + number of channels = 32 , + + wait state = 2 , + + ack = 0 , + nak = 1 , + error nak = 2 , + system catalogue code = 3 , + begin code = 4 , + end code = 5 , + break code = 6 , + rename code = 7 , + password code = 9 , + family password code = 40 , + set autonom code = 41 , + reset autonom code = 42 , + task of channel code = 45 , + canal of channel code = 46 , + set automatic startup code = 47 , + reset automatic startup code = 48 , + + continue code = 100, + define station code = 32000, + + lowest ds number = 4 , + highest ds number = 255 ; + + +TYPE TASK = STRUCT (INT no, version) , + PROCA = STRUCT (INT a, b) ; + +OP := (PROCA VAR right, PROCA CONST left) : + CONCR (right) := CONCR (left) +ENDOP := ; + +PROCA PROC proca (PROC p) : + + push (0, PROC p) ; + pop + +ENDPROC proca ; + +PROC push (INT CONST dummy, PROC p) : ENDPROC push ; + +PROCA PROC pop : + PROCA VAR res; + res +ENDPROC pop ; + +TASK CONST niltask := TASK: (0,0) , + collector := TASK: (-1,0) ; + +TASK PROC supervisor : + + TASK: (my station id + sv no, 0) . + +my station id : pcb (myself no field) AND hex 7f00 . + +ENDPROC supervisor ; + +TASK VAR father task ; + +INITFLAG VAR catalogue known := FALSE , father known := FALSE ; + + + +LET TASKVECTOR = STRUCT (INT version, father, son, brother) ; + + +DATASPACE VAR catalogue space , sv space ; + +BOUND STRUCT (THESAURUS dir, + ROW max task TASKVECTOR link) VAR system catalogue ; + initialize catalogue ; + +BOUND STRUCT (TEXT tname, tpass, TASK task, PROCA start proc) VAR sv msg ; + + +PROC initialize catalogue : + + catalogue space := nilspace ; + system catalogue := catalogue space ; + system catalogue.dir := empty thesaurus ; + + insert (system catalogue.dir, "SUPERVISOR") ; + insert (system catalogue.dir, "UR") ; + system catalogue.link (1) := TASKVECTOR:(0,0,0,2) ; + system catalogue.link (2) := TASKVECTOR:(0,0,0,0) . + +ENDPROC initialize catalogue ; + +DATASPACE PROC sys cat : + catalogue space +ENDPROC sys cat ; + + +TASK PROC myself : + + TASK: (pcb (myself no field), pcb (myself version field)) + +ENDPROC myself ; + + +OP := (TASK VAR dest, TASK CONST source): + + CONCR (dest) := CONCR (source) + +ENDOP := ; + +BOOL OP = (TASK CONST left, right) : + + left.no = right.no AND left.version = right.version + +ENDOP = ; + +BOOL PROC is niltask (TASK CONST t) : + + t.no = 0 + +ENDPROC is niltask ; + +BOOL OP < (TASK CONST left, right) : + + IF both of my station + THEN access (left) ; + access (right) ; + ( index (left) > 0 CAND index (left) <= max task ) + CAND + ( father (left) = right COR father (left) < right ) + ELSE FALSE + FI . + +both of my station : + station (left) = station (right) AND station (right) = station (myself) . + +ENDOP < ; + +BOOL PROC exists (TASK CONST task) : + + EXTERNAL 123 + +ENDPROC exists ; + +BOOL PROC exists task (TEXT CONST name) : + + task id (name).no <> 0 + +ENDPROC exists task ; + +TEXT PROC name (TASK CONST task) : + + IF is task of other station + THEN external name (task) + ELSE + access (task) ; + INT CONST task no := index (task) ; + IF task in catalogue (task ,task no) + THEN name (system catalogue.dir, task no) + ELSE "" + FI + FI. + +is task of other station : + (task.no AND hex 7f00) <> (pcb (myself no field) AND hex 7f00) . + +ENDPROC name ; + +BOOL PROC task in catalogue (TASK CONST task, INT CONST task no) : + + access catalogue ; + task no >= 1 CAND task no <= max task CAND + task.version = system catalogue.link (task no).version . + +ENDPROC task in catalogue ; + +PROC access (TASK CONST task) : + + INT CONST task no := task.no AND hex ff ; + IF task no < 1 OR task no > max task + THEN + ELIF is task of other station + THEN errorstop ("TASK anderer Station") + ELIF actual task id not in catalogue COR NOT exists (task) + THEN access catalogue + FI . + +actual task id not in catalogue : + NOT initialized (catalogue known) COR + ( task no > 0 CAND catalogue version <> task.version ) . + +catalogue version : system catalogue.link (task no).version . + +is task of other station : + (task.no AND hex 7f00) <> (pcb (myself no field) AND hex 7f00) . + +ENDPROC access ; + +TASK PROC task (TEXT CONST task name) : + + TASK CONST id := task id (task name) ; + IF id.no = 0 + THEN errorstop (""""+task name+""" gibt es nicht") + FI ; + id + +ENDPROC task ; + +TASK PROC task id (TEXT CONST task name) : + + IF task name = "-" OR task name = "" + THEN errorstop ("Taskname unzulaessig") + FI ; + IF NOT initialized (catalogue known) + THEN access catalogue + FI ; + + TASK VAR + id := task id (link (system catalogue.dir, task name)) ; + IF NOT exists (id) + THEN access catalogue ; + id := task id (link (system catalogue.dir, task name)) ; + FI ; + id . + +ENDPROC task id ; + +TASK OP / (TEXT CONST task name) : + + task (task name) + +ENDOP / ; + +INT PROC index (TASK CONST task) : + + IF NOT initialized (catalogue known) + THEN access catalogue + FI ; + task.no AND hex ff + +ENDPROC index ; + +INT PROC station (TASK CONST task) : + + task.no DIV 256 + +ENDPROC station ; + +PROC update (TASK VAR task) : + + IF task.no <> nil + THEN task.no := (task.no AND hex ff) + new station number + FI . + +new station number : (pcb (myself no field) AND hex 7f00) . + +ENDPROC update ; + + +TASK PROC public : + + task ("PUBLIC") + +ENDPROC public ; + +TASK PROC father : + + IF NOT initialized (father known) COR station or rename changed father id + THEN access catalogue ; + father task := father (myself) + FI ; + father task . + +station or rename changed father id : + NOT exists (father task) . + +ENDPROC father ; + +INT VAR task no ; + +TASK PROC father (TASK CONST task) : + + task no := index (task) ; + task id (system catalogue.link (task no).father) . + +ENDPROC father ; + +TASK PROC son (TASK CONST task) : + + task no := index (task) ; + IF task no = nil + THEN supervisor + ELSE task id (system catalogue.link (task no).son) + FI . + +ENDPROC son ; + +TASK PROC brother (TASK CONST task) : + + task no := index (task) ; + task id (system catalogue.link (task no).brother) . + +ENDPROC brother ; + +PROC next active (TASK VAR task) : + + next active task index (task.no) ; + IF task.no > 0 + THEN task.version := pcb (task, myself version field) + ELSE task.version := 0 + FI + +ENDPROC next active ; + +PROC next active task index (INT CONST no) : + + EXTERNAL 118 + +ENDPROC next active task index ; + +TASK PROC task id (INT CONST task nr) : + + INT VAR task index := task nr AND hex ff ; + TASK VAR result ; + result.no := task index ; + IF task index = nil + THEN result.version := 0 + ELSE result.version := system catalogue.link (task index).version ; + result.no INCR my station id + FI ; + result . + +my station id : pcb (myself no field) AND hex 7f00 . + +ENDPROC task id ; + +PROC access catalogue : + + IF this is not supervisor + THEN get catalogue from supervisor + FI . + +this is not supervisor : + (pcb (myself no field) AND hex ff) <> sv no . + +get catalogue from supervisor : + INT VAR dummy reply ; + forget (catalogue space) ; + catalogue space := nilspace ; + call (supervisor, system catalogue code, catalogue space, dummy reply) ; + system catalogue := catalogue space . + +ENDPROC access catalogue ; + + +PROC entry (TASK CONST father task, TEXT CONST task name, + TASK VAR son task) : + + IF task name <> "-" CAND (system catalogue.dir CONTAINS task name) + THEN errorstop (""""+task name+""" existiert bereits") + ELIF is niltask (father task) + THEN errorstop ("Vatertask existiert nicht") + ELSE entry task + FI . + +entry task : + INT VAR son task nr ; + INT CONST father task nr := index (father task) ; + insert (system catalogue.dir, task name, son task nr) ; + IF son task nr = nil OR son task nr > max task + THEN delete (system catalogue.dir, son task nr) ; + son task := niltask ; + errorstop ("zu viele Tasks") + ELSE insert task (father task, father vec, son task, son vec, son tasknr) + FI . + +father vec : system catalogue.link (father task nr) . + +son vec : system catalogue.link (son task nr) . + +ENDPROC entry ; + +PROC insert task (TASK CONST father task, TASKVECTOR VAR father vec, + TASK VAR son task, TASKVECTOR VAR son vec, INT CONST nr) : + + initialize version number if son vec is first time used ; + increment version (son vec) ; + son task.no := my station id + nr ; + son task.version := son vec.version ; + link into task tree . + +initialize version number if son vec is first time used : + IF son vec.version < 0 + THEN son vec.version := 0 + FI . + +link into task tree : + son vec.son := nil ; + son vec.brother := father vec.son ; + son vec.father := index (father task) ; + father vec.son := son task.no . + +my station id : pcb (myself no field) AND hex 7f00 . + +END PROC insert task ; + + +PROC delete (TASK CONST superfluous) : + + INT CONST superfluous nr := index (superfluous) ; + delete (system catalogue.dir, superfluous nr) ; + delete superfluous task ; + increment version (superfluous vec) . + +delete superfluous task : + INT CONST successor of superfluous := superfluous vec.brother ; + TASK VAR + last := father (superfluous) , + actual := son (last) ; + IF actual = superfluous + THEN delete first son of last + ELSE search previous brother of superfluous ; + delete from brother chain + FI . + +delete first son of last : + last vec.son := successor of superfluous . + +search previous brother of superfluous : + REP + last := actual ; + actual := brother (actual) + UNTIL actual = superfluous PER . + +delete from brother chain : + last vec.brother := successor of superfluous . + +last vec : system catalogue.link (index (last)) . + +superfluous vec : system catalogue.link (superfluous nr) . + +ENDPROC delete ; + + +PROC name (TASK VAR task, TEXT CONST new name) : + + INT CONST task no := index (task) ; + IF (system catalogue.dir CONTAINS new name) AND (new name <> "-") + AND (name (task) <> new name) + THEN errorstop (""""+new name+""" existiert bereits") + ELSE rename (system catalogue.dir, task no, new name) ; + increment version (system catalogue.link (task no)) ; + IF this is supervisor + THEN update task version in pcb and task variable + FI + FI . + +this is supervisor : (pcb (myself no field) AND hex ff) = sv no . + +update task version in pcb and task variable : + INT CONST new version := system catalogue.link (task no).version ; + write pcb (task, myself version field, new version) ; + task.version := new version . + +ENDPROC name ; + + +PROC increment version (TASKVECTOR VAR task vec) : + + task vec.version := task vec.version MOD max version + 1 + +ENDPROC increment version ; + + +INT PROC pcb (TASK CONST id, INT CONST field) : + + EXTERNAL 104 + +ENDPROC pcb ; + +INT PROC status (TASK CONST id) : + + EXTERNAL 107 + +ENDPROC status ; + +INT PROC channel (TASK CONST id) : + + pcb (id, channel field) + +ENDPROC channel ; + +REAL PROC clock (TASK CONST id) : + + EXTERNAL 106 + +ENDPROC clock ; + +INT PROC storage (TASK CONST id) : + + INT VAR ds number, storage sum := 0, ds size; + FOR ds number FROM lowest ds number UPTO highest ds number REP + ds size := pages (ds number, id) ; + IF ds size > 0 + THEN storage sum INCR ((ds size + 1) DIV 2) + FI + PER ; + storage sum + +ENDPROC storage ; + +INT PROC pages (INT CONST ds number, TASK CONST id) : + + EXTERNAL 88 + +ENDPROC pages ; + +TASK PROC callee (TASK CONST from) : + + IF status (from) = wait state + THEN TASK:(pcb (from, callee no field), pcb (from, callee version field)) + ELSE niltask + FI + +ENDPROC callee ; + + +PROC send (TASK CONST dest, INT CONST send code, DATASPACE VAR ds, + INT VAR quit) : + EXTERNAL 113 + +ENDPROC send ; + +PROC send (TASK CONST dest, INT CONST send code, DATASPACE VAR ds) : + + INT VAR dummy quit ; + send (dest, send code, ds, dummy quit) ; + forget (ds) + +ENDPROC send ; + +PROC wait (DATASPACE VAR ds, INT VAR receive code, TASK VAR source) : + + EXTERNAL 114 + +ENDPROC wait ; + +PROC call (TASK CONST dest, INT CONST order code, DATASPACE VAR ds, + INT VAR reply code) : + EXTERNAL 115 + +ENDPROC call ; + +PROC pingpong (TASK CONST dest, INT CONST order code, DATASPACE VAR ds, + INT VAR reply code) : + EXTERNAL 122 + +ENDPROC pingpong ; + +TASK PROC collected destination : + + TASK: (pcb (collected dest field 1), pcb (collected dest field 2)) + +ENDPROC collected destination ; + + +PROC begin (PROC start, TASK VAR new task) : + + begin ("-", PROC start, new task) + +ENDPROC begin ; + +PROC begin (TEXT CONST son name, PROC start, TASK VAR new task) : + + enable stop ; + forget (sv space) ; + sv space := nilspace ; + sv msg := sv space ; + CONCR (sv msg).tname := son name ; + CONCR (sv msg).start proc := proca (PROC start) ; + supervisor call (begin code) ; + sv msg := sv space ; + new task := CONCR (sv msg).task . + +ENDPROC begin ; + +PROC begin (DATASPACE VAR ds, PROC start, INT VAR reply) : + + sv msg := ds ; + sv msg.start proc := proca (PROC start) ; + call (supervisor, begin code, ds, reply) + +ENDPROC begin ; + +PROC end : + + command dialogue (TRUE) ; + say ("task """) ; + say (name (myself)) ; + IF yes (""" loeschen") + THEN eumel must advertise ; + end (myself) + FI + +ENDPROC end ; + +PROC end (TASK CONST id) : + + forget (sv space) ; + sv space := nilspace ; + sv msg := sv space ; + CONCR (sv msg).task := id ; + supervisor call (end code) + +ENDPROC end ; + +PROC break (QUIET CONST quiet) : + + simple supervisor call (break code) + +ENDPROC break ; + +PROC break : + + eumel must advertise ; + simple supervisor call (break code) + +ENDPROC break ; + +PROC continue (INT CONST channel nr) : + + simple supervisor call (continue code + channel nr) + +ENDPROC continue ; + +PROC rename myself (TEXT CONST new name) : + + forget (sv space) ; + sv space := nilspace ; + sv msg := sv space ; + CONCR (sv msg).tname := new name ; + supervisor call (rename code) . + +ENDPROC rename myself ; + + +PROC simple supervisor call (INT CONST code) : + + forget (sv space) ; + sv space := nilspace ; + supervisor call (code) + +ENDPROC simple supervisor call ; + +PROC supervisor call (INT CONST code) : + + INT VAR answer ; + call (supervisor, code, sv space, answer) ; + WHILE answer = nak REP + pause (20) ; + call (supervisor, code, sv space, answer) + PER ; + IF answer = error nak + THEN BOUND TEXT VAR error message := sv space ; + errorstop (CONCR (error message)) + FI + +ENDPROC supervisor call ; + +PROC task password (TEXT CONST password) : + + IF online + THEN say (""3""5""10"") + FI ; + forget (sv space) ; + sv space := nilspace ; + sv msg := sv space ; + CONCR (sv msg).tpass := password ; + supervisor call (password code) ; + cover tracks . + +ENDPROC task password ; + +PROC set autonom : + + simple supervisor call (set autonom code) + +ENDPROC set autonom ; + +PROC reset autonom : + + simple supervisor call (reset autonom code) + +ENDPROC reset autonom ; + +PROC set automatic startup : + simple supervisor call (set automatic startup code) +ENDPROC set automatic startup ; + +PROC reset automatic startup : + simple supervisor call (reset automatic startup code) +ENDPROC reset automatic startup ; + +PROC define station (INT CONST station number) : + + IF this is supervisor + THEN update all tasks + ELIF i am privileged + THEN IF station number is valid + THEN send define station message + ELSE errorstop ("ungueltige Stationsnummer (0 - 127)") + FI + ELSE errorstop ("falscher Auftrag fuer Task ""SUPERVISOR""") + FI . + +update all tasks : + start at supervisor ; + REP + get next task ; + IF no more task found + THEN update station number of supervisor ; + LEAVE update all tasks + FI ; + update station number of actual task + PER . + +i am privileged : + myself < supervisor . + +station number is valid : + station number >= 0 AND station number <= max station no . + +start at supervisor : + TEXT VAR name ; + INT VAR index := sv no . + +get next task : + get (system catalogue.dir, name, index) . + +no more task found : index = 0 . + +update station number of actual task : + write pcb (task id (index), myself no field, station number * 256 + index). + +update station number of supervisor : + write pcb (supervisor, myself no field, station number * 256 + sv no) . + +send define station message : + forget (sv space) ; + sv space := nilspace ; + INT VAR receipt ; + REP + send (supervisor, define station code+station number, sv space, receipt) + UNTIL receipt = ack PER . + +this is supervisor : + (pcb (myself no field) AND hex ff) = sv no . + +ENDPROC define station ; + + +TASK OP / (INT CONST station number, TEXT CONST task name) : + + IF station number = station (myself) + THEN task (task name) + ELSE get task id from other station + FI . + +get task id from other station : + enable stop ; + forget (sv space) ; + sv space := nilspace ; + BOUND TEXT VAR name message := sv space ; + name message := task name ; + INT VAR reply ; + call (collector, station number, sv space, reply) ; + IF reply = ack + THEN BOUND TASK VAR result := sv space ; + CONCR (result) + ELIF reply = error nak + THEN name message := sv space; + disable stop; + errorstop (name message) ; + forget (sv space) ; + niltask + ELSE forget (sv space); + errorstop ("Collector-Task fehlt") ; + niltask + FI + +ENDOP / ; + + +TASK OP / (INT CONST station number, TASK CONST tsk): + + station number / name (tsk) + +END OP / ; + + +TEXT PROC external name (TASK CONST tsk): + + IF tsk = nil task + THEN + "" + ELIF tsk = collector + THEN + "** collector **" + ELSE + name via net + FI. + +name via net: + enable stop ; + forget (sv space); + sv space := nil space; + BOUND TASK VAR task message := sv space; + task message := tsk; + INT VAR reply; + call (collector, 256, sv space, reply); + BOUND TEXT VAR result := sv space; + CONCR (result). + +END PROC external name; + +PROC write pcb (TASK CONST task, INT CONST field, value) : + EXTERNAL 105 +ENDPROC write pcb ; + +TASK PROC task (INT CONST channel number) : + + IF channel number < 1 OR channel number > 32 + THEN errorstop ("ungueltige Kanalnummer") + FI ; + forget (sv space) ; + sv space := nilspace ; + sv msg := sv space ; + sv msg.tname := text (channel number) ; + supervisor call (task of channel code) ; + sv msg := sv space ; + sv msg.task + +END PROC task; + +TASK PROC canal (INT CONST channel number) : + + IF channel number < 1 OR channel number > highest terminal channel + THEN errorstop ("ungueltige Kanalnummer") + FI ; + forget (sv space); + sv space := nilspace ; + sv msg := sv space ; + sv msg.tname := text (channel number) ; + supervisor call (canal of channel code) ; + sv msg := sv space ; + sv msg.task + +END PROC canal ; + +PROC family password (TEXT CONST password) : + + IF online + THEN say (""3""5""10"") + FI ; + forget (sv space) ; + sv space := nilspace ; + sv msg := sv space ; + sv msg.tpass := password ; + supervisor call (family password code) ; + cover tracks . + +ENDPROC family password ; + +INT PROC dataspaces (TASK CONST task) : + + INT VAR ds number, spaces := 0 ; + FOR ds number FROM lowest ds number UPTO highest ds number REP + IF pages (ds number, index (task)) >= 0 + THEN spaces INCR 1 + FI + PER ; + spaces + +ENDPROC dataspaces ; + +INT PROC dataspaces : + dataspaces (myself) +ENDPROC dataspaces ; + +INT PROC pages (INT CONST ds number, INT CONST task no) : + EXTERNAL 88 +ENDPROC pages ; + +ENDPACKET tasks ; + diff --git a/system/multiuser/1.7.5/src/ur start b/system/multiuser/1.7.5/src/ur start new file mode 100644 index 0000000..efbf8c1 --- /dev/null +++ b/system/multiuser/1.7.5/src/ur start @@ -0,0 +1,40 @@ +(* ------------------- VERSION 2 06.03.86 ------------------- *) +PROC begin process (TASK CONST father, son, INT CONST priv, PROCA CONST start) : + EXTERNAL 95 +ENDPROC begin process ; + +PROC ur : + TASK VAR dummy ; + begin ("PUBLIC", PROC public manager, dummy) ; + global manager (PROC ur manager) +ENDPROC ur ; + +PROC public manager : + + page ; + REP UNTIL yes("Archiv 'help' eingelegt") PER; + archive ("help") ; + fetch ("help", archive) ; + release (archive) ; + free global manager + +ENDPROC public manager ; + +PROC ur manager (DATASPACE VAR ds, INT CONST order, phase, + TASK CONST order task) : + + LET begin code = 4 ; + enable stop ; + IF order = begin code + THEN std manager (ds, order, phase, order task) + ELSE errorstop ("falscher Auftrag fuer Task ""UR""") + FI + +ENDPROC ur manager ; + +check on ; +command dialogue (TRUE) ; +begin process (supervisor, task ("UR"), 0, proca (PROC ur)) ; +command dialogue (FALSE) ; +check off; + |